diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ddf7c7cb09..26e105d94d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -58,7 +58,7 @@ jobs: sudo apt-get install --yes gnuplot-nox \ poppler-utils graphviz texlive-latex-recommended \ texlive-fonts-recommended texlive-pictures tex4ht - opam install --yes dune num yojson lwt fmt logs re \ + opam install --yes dune num yojson result lwt fmt logs re \ cohttp-lwt-unix atdgen pip install nose - name: Make Kappa diff --git a/.gitignore b/.gitignore index 40fbb75cad..fd966d2ccb 100644 --- a/.gitignore +++ b/.gitignore @@ -27,6 +27,7 @@ man/zzKaSim_manual.ps man/generated_img/ # test suite +# TODO: should we remove these for tests/integration ones? models/test_suite/*/*/output/*.xml models/test_suite/*/*/output/*.html models/test_suite/*/*/output/*.diff @@ -49,6 +50,32 @@ models/test_suite/*/*/output/profiling.txt models/test_suite/*/*/output/profiling.html models/test_suite/*/*/output/compression_status.txt +tests/integration/*/*/output/*.xml +tests/integration/*/*/output/*.html +tests/integration/*/*/output/*.diff +tests/integration/*/*/output/*.dot +tests/integration/*/*/output/*.dat +tests/integration/*/*/output/*.ka +tests/integration/*/*/output/*.json +tests/integration/*/*/output/*.m +tests/integration/*/*/output/ode.m +tests/integration/*/*/output/ode.mws +tests/integration/*/*/output/ode.nb +tests/integration/*/*/output/data.csv +tests/integration/*/*/output/data.tsv +tests/integration/*/*/output/data.svg +tests/integration/*/*/output/LOG +tests/integration/simulation/*/output/stream.txt +tests/integration/*/*/output/example +tests/integration/*/*/output/error.log +tests/integration/*/*/error +tests/integration/error +tests/integration/*/*/output/profiling.txt +tests/integration/*/*/output/profiling.html +tests/integration/*/*/output/compression_status.txt +tests/integration/*/*/output/network.net +tests/integration/*/*/output/data_2.csv + # generated code site *.install @@ -67,3 +94,9 @@ python/*.egg-info # MacOS .DS_Store + +# manual build +man/KaSim_manual.ilg +man/KaSim_manual.ind +man/scripts/inputs~0.ka +man/scripts/ode.m diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000000..d6edf85ecc --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,15 @@ +version = 0.26.1 +profile=conventional +margin=80 +if-then-else=k-r +parens-ite=true +parens-tuple=multi-line-only +sequence-style=terminator +type-decl=compact +break-cases=toplevel +cases-exp-indent=2 +field-space=tight-decl +leading-nested-match-parens=true +module-item-spacing=compact +quiet=false + diff --git a/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.ml b/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.ml index 0bb94a2507..80ce63b56f 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.ml @@ -12,191 +12,236 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - let sanity_check = false let test_workbench = false let trace_mvbdu_allocation = false -module Mvbdu_Skeleton = -struct +module Mvbdu_Skeleton = struct type t = bool Mvbdu_sig.skeleton - let (compare:t->t -> int) = compare + + let (compare : t -> t -> int) = compare let print _ _ = () end -module Association_List_Skeleton = -struct +module Association_List_Skeleton = struct type t = int List_sig.skeleton - let (compare:t->t->int) = compare + + let (compare : t -> t -> int) = compare let print _ _ = () end -module Range_List_Skeleton = -struct +module Range_List_Skeleton = struct type t = (int option * int option) List_sig.skeleton - let (compare:t->t->int) = compare + + let (compare : t -> t -> int) = compare let print _ _ = () end -module Variables_List_Skeleton = -struct +module Variables_List_Skeleton = struct type t = unit List_sig.skeleton - let (compare:t->t->int) = compare + + let (compare : t -> t -> int) = compare let print _ _ = () end -module Hash_key = -struct +module Hash_key = struct type t = int + let compare = compare end -module D_mvbdu_skeleton = - (Dictionary.Dictionary_of_Ord (Mvbdu_Skeleton):Dictionary.Dictionary - with type key = int - and type value = bool Mvbdu_sig.skeleton) - -module D_Association_list_skeleton = - (Dictionary.Dictionary_of_Ord (Association_List_Skeleton):Dictionary.Dictionary - with type key = int - and type value = int List_sig.skeleton) - -module D_Range_list_skeleton = - (Dictionary.Dictionary_of_Ord (Range_List_Skeleton):Dictionary.Dictionary - with type key = int - and type value = (int option * int option) List_sig.skeleton) - -module D_Variables_list_skeleton = - (Dictionary.Dictionary_of_Ord (Variables_List_Skeleton):Dictionary.Dictionary - with type key = int - and type value = unit List_sig.skeleton) +module D_mvbdu_skeleton : + Dictionary.Dictionary + with type key = int + and type value = bool Mvbdu_sig.skeleton = + Dictionary.Dictionary_of_Ord (Mvbdu_Skeleton) + +module D_Association_list_skeleton : + Dictionary.Dictionary + with type key = int + and type value = int List_sig.skeleton = + Dictionary.Dictionary_of_Ord (Association_List_Skeleton) + +module D_Range_list_skeleton : + Dictionary.Dictionary + with type key = int + and type value = (int option * int option) List_sig.skeleton = + Dictionary.Dictionary_of_Ord (Range_List_Skeleton) + +module D_Variables_list_skeleton : + Dictionary.Dictionary + with type key = int + and type value = unit List_sig.skeleton = + Dictionary.Dictionary_of_Ord (Variables_List_Skeleton) module Hash_1 = Int_storage.Nearly_inf_Imperatif (*site_type*) - module Hash_2 = Int_storage.Nearly_Inf_Int_Int_storage_Imperatif_Imperatif type memo_unary = bool Mvbdu_sig.mvbdu Hash_1.t -type memo_tables = - { - boolean_mvbdu_identity : bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_not : bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_and : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_or : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_xor : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nand : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_equiv : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_is_implied : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_imply : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nis_implied : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nimply : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nor : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_fst : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nfst : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_snd : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nsnd : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_clean_head : bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_keep_head_only: bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_redefine : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_redefine_range : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_monotonicaly_rename: bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_project_keep_only: bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_project_abstract_away: bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_length_variables_list: int Hash_1.t; - boolean_mvbdu_merge_variables_lists: unit List_sig.list Hash_2.t; - boolean_mvbdu_overwrite_association_list: int List_sig.list Hash_2.t; - - boolean_mvbdu_extensional_description_of_variables_list: int list Hash_1.t; - - boolean_mvbdu_extensional_description_of_association_list: (int * int) list Hash_1.t; - boolean_mvbdu_extensional_description_of_range_list: (int * (int option *int option)) list - Hash_1.t; - - - boolean_mvbdu_variables_of_mvbdu: unit List_sig.list Hash_1.t; - - boolean_mvbdu_extensional_description_of_mvbdu: (int *int ) list list Hash_1.t; - } - -type mvbdu_dic = (bool Mvbdu_sig.cell, bool Mvbdu_sig.mvbdu) D_mvbdu_skeleton.dictionary -type association_list_dic = (int List_sig.cell, int List_sig.list) D_Association_list_skeleton.dictionary -type range_list_dic = ((int option * int option) List_sig.cell, (int option * int option) List_sig.list) -D_Range_list_skeleton.dictionary -type variables_list_dic = (unit List_sig.cell, unit List_sig.list) D_Variables_list_skeleton.dictionary -type handler = (memo_tables, mvbdu_dic, association_list_dic, range_list_dic, variables_list_dic, bool, int) Memo_sig.handler +type memo_tables = { + boolean_mvbdu_identity: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_not: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_and: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_or: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_xor: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nand: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_equiv: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_is_implied: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_imply: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nis_implied: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nimply: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nor: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_fst: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nfst: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_snd: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nsnd: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_clean_head: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_keep_head_only: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_redefine: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_redefine_range: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_monotonicaly_rename: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_project_keep_only: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_project_abstract_away: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_length_variables_list: int Hash_1.t; + boolean_mvbdu_merge_variables_lists: unit List_sig.list Hash_2.t; + boolean_mvbdu_overwrite_association_list: int List_sig.list Hash_2.t; + boolean_mvbdu_extensional_description_of_variables_list: int list Hash_1.t; + boolean_mvbdu_extensional_description_of_association_list: + (int * int) list Hash_1.t; + boolean_mvbdu_extensional_description_of_range_list: + (int * (int option * int option)) list Hash_1.t; + boolean_mvbdu_variables_of_mvbdu: unit List_sig.list Hash_1.t; + boolean_mvbdu_extensional_description_of_mvbdu: (int * int) list list Hash_1.t; +} + +type mvbdu_dic = + (bool Mvbdu_sig.cell, bool Mvbdu_sig.mvbdu) D_mvbdu_skeleton.dictionary + +type association_list_dic = + (int List_sig.cell, int List_sig.list) D_Association_list_skeleton.dictionary + +type range_list_dic = + ( (int option * int option) List_sig.cell, + (int option * int option) List_sig.list ) + D_Range_list_skeleton.dictionary + +type variables_list_dic = + (unit List_sig.cell, unit List_sig.list) D_Variables_list_skeleton.dictionary + +type handler = + ( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + int ) + Memo_sig.handler type unary_memoized_fun = - (bool, - mvbdu_dic, - association_list_dic, - range_list_dic, - variables_list_dic, - Exception.method_handler -> bool -> Exception.method_handler * - (bool Mvbdu_sig.mvbdu,bool) Mvbdu_sig.premvbdu, memo_tables, - memo_tables, int) - Memo_sig.memoized_fun + ( bool, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + Exception.method_handler -> + bool -> + Exception.method_handler * (bool Mvbdu_sig.mvbdu, bool) Mvbdu_sig.premvbdu, + memo_tables, + memo_tables, + int ) + Memo_sig.memoized_fun let split_memo error handler = let x = handler.Memo_sig.data in - error, - [ (* _ -> mvbdu *) - "id:", x.boolean_mvbdu_identity; - "not:", x.boolean_mvbdu_not; - "clean_head:", x.boolean_mvbdu_clean_head; - "keep_head_only:", x.boolean_mvbdu_keep_head_only; - ], - [ (* _ -> _ -> mvbdu *) - "and:", x.boolean_mvbdu_and; - "or:", x.boolean_mvbdu_or; - "xor:", x.boolean_mvbdu_xor; - "nand:", x.boolean_mvbdu_nand; - "<=>:", x.boolean_mvbdu_equiv; - "<=:", x.boolean_mvbdu_is_implied; - "=>:", x.boolean_mvbdu_imply; - "not <=:", x.boolean_mvbdu_nis_implied; - "not =>:", x.boolean_mvbdu_nimply; - "not:", x.boolean_mvbdu_nor; - "fst:", x.boolean_mvbdu_fst; - "not fst:", x.boolean_mvbdu_nfst; - "snd:", x.boolean_mvbdu_snd; - "not snd:", x.boolean_mvbdu_nsnd; - "reset:", x.boolean_mvbdu_redefine; - "rename:", x.boolean_mvbdu_monotonicaly_rename; - "project_onto:", x.boolean_mvbdu_project_keep_only; - "project_away:", x.boolean_mvbdu_project_abstract_away;], - [ (* _ -> variables_list *) - "variables_of:", x.boolean_mvbdu_variables_of_mvbdu; - ], - [ (* _ -> _ -> variables_list *) - "merge:", x.boolean_mvbdu_merge_variables_lists; - ], - [ (* _ -> _ -> association_list *) - "overwrite:", x.boolean_mvbdu_overwrite_association_list; - ], - [ (* _ -> int list *) - "extensional_of_variables_list:", x.boolean_mvbdu_extensional_description_of_variables_list; - ], - [ (* _ -> (int * int) list *) - "Boolean_mvbdu_extensional_description_of_association_list:", - x.boolean_mvbdu_extensional_description_of_association_list; - ], - [ (* _ -> (int * (int option * int option)) list *) - "Boolean_mvbdu_extensional_description_of_range_list:", - x.boolean_mvbdu_extensional_description_of_range_list; - ], - [ (* _ -> (int * int) list list *) - "Boolean_mvbdu_extensional_description_of_mvbdu:",x.boolean_mvbdu_extensional_description_of_mvbdu; - ] + ( error, + [ + (* _ -> mvbdu *) + "id:", x.boolean_mvbdu_identity; + "not:", x.boolean_mvbdu_not; + "clean_head:", x.boolean_mvbdu_clean_head; + "keep_head_only:", x.boolean_mvbdu_keep_head_only; + ], + [ + (* _ -> _ -> mvbdu *) + "and:", x.boolean_mvbdu_and; + "or:", x.boolean_mvbdu_or; + "xor:", x.boolean_mvbdu_xor; + "nand:", x.boolean_mvbdu_nand; + "<=>:", x.boolean_mvbdu_equiv; + "<=:", x.boolean_mvbdu_is_implied; + "=>:", x.boolean_mvbdu_imply; + "not <=:", x.boolean_mvbdu_nis_implied; + "not =>:", x.boolean_mvbdu_nimply; + "not:", x.boolean_mvbdu_nor; + "fst:", x.boolean_mvbdu_fst; + "not fst:", x.boolean_mvbdu_nfst; + "snd:", x.boolean_mvbdu_snd; + "not snd:", x.boolean_mvbdu_nsnd; + "reset:", x.boolean_mvbdu_redefine; + "rename:", x.boolean_mvbdu_monotonicaly_rename; + "project_onto:", x.boolean_mvbdu_project_keep_only; + "project_away:", x.boolean_mvbdu_project_abstract_away; + ], + [ + (* _ -> variables_list *) + "variables_of:", x.boolean_mvbdu_variables_of_mvbdu; + ], + [ + (* _ -> _ -> variables_list *) + "merge:", x.boolean_mvbdu_merge_variables_lists; + ], + [ + (* _ -> _ -> association_list *) + "overwrite:", x.boolean_mvbdu_overwrite_association_list; + ], + [ + (* _ -> int list *) + ( "extensional_of_variables_list:", + x.boolean_mvbdu_extensional_description_of_variables_list ); + ], + [ + (* _ -> (int * int) list *) + ( "Boolean_mvbdu_extensional_description_of_association_list:", + x.boolean_mvbdu_extensional_description_of_association_list ); + ], + [ + (* _ -> (int * (int option * int option)) list *) + ( "Boolean_mvbdu_extensional_description_of_range_list:", + x.boolean_mvbdu_extensional_description_of_range_list ); + ], + [ + (* _ -> (int * int) list list *) + ( "Boolean_mvbdu_extensional_description_of_mvbdu:", + x.boolean_mvbdu_extensional_description_of_mvbdu ); + ] ) let rec print_cell parameter cell = match cell with | Mvbdu_sig.Leaf x -> - let s = "Leaf "^(if x then "True" else "False")^" \n" in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s%s" (Remanent_parameters.get_prefix parameter) s in + let s = + "Leaf " + ^ (if x then + "True" + else + "False") + ^ " \n" + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s" + (Remanent_parameters.get_prefix parameter) + s + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in () | Mvbdu_sig.Node x -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%sNode(site_type:%i<%i)" + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%sNode(site_type:%i<%i)" (Remanent_parameters.get_prefix parameter) x.Mvbdu_sig.variable (x.Mvbdu_sig.upper_bound + 1) @@ -208,7 +253,13 @@ let rec print_cell parameter cell = () and print_mvbdu parameter mvbdu = - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%sId=%i" (Remanent_parameters.get_prefix parameter) mvbdu.Mvbdu_sig.id in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%sId=%i" + (Remanent_parameters.get_prefix parameter) + mvbdu.Mvbdu_sig.id + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in let parameter = Remanent_parameters.update_prefix parameter " " in let _ = print_cell parameter mvbdu.Mvbdu_sig.value in @@ -217,417 +268,515 @@ and print_mvbdu parameter mvbdu = and print_skeleton parameter skel = match skel with | Mvbdu_sig.Leaf x -> - let s = "Leaf "^(if x then "True" else "False")^" \n" in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s%s" (Remanent_parameters.get_prefix parameter) s in + let s = + "Leaf " + ^ (if x then + "True" + else + "False") + ^ " \n" + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s" + (Remanent_parameters.get_prefix parameter) + s + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in () | Mvbdu_sig.Node x -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%sNode(site_type:%i<%i,branch_true:%i,branch_false:%i)" + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%sNode(site_type:%i<%i,branch_true:%i,branch_false:%i)" (Remanent_parameters.get_prefix parameter) x.Mvbdu_sig.variable (x.Mvbdu_sig.upper_bound + 1) - x.Mvbdu_sig.branch_true - x.Mvbdu_sig.branch_false + x.Mvbdu_sig.branch_true x.Mvbdu_sig.branch_false in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in () let init_data parameters error = - let error,id = Hash_1.create parameters error 0 in - let error,not = Hash_1.create parameters error 0 in - let error,mvbdu_clean_head = Hash_1.create parameters error 0 in - let error,mvbdu_keep_head_only = Hash_1.create parameters error 0 in - let error,mvbdu_and = Hash_2.create parameters error (0,0) in - let error,mvbdu_or = Hash_2.create parameters error (0,0) in - let error,mvbdu_xor = Hash_2.create parameters error (0,0) in - let error,mvbdu_nand = Hash_2.create parameters error (0,0) in - let error,mvbdu_eq = Hash_2.create parameters error (0,0) in - let error,mvbdu_nor = Hash_2.create parameters error (0,0) in - let error,mvbdu_fst = Hash_2.create parameters error (0,0) in - let error,mvbdu_snd = Hash_2.create parameters error (0,0) in - let error,mvbdu_nfst = Hash_2.create parameters error (0,0) in - let error,mvbdu_nsnd = Hash_2.create parameters error (0,0) in - let error,mvbdu_imply = Hash_2.create parameters error (0,0) in - let error,mvbdu_is_implied = Hash_2.create parameters error (0,0) in - let error,mvbdu_nimply = Hash_2.create parameters error (0,0) in - let error,mvbdu_nis_implied = Hash_2.create parameters error (0,0) in - let error,mvbdu_redefine = Hash_2.create parameters error (0,0) in - let error,mvbdu_redefine_range = Hash_2.create parameters error (0,0) in - let error,mvbdu_project_keep_only = Hash_2.create parameters error (0,0) in - let error,mvbdu_project_abstract_away = Hash_2.create parameters error (0,0) in - let error,mvbdu_merge = Hash_2.create parameters error (0,0) in - let error,mvbdu_length = Hash_1.create parameters error 0 in - let error,mvbdu_overwrite = Hash_2.create parameters error (0,0) in - let error,mvbdu_extensional_range_list = Hash_1.create parameters error 0 in - let error,mvbdu_extensional_variables_list = Hash_1.create parameters error 0 in - let error,mvbdu_extensional_association_list = Hash_1.create parameters error 0 in - let error,mvbdu_variables_of = Hash_1.create parameters error 0 in - let error,mvbdu_extensional_description_of_mvbdu = Hash_1.create parameters error 0 in - let error,mvbdu_rename = Hash_2.create parameters error (0,0) in - error, - { - boolean_mvbdu_clean_head = mvbdu_clean_head ; - boolean_mvbdu_keep_head_only = mvbdu_keep_head_only ; - boolean_mvbdu_identity = id ; - boolean_mvbdu_not = not; - boolean_mvbdu_and = mvbdu_and ; - boolean_mvbdu_or = mvbdu_or ; - boolean_mvbdu_xor = mvbdu_xor ; - boolean_mvbdu_nand = mvbdu_nand ; - boolean_mvbdu_equiv = mvbdu_eq; - boolean_mvbdu_nor = mvbdu_nor ; - boolean_mvbdu_fst = mvbdu_fst ; - boolean_mvbdu_snd = mvbdu_snd ; - boolean_mvbdu_nfst = mvbdu_nfst; - boolean_mvbdu_nsnd = mvbdu_nsnd; - boolean_mvbdu_is_implied = mvbdu_is_implied; - boolean_mvbdu_imply = mvbdu_imply; - boolean_mvbdu_nis_implied = mvbdu_nis_implied; - boolean_mvbdu_nimply = mvbdu_nimply; - boolean_mvbdu_redefine = mvbdu_redefine; - boolean_mvbdu_redefine_range = mvbdu_redefine_range; - boolean_mvbdu_monotonicaly_rename = mvbdu_rename; - boolean_mvbdu_project_keep_only = mvbdu_project_keep_only; - boolean_mvbdu_project_abstract_away = mvbdu_project_abstract_away; - boolean_mvbdu_merge_variables_lists = mvbdu_merge; - boolean_mvbdu_length_variables_list = mvbdu_length; - boolean_mvbdu_overwrite_association_list = mvbdu_overwrite; - boolean_mvbdu_extensional_description_of_variables_list = mvbdu_extensional_variables_list; - boolean_mvbdu_extensional_description_of_association_list = mvbdu_extensional_association_list; - boolean_mvbdu_extensional_description_of_range_list = - mvbdu_extensional_range_list; - boolean_mvbdu_variables_of_mvbdu = mvbdu_variables_of; - boolean_mvbdu_extensional_description_of_mvbdu = mvbdu_extensional_description_of_mvbdu; - } + let error, id = Hash_1.create parameters error 0 in + let error, not = Hash_1.create parameters error 0 in + let error, mvbdu_clean_head = Hash_1.create parameters error 0 in + let error, mvbdu_keep_head_only = Hash_1.create parameters error 0 in + let error, mvbdu_and = Hash_2.create parameters error (0, 0) in + let error, mvbdu_or = Hash_2.create parameters error (0, 0) in + let error, mvbdu_xor = Hash_2.create parameters error (0, 0) in + let error, mvbdu_nand = Hash_2.create parameters error (0, 0) in + let error, mvbdu_eq = Hash_2.create parameters error (0, 0) in + let error, mvbdu_nor = Hash_2.create parameters error (0, 0) in + let error, mvbdu_fst = Hash_2.create parameters error (0, 0) in + let error, mvbdu_snd = Hash_2.create parameters error (0, 0) in + let error, mvbdu_nfst = Hash_2.create parameters error (0, 0) in + let error, mvbdu_nsnd = Hash_2.create parameters error (0, 0) in + let error, mvbdu_imply = Hash_2.create parameters error (0, 0) in + let error, mvbdu_is_implied = Hash_2.create parameters error (0, 0) in + let error, mvbdu_nimply = Hash_2.create parameters error (0, 0) in + let error, mvbdu_nis_implied = Hash_2.create parameters error (0, 0) in + let error, mvbdu_redefine = Hash_2.create parameters error (0, 0) in + let error, mvbdu_redefine_range = Hash_2.create parameters error (0, 0) in + let error, mvbdu_project_keep_only = Hash_2.create parameters error (0, 0) in + let error, mvbdu_project_abstract_away = + Hash_2.create parameters error (0, 0) + in + let error, mvbdu_merge = Hash_2.create parameters error (0, 0) in + let error, mvbdu_length = Hash_1.create parameters error 0 in + let error, mvbdu_overwrite = Hash_2.create parameters error (0, 0) in + let error, mvbdu_extensional_range_list = Hash_1.create parameters error 0 in + let error, mvbdu_extensional_variables_list = + Hash_1.create parameters error 0 + in + let error, mvbdu_extensional_association_list = + Hash_1.create parameters error 0 + in + let error, mvbdu_variables_of = Hash_1.create parameters error 0 in + let error, mvbdu_extensional_description_of_mvbdu = + Hash_1.create parameters error 0 + in + let error, mvbdu_rename = Hash_2.create parameters error (0, 0) in + ( error, + { + boolean_mvbdu_clean_head = mvbdu_clean_head; + boolean_mvbdu_keep_head_only = mvbdu_keep_head_only; + boolean_mvbdu_identity = id; + boolean_mvbdu_not = not; + boolean_mvbdu_and = mvbdu_and; + boolean_mvbdu_or = mvbdu_or; + boolean_mvbdu_xor = mvbdu_xor; + boolean_mvbdu_nand = mvbdu_nand; + boolean_mvbdu_equiv = mvbdu_eq; + boolean_mvbdu_nor = mvbdu_nor; + boolean_mvbdu_fst = mvbdu_fst; + boolean_mvbdu_snd = mvbdu_snd; + boolean_mvbdu_nfst = mvbdu_nfst; + boolean_mvbdu_nsnd = mvbdu_nsnd; + boolean_mvbdu_is_implied = mvbdu_is_implied; + boolean_mvbdu_imply = mvbdu_imply; + boolean_mvbdu_nis_implied = mvbdu_nis_implied; + boolean_mvbdu_nimply = mvbdu_nimply; + boolean_mvbdu_redefine = mvbdu_redefine; + boolean_mvbdu_redefine_range = mvbdu_redefine_range; + boolean_mvbdu_monotonicaly_rename = mvbdu_rename; + boolean_mvbdu_project_keep_only = mvbdu_project_keep_only; + boolean_mvbdu_project_abstract_away = mvbdu_project_abstract_away; + boolean_mvbdu_merge_variables_lists = mvbdu_merge; + boolean_mvbdu_length_variables_list = mvbdu_length; + boolean_mvbdu_overwrite_association_list = mvbdu_overwrite; + boolean_mvbdu_extensional_description_of_variables_list = + mvbdu_extensional_variables_list; + boolean_mvbdu_extensional_description_of_association_list = + mvbdu_extensional_association_list; + boolean_mvbdu_extensional_description_of_range_list = + mvbdu_extensional_range_list; + boolean_mvbdu_variables_of_mvbdu = mvbdu_variables_of; + boolean_mvbdu_extensional_description_of_mvbdu = + mvbdu_extensional_description_of_mvbdu; + } ) let init_remanent parameters error = - let error,data = init_data parameters error in - error,{ - Memo_sig.data = data; - Memo_sig.range_list_dictionary = D_Range_list_skeleton.init () ; - Memo_sig.mvbdu_dictionary = D_mvbdu_skeleton.init (); - Memo_sig.association_list_dictionary = D_Association_list_skeleton.init (); - Memo_sig.variables_list_dictionary = D_Variables_list_skeleton.init (); - Memo_sig.print_skel = print_skeleton ; - Memo_sig.print_cell = print_cell ; - Memo_sig.print_mvbdu = print_mvbdu - } - -let mvbdu_allocate = - (fun parameters error b c d e - (old_handler:('a,mvbdu_dic,association_list_dic,range_list_dic,variables_list_dic,'c,'d) Memo_sig.handler) -> - let old_dictionary = old_handler.Memo_sig.mvbdu_dictionary in - let error,output = - D_mvbdu_skeleton.allocate - parameters + let error, data = init_data parameters error in + ( error, + { + Memo_sig.data; + Memo_sig.range_list_dictionary = D_Range_list_skeleton.init (); + Memo_sig.mvbdu_dictionary = D_mvbdu_skeleton.init (); + Memo_sig.association_list_dictionary = D_Association_list_skeleton.init (); + Memo_sig.variables_list_dictionary = D_Variables_list_skeleton.init (); + Memo_sig.print_skel = print_skeleton; + Memo_sig.print_cell; + Memo_sig.print_mvbdu; + } ) + +let mvbdu_allocate parameters error b c d e + (old_handler : + ( 'a, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + 'c, + 'd ) + Memo_sig.handler) = + let old_dictionary = old_handler.Memo_sig.mvbdu_dictionary in + let error, output = + D_mvbdu_skeleton.allocate parameters error b c d e old_dictionary + in + match output with + | None -> error, None + | Some ((i : int), a, b, new_dic) -> + let error = + if Remanent_parameters.get_trace parameters && trace_mvbdu_allocation then ( + let error, int = D_mvbdu_skeleton.last_entry parameters error new_dic in + if i = int then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "LAST ENTRY: %i" int + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error + ) else + error + ) else error - b - c - d - e - old_dictionary in - match output with - | None -> error,None - | Some ((i:int), a, b, new_dic) -> - let error = - if Remanent_parameters.get_trace parameters - && trace_mvbdu_allocation - then - let error,int = - D_mvbdu_skeleton.last_entry - parameters - error - new_dic - in - if i=int - then - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "LAST ENTRY: %i" int in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - error - else error - else error - in - let new_handler = - Mvbdu_core.update_dictionary - old_handler - new_dic - in - error, (Some (i, a, b, new_handler))) + let new_handler = Mvbdu_core.update_dictionary old_handler new_dic in + error, Some (i, a, b, new_handler) let build_memoize_unary f get_handler update_handler = - Mvbdu_algebra.recursive_memoize - f - get_handler - update_handler + Mvbdu_algebra.recursive_memoize f get_handler update_handler (fun parameters error handler mvbdu x -> - let a,b = - Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) x - in - a,(handler,b)) + let a, b = + Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) x + in + a, (handler, b)) (fun parameters error _handler mvbdu -> - Hash_1.set - parameters - error - (Mvbdu_core.id_of_mvbdu mvbdu)) + Hash_1.set parameters error (Mvbdu_core.id_of_mvbdu mvbdu)) let build_memoize_binary f get_handler update_handler = - Mvbdu_algebra.recursive_memoize - f - get_handler - update_handler - (fun parameters error handler (mvbdu_a,mvbdu_b) x -> - let a,b = - Hash_2.unsafe_get parameters error - (Mvbdu_core.id_of_mvbdu mvbdu_a, Mvbdu_core.id_of_mvbdu mvbdu_b) x - in - a, (handler,b)) - (fun parameters error _handler (mvbdu_a,mvbdu_b) -> - Hash_2.set parameters error - (Mvbdu_core.id_of_mvbdu mvbdu_a, Mvbdu_core.id_of_mvbdu mvbdu_b)) + Mvbdu_algebra.recursive_memoize f get_handler update_handler + (fun parameters error handler (mvbdu_a, mvbdu_b) x -> + let a, b = + Hash_2.unsafe_get parameters error + (Mvbdu_core.id_of_mvbdu mvbdu_a, Mvbdu_core.id_of_mvbdu mvbdu_b) + x + in + a, (handler, b)) + (fun parameters error _handler (mvbdu_a, mvbdu_b) -> + Hash_2.set parameters error + (Mvbdu_core.id_of_mvbdu mvbdu_a, Mvbdu_core.id_of_mvbdu mvbdu_b)) let memo_identity = Mvbdu_algebra.not_recursive_not_memoize_unary (fun error x -> error, x.Mvbdu_sig.value, Some x) - (fun parameters error -> - (fun bool -> - error, - (fun error -> - Exception.warn - parameters error __POS__ Exit - (Mvbdu_sig.Leaf bool) - ))) + (fun parameters error bool -> + ( error, + fun error -> + Exception.warn parameters error __POS__ Exit (Mvbdu_sig.Leaf bool) )) mvbdu_allocate let memo_not = - (build_memoize_unary - (fun _parameters error x -> error, (fun error -> error, Mvbdu_sig.Leaf (not x))) - (fun x -> x.Memo_sig.data.boolean_mvbdu_not) - (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_not = x}})) + build_memoize_unary + (fun _parameters error x -> + error, fun error -> error, Mvbdu_sig.Leaf (not x)) + (fun x -> x.Memo_sig.data.boolean_mvbdu_not) + (fun x h -> + { h with Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_not = x } }) let boolean_mvbdu_not parameters = - Mvbdu_algebra.generic_unary - (mvbdu_allocate parameters) - memo_not + Mvbdu_algebra.generic_unary (mvbdu_allocate parameters) memo_not -let memo_constant_true = +let memo_constant_true = Mvbdu_algebra.not_recursive_not_memoize_unary - (fun error _ -> error, Mvbdu_sig.Leaf true,None) - (fun parameters error -> - (fun _bool -> - error, - (fun error -> - Exception.warn - parameters error __POS__ Exit - (Mvbdu_sig.Leaf true)))) + (fun error _ -> error, Mvbdu_sig.Leaf true, None) + (fun parameters error _bool -> + ( error, + fun error -> + Exception.warn parameters error __POS__ Exit (Mvbdu_sig.Leaf true) )) mvbdu_allocate let memo_constant_false = Mvbdu_algebra.not_recursive_not_memoize_unary - (fun error _ -> error, Mvbdu_sig.Leaf false,None) - (fun parameters error -> - (fun _bool -> - error, - (fun error -> - Exception.warn - parameters error __POS__ Exit - (Mvbdu_sig.Leaf false)))) + (fun error _ -> error, Mvbdu_sig.Leaf false, None) + (fun parameters error _bool -> + ( error, + fun error -> + Exception.warn parameters error __POS__ Exit (Mvbdu_sig.Leaf false) )) mvbdu_allocate let boolean_mvbdu_true parameters handler = - Mvbdu_algebra.generic_zeroary - (mvbdu_allocate parameters) - handler + Mvbdu_algebra.generic_zeroary (mvbdu_allocate parameters) handler (fun error -> error, Mvbdu_sig.Leaf true) let boolean_mvbdu_false parameters handler = - Mvbdu_algebra.generic_zeroary - (mvbdu_allocate parameters) - handler + Mvbdu_algebra.generic_zeroary (mvbdu_allocate parameters) handler (fun error -> error, Mvbdu_sig.Leaf false) let boolean_mvbdu_constant_true parameters = - Mvbdu_algebra.generic_unary - (mvbdu_allocate parameters) - memo_constant_true + Mvbdu_algebra.generic_unary (mvbdu_allocate parameters) memo_constant_true let boolean_mvbdu_constant_false parameters = - Mvbdu_algebra.generic_unary - (mvbdu_allocate parameters) - memo_constant_false + Mvbdu_algebra.generic_unary (mvbdu_allocate parameters) memo_constant_false let boolean_mvbdu_and parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error, - if x then memo_identity else memo_constant_false) - in - (g,g)) + let g x = + ( error, + if x then + memo_identity + else + memo_constant_false ) + in + g, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_and) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_and = x}}) - ) + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_and = x }; + })) let memo_or = build_memoize_binary (fun _parameters error -> - let g x = (error, - if x then memo_constant_true else memo_identity) - in - (g,g)) + let g x = + ( error, + if x then + memo_constant_true + else + memo_identity ) + in + g, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_or) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_or = x}}) + (fun x h -> + { h with Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_or = x } }) let boolean_mvbdu_or parameters = - Mvbdu_algebra.generic_binary - (mvbdu_allocate parameters) - memo_or + Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) memo_or let boolean_mvbdu_xor parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error, - if x then memo_not else memo_identity) - in - (g,g)) + let g x = + ( error, + if x then + memo_not + else + memo_identity ) + in + g, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_xor) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_xor = x}})) + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_xor = x }; + })) let boolean_mvbdu_nand parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error, - if x then memo_not else memo_constant_true) - in - (g,g)) + let g x = + ( error, + if x then + memo_not + else + memo_constant_true ) + in + g, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_nand) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_nand = x}})) + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_nand = x }; + })) let boolean_mvbdu_equiv parameters = Mvbdu_algebra.generic_binary - (mvbdu_allocate parameters ) + (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error, - if x then memo_identity else memo_not) - in (g,g)) + let g x = + ( error, + if x then + memo_identity + else + memo_not ) + in + g, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_equiv) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_equiv = x}})) + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_equiv = x }; + })) let boolean_mvbdu_nor parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error, - if x then memo_constant_false else memo_not) - in - (g,g)) + let g x = + ( error, + if x then + memo_constant_false + else + memo_not ) + in + g, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_nor) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_nor = x}})) + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_nor = x }; + })) let boolean_mvbdu_imply parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error,if x then memo_identity else memo_constant_true) in - let h x = (error,if x then memo_constant_true else memo_not) in - (g,h)) + let g x = + ( error, + if x then + memo_identity + else + memo_constant_true ) + in + let h x = + ( error, + if x then + memo_constant_true + else + memo_not ) + in + g, h) (fun x -> x.Memo_sig.data.boolean_mvbdu_imply) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_imply = x}})) + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_imply = x }; + })) let boolean_mvbdu_is_implied parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error,if x then memo_identity else memo_constant_true) in - let h x = (error,if x then memo_constant_true else memo_not) in - (h,g)) + let g x = + ( error, + if x then + memo_identity + else + memo_constant_true ) + in + let h x = + ( error, + if x then + memo_constant_true + else + memo_not ) + in + h, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_is_implied) (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_is_implied = x}})) + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_is_implied = x }; + })) let boolean_mvbdu_nimply parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error,if x then memo_not else memo_constant_false) in - let h x = (error,if x then memo_constant_false else memo_identity) in - (g,h)) + let g x = + ( error, + if x then + memo_not + else + memo_constant_false ) + in + let h x = + ( error, + if x then + memo_constant_false + else + memo_identity ) + in + g, h) (fun x -> x.Memo_sig.data.boolean_mvbdu_nimply) (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_nimply = x}})) + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_nimply = x }; + })) let boolean_mvbdu_nis_implied parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error,if x then memo_not else memo_constant_false) in - let h x = (error,if x then memo_constant_false else memo_identity) in - (h,g)) + let g x = + ( error, + if x then + memo_not + else + memo_constant_false ) + in + let h x = + ( error, + if x then + memo_constant_false + else + memo_identity ) + in + h, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_nis_implied) (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_nis_implied = x}})) + { + h with + Memo_sig.data = + { h.Memo_sig.data with boolean_mvbdu_nis_implied = x }; + })) let boolean_constant_bi_true parameters = Mvbdu_algebra.generic_binary - (mvbdu_allocate parameters ) + (mvbdu_allocate parameters) (Mvbdu_algebra.not_recursive_binary - (fun error _ _ -> error,Mvbdu_sig.Leaf true, None) + (fun error _ _ -> error, Mvbdu_sig.Leaf true, None) (fun parameters error -> - let g (_:bool) = - Exception.warn parameters error __POS__ Exit memo_identity - in - (g,g)) + let g (_ : bool) = + Exception.warn parameters error __POS__ Exit memo_identity + in + g, g) (mvbdu_allocate parameters)) let boolean_constant_bi_false parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (Mvbdu_algebra.not_recursive_binary - (fun error _ _ -> error,Mvbdu_sig.Leaf false, None) + (fun error _ _ -> error, Mvbdu_sig.Leaf false, None) (fun _parameters error -> - let g (_:bool) = - Exception.warn parameters error __POS__ Exit memo_identity - in - (g,g)) + let g (_ : bool) = + Exception.warn parameters error __POS__ Exit memo_identity + in + g, g) (mvbdu_allocate parameters)) let boolean_mvbdu_fst parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (Mvbdu_algebra.not_recursive_binary - (fun error x _ -> error,x.Mvbdu_sig.value,Some x) + (fun error x _ -> error, x.Mvbdu_sig.value, Some x) (fun parameters error -> - let g (_:bool) = - Exception.warn parameters error __POS__ Exit memo_identity - in - (g,g)) + let g (_ : bool) = + Exception.warn parameters error __POS__ Exit memo_identity + in + g, g) (mvbdu_allocate parameters)) let boolean_mvbdu_snd parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (Mvbdu_algebra.not_recursive_binary - (fun error x y -> error,x.Mvbdu_sig.value,Some y) + (fun error x y -> error, x.Mvbdu_sig.value, Some y) (fun parameters error -> - let g (_:bool) = - Exception.warn parameters error __POS__ Exit memo_identity - in - (g,g)) + let g (_ : bool) = + Exception.warn parameters error __POS__ Exit memo_identity + in + g, g) (mvbdu_allocate parameters)) let boolean_mvbdu_nfst parameters = @@ -635,236 +784,231 @@ let boolean_mvbdu_nfst parameters = (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error,if x then memo_constant_false else memo_constant_true) in - let h _ = (error,memo_not) in - (g,h)) + let g x = + ( error, + if x then + memo_constant_false + else + memo_constant_true ) + in + let h _ = error, memo_not in + g, h) (fun x -> x.Memo_sig.data.boolean_mvbdu_nfst) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_nfst = x}})) + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_nfst = x }; + })) let boolean_mvbdu_nsnd parameters = Mvbdu_algebra.generic_binary (mvbdu_allocate parameters) (build_memoize_binary (fun _parameters error -> - let g x = (error,if x then memo_constant_false else memo_constant_true) in - let h _ = (error,memo_not) in - (h,g)) + let g x = + ( error, + if x then + memo_constant_false + else + memo_constant_true ) + in + let h _ = error, memo_not in + h, g) (fun x -> x.Memo_sig.data.boolean_mvbdu_nsnd) - (fun x h -> {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_nsnd = x}})) - -let gen_list_allocate allocate get_dic update parameters error b c d e (old_handler:('a,mvbdu_dic,association_list_dic,range_list_dic,variables_list_dic,'c,'d) Memo_sig.handler) = + (fun x h -> + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_nsnd = x }; + })) + +let gen_list_allocate allocate get_dic update parameters error b c d e + (old_handler : + ( 'a, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + 'c, + 'd ) + Memo_sig.handler) = let old_dictionary = get_dic old_handler in - let error,output = - allocate - parameters - error - b - c - d - e - old_dictionary - in + let error, output = allocate parameters error b c d e old_dictionary in match output with | None -> error, None - | Some (i,a,b,new_dic) -> - let new_handler = - update - old_handler - new_dic - in - error, (Some (i, a, b, new_handler)) - + | Some (i, a, b, new_dic) -> + let new_handler = update old_handler new_dic in + error, Some (i, a, b, new_handler) let association_list_allocate parameters error b c d e old_handler = - gen_list_allocate D_Association_list_skeleton.allocate (fun x -> x.Memo_sig.association_list_dictionary) - List_core.update_association_dictionary - parameters error b c d e old_handler + gen_list_allocate D_Association_list_skeleton.allocate + (fun x -> x.Memo_sig.association_list_dictionary) + List_core.update_association_dictionary parameters error b c d e old_handler let range_list_allocate parameters error b c d e old_handler = - gen_list_allocate D_Range_list_skeleton.allocate (fun x -> x.Memo_sig.range_list_dictionary) - List_core.update_range_dictionary - parameters error b c d e old_handler + gen_list_allocate D_Range_list_skeleton.allocate + (fun x -> x.Memo_sig.range_list_dictionary) + List_core.update_range_dictionary parameters error b c d e old_handler let variables_list_allocate parameters error b c d e old_handler = - gen_list_allocate D_Variables_list_skeleton.allocate (fun x -> x.Memo_sig.variables_list_dictionary) - List_core.update_variables_dictionary - parameters error b c d e old_handler + gen_list_allocate D_Variables_list_skeleton.allocate + (fun x -> x.Memo_sig.variables_list_dictionary) + List_core.update_variables_dictionary parameters error b c d e old_handler let memo_clean_head = Mvbdu_algebra.memoize_no_fun (fun x -> x.Memo_sig.data.boolean_mvbdu_clean_head) (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_clean_head = x}}) + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_clean_head = x }; + }) (fun parameters error handler mvbdu d -> - let a,b = Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d - in a,(handler,b) - ) + let a, b = + Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d + in + a, (handler, b)) (fun parameters error _h mvbdu -> - Hash_1.set - parameters - error - (Mvbdu_core.id_of_mvbdu mvbdu)) + Hash_1.set parameters error (Mvbdu_core.id_of_mvbdu mvbdu)) let clean_head parameters error handler = Mvbdu_algebra.clean_head (mvbdu_allocate parameters) - memo_clean_head - boolean_mvbdu_or - handler - error - parameters + memo_clean_head boolean_mvbdu_or handler error parameters let memo_clean_head = Mvbdu_algebra.memoize_no_fun (fun x -> x.Memo_sig.data.boolean_mvbdu_clean_head) (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_clean_head = x}}) + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_clean_head = x }; + }) (fun parameters error handler mvbdu d -> - match Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d with - | error,None -> - clean_head parameters error handler mvbdu - | error,Some x -> error,(handler,Some x) - ) + match + Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d + with + | error, None -> clean_head parameters error handler mvbdu + | error, Some x -> error, (handler, Some x)) (fun parameters error _h mvbdu -> - Hash_1.set - parameters - error - (Mvbdu_core.id_of_mvbdu mvbdu)) + Hash_1.set parameters error (Mvbdu_core.id_of_mvbdu mvbdu)) let memo_keep_head_only = Mvbdu_algebra.memoize_no_fun (fun x -> x.Memo_sig.data.boolean_mvbdu_keep_head_only) (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_keep_head_only = x}}) + { + h with + Memo_sig.data = + { h.Memo_sig.data with boolean_mvbdu_keep_head_only = x }; + }) (fun parameters error handler mvbdu d -> - let a,b = Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d - in a,(handler,b) - ) + let a, b = + Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d + in + a, (handler, b)) (fun parameters error _h mvbdu -> - Hash_1.set - parameters - error - (Mvbdu_core.id_of_mvbdu mvbdu)) + Hash_1.set parameters error (Mvbdu_core.id_of_mvbdu mvbdu)) let keep_head_only parameters error handler = Mvbdu_algebra.keep_head_only (mvbdu_allocate parameters) - memo_keep_head_only - boolean_mvbdu_true - handler - error - parameters + memo_keep_head_only boolean_mvbdu_true handler error parameters let memo_keep_head_only = Mvbdu_algebra.memoize_no_fun (fun x -> x.Memo_sig.data.boolean_mvbdu_keep_head_only) (fun x h -> - {h with Memo_sig.data = {h.Memo_sig.data with boolean_mvbdu_keep_head_only = x}}) + { + h with + Memo_sig.data = + { h.Memo_sig.data with boolean_mvbdu_keep_head_only = x }; + }) (fun parameters error handler mvbdu d -> - match Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d with - | error,None -> - keep_head_only parameters error handler mvbdu - | error,Some x -> error,(handler,Some x) - ) + match + Hash_1.unsafe_get parameters error (Mvbdu_core.id_of_mvbdu mvbdu) d + with + | error, None -> keep_head_only parameters error handler mvbdu + | error, Some x -> error, (handler, Some x)) (fun parameters error _h mvbdu -> - Hash_1.set - parameters - error - (Mvbdu_core.id_of_mvbdu mvbdu)) - + Hash_1.set parameters error (Mvbdu_core.id_of_mvbdu mvbdu)) let reset_handler error = { Memo_sig.empty_range_list = error, memo_identity; - Memo_sig.empty_association_list = error,memo_identity; - Memo_sig.empty_variables_list = error,memo_identity; - Memo_sig.leaf = (fun bool -> error,(fun error -> error, Mvbdu_sig.Leaf bool)); - Memo_sig.clean_head = error,memo_clean_head; + Memo_sig.empty_association_list = error, memo_identity; + Memo_sig.empty_variables_list = error, memo_identity; + Memo_sig.leaf = (fun bool -> error, fun error -> error, Mvbdu_sig.Leaf bool); + Memo_sig.clean_head = error, memo_clean_head; Memo_sig.build_false = - (fun _var _bound -> error,(fun error -> error, Mvbdu_sig.Leaf false)); - Memo_sig.build_true= + (fun _var _bound -> error, fun error -> error, Mvbdu_sig.Leaf false); + Memo_sig.build_true = (fun var bound mvbdu_false mvbdu_true -> - error, - (fun error -> - error, - if Mvbdu_core.mvbdu_equal mvbdu_true mvbdu_false - then - mvbdu_true.Mvbdu_sig.value - else - (Mvbdu_sig.Node - { - Mvbdu_sig.variable = var ; - Mvbdu_sig.upper_bound = bound ; - Mvbdu_sig.branch_true = mvbdu_true ; - Mvbdu_sig.branch_false = mvbdu_false}) - )) + ( error, + fun error -> + ( error, + if Mvbdu_core.mvbdu_equal mvbdu_true mvbdu_false then + mvbdu_true.Mvbdu_sig.value + else + Mvbdu_sig.Node + { + Mvbdu_sig.variable = var; + Mvbdu_sig.upper_bound = bound; + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + } ) )); } -let gen_bin_mvbdu_list f get set parameters error handler mvbdu_input list_input = - let memoized_fun = Mvbdu_algebra.recursive_memoize +let gen_bin_mvbdu_list f get set parameters error handler mvbdu_input list_input + = + let memoized_fun = + Mvbdu_algebra.recursive_memoize (fun _parameters -> reset_handler) - get - set - (fun parameters error handler (mvbdu,list) d -> - let a,b = - Hash_2.unsafe_get - parameters - error - (Mvbdu_core.id_of_mvbdu mvbdu, List_core.id_of_list list) - d - in - a, (handler, b)) - (fun parameters error _handler (mvbdu,list) -> - Hash_2.set - parameters - error - (Mvbdu_core.id_of_mvbdu mvbdu, List_core.id_of_list list)) + get set + (fun parameters error handler (mvbdu, list) d -> + let a, b = + Hash_2.unsafe_get parameters error + (Mvbdu_core.id_of_mvbdu mvbdu, List_core.id_of_list list) + d + in + a, (handler, b)) + (fun parameters error _handler (mvbdu, list) -> + Hash_2.set parameters error + (Mvbdu_core.id_of_mvbdu mvbdu, List_core.id_of_list list)) in f (mvbdu_allocate parameters) - memoized_fun - error - handler - mvbdu_input - list_input + memoized_fun error handler mvbdu_input list_input let redefine parameters error handler mvbdu_input list_input = - gen_bin_mvbdu_list - Mvbdu_algebra.redefine + gen_bin_mvbdu_list Mvbdu_algebra.redefine (fun x -> x.Memo_sig.data.boolean_mvbdu_redefine) (fun x h -> - { - h with Memo_sig.data = - { - h.Memo_sig.data with boolean_mvbdu_redefine = x - } - }) + { + h with + Memo_sig.data = { h.Memo_sig.data with boolean_mvbdu_redefine = x }; + }) parameters error handler mvbdu_input list_input let redefine_range parameters error handler mvbdu_input list_input = - gen_bin_mvbdu_list - Mvbdu_algebra.redefine_range + gen_bin_mvbdu_list Mvbdu_algebra.redefine_range (fun x -> x.Memo_sig.data.boolean_mvbdu_redefine_range) (fun x h -> - { - h with Memo_sig.data = - { - h.Memo_sig.data with boolean_mvbdu_redefine_range = x - } - }) + { + h with + Memo_sig.data = + { h.Memo_sig.data with boolean_mvbdu_redefine_range = x }; + }) parameters error handler mvbdu_input list_input let monotonicaly_rename parameters error handler mvbdu_input list_input = - gen_bin_mvbdu_list - Mvbdu_algebra.monotonicaly_rename + gen_bin_mvbdu_list Mvbdu_algebra.monotonicaly_rename (fun x -> x.Memo_sig.data.boolean_mvbdu_monotonicaly_rename) (fun x h -> - { - h with Memo_sig.data = - { - h.Memo_sig.data with boolean_mvbdu_monotonicaly_rename = x - } - }) + { + h with + Memo_sig.data = + { h.Memo_sig.data with boolean_mvbdu_monotonicaly_rename = x }; + }) parameters error handler mvbdu_input list_input let project_keep_only parameters error handler mvbdu_input list_input = @@ -872,276 +1016,256 @@ let project_keep_only parameters error handler mvbdu_input list_input = (fun a b -> Mvbdu_algebra.project_keep_only a b boolean_mvbdu_true) (fun x -> x.Memo_sig.data.boolean_mvbdu_project_keep_only) (fun x h -> - { - h with Memo_sig.data = - { - h.Memo_sig.data with boolean_mvbdu_project_keep_only = x - } - }) + { + h with + Memo_sig.data = + { h.Memo_sig.data with boolean_mvbdu_project_keep_only = x }; + }) parameters error handler mvbdu_input list_input let project_abstract_away parameters error handler mvbdu_input list_input = - gen_bin_mvbdu_list - Mvbdu_algebra.project_abstract_away + gen_bin_mvbdu_list Mvbdu_algebra.project_abstract_away (fun x -> x.Memo_sig.data.boolean_mvbdu_project_abstract_away) (fun x h -> - { - h with Memo_sig.data = - { - h.Memo_sig.data with boolean_mvbdu_project_abstract_away = x - } - }) + { + h with + Memo_sig.data = + { h.Memo_sig.data with boolean_mvbdu_project_abstract_away = x }; + }) parameters error handler mvbdu_input list_input let merge_variables_lists parameters error handler list1 list2 = List_algebra.overwrite (variables_list_allocate parameters) - (fun parameter error handler (x1,x2) -> - let error, output = - Hash_2.unsafe_get parameter error - (x1.List_sig.id, x2.List_sig.id) - handler.Memo_sig.data.boolean_mvbdu_merge_variables_lists - in - error, (handler, output)) - (fun parameter error handler (x1,x2) output -> - let error, memo = - Hash_2.set parameter error - (x1.List_sig.id, x2.List_sig.id) - output - handler.Memo_sig.data.boolean_mvbdu_merge_variables_lists - in - error, - { - handler with Memo_sig.data = - { - handler.Memo_sig.data with boolean_mvbdu_merge_variables_lists = memo - } - }) - error parameters handler - list1 - list2 + (fun parameter error handler (x1, x2) -> + let error, output = + Hash_2.unsafe_get parameter error + (x1.List_sig.id, x2.List_sig.id) + handler.Memo_sig.data.boolean_mvbdu_merge_variables_lists + in + error, (handler, output)) + (fun parameter error handler (x1, x2) output -> + let error, memo = + Hash_2.set parameter error + (x1.List_sig.id, x2.List_sig.id) + output handler.Memo_sig.data.boolean_mvbdu_merge_variables_lists + in + ( error, + { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_merge_variables_lists = memo; + }; + } )) + error parameters handler list1 list2 let length parameters error handler list = List_algebra.length (variables_list_allocate parameters) (fun parameter error handler x -> - let error, output = - Hash_1.unsafe_get parameter error - x.List_sig.id - handler.Memo_sig.data.boolean_mvbdu_length_variables_list - in - error, (handler, output)) + let error, output = + Hash_1.unsafe_get parameter error x.List_sig.id + handler.Memo_sig.data.boolean_mvbdu_length_variables_list + in + error, (handler, output)) (fun parameter error handler x output -> - let error, memo = - Hash_1.set parameter error - x.List_sig.id - output - handler.Memo_sig.data.boolean_mvbdu_length_variables_list - in - error, - { handler with Memo_sig.data = - {handler.Memo_sig.data with - boolean_mvbdu_length_variables_list = memo} - }) + let error, memo = + Hash_1.set parameter error x.List_sig.id output + handler.Memo_sig.data.boolean_mvbdu_length_variables_list + in + ( error, + { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_length_variables_list = memo; + }; + } )) error parameters handler list let overwrite_association_lists parameters error handler list1 list2 = List_algebra.overwrite (association_list_allocate parameters) - (fun parameter error handler (x1,x2) -> - let error, output = - Hash_2.unsafe_get parameter error - (x1.List_sig.id, x2.List_sig.id) - handler.Memo_sig.data.boolean_mvbdu_overwrite_association_list - in - error, (handler, output)) - (fun parameter error handler (x1,x2) output -> - let error, memo = - Hash_2.set parameter error - (x1.List_sig.id, x2.List_sig.id) - output - handler.Memo_sig.data.boolean_mvbdu_overwrite_association_list - in - error, - { - handler with Memo_sig.data = - { - handler.Memo_sig.data with - boolean_mvbdu_overwrite_association_list = memo - } - }) - error parameters handler - list1 - list2 + (fun parameter error handler (x1, x2) -> + let error, output = + Hash_2.unsafe_get parameter error + (x1.List_sig.id, x2.List_sig.id) + handler.Memo_sig.data.boolean_mvbdu_overwrite_association_list + in + error, (handler, output)) + (fun parameter error handler (x1, x2) output -> + let error, memo = + Hash_2.set parameter error + (x1.List_sig.id, x2.List_sig.id) + output handler.Memo_sig.data.boolean_mvbdu_overwrite_association_list + in + ( error, + { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_overwrite_association_list = memo; + }; + } )) + error parameters handler list1 list2 let extensional_description_of_variables_list _parameters error handler list = List_algebra.extensional_without_asso (fun parameter error handler x -> - let error, output = - Hash_1.unsafe_get parameter error - x.List_sig.id - handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_variables_list - in - error, (handler, output)) + let error, output = + Hash_1.unsafe_get parameter error x.List_sig.id + handler.Memo_sig.data + .boolean_mvbdu_extensional_description_of_variables_list + in + error, (handler, output)) (fun parameter error handler x output -> - let error, memo = - Hash_1.set parameter error - x.List_sig.id - output - handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_variables_list - in - error, - { - handler with Memo_sig.data = - { - handler.Memo_sig.data with - boolean_mvbdu_extensional_description_of_variables_list = memo - } - }) + let error, memo = + Hash_1.set parameter error x.List_sig.id output + handler.Memo_sig.data + .boolean_mvbdu_extensional_description_of_variables_list + in + ( error, + { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_extensional_description_of_variables_list = memo; + }; + } )) error handler list let extensional_description_of_association_list _parameters error handler list = List_algebra.extensional_with_asso (fun parameter error handler x -> - let error, output = - Hash_1.unsafe_get parameter error - x.List_sig.id - handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_association_list - in - error, (handler, output)) + let error, output = + Hash_1.unsafe_get parameter error x.List_sig.id + handler.Memo_sig.data + .boolean_mvbdu_extensional_description_of_association_list + in + error, (handler, output)) (fun parameter error handler x output -> - let error, memo = - Hash_1.set parameter error - x.List_sig.id - output - handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_association_list - in - error, - { - handler with Memo_sig.data = - { - handler.Memo_sig.data with - boolean_mvbdu_extensional_description_of_association_list = memo - } - }) + let error, memo = + Hash_1.set parameter error x.List_sig.id output + handler.Memo_sig.data + .boolean_mvbdu_extensional_description_of_association_list + in + ( error, + { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_extensional_description_of_association_list = memo; + }; + } )) error handler list -let extensional_description_of_range_list _parameters (error:Exception.method_handler) (handler:Remanent_parameters_sig.parameters) - (list:(memo_tables, 'a, 'b, 'c, 'd, 'e, 'f) Memo_sig.handler) (x:((int option * int option)) List_sig.list) = - (List_algebra.extensional_with_asso +let extensional_description_of_range_list _parameters + (error : Exception.method_handler) + (handler : Remanent_parameters_sig.parameters) + (list : (memo_tables, 'a, 'b, 'c, 'd, 'e, 'f) Memo_sig.handler) + (x : (int option * int option) List_sig.list) = + List_algebra.extensional_with_asso (fun parameter error handler x -> - let error, output = - Hash_1.unsafe_get parameter error - x.List_sig.id - handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_range_list - in - error, (handler, output)) + let error, output = + Hash_1.unsafe_get parameter error x.List_sig.id + handler.Memo_sig.data + .boolean_mvbdu_extensional_description_of_range_list + in + error, (handler, output)) (fun parameter error handler x output -> - let error, memo = - Hash_1.set parameter error - x.List_sig.id - output - handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_range_list - in - error, - { - handler with Memo_sig.data = - { - handler.Memo_sig.data with - boolean_mvbdu_extensional_description_of_range_list = memo - } - }) - error handler list x (*: int * (int option * int option) list *)) - + let error, memo = + Hash_1.set parameter error x.List_sig.id output + handler.Memo_sig.data + .boolean_mvbdu_extensional_description_of_range_list + in + ( error, + { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_extensional_description_of_range_list = memo; + }; + } )) + error handler list x (*: int * (int option * int option) list *) let rec variables_of_mvbdu parameters error handler mvbdu = match - Hash_1.unsafe_get parameters error - mvbdu.Mvbdu_sig.id + Hash_1.unsafe_get parameters error mvbdu.Mvbdu_sig.id handler.Memo_sig.data.boolean_mvbdu_variables_of_mvbdu with | error, Some output -> error, (handler, Some output) | error, None -> - begin - let error, (handler, output) = - match mvbdu.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> - let error, (handler, list) = - List_algebra.build_reversed_sorted_list - (variables_list_allocate parameters) parameters error handler - [] - in - error, (handler, Some list) - | Mvbdu_sig.Node a -> - let error, (handler, list_false) = - variables_of_mvbdu parameters error handler - a.Mvbdu_sig.branch_false - in - let error, (handler, list_true) = - variables_of_mvbdu parameters error handler - a.Mvbdu_sig.branch_true + let error, (handler, output) = + match mvbdu.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> + let error, (handler, list) = + List_algebra.build_reversed_sorted_list + (variables_list_allocate parameters) + parameters error handler [] + in + error, (handler, Some list) + | Mvbdu_sig.Node a -> + let error, (handler, list_false) = + variables_of_mvbdu parameters error handler a.Mvbdu_sig.branch_false + in + let error, (handler, list_true) = + variables_of_mvbdu parameters error handler a.Mvbdu_sig.branch_true + in + let error, (handler, singleton) = + List_algebra.build_reversed_sorted_list + (variables_list_allocate parameters) + parameters error handler + [ a.Mvbdu_sig.variable, () ] + in + (match list_false, list_true with + | Some list_f, Some list_t -> + let error, (handler, list_sibblings) = + merge_variables_lists parameters error handler list_f list_t in - let error, (handler, singleton) = - List_algebra.build_reversed_sorted_list - (variables_list_allocate parameters) parameters error handler - [a.Mvbdu_sig.variable, ()] + let error, (handler, output) = + match list_sibblings with + | Some list_s -> + merge_variables_lists parameters error handler singleton list_s + | None -> + Exception.warn parameters error __POS__ Exit (handler, None) in - begin - match list_false, list_true with - | Some list_f, Some list_t -> - begin - let error, (handler, list_sibblings) = - merge_variables_lists parameters error handler - list_f - list_t - in - let error, (handler,output) = - match list_sibblings with - | Some list_s -> - merge_variables_lists parameters error handler - singleton - list_s - | None -> - Exception.warn parameters error __POS__ Exit (handler,None) - in - error, (handler, output) - end - | None,_ | _,None -> - Exception.warn parameters error __POS__ Exit (handler,None) - end + error, (handler, output) + | None, _ | _, None -> + Exception.warn parameters error __POS__ Exit (handler, None)) + in + (match output with + | Some output -> + let error, memo = + Hash_1.set parameters error mvbdu.Mvbdu_sig.id output + handler.Memo_sig.data.boolean_mvbdu_variables_of_mvbdu in - match output with - | Some output -> - let error, memo = - Hash_1.set parameters error - mvbdu.Mvbdu_sig.id - output - handler.Memo_sig.data.boolean_mvbdu_variables_of_mvbdu - in - error, - ({ - handler with Memo_sig.data = - { - handler.Memo_sig.data with boolean_mvbdu_variables_of_mvbdu = memo - } - }, Some output) - | None -> - Exception.warn parameters error __POS__ Exit (handler, None) - end - -let mvbdu_cartesian_decomposition_depth - variables_list_of_mvbdu extensional_of_variables_list - build_sorted_variables_list - mvbdu_project_keep_only - mvbdu_project_abstract_away - mvbdu_and - equal + ( error, + ( { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_variables_of_mvbdu = memo; + }; + }, + Some output ) ) + | None -> Exception.warn parameters error __POS__ Exit (handler, None)) + +let mvbdu_cartesian_decomposition_depth variables_list_of_mvbdu + extensional_of_variables_list build_sorted_variables_list + mvbdu_project_keep_only mvbdu_project_abstract_away mvbdu_and equal parameters handler error bdu int = let rec aux_k k handler error bdu_to_decompose list = - if k > int - then - error, handler, (Some bdu_to_decompose,list) - else + if k > int then + error, handler, (Some bdu_to_decompose, list) + else ( let error, handler, l = variables_list_of_mvbdu parameters handler error bdu_to_decompose in @@ -1149,170 +1273,159 @@ let mvbdu_cartesian_decomposition_depth extensional_of_variables_list parameters handler error l in let n_var = List.length list_var in - if k > n_var / 2 - then - error, handler, (Some bdu_to_decompose,list) - else + if k > n_var / 2 then + error, handler, (Some bdu_to_decompose, list) + else ( let parts = Tools_kasa.sorted_parts_of_list k list_var in - let rec aux n_var list_of_parts handler error - bdu_to_decompose - list_of_decomposed_bdu - decomposed_var - = - if k > n_var / 2 - then + let rec aux n_var list_of_parts handler error bdu_to_decompose + list_of_decomposed_bdu decomposed_var = + if k > n_var / 2 then error, handler, None, bdu_to_decompose :: list_of_decomposed_bdu - else + else ( match list_of_parts with - | [] -> error, handler, Some bdu_to_decompose, list_of_decomposed_bdu + | [] -> + error, handler, Some bdu_to_decompose, list_of_decomposed_bdu | h :: t -> - if - List.exists (fun x -> Mods.IntSet.mem x decomposed_var) h - then - aux n_var t handler error - bdu_to_decompose - list_of_decomposed_bdu - decomposed_var - else + if List.exists (fun x -> Mods.IntSet.mem x decomposed_var) h then + aux n_var t handler error bdu_to_decompose + list_of_decomposed_bdu decomposed_var + else ( let error, handler, list = build_sorted_variables_list parameters handler error h in let error, handler, restriction = mvbdu_project_keep_only parameters handler error - bdu_to_decompose - list + bdu_to_decompose list in let error, handler, abstract_away = mvbdu_project_abstract_away parameters handler error - bdu_to_decompose - list + bdu_to_decompose list in let error, handler, cartesian_abstraction = - mvbdu_and parameters handler error - restriction - abstract_away + mvbdu_and parameters handler error restriction abstract_away in - if equal cartesian_abstraction bdu_to_decompose - then + if equal cartesian_abstraction bdu_to_decompose then ( let decomposed_var = - List.fold_left (fun set a -> Mods.IntSet.add a set) decomposed_var h + List.fold_left + (fun set a -> Mods.IntSet.add a set) + decomposed_var h in - aux (n_var - k) t handler error - abstract_away + aux (n_var - k) t handler error abstract_away (restriction :: list_of_decomposed_bdu) decomposed_var - else - aux n_var t handler error - bdu_to_decompose + ) else + aux n_var t handler error bdu_to_decompose list_of_decomposed_bdu decomposed_var + ) + ) in let error, handler, bdu_opt, list = - aux - n_var - parts - handler error bdu_to_decompose - list - Mods.IntSet.empty + aux n_var parts handler error bdu_to_decompose list Mods.IntSet.empty in match bdu_opt with | None -> error, handler, (None, list) - | Some bdu -> aux_k (k+1) handler error bdu list - in - let error, handler, (bdu_opt, list) = - aux_k 1 handler error bdu [] + | Some bdu -> aux_k (k + 1) handler error bdu list + ) + ) in + let error, handler, (bdu_opt, list) = aux_k 1 handler error bdu [] in error, handler, (bdu_opt, List.rev list) let rec extensional_description_of_mvbdu parameters handler error mvbdu = match - Hash_1.unsafe_get parameters error - mvbdu.Mvbdu_sig.id + Hash_1.unsafe_get parameters error mvbdu.Mvbdu_sig.id handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_mvbdu with | error, Some output -> error, (handler, output) | error, None -> - begin - let rec aux mvbdu remanent handler error output = - match mvbdu.Mvbdu_sig.value with - | Mvbdu_sig.Leaf true -> error, (handler, [] :: output) - | Mvbdu_sig.Leaf false -> error, (handler, output) - | Mvbdu_sig.Node a -> - let error, (handler, branch_true) = - extensional_description_of_mvbdu parameters handler error - a.Mvbdu_sig.branch_true - in - let upper_bound = a.Mvbdu_sig.upper_bound in - let error, (handler, output) = - match remanent, branch_true with - | _, [] -> error, (handler, output) - | None, _ -> - Exception.warn parameters error __POS__ Exit (handler,[]) - | Some (var, lower_bound), list -> - let head_list = - let rec aux k res = - if k <= lower_bound then res else aux (k-1) (k::res) - in aux upper_bound [] - in - let output = - List.fold_left - (fun output head -> - List.fold_left - (fun output tail -> - ((var, head) :: tail) :: output) - output list) - output head_list + let rec aux mvbdu remanent handler error output = + match mvbdu.Mvbdu_sig.value with + | Mvbdu_sig.Leaf true -> error, (handler, [] :: output) + | Mvbdu_sig.Leaf false -> error, (handler, output) + | Mvbdu_sig.Node a -> + let error, (handler, branch_true) = + extensional_description_of_mvbdu parameters handler error + a.Mvbdu_sig.branch_true + in + let upper_bound = a.Mvbdu_sig.upper_bound in + let error, (handler, output) = + match remanent, branch_true with + | _, [] -> error, (handler, output) + | None, _ -> Exception.warn parameters error __POS__ Exit (handler, []) + | Some (var, lower_bound), list -> + let head_list = + let rec aux k res = + if k <= lower_bound then + res + else + aux (k - 1) (k :: res) in - error, (handler, output) - in - aux - a.Mvbdu_sig.branch_false - (Some (a.Mvbdu_sig.variable,upper_bound)) - handler error - output - in - let error,(handler,output) = aux mvbdu None handler error [] in - let error, memo = - Hash_1.set parameters error - mvbdu.Mvbdu_sig.id - output - handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_mvbdu - in - error, - ({ - handler with Memo_sig.data = - { - handler.Memo_sig.data with - boolean_mvbdu_extensional_description_of_mvbdu = memo - } - }, output) - end - -let print_boolean_mvbdu parameters (error:Exception.method_handler) = + aux upper_bound [] + in + let output = + List.fold_left + (fun output head -> + List.fold_left + (fun output tail -> ((var, head) :: tail) :: output) + output list) + output head_list + in + error, (handler, output) + in + aux a.Mvbdu_sig.branch_false + (Some (a.Mvbdu_sig.variable, upper_bound)) + handler error output + in + let error, (handler, output) = aux mvbdu None handler error [] in + let error, memo = + Hash_1.set parameters error mvbdu.Mvbdu_sig.id output + handler.Memo_sig.data.boolean_mvbdu_extensional_description_of_mvbdu + in + ( error, + ( { + handler with + Memo_sig.data = + { + handler.Memo_sig.data with + boolean_mvbdu_extensional_description_of_mvbdu = memo; + }; + }, + output ) ) + +let print_boolean_mvbdu parameters (error : Exception.method_handler) = Mvbdu_core.print_mvbdu error (fun error parameters a -> - let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s %s" - parameters.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix - (if a then "true" else "false") - in - let _ = - Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - (fun i -> "x" ^ (string_of_int i)) parameters - -let (f:Remanent_parameters_sig.parameters -> - Exception.method_handler -> - bool Mvbdu_sig.mvbdu -> Exception.method_handler) = print_boolean_mvbdu - -let print_hash1 p error log = - Hash_1.print p error print_boolean_mvbdu log - -let print_hash2 p error log = - Hash_2.print p error print_boolean_mvbdu log - -let lift f a b c = - let () = f a c - in b + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s %s" + parameters.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix + (if a then + "true" + else + "false") + in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) + (fun i -> "x" ^ string_of_int i) + parameters + +let (f : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + bool Mvbdu_sig.mvbdu -> + Exception.method_handler) = + print_boolean_mvbdu + +let print_hash1 p error log = Hash_1.print p error print_boolean_mvbdu log +let print_hash2 p error log = Hash_2.print p error print_boolean_mvbdu log + +let lift f a b c = + let () = f a c in + b let print_hash3 p error log = Hash_1.print p error (lift List_algebra.print_variables_list) log @@ -1321,88 +1434,128 @@ let print_hash4 p error log = Hash_2.print p error (lift List_algebra.print_variables_list) log let print_hash5 p error log = - Hash_2.print p error - (lift List_algebra.print_association_list) - log + Hash_2.print p error (lift List_algebra.print_association_list) log let print_hash6 p error log = Hash_1.print p error (fun a b c -> - let log = Remanent_parameters.get_logger a in - let prefix = a.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix in - let () = Loggers.fprintf log "%s" prefix in - let () = List.iter (Loggers.fprintf log "%i;") c in - let () = Loggers.print_newline log in b) + let log = Remanent_parameters.get_logger a in + let prefix = + a.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix + in + let () = Loggers.fprintf log "%s" prefix in + let () = List.iter (Loggers.fprintf log "%i;") c in + let () = Loggers.print_newline log in + b) log let print_hash7 p error log = - Hash_1.print p error (fun a b c -> + Hash_1.print p error + (fun a b c -> let log = Remanent_parameters.get_logger a in - let prefix = a.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix in + let prefix = + a.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix + in let () = Loggers.fprintf log "%s" prefix in - let () = List.iter (fun (a,b) -> Loggers.fprintf log "%i,%i;" a b) c in - let () = Loggers.print_newline log in b) + let () = List.iter (fun (a, b) -> Loggers.fprintf log "%i,%i;" a b) c in + let () = Loggers.print_newline log in + b) log let print_hash8 p error log = - Hash_1.print p error (fun a b c -> - let log = Remanent_parameters.get_logger a in - let prefix = a.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix in - let () = Loggers.fprintf log "%s" prefix in - let () = List.iter (fun (a,(b,c)) -> Loggers.fprintf log "%i,[%s,%s];" a - (match b with None -> - Remanent_parameters.get_minus_infinity_symbol p - | Some b -> string_of_int b) - (match c with None -> - Remanent_parameters.get_plus_infinity_symbol p | Some b -> string_of_int b)) c in - let () = Loggers.print_newline log in b) - log + Hash_1.print p error + (fun a b c -> + let log = Remanent_parameters.get_logger a in + let prefix = + a.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix + in + let () = Loggers.fprintf log "%s" prefix in + let () = + List.iter + (fun (a, (b, c)) -> + Loggers.fprintf log "%i,[%s,%s];" a + (match b with + | None -> Remanent_parameters.get_minus_infinity_symbol p + | Some b -> string_of_int b) + (match c with + | None -> Remanent_parameters.get_plus_infinity_symbol p + | Some b -> string_of_int b)) + c + in + let () = Loggers.print_newline log in + b) + log let print_hash9 p error log = Hash_1.print p error (fun a b c -> - let log = Remanent_parameters.get_logger a in - let prefix = - a.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix - in - let () = Loggers.fprintf log "%s" prefix in - let () = - List.iter - (fun x -> - let () = - List.iter - (fun (a,b) -> Loggers.fprintf log "%i,%i;" a b) - x - in - Loggers.fprintf log "\n") - c - in - let () = Loggers.fprintf log "\n" in b) + let log = Remanent_parameters.get_logger a in + let prefix = + a.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix + in + let () = Loggers.fprintf log "%s" prefix in + let () = + List.iter + (fun x -> + let () = + List.iter (fun (a, b) -> Loggers.fprintf log "%i,%i;" a b) x + in + Loggers.fprintf log "\n") + c + in + let () = Loggers.fprintf log "\n" in + b) log -let print_gen log parameters error (title,print_hash,l) = +let print_gen log parameters error (title, print_hash, l) = let () = Printf.fprintf log "%s:\n" title in List.fold_left - (fun error (pref,x) -> - print_hash (Remanent_parameters.update_prefix parameters pref) error x) + (fun error (pref, x) -> + print_hash (Remanent_parameters.update_prefix parameters pref) error x) error l -let print_memo (error:Exception.method_handler) handler parameters = - let error,l1,l2,l3,l4,l5,l6,l7,l8,l9 = split_memo error handler in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" parameters.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix in +let print_memo (error : Exception.method_handler) handler parameters = + let error, l1, l2, l3, l4, l5, l6, l7, l8, l9 = split_memo error handler in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + parameters.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let error = print_gen stdout parameters error ("Print Hash_1",print_hash1,l1) in - let error = print_gen stdout parameters error ("Print Hash_2",print_hash2,l2) in - let error = print_gen stdout parameters error ("Print Hash_3",print_hash3,l3) in - let error = print_gen stdout parameters error ("Print Hash_4",print_hash4,l4) in - let error = print_gen stdout parameters error ("Print Hash_5",print_hash5,l5) in - let error = print_gen stdout parameters error ("Print Hash_6",print_hash6,l6) in - let error = print_gen stdout parameters error ("Print Hash_7",print_hash7,l7) in - let error = print_gen stdout parameters error ("Print Hash_8",print_hash8,l8) in - let error = print_gen stdout parameters error ("Print Hash_9",print_hash9,l9) in + let error = + print_gen stdout parameters error ("Print Hash_1", print_hash1, l1) + in + let error = + print_gen stdout parameters error ("Print Hash_2", print_hash2, l2) + in + let error = + print_gen stdout parameters error ("Print Hash_3", print_hash3, l3) + in + let error = + print_gen stdout parameters error ("Print Hash_4", print_hash4, l4) + in + let error = + print_gen stdout parameters error ("Print Hash_5", print_hash5, l5) + in + let error = + print_gen stdout parameters error ("Print Hash_6", print_hash6, l6) + in + let error = + print_gen stdout parameters error ("Print Hash_7", print_hash7, l7) + in + let error = + print_gen stdout parameters error ("Print Hash_8", print_hash8, l8) + in + let error = + print_gen stdout parameters error ("Print Hash_9", print_hash9, l9) + in error let last_entry parameter handler error = - Mvbdu_core.last_entry parameter - handler error - D_mvbdu_skeleton.last_entry + Mvbdu_core.last_entry parameter handler error D_mvbdu_skeleton.last_entry diff --git a/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.mli b/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.mli index 48da31d76e..151504a9e4 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/boolean_mvbdu.mli @@ -1,156 +1,170 @@ - - -val sanity_check: bool -val test_workbench:bool +val sanity_check : bool +val test_workbench : bool (*module type Sig_Mvbdu_Skeleton = -sig - type t = bool Mvbdu_sig.skeleton - val compare:t->t -> int - val print: 'a -> 'b -> unit -end + sig + type t = bool Mvbdu_sig.skeleton + val compare:t->t -> int + val print: 'a -> 'b -> unit + end - module Mvbdu_Skeleton: Sig_Mvbdu_Skeleton*) + module Mvbdu_Skeleton: Sig_Mvbdu_Skeleton*) module D_mvbdu_skeleton : - (Dictionary.Dictionary - with type key = int - and type value = bool Mvbdu_sig.skeleton) + Dictionary.Dictionary + with type key = int + and type value = bool Mvbdu_sig.skeleton module D_Range_list_skeleton : - (Dictionary.Dictionary - with type key = int - and type value = (int option * int option) List_sig.skeleton) + Dictionary.Dictionary + with type key = int + and type value = (int option * int option) List_sig.skeleton module D_Association_list_skeleton : - (Dictionary.Dictionary - with type key = int - and type value = int List_sig.skeleton) + Dictionary.Dictionary + with type key = int + and type value = int List_sig.skeleton module D_Variables_list_skeleton : - (Dictionary.Dictionary - with type key = int - and type value = unit List_sig.skeleton) - -module Hash_key: Set.OrderedType - -module Hash_1: Int_storage.Storage -module Hash_2: Int_storage.Storage - -type memo_tables = - { - boolean_mvbdu_identity : bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_not : bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_and : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_or : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_xor : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nand : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_equiv : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_is_implied : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_imply : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nis_implied : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nimply : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nor : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_fst : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nfst : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_snd : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_nsnd : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_clean_head : bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_keep_head_only: bool Mvbdu_sig.mvbdu Hash_1.t; - boolean_mvbdu_redefine : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_redefine_range : bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_monotonicaly_rename: bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_project_keep_only: bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_project_abstract_away: bool Mvbdu_sig.mvbdu Hash_2.t; - boolean_mvbdu_length_variables_list: int Hash_1.t; - boolean_mvbdu_merge_variables_lists: unit List_sig.list Hash_2.t; - boolean_mvbdu_overwrite_association_list: int List_sig.list Hash_2.t; - - boolean_mvbdu_extensional_description_of_variables_list: int list Hash_1.t; - - boolean_mvbdu_extensional_description_of_association_list: (int * int) list Hash_1.t; - boolean_mvbdu_extensional_description_of_range_list: (int * (int option *int option)) list - Hash_1.t; - boolean_mvbdu_variables_of_mvbdu: unit List_sig.list Hash_1.t; - - boolean_mvbdu_extensional_description_of_mvbdu: (int *int ) list list Hash_1.t; - } + Dictionary.Dictionary + with type key = int + and type value = unit List_sig.skeleton + +module Hash_key : Set.OrderedType +module Hash_1 : Int_storage.Storage +module Hash_2 : Int_storage.Storage + +type memo_tables = { + boolean_mvbdu_identity: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_not: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_and: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_or: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_xor: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nand: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_equiv: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_is_implied: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_imply: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nis_implied: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nimply: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nor: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_fst: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nfst: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_snd: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_nsnd: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_clean_head: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_keep_head_only: bool Mvbdu_sig.mvbdu Hash_1.t; + boolean_mvbdu_redefine: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_redefine_range: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_monotonicaly_rename: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_project_keep_only: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_project_abstract_away: bool Mvbdu_sig.mvbdu Hash_2.t; + boolean_mvbdu_length_variables_list: int Hash_1.t; + boolean_mvbdu_merge_variables_lists: unit List_sig.list Hash_2.t; + boolean_mvbdu_overwrite_association_list: int List_sig.list Hash_2.t; + boolean_mvbdu_extensional_description_of_variables_list: int list Hash_1.t; + boolean_mvbdu_extensional_description_of_association_list: + (int * int) list Hash_1.t; + boolean_mvbdu_extensional_description_of_range_list: + (int * (int option * int option)) list Hash_1.t; + boolean_mvbdu_variables_of_mvbdu: unit List_sig.list Hash_1.t; + boolean_mvbdu_extensional_description_of_mvbdu: (int * int) list list Hash_1.t; +} type unary_memoized_fun -type mvbdu_dic = (bool Mvbdu_sig.cell, bool Mvbdu_sig.mvbdu) D_mvbdu_skeleton.dictionary -type association_list_dic = (int List_sig.cell, int List_sig.list) D_Association_list_skeleton.dictionary -type range_list_dic = ((int option * int option) List_sig.cell, (int option * int option) List_sig.list) -D_Range_list_skeleton.dictionary -type variables_list_dic = (unit List_sig.cell, unit List_sig.list) D_Variables_list_skeleton.dictionary -type handler = (memo_tables, mvbdu_dic, association_list_dic, range_list_dic,variables_list_dic, bool, int) Memo_sig.handler + +type mvbdu_dic = + (bool Mvbdu_sig.cell, bool Mvbdu_sig.mvbdu) D_mvbdu_skeleton.dictionary + +type association_list_dic = + (int List_sig.cell, int List_sig.list) D_Association_list_skeleton.dictionary + +type range_list_dic = + ( (int option * int option) List_sig.cell, + (int option * int option) List_sig.list ) + D_Range_list_skeleton.dictionary + +type variables_list_dic = + (unit List_sig.cell, unit List_sig.list) D_Variables_list_skeleton.dictionary + +type handler = + ( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + int ) + Memo_sig.handler + type memo_unary -val last_entry: -Remanent_parameters_sig.parameters -> -handler -> -Exception_without_parameter.method_handler -> -Exception_without_parameter.method_handler * int +val last_entry : + Remanent_parameters_sig.parameters -> + handler -> + Exception_without_parameter.method_handler -> + Exception_without_parameter.method_handler * int -val print_memo: Exception_without_parameter.method_handler -> +val print_memo : + Exception_without_parameter.method_handler -> handler -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -val extensional_description_of_mvbdu: Remanent_parameters_sig.parameters -> +val extensional_description_of_mvbdu : + Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * (int * int) list list) + Exception_without_parameter.method_handler * (handler * (int * int) list list) -val extensional_description_of_range_list: +val extensional_description_of_range_list : 'g -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> (int option * int option) List_sig.list -> - Exception_without_parameter.method_handler * - (handler * - (int * (int option * int option)) list option) + Exception_without_parameter.method_handler + * (handler * (int * (int option * int option)) list option) -val extensional_description_of_association_list: +val extensional_description_of_association_list : 'a -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> int List_sig.list -> - Exception_without_parameter.method_handler * - (handler * (int * int) list option) + Exception_without_parameter.method_handler + * (handler * (int * int) list option) -val extensional_description_of_variables_list: +val extensional_description_of_variables_list : 'a -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> 'h List_sig.list -> - Exception_without_parameter.method_handler * - (handler * - int list option) + Exception_without_parameter.method_handler * (handler * int list option) -val overwrite_association_lists: +val overwrite_association_lists : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> handler -> int List_sig.list -> int List_sig.list -> - Exception_without_parameter.method_handler * - (handler * int List_sig.list option) -val length: Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler + * (handler * int List_sig.list option) + +val length : + Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> handler -> 'g List_sig.list -> - Exception_without_parameter.method_handler * - (handler * int) -val f: -Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler -val mvbdu_cartesian_decomposition_depth: + Exception_without_parameter.method_handler * (handler * int) + +val f : + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + bool Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + +val mvbdu_cartesian_decomposition_depth : ('a -> 'b -> 'c -> 'd -> 'e * 'f * 'g) -> ('a -> 'f -> 'e -> 'g -> 'c * 'b * int list) -> ('a -> 'b -> 'c -> int list -> 'h * 'i * 'j) -> @@ -158,314 +172,391 @@ val mvbdu_cartesian_decomposition_depth: ('a -> 'l -> 'k -> 'd -> 'j -> 'm * 'n * 'd) -> ('a -> 'n -> 'm -> 'd -> 'd -> 'c * 'b * 'o) -> ('o -> 'd -> bool) -> - 'a -> 'b -> 'c -> 'd -> int -> 'c * 'b * ('d option * 'd list) -val variables_of_mvbdu: + 'a -> + 'b -> + 'c -> + 'd -> + int -> + 'c * 'b * ('d option * 'd list) + +val variables_of_mvbdu : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> handler -> 'c Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * unit List_sig.list option) + Exception_without_parameter.method_handler + * (handler * unit List_sig.list option) -val project_abstract_away: +val project_abstract_away : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> bool Mvbdu_sig.mvbdu -> 'b List_sig.list -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) -val project_keep_only: + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) + +val project_keep_only : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> bool Mvbdu_sig.mvbdu -> 'b List_sig.list -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val memo_keep_head_only: -(bool, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, 'a, memo_tables, 'b) - Memo_sig.unary_memoized_fun +val memo_keep_head_only : + ( bool, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + 'a, + memo_tables, + 'b ) + Memo_sig.unary_memoized_fun -val redefine: +val redefine : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> bool Mvbdu_sig.mvbdu -> int List_sig.list -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) -val redefine_range: + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) + +val redefine_range : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> bool Mvbdu_sig.mvbdu -> (int option * int option) List_sig.list -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) -val monotonicaly_rename: + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) + +val monotonicaly_rename : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> handler -> bool Mvbdu_sig.mvbdu -> int List_sig.list -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) -val range_list_allocate: + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) + +val range_list_allocate : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> ((int option * int option) List_sig.cell -> - (int option * int option) List_sig.cell -> int) -> + (int option * int option) List_sig.cell -> + int) -> D_Range_list_skeleton.value -> (int option * int option) List_sig.cell -> (int -> (int option * int option) List_sig.list) -> handler -> - Exception_without_parameter.method_handler * - (int * (int option * int option) List_sig.cell * - (int option * int option) List_sig.list * - handler) + Exception_without_parameter.method_handler + * (int + * (int option * int option) List_sig.cell + * (int option * int option) List_sig.list + * handler) option -val boolean_mvbdu_nsnd: Remanent_parameters_sig.parameters -> +val boolean_mvbdu_nsnd : + Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_nfst: +val boolean_mvbdu_nfst : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_snd: +val boolean_mvbdu_snd : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_fst: +val boolean_mvbdu_fst : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_nand: +val boolean_mvbdu_nand : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_and: +val boolean_mvbdu_and : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_or: +val boolean_mvbdu_or : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_nor: +val boolean_mvbdu_nor : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_constant_bi_false: +val boolean_constant_bi_false : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_constant_bi_true: +val boolean_constant_bi_true : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_nis_implied: +val boolean_mvbdu_nis_implied : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_is_implied: +val boolean_mvbdu_is_implied : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_nimply: +val boolean_mvbdu_nimply : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_imply: +val boolean_mvbdu_imply : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_equiv: +val boolean_mvbdu_equiv : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_xor: +val boolean_mvbdu_xor : Remanent_parameters_sig.parameters -> handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_constant_true: +val boolean_mvbdu_constant_true : Remanent_parameters_sig.parameters -> - (memo_tables, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, bool, 'a) - Memo_sig.handler -> + ( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + 'a ) + Memo_sig.handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ((memo_tables, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, bool, 'a) - Memo_sig.handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + 'a ) + Memo_sig.handler + * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_constant_false: +val boolean_mvbdu_constant_false : Remanent_parameters_sig.parameters -> - (memo_tables, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, bool, 'a) - Memo_sig.handler -> + ( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + 'a ) + Memo_sig.handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ((memo_tables, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, bool, 'a) - Memo_sig.handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + 'a ) + Memo_sig.handler + * bool Mvbdu_sig.mvbdu option) -val init_remanent: +val init_remanent : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Exception_without_parameter.method_handler * - (memo_tables, ('a, 'b) D_mvbdu_skeleton.dictionary, - ('c, 'd) D_Association_list_skeleton.dictionary, - ('e, 'f) D_Range_list_skeleton.dictionary, - ('g, 'h) D_Variables_list_skeleton.dictionary, bool, 'i) + Exception_without_parameter.method_handler + * ( memo_tables, + ('a, 'b) D_mvbdu_skeleton.dictionary, + ('c, 'd) D_Association_list_skeleton.dictionary, + ('e, 'f) D_Range_list_skeleton.dictionary, + ('g, 'h) D_Variables_list_skeleton.dictionary, + bool, + 'i ) Memo_sig.handler -val boolean_mvbdu_false: +val boolean_mvbdu_false : Remanent_parameters_sig.parameters -> - ('a, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, 'b, 'c) - Memo_sig.handler -> + ( 'a, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + 'b, + 'c ) + Memo_sig.handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler * - (('a, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, 'b, 'c) - Memo_sig.handler * bool Mvbdu_sig.mvbdu option) - -val boolean_mvbdu_true: - Remanent_parameters_sig.parameters -> - ('a, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, 'b, 'c) - Memo_sig.handler -> + Exception_without_parameter.method_handler + * (( 'a, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + 'b, + 'c ) + Memo_sig.handler + * bool Mvbdu_sig.mvbdu option) + +val boolean_mvbdu_true : + Remanent_parameters_sig.parameters -> + ( 'a, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + 'b, + 'c ) + Memo_sig.handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler * - (('a, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, 'b, 'c) - Memo_sig.handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (( 'a, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + 'b, + 'c ) + Memo_sig.handler + * bool Mvbdu_sig.mvbdu option) -val boolean_mvbdu_not: +val boolean_mvbdu_not : Remanent_parameters_sig.parameters -> - (memo_tables, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, bool, 'a) - Memo_sig.handler -> + ( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + 'a ) + Memo_sig.handler -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ((memo_tables, mvbdu_dic, association_list_dic, range_list_dic, - variables_list_dic, bool, 'a) - Memo_sig.handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (( memo_tables, + mvbdu_dic, + association_list_dic, + range_list_dic, + variables_list_dic, + bool, + 'a ) + Memo_sig.handler + * bool Mvbdu_sig.mvbdu option) -val association_list_allocate: +val association_list_allocate : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> (int List_sig.cell -> int List_sig.cell -> int) -> @@ -473,12 +564,10 @@ val association_list_allocate: int List_sig.cell -> (int -> int List_sig.list) -> handler -> - Exception_without_parameter.method_handler * - (int * int List_sig.cell * int List_sig.list * - handler) - option + Exception_without_parameter.method_handler + * (int * int List_sig.cell * int List_sig.list * handler) option -val variables_list_allocate: +val variables_list_allocate : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> (unit List_sig.cell -> unit List_sig.cell -> int) -> @@ -486,41 +575,38 @@ val variables_list_allocate: unit List_sig.cell -> (int -> unit List_sig.list) -> handler -> - Exception_without_parameter.method_handler * - (int * unit List_sig.cell * unit List_sig.list * - handler) - option + Exception_without_parameter.method_handler + * (int * unit List_sig.cell * unit List_sig.list * handler) option -val print_mvbdu: -Remanent_parameters_sig.parameters -> -bool Mvbdu_sig.mvbdu -> unit +val print_mvbdu : + Remanent_parameters_sig.parameters -> bool Mvbdu_sig.mvbdu -> unit -val clean_head: +val clean_head : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> handler -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val keep_head_only: +val keep_head_only : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> handler -> bool Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (handler * bool Mvbdu_sig.mvbdu option) + Exception_without_parameter.method_handler + * (handler * bool Mvbdu_sig.mvbdu option) -val merge_variables_lists: +val merge_variables_lists : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> handler -> unit List_sig.list -> unit List_sig.list -> - Exception_without_parameter.method_handler * - (handler * unit List_sig.list option) + Exception_without_parameter.method_handler + * (handler * unit List_sig.list option) -val print_boolean_mvbdu: +val print_boolean_mvbdu : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> bool Mvbdu_sig.mvbdu -> diff --git a/core/KaSa_rep/abstract_domains/mvbdu/dune b/core/KaSa_rep/abstract_domains/mvbdu/dune index ea559ca43f..a26bb9ce15 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/dune +++ b/core/KaSa_rep/abstract_domains/mvbdu/dune @@ -1,10 +1,17 @@ (library - (name kappa_mvbdu) - (libraries kappa_kasa_kastor_toolset kappa-library.generic) - (flags (:standard -w @a - -open Kappa_parameters - -open Kappa_errors - -open Kappa_logging - -open Kappa_kasa_kastor_toolset - -open Kappa_generic_toolset - ))) + (name kappa_mvbdu) + (libraries kappa_kasa_kastor_toolset kappa-library.generic) + (flags + (:standard + -w + @a + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_logging + -open + Kappa_kasa_kastor_toolset + -open + Kappa_generic_toolset))) diff --git a/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.ml b/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.ml index 2d2528085e..651b4a9ff8 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.ml @@ -12,244 +12,229 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -let build_reversed_sorted_list_aux - allocate - parameters error handler list already = +let build_reversed_sorted_list_aux allocate parameters error handler list + already = List.fold_left - (fun (error,(handler,already)) (var,asso) -> - let error,output = - List_core.build_list - allocate - error - handler - (List_sig.Cons - { - List_sig.variable = var; - List_sig.association = asso; - List_sig.tail = already.List_sig.id - }) - (List_sig.Cons - { - List_sig.variable = var; - List_sig.association = asso; - List_sig.tail = already - }) - in - match output with - | Some (_key,_cell,list,handler) -> error,(handler,list) - | None -> Exception.warn - parameters error __POS__ Exit (handler,already) - ) + (fun (error, (handler, already)) (var, asso) -> + let error, output = + List_core.build_list allocate error handler + (List_sig.Cons + { + List_sig.variable = var; + List_sig.association = asso; + List_sig.tail = already.List_sig.id; + }) + (List_sig.Cons + { + List_sig.variable = var; + List_sig.association = asso; + List_sig.tail = already; + }) + in + match output with + | Some (_key, _cell, list, handler) -> error, (handler, list) + | None -> Exception.warn parameters error __POS__ Exit (handler, already)) (error, (handler, already)) list -let build_reversed_sorted_list allocate parameters error handler list = - let error,output = - List_core.build_list - allocate - error - handler - (List_sig.Empty) - (List_sig.Empty) +let build_reversed_sorted_list allocate parameters error handler list = + let error, output = + List_core.build_list allocate error handler List_sig.Empty List_sig.Empty in match output with - | Some (_key,_cell,empty_list,handler) -> - build_reversed_sorted_list_aux - allocate - parameters - error - handler - list + | Some (_key, _cell, empty_list, handler) -> + build_reversed_sorted_list_aux allocate parameters error handler list empty_list | None -> Exception.warn parameters error __POS__ Exit - (handler, - {List_sig.id = 0; - List_sig.value = List_sig.Empty}) + (handler, { List_sig.id = 0; List_sig.value = List_sig.Empty }) let build_sorted_list allocate parameters error handler list = build_reversed_sorted_list allocate parameters error handler (List.rev list) let build_list allocate parameters error handler list = - let sort (i,_) (j,_) = - (compare i j) in - build_reversed_sorted_list allocate error parameters handler (List.sort sort list) + let sort (i, _) (j, _) = -compare i j in + build_reversed_sorted_list allocate error parameters handler + (List.sort sort list) let rec print_cell parameter cell = match cell with | List_sig.Empty -> let s = "[]" in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s%s" (Remanent_parameters.get_prefix parameter) s in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s" + (Remanent_parameters.get_prefix parameter) + s + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in () | List_sig.Cons x -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s(site_type:%i = %i)" + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s(site_type:%i = %i)" (Remanent_parameters.get_prefix parameter) - x.List_sig.variable - x.List_sig.association + x.List_sig.variable x.List_sig.association in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in let parameter = Remanent_parameters.update_prefix parameter " " in let _ = print_association_list parameter x.List_sig.tail in () + and print_association_list parameter list = - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%sId=%i" (Remanent_parameters.get_prefix parameter) list.List_sig.id in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%sId=%i" + (Remanent_parameters.get_prefix parameter) + list.List_sig.id + in let _ = Loggers.print_newline (Remanent_parameters.get_logger parameter) in - let _ = print_cell (Remanent_parameters.update_prefix parameter" ") list.List_sig.value in + let _ = + print_cell + (Remanent_parameters.update_prefix parameter " ") + list.List_sig.value + in () let rec print_cell parameter cell = match cell with | List_sig.Empty -> let s = "[]" in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s%s" (Remanent_parameters.get_prefix parameter) s in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s" + (Remanent_parameters.get_prefix parameter) + s + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in () | List_sig.Cons x -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s(site_type:%i)" + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s(site_type:%i)" (Remanent_parameters.get_prefix parameter) x.List_sig.variable in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in - let _ = print_variables_list (Remanent_parameters.update_prefix parameter " ") x.List_sig.tail in + let _ = + print_variables_list + (Remanent_parameters.update_prefix parameter " ") + x.List_sig.tail + in () + and print_variables_list parameter list = - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "%sId=%i" (Remanent_parameters.get_prefix parameter) list.List_sig.id in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%sId=%i" + (Remanent_parameters.get_prefix parameter) + list.List_sig.id + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameter) in - let () = print_cell (Remanent_parameters.update_prefix parameter " ") list.List_sig.value in + let () = + print_cell + (Remanent_parameters.update_prefix parameter " ") + list.List_sig.value + in () let rec extensional_gen f get set error parameters handler list = - match get parameters error handler list - with + match get parameters error handler list with | error, (handler, Some output) -> error, (handler, Some output) | error, (handler, None) -> - begin - match - list.List_sig.value - with - | List_sig.Empty -> error,(handler,Some []) - | List_sig.Cons a1 -> - let error, (handler, tail) = - extensional_gen f get set error parameters handler a1.List_sig.tail - in - match - tail - with - | Some tail -> - let output = (f a1)::tail in - let error,handler = set parameters error handler list output in - error, (handler, Some output) - | None -> - Exception.warn - parameters error __POS__ Exit - (handler,Some []) - end + (match list.List_sig.value with + | List_sig.Empty -> error, (handler, Some []) + | List_sig.Cons a1 -> + let error, (handler, tail) = + extensional_gen f get set error parameters handler a1.List_sig.tail + in + (match tail with + | Some tail -> + let output = f a1 :: tail in + let error, handler = set parameters error handler list output in + error, (handler, Some output) + | None -> Exception.warn parameters error __POS__ Exit (handler, Some []))) let extensional_with_asso get set error parameters handler list = - extensional_gen (fun a1 -> (a1.List_sig.variable,a1.List_sig.association)) get set error parameters handler list + extensional_gen + (fun a1 -> a1.List_sig.variable, a1.List_sig.association) + get set error parameters handler list let extensional_without_asso get set error parameters handler list = - extensional_gen (fun a1 -> (a1.List_sig.variable)) get set error parameters handler list + extensional_gen + (fun a1 -> a1.List_sig.variable) + get set error parameters handler list let rec length allocate get set error parameters handler list = - match get parameters error handler list - with - | error, (handler,Some output) -> error, (handler, output) - | error, (handler,None) -> - begin - let error, (handler,output) = - match list.List_sig.value with - | List_sig.Empty-> error,(handler,0) - | List_sig.Cons a -> - let error, (handler,tail_size) = - length allocate get set error parameters handler a.List_sig.tail - in - error, (handler, tail_size+1) - in - let error, handler = - set - parameters - error - handler - list - output - in - error, (handler, output) - end + match get parameters error handler list with + | error, (handler, Some output) -> error, (handler, output) + | error, (handler, None) -> + let error, (handler, output) = + match list.List_sig.value with + | List_sig.Empty -> error, (handler, 0) + | List_sig.Cons a -> + let error, (handler, tail_size) = + length allocate get set error parameters handler a.List_sig.tail + in + error, (handler, tail_size + 1) + in + let error, handler = set parameters error handler list output in + error, (handler, output) let rec overwrite allocate get set error parameters handler list1 list2 = - match get parameters error handler (list1,list2) - with - | error, (handler,Some output) -> error, (handler, Some output) - | error, (handler,None) -> - begin - let error, (handler,output) = - match list1.List_sig.value,list2.List_sig.value with - | List_sig.Empty,_ -> error,(handler,list2) - | _,List_sig.Empty -> error,(handler,list1) - | List_sig.Cons a1,List_sig.Cons a2 -> - let var1 = a1.List_sig.variable in - let var2 = a2.List_sig.variable in - let cmp = compare var1 var2 in - let var,asso,tail1,tail2 = - if cmp < 0 - then - var1,a1.List_sig.association, - a1.List_sig.tail,list2 - else if cmp = 0 - then - var1,a2.List_sig.association, - a1.List_sig.tail,a2.List_sig.tail - else - var2,a2.List_sig.association, - list1,a2.List_sig.tail - in - let error, (handler,tail) = - overwrite allocate get set error parameters handler tail1 tail2 + match get parameters error handler (list1, list2) with + | error, (handler, Some output) -> error, (handler, Some output) + | error, (handler, None) -> + let error, (handler, output) = + match list1.List_sig.value, list2.List_sig.value with + | List_sig.Empty, _ -> error, (handler, list2) + | _, List_sig.Empty -> error, (handler, list1) + | List_sig.Cons a1, List_sig.Cons a2 -> + let var1 = a1.List_sig.variable in + let var2 = a2.List_sig.variable in + let cmp = compare var1 var2 in + let var, asso, tail1, tail2 = + if cmp < 0 then + var1, a1.List_sig.association, a1.List_sig.tail, list2 + else if cmp = 0 then + var1, a2.List_sig.association, a1.List_sig.tail, a2.List_sig.tail + else + var2, a2.List_sig.association, list1, a2.List_sig.tail + in + let error, (handler, tail) = + overwrite allocate get set error parameters handler tail1 tail2 + in + (match tail with + | Some tail -> + let error, output = + List_core.build_list allocate error handler + (List_sig.Cons + { + List_sig.variable = var; + List_sig.association = asso; + List_sig.tail = tail.List_sig.id; + }) + (List_sig.Cons + { + List_sig.variable = var; + List_sig.association = asso; + List_sig.tail; + }) in - match tail with - | Some tail -> - let error,output = - List_core.build_list - allocate - error - handler - (List_sig.Cons - { - List_sig.variable = var; - List_sig.association = asso; - List_sig.tail = tail.List_sig.id - }) - (List_sig.Cons - { - List_sig.variable = var; - List_sig.association = asso; - List_sig.tail = tail - }) - in - begin - match output with - | Some (_key,_cell,list,handler) -> error,(handler,list) - | None -> - Exception.warn - parameters error __POS__ Exit - (handler, - {List_sig.id = 0; - List_sig.value = List_sig.Empty}) - end + (match output with + | Some (_key, _cell, list, handler) -> error, (handler, list) | None -> Exception.warn parameters error __POS__ Exit - (handler, - {List_sig.id = 0; - List_sig.value = List_sig.Empty}) - in - let error, handler = - set - parameters - error - handler - (list1,list2) - output - in - error, (handler, Some output) - end + (handler, { List_sig.id = 0; List_sig.value = List_sig.Empty })) + | None -> + Exception.warn parameters error __POS__ Exit + (handler, { List_sig.id = 0; List_sig.value = List_sig.Empty })) + in + let error, handler = set parameters error handler (list1, list2) output in + error, (handler, Some output) diff --git a/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.mli b/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.mli index e55b2d4b8d..b45f878487 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/list_algebra.mli @@ -1,125 +1,128 @@ -val overwrite: +val overwrite : (Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - (int, 'b) List_sig.precell List_sig.prelist -> - 'b List_sig.cell -> - (int -> 'b List_sig.list) -> - 'c -> - Exception_without_parameter.method_handler * - ('d * 'e * 'b List_sig.list * 'c) option) -> + ('a -> 'a -> int) -> + (int, 'b) List_sig.precell List_sig.prelist -> + 'b List_sig.cell -> + (int -> 'b List_sig.list) -> + 'c -> + Exception_without_parameter.method_handler + * ('d * 'e * 'b List_sig.list * 'c) option) -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - 'c -> - 'b List_sig.list * 'b List_sig.list -> - Exception_without_parameter.method_handler * - ('c * 'b List_sig.list option)) -> + Exception_without_parameter.method_handler -> + 'c -> + 'b List_sig.list * 'b List_sig.list -> + Exception_without_parameter.method_handler * ('c * 'b List_sig.list option)) -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - 'c -> - 'b List_sig.list * 'b List_sig.list -> - 'b List_sig.list -> - Exception_without_parameter.method_handler * 'c) -> + Exception_without_parameter.method_handler -> + 'c -> + 'b List_sig.list * 'b List_sig.list -> + 'b List_sig.list -> + Exception_without_parameter.method_handler * 'c) -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> 'c -> 'b List_sig.list -> 'b List_sig.list -> - Exception_without_parameter.method_handler * - ('c * 'b List_sig.list option) -val length: + Exception_without_parameter.method_handler * ('c * 'b List_sig.list option) + +val length : 'a -> ('b -> 'c -> 'd -> 'e List_sig.list -> 'c * ('d * int option)) -> ('b -> 'c -> 'd -> 'e List_sig.list -> int -> 'c * 'd) -> - 'c -> 'b -> 'd -> 'e List_sig.list -> 'c * ('d * int) + 'c -> + 'b -> + 'd -> + 'e List_sig.list -> + 'c * ('d * int) -val extensional_without_asso: +val extensional_without_asso : (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - 'a -> - 'b List_sig.list -> - Exception_without_parameter.method_handler * - ('a * int list option)) -> + Exception_without_parameter.method_handler -> + 'a -> + 'b List_sig.list -> + Exception_without_parameter.method_handler * ('a * int list option)) -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - 'a -> - 'b List_sig.list -> - int list -> Exception_without_parameter.method_handler * 'a) -> + Exception_without_parameter.method_handler -> + 'a -> + 'b List_sig.list -> + int list -> + Exception_without_parameter.method_handler * 'a) -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> 'a -> 'b List_sig.list -> - Exception_without_parameter.method_handler * - ('a * int list option) -val extensional_with_asso: + Exception_without_parameter.method_handler * ('a * int list option) + +val extensional_with_asso : (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - 'a -> - 'b List_sig.list -> - Exception_without_parameter.method_handler * - ('a * (int * 'b) list option)) -> + Exception_without_parameter.method_handler -> + 'a -> + 'b List_sig.list -> + Exception_without_parameter.method_handler * ('a * (int * 'b) list option)) -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - 'a -> - 'b List_sig.list -> - (int * 'b) list -> - Exception_without_parameter.method_handler * 'a) -> + Exception_without_parameter.method_handler -> + 'a -> + 'b List_sig.list -> + (int * 'b) list -> + Exception_without_parameter.method_handler * 'a) -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> 'a -> 'b List_sig.list -> - Exception_without_parameter.method_handler * - ('a * (int * 'b) list option) + Exception_without_parameter.method_handler * ('a * (int * 'b) list option) -val build_reversed_sorted_list: +val build_reversed_sorted_list : (Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - (int, 'b) List_sig.precell List_sig.prelist -> - 'b List_sig.cell -> - (int -> 'b List_sig.list) -> - 'c -> - Exception_without_parameter.method_handler * - ('d * 'e * 'b List_sig.list * 'c) option) -> + ('a -> 'a -> int) -> + (int, 'b) List_sig.precell List_sig.prelist -> + 'b List_sig.cell -> + (int -> 'b List_sig.list) -> + 'c -> + Exception_without_parameter.method_handler + * ('d * 'e * 'b List_sig.list * 'c) option) -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> 'c -> (int * 'b) list -> - Exception_without_parameter.method_handler * - ('c * 'b List_sig.list) + Exception_without_parameter.method_handler * ('c * 'b List_sig.list) -val build_sorted_list: +val build_sorted_list : (Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - (int, 'b) List_sig.precell List_sig.prelist -> - 'b List_sig.cell -> - (int -> 'b List_sig.list) -> - 'c -> - Exception_without_parameter.method_handler * - ('d * 'e * 'b List_sig.list * 'c) option) -> + ('a -> 'a -> int) -> + (int, 'b) List_sig.precell List_sig.prelist -> + 'b List_sig.cell -> + (int -> 'b List_sig.list) -> + 'c -> + Exception_without_parameter.method_handler + * ('d * 'e * 'b List_sig.list * 'c) option) -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> 'c -> (int * 'b) list -> - Exception_without_parameter.method_handler * - ('c * 'b List_sig.list) + Exception_without_parameter.method_handler * ('c * 'b List_sig.list) -val build_list: +val build_list : (Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - (int, 'b) List_sig.precell List_sig.prelist -> - 'b List_sig.cell -> - (int -> 'b List_sig.list) -> - 'c -> - Exception_without_parameter.method_handler * - ('d * 'e * 'b List_sig.list * 'c) option) -> + ('a -> 'a -> int) -> + (int, 'b) List_sig.precell List_sig.prelist -> + 'b List_sig.cell -> + (int -> 'b List_sig.list) -> + 'c -> + Exception_without_parameter.method_handler + * ('d * 'e * 'b List_sig.list * 'c) option) -> Exception_without_parameter.method_handler -> Remanent_parameters_sig.parameters -> 'c -> (int * 'b) list -> - Exception_without_parameter.method_handler * - ('c * 'b List_sig.list) + Exception_without_parameter.method_handler * ('c * 'b List_sig.list) + +val print_variables_list : + Remanent_parameters_sig.parameters -> 'a List_sig.list -> unit +val print_cell : + Remanent_parameters_sig.parameters -> + ('a List_sig.list, 'a) List_sig.precell List_sig.prelist -> + unit -val print_variables_list:Remanent_parameters_sig.parameters -> 'a List_sig.list -> unit -val print_cell:Remanent_parameters_sig.parameters -> - ('a List_sig.list, 'a) List_sig.precell List_sig.prelist -> unit -val print_association_list:Remanent_parameters_sig.parameters -> int List_sig.list -> unit +val print_association_list : + Remanent_parameters_sig.parameters -> int List_sig.list -> unit diff --git a/core/KaSa_rep/abstract_domains/mvbdu/list_core.ml b/core/KaSa_rep/abstract_domains/mvbdu/list_core.ml index bcb7379c28..afe48b59ab 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/list_core.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/list_core.ml @@ -12,77 +12,60 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - let sanity_check = true let test_workbench = false - let get_hash_key list = list.List_sig.id - -let list_equal a b = a==b +let list_equal a b = a == b let get_skeleton prelist = match prelist with - | List_sig.Empty -> List_sig.Empty - | List_sig.Cons x -> - List_sig.Cons - { x with - List_sig.tail = get_hash_key x.List_sig.tail} + | List_sig.Empty -> List_sig.Empty + | List_sig.Cons x -> + List_sig.Cons { x with List_sig.tail = get_hash_key x.List_sig.tail } let build_list allocate error handler skeleton cell = - allocate - error - compare - skeleton - cell - (fun key -> {List_sig.id = key; List_sig.value = cell}) + allocate error compare skeleton cell + (fun key -> { List_sig.id = key; List_sig.value = cell }) handler let id_of_list x = x.List_sig.id let update_association_dictionary handler dictionary = - if handler.Memo_sig.association_list_dictionary == dictionary - then + if handler.Memo_sig.association_list_dictionary == dictionary then handler else - {handler with Memo_sig.association_list_dictionary = dictionary} + { handler with Memo_sig.association_list_dictionary = dictionary } let update_range_dictionary handler dictionary = - if handler.Memo_sig.range_list_dictionary == dictionary - then + if handler.Memo_sig.range_list_dictionary == dictionary then handler else - {handler with Memo_sig.range_list_dictionary = dictionary} + { handler with Memo_sig.range_list_dictionary = dictionary } let update_variables_dictionary handler dictionary = - if handler.Memo_sig.variables_list_dictionary == dictionary - then + if handler.Memo_sig.variables_list_dictionary == dictionary then handler else - {handler with Memo_sig.variables_list_dictionary = dictionary} + { handler with Memo_sig.variables_list_dictionary = dictionary } -let rec print_list error print_empty string_of_var string_of_value (parameters:Remanent_parameters_sig.parameters) list = +let rec print_list error print_empty string_of_var string_of_value + (parameters : Remanent_parameters_sig.parameters) list = match list.List_sig.value with - | List_sig.Empty -> print_empty error parameters - | List_sig.Cons x -> - let parameters' = Remanent_parameters.update_prefix parameters " " in - let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s (%d )%s=%s;" - parameters.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix - (id_of_list list) - (string_of_var x.List_sig.variable) - (string_of_value x.List_sig.association) - in - let _ = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let error = - print_list - error - print_empty - string_of_var - string_of_value - parameters' - x.List_sig.tail - in - error + | List_sig.Empty -> print_empty error parameters + | List_sig.Cons x -> + let parameters' = Remanent_parameters.update_prefix parameters " " in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s (%d )%s=%s;" + parameters.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix (id_of_list list) + (string_of_var x.List_sig.variable) + (string_of_value x.List_sig.association) + in + let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let error = + print_list error print_empty string_of_var string_of_value parameters' + x.List_sig.tail + in + error diff --git a/core/KaSa_rep/abstract_domains/mvbdu/list_core.mli b/core/KaSa_rep/abstract_domains/mvbdu/list_core.mli index 7f58540564..b48746c59c 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/list_core.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/list_core.mli @@ -1,33 +1,47 @@ -val sanity_check: bool -val test_workbench: bool +val sanity_check : bool +val test_workbench : bool +val list_equal : 'a -> 'a -> bool -val list_equal: 'a -> 'a -> bool -val get_skeleton: -('a List_sig.list, 'b) List_sig.precell List_sig.prelist -> - (int, 'b) List_sig.precell List_sig.prelist +val get_skeleton : + ('a List_sig.list, 'b) List_sig.precell List_sig.prelist -> + (int, 'b) List_sig.precell List_sig.prelist +val build_list : + ('a -> + ('b -> 'b -> int) -> + 'c -> + 'd List_sig.cell -> + (int -> 'd List_sig.list) -> + 'e -> + 'f) -> + 'a -> + 'e -> + 'c -> + 'd List_sig.cell -> + 'f -val build_list: -('a -> - ('b -> 'b -> int) -> - 'c -> 'd List_sig.cell -> (int -> 'd List_sig.list) -> 'e -> 'f) -> - 'a -> 'e -> 'c -> 'd List_sig.cell -> 'f +val update_association_dictionary : + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> + 'c -> + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -val update_association_dictionary: -('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> - 'c -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -val update_range_dictionary: -('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> - 'd -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -val update_variables_dictionary: -('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> - 'e -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler +val update_range_dictionary : + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> + 'd -> + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -val print_list: -'a -> - ('a -> Remanent_parameters_sig.parameters -> 'b) -> - (int -> string) -> - ('c -> string) -> - Remanent_parameters_sig.parameters -> 'c List_sig.list -> 'b +val update_variables_dictionary : + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> + 'e -> + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -val id_of_list: 'a List_sig.list -> int +val print_list : + 'a -> + ('a -> Remanent_parameters_sig.parameters -> 'b) -> + (int -> string) -> + ('c -> string) -> + Remanent_parameters_sig.parameters -> + 'c List_sig.list -> + 'b + +val id_of_list : 'a List_sig.list -> int diff --git a/core/KaSa_rep/abstract_domains/mvbdu/list_sig.ml b/core/KaSa_rep/abstract_domains/mvbdu/list_sig.ml index 4382200436..d21393df3f 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/list_sig.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/list_sig.ml @@ -12,27 +12,11 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type variable = Mvbdu_sig.variable type hash_key = Mvbdu_sig.hash_key -type ('a,'b) precell = - { - variable:variable; - association:'b; - tail:'a - } - -and ('a) prelist = - | Empty - | Cons of 'a - -and 'a cell = ('a list,'a) precell prelist - -and 'a list = - { - id : hash_key ; - value : 'a cell - } - -and 'a skeleton = (hash_key,'a) precell prelist +type ('a, 'b) precell = { variable: variable; association: 'b; tail: 'a } +and 'a prelist = Empty | Cons of 'a +and 'a cell = ('a list, 'a) precell prelist +and 'a list = { id: hash_key; value: 'a cell } +and 'a skeleton = (hash_key, 'a) precell prelist diff --git a/core/KaSa_rep/abstract_domains/mvbdu/list_sig.mli b/core/KaSa_rep/abstract_domains/mvbdu/list_sig.mli index 39b8dc9f8f..fb97fef427 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/list_sig.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/list_sig.mli @@ -1,24 +1,8 @@ - type variable = Mvbdu_sig.variable type hash_key = Mvbdu_sig.hash_key -type ('a,'b) precell = - { - variable:variable; - association:'b; - tail:'a - } - -and ('a) prelist = - | Empty - | Cons of 'a - -and 'a cell = ('a list,'a) precell prelist - -and 'a list = - { - id : hash_key ; - value : 'a cell - } - -and 'a skeleton = (hash_key,'a) precell prelist +type ('a, 'b) precell = { variable: variable; association: 'b; tail: 'a } +and 'a prelist = Empty | Cons of 'a +and 'a cell = ('a list, 'a) precell prelist +and 'a list = { id: hash_key; value: 'a cell } +and 'a skeleton = (hash_key, 'a) precell prelist diff --git a/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.ml b/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.ml index 873a966d18..97c49b96f9 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.ml @@ -12,98 +12,109 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'f,'g) memoized_fun = - { - f : Remanent_parameters_sig.parameters -> Exception.method_handler-> 'c; - store : Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('f,'b,'blist,'rlist,'vlist,'a,'g) handler -> 'd -> 'a Mvbdu_sig.mvbdu -> - Exception.method_handler * ('f,'b,'blist,'rlist,'vlist,'a,'g) handler; - get : Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('f,'b,'blist,'rlist,'vlist,'a,'g) handler -> 'd -> - Exception.method_handler * - (('f,'b,'blist,'rlist,'vlist,'a,'g) handler * 'a Mvbdu_sig.mvbdu option) - } +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'f, 'g) memoized_fun = { + f: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'c; + store: + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler -> + 'd -> + 'a Mvbdu_sig.mvbdu -> + Exception.method_handler * ('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler; + get: + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler -> + 'd -> + Exception.method_handler + * (('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler + * 'a Mvbdu_sig.mvbdu option); +} -and - ('f,'b,'c,'rlist,'vlist,'d,'e) handler = - { - data : 'f; - mvbdu_dictionary : 'b; - association_list_dictionary : 'c; - variables_list_dictionary : 'vlist; - range_list_dictionary : 'rlist; - print_cell : Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.cell -> unit; - print_skel : Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.skeleton -> unit; - print_mvbdu : Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.mvbdu -> unit - } +and ('f, 'b, 'c, 'rlist, 'vlist, 'd, 'e) handler = { + data: 'f; + mvbdu_dictionary: 'b; + association_list_dictionary: 'c; + variables_list_dictionary: 'vlist; + range_list_dictionary: 'rlist; + print_cell: Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.cell -> unit; + print_skel: + Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.skeleton -> unit; + print_mvbdu: Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.mvbdu -> unit; +} type 'a pair = 'a * 'a -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun = - ( - 'a, - 'b, - 'blist, - 'rlist, - 'vlist, - ('a -> - (Exception.method_handler * - (Exception.method_handler -> Exception.method_handler * 'c))), - 'a Mvbdu_sig.mvbdu, - 'd, - 'e) - memoized_fun +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun = + ( 'a, + 'b, + 'blist, + 'rlist, + 'vlist, + 'a -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'c), + 'a Mvbdu_sig.mvbdu, + 'd, + 'e ) + memoized_fun -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) binary_memoized_fun = - ( - 'a, - 'b, - 'blist, - 'rlist, - 'vlist, - (('a -> (Exception.method_handler * - ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun)) pair), - 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu, - 'd, - 'e - ) memoized_fun +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) binary_memoized_fun = + ( 'a, + 'b, + 'blist, + 'rlist, + 'vlist, + ('a -> + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun) + pair, + 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu, + 'd, + 'e ) + memoized_fun -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_other_memoized_fun = - ( - 'a, - 'b, - 'blist, - 'rlist, - 'vlist, - 'a -> (Exception.method_handler * - (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell)), - 'd * 'a Mvbdu_sig.mvbdu, - 'c, - 'e - ) memoized_fun +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_other_memoized_fun = + ( 'a, + 'b, + 'blist, + 'rlist, + 'vlist, + 'a -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell), + 'd * 'a Mvbdu_sig.mvbdu, + 'c, + 'e ) + memoized_fun - - -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) reset = - { - empty_range_list : - (Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun); - empty_association_list : - (Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun); - empty_variables_list : - (Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun); - leaf : 'a -> (Exception.method_handler * - (Exception.method_handler -> - Exception.method_handler * 'a Mvbdu_sig.cell)); - clean_head : - Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun; - build_false : int -> int -> - (Exception.method_handler * - (Exception.method_handler -> - Exception.method_handler * 'a Mvbdu_sig.cell)); - build_true : int -> int -> - 'a Mvbdu_sig.mvbdu -> 'a Mvbdu_sig.mvbdu -> - (Exception.method_handler * - (Exception.method_handler -> - Exception.method_handler * 'a Mvbdu_sig.cell)) ; - } +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) reset = { + empty_range_list: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + empty_association_list: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + empty_variables_list: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + leaf: + 'a -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell); + clean_head: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + build_false: + int -> + int -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell); + build_true: + int -> + int -> + 'a Mvbdu_sig.mvbdu -> + 'a Mvbdu_sig.mvbdu -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell); +} diff --git a/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.mli b/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.mli index e912a92d28..f8a59c4d76 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/memo_sig.mli @@ -1,95 +1,106 @@ -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'f,'g) memoized_fun = - { - f : Remanent_parameters_sig.parameters -> Exception.method_handler-> 'c; - store : Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('f,'b,'blist,'rlist,'vlist,'a,'g) handler -> 'd -> 'a Mvbdu_sig.mvbdu -> - Exception.method_handler * ('f,'b,'blist,'rlist,'vlist,'a,'g) handler; - get : Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('f,'b,'blist,'rlist,'vlist,'a,'g) handler -> 'd -> - Exception.method_handler * - (('f,'b,'blist,'rlist,'vlist,'a,'g) handler * 'a Mvbdu_sig.mvbdu option) - } +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'f, 'g) memoized_fun = { + f: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'c; + store: + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler -> + 'd -> + 'a Mvbdu_sig.mvbdu -> + Exception.method_handler * ('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler; + get: + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler -> + 'd -> + Exception.method_handler + * (('f, 'b, 'blist, 'rlist, 'vlist, 'a, 'g) handler + * 'a Mvbdu_sig.mvbdu option); +} -and - ('f,'b,'c,'rlist,'vlist,'d,'e) handler = - { - data : 'f; - mvbdu_dictionary : 'b; - association_list_dictionary : 'c; - variables_list_dictionary : 'vlist; - range_list_dictionary : 'rlist; - print_cell : Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.cell -> unit; - print_skel : Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.skeleton -> unit; - print_mvbdu : Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.mvbdu -> unit - } +and ('f, 'b, 'c, 'rlist, 'vlist, 'd, 'e) handler = { + data: 'f; + mvbdu_dictionary: 'b; + association_list_dictionary: 'c; + variables_list_dictionary: 'vlist; + range_list_dictionary: 'rlist; + print_cell: Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.cell -> unit; + print_skel: + Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.skeleton -> unit; + print_mvbdu: Remanent_parameters_sig.parameters -> 'd Mvbdu_sig.mvbdu -> unit; +} type 'a pair = 'a * 'a -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun = - ( - 'a, - 'b, - 'blist, - 'rlist, - 'vlist, - ('a -> - (Exception.method_handler * - (Exception.method_handler -> Exception.method_handler * 'c))), - 'a Mvbdu_sig.mvbdu, - 'd, - 'e) - memoized_fun +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun = + ( 'a, + 'b, + 'blist, + 'rlist, + 'vlist, + 'a -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'c), + 'a Mvbdu_sig.mvbdu, + 'd, + 'e ) + memoized_fun -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) binary_memoized_fun = - ( - 'a, - 'b, - 'blist, - 'rlist, - 'vlist, - (('a -> (Exception.method_handler * - ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun)) pair), - 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu, - 'd, - 'e - ) memoized_fun +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) binary_memoized_fun = + ( 'a, + 'b, + 'blist, + 'rlist, + 'vlist, + ('a -> + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun) + pair, + 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu, + 'd, + 'e ) + memoized_fun -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_other_memoized_fun = - ( - 'a, - 'b, - 'blist, - 'rlist, - 'vlist, - 'a -> (Exception.method_handler * - (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell)), - 'd * 'a Mvbdu_sig.mvbdu, - 'c, - 'e - ) memoized_fun +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_other_memoized_fun = + ( 'a, + 'b, + 'blist, + 'rlist, + 'vlist, + 'a -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell), + 'd * 'a Mvbdu_sig.mvbdu, + 'c, + 'e ) + memoized_fun - - -type ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) reset = - { - empty_range_list : - (Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun); - empty_association_list : - (Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun); - empty_variables_list : - (Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun); - leaf : 'a -> (Exception.method_handler * - (Exception.method_handler -> - Exception.method_handler * 'a Mvbdu_sig.cell)); - clean_head : - Exception.method_handler * ('a,'b,'blist,'rlist,'vlist,'c,'d,'e) unary_memoized_fun; - build_false : int -> int -> - (Exception.method_handler * - (Exception.method_handler -> - Exception.method_handler * 'a Mvbdu_sig.cell)); - build_true : int -> int -> - 'a Mvbdu_sig.mvbdu -> 'a Mvbdu_sig.mvbdu -> - (Exception.method_handler * - (Exception.method_handler -> - Exception.method_handler * 'a Mvbdu_sig.cell)) ; - } +type ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) reset = { + empty_range_list: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + empty_association_list: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + empty_variables_list: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + leaf: + 'a -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell); + clean_head: + Exception.method_handler + * ('a, 'b, 'blist, 'rlist, 'vlist, 'c, 'd, 'e) unary_memoized_fun; + build_false: + int -> + int -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell); + build_true: + int -> + int -> + 'a Mvbdu_sig.mvbdu -> + 'a Mvbdu_sig.mvbdu -> + Exception.method_handler + * (Exception.method_handler -> Exception.method_handler * 'a Mvbdu_sig.cell); +} diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.ml b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.ml index 0e0019c3ad..49d3cf63e4 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.ml @@ -29,1282 +29,922 @@ let downgrade parameters mh message value mvbdu = match mvbdu with - | Some x -> mh,x + | Some x -> mh, x | None -> Exception.warn parameters mh message Exit (value ()) -let generic_zeroary allocate handler f error parameters = - let error,cell = f error in - let error,output = - Mvbdu_core.build_already_compressed_cell - allocate error handler (Mvbdu_core.get_skeleton cell) cell +let generic_zeroary allocate handler f error parameters = + let error, cell = f error in + let error, output = + Mvbdu_core.build_already_compressed_cell allocate error handler + (Mvbdu_core.get_skeleton cell) + cell in match output with - | None -> Exception.warn parameters error __POS__ Exit (handler,None) - | Some (_key,_cell,mvbdu,handler) -> error,(handler,Some mvbdu) + | None -> Exception.warn parameters error __POS__ Exit (handler, None) + | Some (_key, _cell, mvbdu, handler) -> error, (handler, Some mvbdu) -let rec generic_unary allocate (memoized_fun:('a,'b,'c,'d,'e,'f,'g,'h) Memo_sig.unary_memoized_fun) - handler error parameters mvbdu_input = +let rec generic_unary allocate + (memoized_fun : + ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.unary_memoized_fun) handler + error parameters mvbdu_input = match memoized_fun.Memo_sig.get parameters error handler mvbdu_input with - | error,(handler,Some output) -> - error,(handler,Some output) - | error,(handler,None) -> - begin - let error, (handler, output) = - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf a -> - let error, depreciated_fun = memoized_fun.Memo_sig.f parameters error a in - generic_zeroary allocate handler depreciated_fun error parameters - | Mvbdu_sig.Node x -> - begin - match generic_unary - allocate memoized_fun handler error parameters - x.Mvbdu_sig.branch_true - with - | error,(handler,None) -> error,(handler,None) - | error,(handler,Some(mvbdu_true)) -> - begin - match generic_unary - allocate memoized_fun handler error parameters - x.Mvbdu_sig.branch_false - with - | error,(handler,None) -> error,(handler,None) - | error,(handler,Some(mvbdu_false)) -> - begin - match Mvbdu_core.compress_node allocate error handler - (Mvbdu_sig.Node - {x with - Mvbdu_sig.branch_true = mvbdu_true; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error,None -> error, (handler, None) - | error, Some(_id, _cell, mvbdu, handler) -> error, (handler, Some(mvbdu)) - end - end - end - in - match output with - | None -> error, (handler, None) - | Some mvbdu_output -> - let error, handler = - memoized_fun.Memo_sig.store - parameters error handler - mvbdu_input - mvbdu_output + | error, (handler, Some output) -> error, (handler, Some output) + | error, (handler, None) -> + let error, (handler, output) = + match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Leaf a -> + let error, depreciated_fun = + memoized_fun.Memo_sig.f parameters error a in - error, (handler, Some mvbdu_output) - end + generic_zeroary allocate handler depreciated_fun error parameters + | Mvbdu_sig.Node x -> + (match + generic_unary allocate memoized_fun handler error parameters + x.Mvbdu_sig.branch_true + with + | error, (handler, None) -> error, (handler, None) + | error, (handler, Some mvbdu_true) -> + (match + generic_unary allocate memoized_fun handler error parameters + x.Mvbdu_sig.branch_false + with + | error, (handler, None) -> error, (handler, None) + | error, (handler, Some mvbdu_false) -> + (match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + x with + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu)))) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler mvbdu_input + mvbdu_output + in + error, (handler, Some mvbdu_output)) let less parameters error x y = match compare x.Mvbdu_sig.variable y.Mvbdu_sig.variable with | 0 -> error, compare x.Mvbdu_sig.upper_bound y.Mvbdu_sig.upper_bound - | 1 | -1 as x-> error, x - | _ -> Exception.warn parameters error __POS__ Exit 0 + | (1 | -1) as x -> error, x + | _ -> Exception.warn parameters error __POS__ Exit 0 -let cut x t1 = +let cut x t1 = match t1.Mvbdu_sig.value with - | Mvbdu_sig.Node y when compare x y.Mvbdu_sig.variable = 0 -> y.Mvbdu_sig.branch_true + | Mvbdu_sig.Node y when compare x y.Mvbdu_sig.variable = 0 -> + y.Mvbdu_sig.branch_true | Mvbdu_sig.Leaf _ | Mvbdu_sig.Node _ -> t1 -let rec generic_binary allocate (memoized_fun:('a,'b,'c,'d,'e,'f,'g,'h) Memo_sig.binary_memoized_fun) handler error parameters mvbdu_a mvbdu_b = - match memoized_fun.Memo_sig.get parameters error handler (mvbdu_a,mvbdu_b) with - | error,(handler,Some output) -> error, (handler, Some output) - | error,(handler,None) -> - begin - let error,(handler,output) = - match mvbdu_a.Mvbdu_sig.value, mvbdu_b.Mvbdu_sig.value with - | Mvbdu_sig.Leaf a, _ -> - let error,depreciated = - fst (memoized_fun.Memo_sig.f parameters error) a - in - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_b - | _ ,Mvbdu_sig.Leaf b -> - let error,depreciated = - snd (memoized_fun.Memo_sig.f parameters error) b - in - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_a - | Mvbdu_sig.Node x,Mvbdu_sig.Node y -> - let error,(cell, x_true, x_false, y_true, y_false) = - let error,cmp = less parameters error x y in - error, +let rec generic_binary allocate + (memoized_fun : + ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.binary_memoized_fun) handler + error parameters mvbdu_a mvbdu_b = + match + memoized_fun.Memo_sig.get parameters error handler (mvbdu_a, mvbdu_b) + with + | error, (handler, Some output) -> error, (handler, Some output) + | error, (handler, None) -> + let error, (handler, output) = + match mvbdu_a.Mvbdu_sig.value, mvbdu_b.Mvbdu_sig.value with + | Mvbdu_sig.Leaf a, _ -> + let error, depreciated = + fst (memoized_fun.Memo_sig.f parameters error) a + in + generic_unary allocate depreciated handler error parameters mvbdu_b + | _, Mvbdu_sig.Leaf b -> + let error, depreciated = + snd (memoized_fun.Memo_sig.f parameters error) b + in + generic_unary allocate depreciated handler error parameters mvbdu_a + | Mvbdu_sig.Node x, Mvbdu_sig.Node y -> + let error, (cell, x_true, x_false, y_true, y_false) = + let error, cmp = less parameters error x y in + ( error, match cmp with | 0 -> - x, - x.Mvbdu_sig.branch_true, - x.Mvbdu_sig.branch_false, - y.Mvbdu_sig.branch_true, - y.Mvbdu_sig.branch_false + ( x, + x.Mvbdu_sig.branch_true, + x.Mvbdu_sig.branch_false, + y.Mvbdu_sig.branch_true, + y.Mvbdu_sig.branch_false ) | -1 -> - x, - x.Mvbdu_sig.branch_true, - x.Mvbdu_sig.branch_false, - cut x.Mvbdu_sig.variable mvbdu_b, - mvbdu_b + ( x, + x.Mvbdu_sig.branch_true, + x.Mvbdu_sig.branch_false, + cut x.Mvbdu_sig.variable mvbdu_b, + mvbdu_b ) | _ -> - y, - cut y.Mvbdu_sig.variable mvbdu_a, - mvbdu_a, - y.Mvbdu_sig.branch_true, - y.Mvbdu_sig.branch_false - in - begin - match generic_binary - allocate memoized_fun handler error parameters x_true y_true - with - | error,(handler,None) -> error,(handler,None) - | error,(handler,Some(mvbdu_true)) -> - begin - match generic_binary - allocate memoized_fun handler error parameters x_false y_false - with - | error,(handler,None) -> - error,(handler,None) - | error,(handler,Some(mvbdu_false)) -> - begin - match Mvbdu_core.compress_node allocate error handler - (Mvbdu_sig.Node - {cell with - Mvbdu_sig.branch_true = mvbdu_true ; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error,None -> - error,(handler,None) - | error,Some(_id,_cell,mvbdu,handler) -> - error,(handler,Some(mvbdu)) - end - end - end - in - match output with - | None -> error,(handler,None) - | Some mvbdu_output -> - let error,handler = - memoized_fun.Memo_sig.store - parameters - error - handler - (mvbdu_a, mvbdu_b) - mvbdu_output + ( y, + cut y.Mvbdu_sig.variable mvbdu_a, + mvbdu_a, + y.Mvbdu_sig.branch_true, + y.Mvbdu_sig.branch_false ) ) in - error, (handler, Some mvbdu_output) - end - -let rec generic_unary_other allocate memoized_fun handler error parameters other mvbdu_input - = - match memoized_fun.Memo_sig.get parameters error handler (other,mvbdu_input) with - | error,(handler,Some output) -> error,(handler,Some output) - | error,(handler,None) -> - begin - let error,(handler,output) = - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf a -> - let error,depreciated = - memoized_fun.Memo_sig.f parameters error a other - in - generic_zeroary - allocate - handler - depreciated - error - parameters - | Mvbdu_sig.Node x -> - begin - match generic_unary_other allocate memoized_fun handler error parameters - x.Mvbdu_sig.branch_true other - with - | error,(handler,None) -> error,(handler,None) - | error,(handler,Some(mvbdu_true)) -> - begin - match generic_unary_other allocate memoized_fun handler error - parameters x.Mvbdu_sig.branch_false other - with - | error,(handler,None) -> error,(handler,None) - | error,(handler,Some(mvbdu_false)) -> - begin - match Mvbdu_core.compress_node allocate error handler - (Mvbdu_sig.Node - {x with Mvbdu_sig.branch_true = mvbdu_true; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error,None -> error,(handler,None) - | error,Some(_id,_cell,mvbdu,handler) -> - error,(handler,Some(mvbdu)) - end - end - end + (match + generic_binary allocate memoized_fun handler error parameters x_true + y_true + with + | error, (handler, None) -> error, (handler, None) + | error, (handler, Some mvbdu_true) -> + (match + generic_binary allocate memoized_fun handler error parameters + x_false y_false + with + | error, (handler, None) -> error, (handler, None) + | error, (handler, Some mvbdu_false) -> + (match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + cell with + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu)))) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler (mvbdu_a, mvbdu_b) + mvbdu_output in - match output with - | None -> error,(handler,None) - | Some mvbdu_output -> - let error,handler = - memoized_fun.Memo_sig.store - parameters - error - handler - (other, mvbdu_input) - mvbdu_output - in - error, (handler,Some mvbdu_output) - end + error, (handler, Some mvbdu_output)) -let clean_head _allocate memoized_fun union handler error parameters (mvbdu_input:'mvbdu) - = - match memoized_fun.Memo_sig.get parameters error handler mvbdu_input with - | error,(handler,Some output) -> error,(handler,Some output) - | error,(handler,None) -> - begin - let error,(handler,mvbdu_output) = - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _a -> - error,(handler,Some mvbdu_input) - | Mvbdu_sig.Node x -> - let var_ref = x.Mvbdu_sig.variable in - let rec aux handler error mvbdu_input_list mvbdu_output = - match mvbdu_input_list with - | [] -> error,(handler,mvbdu_output) - | t::q -> - begin - match t.Mvbdu_sig.value with - | Mvbdu_sig.Node x when x.Mvbdu_sig.variable = var_ref -> - aux handler error - (x.Mvbdu_sig.branch_true::x.Mvbdu_sig.branch_false::q) - mvbdu_output - | Mvbdu_sig.Node _ - | Mvbdu_sig.Leaf _ -> - begin - match mvbdu_output with - | None -> aux handler error q (Some t) - | Some a -> - let error,(handler,output) = - union parameters handler error parameters t a - in - begin - match output with - | None -> - Exception.warn - parameters error __POS__ Exit (handler,None) - | Some a -> - aux handler error q (Some (a:'mvbdu)) - end - end - end - in - aux handler error [mvbdu_input] None +let rec generic_unary_other allocate memoized_fun handler error parameters other + mvbdu_input = + match + memoized_fun.Memo_sig.get parameters error handler (other, mvbdu_input) + with + | error, (handler, Some output) -> error, (handler, Some output) + | error, (handler, None) -> + let error, (handler, output) = + match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Leaf a -> + let error, depreciated = + memoized_fun.Memo_sig.f parameters error a other + in + generic_zeroary allocate handler depreciated error parameters + | Mvbdu_sig.Node x -> + (match + generic_unary_other allocate memoized_fun handler error parameters + x.Mvbdu_sig.branch_true other + with + | error, (handler, None) -> error, (handler, None) + | error, (handler, Some mvbdu_true) -> + (match + generic_unary_other allocate memoized_fun handler error parameters + x.Mvbdu_sig.branch_false other + with + | error, (handler, None) -> error, (handler, None) + | error, (handler, Some mvbdu_false) -> + (match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + x with + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu)))) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler + (other, mvbdu_input) mvbdu_output in - begin - match mvbdu_output with - | None -> error,(handler,None) - | Some mvbdu_output -> - let error,handler = - memoized_fun.Memo_sig.store parameters error handler - mvbdu_input mvbdu_output - in - error, (handler,Some (mvbdu_output:'mvbdu)) - end - end + error, (handler, Some mvbdu_output)) -let keep_head_only allocate memoized_fun bdu_true handler error parameters (mvbdu_input:'mvbdu) = +let clean_head _allocate memoized_fun union handler error parameters + (mvbdu_input : 'mvbdu) = match memoized_fun.Memo_sig.get parameters error handler mvbdu_input with | error, (handler, Some output) -> error, (handler, Some output) | error, (handler, None) -> - begin + let error, (handler, mvbdu_output) = match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> - error, (handler, Some mvbdu_input) + | Mvbdu_sig.Leaf _a -> error, (handler, Some mvbdu_input) | Mvbdu_sig.Node x -> let var_ref = x.Mvbdu_sig.variable in - let rec aux handler error mvbdu = - begin - match mvbdu.Mvbdu_sig.value with + let rec aux handler error mvbdu_input_list mvbdu_output = + match mvbdu_input_list with + | [] -> error, (handler, mvbdu_output) + | t :: q -> + (match t.Mvbdu_sig.value with | Mvbdu_sig.Node x when x.Mvbdu_sig.variable = var_ref -> - begin - let error, (handler, b_true) = - aux handler error x.Mvbdu_sig.branch_true - in - let error, (handler, b_false) = - aux handler error x.Mvbdu_sig.branch_false + aux handler error + (x.Mvbdu_sig.branch_true :: x.Mvbdu_sig.branch_false :: q) + mvbdu_output + | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> + (match mvbdu_output with + | None -> aux handler error q (Some t) + | Some a -> + let error, (handler, output) = + union parameters handler error parameters t a in - match b_true, b_false with - | Some b_true, Some b_false -> - begin - match Mvbdu_core.compress_node allocate error handler - (Mvbdu_sig.Node - {x with - Mvbdu_sig.branch_true = b_true; - Mvbdu_sig.branch_false = b_false}) - with - | error, None -> - Exception.warn parameters error __POS__ Exit (handler, None) - | error, Some (_, _, bdu, handler) -> error, (handler, Some bdu) - end - | None, _ | _, None -> error, (handler, None) - end - | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu) - | Mvbdu_sig.Node _ -> - let error, (handler, output) = - bdu_true parameters handler error parameters - in - begin - match output with - | None -> - Exception.warn - parameters error __POS__ Exit (handler, None) - | Some a -> error, (handler, Some a) - end - end + (match output with + | None -> + Exception.warn parameters error __POS__ Exit (handler, None) + | Some a -> aux handler error q (Some (a : 'mvbdu))))) in - aux handler error mvbdu_input - end + aux handler error [ mvbdu_input ] None + in + (match mvbdu_output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler mvbdu_input + mvbdu_output + in + error, (handler, Some (mvbdu_output : 'mvbdu))) -let rec redefine_range allocate memoized_fun error parameters handler mvbdu_input list_input = - match memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) - with +let keep_head_only allocate memoized_fun bdu_true handler error parameters + (mvbdu_input : 'mvbdu) = + match memoized_fun.Memo_sig.get parameters error handler mvbdu_input with | error, (handler, Some output) -> error, (handler, Some output) | error, (handler, None) -> - begin - let error, (handler, output) = - match list_input.List_sig.value with - | List_sig.Empty -> - let error, depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.empty_range_list + (match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) + | Mvbdu_sig.Node x -> + let var_ref = x.Mvbdu_sig.variable in + let rec aux handler error mvbdu = + match mvbdu.Mvbdu_sig.value with + | Mvbdu_sig.Node x when x.Mvbdu_sig.variable = var_ref -> + let error, (handler, b_true) = + aux handler error x.Mvbdu_sig.branch_true in - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_input - | List_sig.Cons(list) -> - begin - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Node mvbdu when - compare list.List_sig.variable mvbdu.Mvbdu_sig.variable > 0 -> - let error, (handler, b_true) = - redefine_range - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_true - list_input - in - let error, mvbdu_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_true) - b_true - in - let error, (handler,b_false) = - redefine_range - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_false - list_input - in - let error, mvbdu_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_false) - b_false - in - begin - match Mvbdu_core.compress_node - allocate - error - handler - (Mvbdu_sig.Node - {mvbdu with Mvbdu_sig.branch_true = mvbdu_true; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error, None -> - error, (handler, None) - | error, Some(_id, _cell, mvbdu, handler) -> - error, (handler, Some(mvbdu)) - end - | Mvbdu_sig.Node _ - | Mvbdu_sig.Leaf _ -> - begin - let error, (handler, branch_true) = - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Node x when - compare - list.List_sig.variable - x.Mvbdu_sig.variable = 0 -> - let error,depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head - in - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_input - | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> - error, (handler,Some mvbdu_input) - in - let error,branch_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - branch_true - in - let error, (handler, enriched_branch_true) = - match snd list.List_sig.association with - | Some ub -> - let error,depreciated = - (memoized_fun.Memo_sig.f parameters - error).Memo_sig.build_false - list.List_sig.variable - ub - in - let error,(handler,branch_false) = - generic_zeroary - allocate - handler - depreciated - error - parameters - in - let error,branch_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - branch_false - in - let error,depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_true - list.List_sig.variable - ub - branch_false - branch_true - in - let error,(handler,enriched_branch_true) = - generic_zeroary - allocate - handler - depreciated - error - parameters - in - let error,enriched_branch_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - enriched_branch_true - in - error, (handler, enriched_branch_true) - | None -> - error, (handler, branch_true) - in - let error, (handler, rep) = - match - fst list.List_sig.association - with - | Some lb -> - let error,depreciated = - (memoized_fun.Memo_sig.f parameters - error).Memo_sig.build_false - list.List_sig.variable - lb - in - let error,(handler,branch_false) = - generic_zeroary - allocate - handler - depreciated - error - parameters - in - let error,branch_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - branch_false - in - let error,depreciated = - (memoized_fun.Memo_sig.f parameters - error).Memo_sig.build_true - list.List_sig.variable - (lb - 1) - enriched_branch_true - branch_false - in - let error, (handler, rep) = - generic_zeroary - allocate - handler - depreciated - error - parameters - in - let error, rep = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - rep - in - error, (handler, rep) - | None -> - error, (handler, enriched_branch_true) - in - redefine_range - allocate - memoized_fun - error - parameters - handler - rep - list.List_sig.tail - end - end + let error, (handler, b_false) = + aux handler error x.Mvbdu_sig.branch_false + in + (match b_true, b_false with + | Some b_true, Some b_false -> + (match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + x with + Mvbdu_sig.branch_true = b_true; + Mvbdu_sig.branch_false = b_false; + }) + with + | error, None -> + Exception.warn parameters error __POS__ Exit (handler, None) + | error, Some (_, _, bdu, handler) -> error, (handler, Some bdu)) + | None, _ | _, None -> error, (handler, None)) + | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu) + | Mvbdu_sig.Node _ -> + let error, (handler, output) = + bdu_true parameters handler error parameters + in + (match output with + | None -> Exception.warn parameters error __POS__ Exit (handler, None) + | Some a -> error, (handler, Some a)) in - match output with - | None -> - error, (handler, None) - | Some mvbdu_output -> - let error, handler = - memoized_fun.Memo_sig.store - parameters - error - handler - (mvbdu_input, list_input) - mvbdu_output - in - error, (handler, Some (mvbdu_output:'mvbdu)) - end + aux handler error mvbdu_input) -let rec redefine allocate memoized_fun error parameters handler mvbdu_input list_input = - match memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) +let rec redefine_range allocate memoized_fun error parameters handler + mvbdu_input list_input = + match + memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) with | error, (handler, Some output) -> error, (handler, Some output) | error, (handler, None) -> - begin - let error, (handler, output) = - match list_input.List_sig.value with - | List_sig.Empty -> - let error, depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.empty_association_list + let error, (handler, output) = + match list_input.List_sig.value with + | List_sig.Empty -> + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.empty_range_list + in + generic_unary allocate depreciated handler error parameters mvbdu_input + | List_sig.Cons list -> + (match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Node mvbdu + when compare list.List_sig.variable mvbdu.Mvbdu_sig.variable > 0 -> + let error, (handler, b_true) = + redefine_range allocate memoized_fun error parameters handler + mvbdu.Mvbdu_sig.branch_true list_input in - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_input - | List_sig.Cons(list) -> - begin + let error, mvbdu_true = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_true) + b_true + in + let error, (handler, b_false) = + redefine_range allocate memoized_fun error parameters handler + mvbdu.Mvbdu_sig.branch_false list_input + in + let error, mvbdu_false = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_false) + b_false + in + (match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + mvbdu with + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu)) + | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> + let error, (handler, branch_true) = match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Node mvbdu when - compare list.List_sig.variable mvbdu.Mvbdu_sig.variable > 0 -> - let error, (handler, b_true) = - redefine - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_true - list_input + | Mvbdu_sig.Node x + when compare list.List_sig.variable x.Mvbdu_sig.variable = 0 -> + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head in - let error, mvbdu_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_true) - b_true + generic_unary allocate depreciated handler error parameters + mvbdu_input + | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> + error, (handler, Some mvbdu_input) + in + let error, branch_true = + downgrade parameters error __POS__ + (fun () -> mvbdu_input) + branch_true + in + let error, (handler, enriched_branch_true) = + match snd list.List_sig.association with + | Some ub -> + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_false + list.List_sig.variable ub in - let error, (handler,b_false) = - redefine - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_false - list_input + let error, (handler, branch_false) = + generic_zeroary allocate handler depreciated error parameters in - let error, mvbdu_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_false) - b_false + let error, branch_false = + downgrade parameters error __POS__ + (fun () -> mvbdu_input) + branch_false in - begin - match Mvbdu_core.compress_node - allocate - error - handler - (Mvbdu_sig.Node - {mvbdu with Mvbdu_sig.branch_true = mvbdu_true; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error, None -> - error, (handler, None) - | error, Some(_id, _cell, mvbdu, handler) -> - error, (handler, Some(mvbdu)) - end - | Mvbdu_sig.Node _ - | Mvbdu_sig.Leaf _ -> - begin - let error, (handler, branch_true) = - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Node x when - compare - list.List_sig.variable - x.Mvbdu_sig.variable = 0 -> - let error,depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head - in - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_input - | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> - error, (handler,Some mvbdu_input) - in - let error,branch_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - branch_true - in - let error,depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_false - list.List_sig.variable - list.List_sig.association - in - let error,(handler,branch_false) = - generic_zeroary - allocate - handler - depreciated - error - parameters - in - let error,branch_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - branch_false - in - let error,depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_true - list.List_sig.variable - list.List_sig.association - branch_false - branch_true - in - let error,(handler,enriched_branch_true) = - generic_zeroary - allocate - handler - depreciated - error - parameters - in - let error,enriched_branch_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - enriched_branch_true - in - let error,depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_true - list.List_sig.variable - (list.List_sig.association - 1) - enriched_branch_true - branch_false - in - let error,(handler,rep) = - generic_zeroary - allocate - handler - depreciated - error - parameters - in - let error,rep = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - rep - in - redefine - allocate - memoized_fun - error - parameters - handler - rep - list.List_sig.tail - end - end + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_true + list.List_sig.variable ub branch_false branch_true + in + let error, (handler, enriched_branch_true) = + generic_zeroary allocate handler depreciated error parameters + in + let error, enriched_branch_true = + downgrade parameters error __POS__ + (fun () -> mvbdu_input) + enriched_branch_true + in + error, (handler, enriched_branch_true) + | None -> error, (handler, branch_true) + in + let error, (handler, rep) = + match fst list.List_sig.association with + | Some lb -> + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_false + list.List_sig.variable lb + in + let error, (handler, branch_false) = + generic_zeroary allocate handler depreciated error parameters + in + let error, branch_false = + downgrade parameters error __POS__ + (fun () -> mvbdu_input) + branch_false + in + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_true + list.List_sig.variable (lb - 1) enriched_branch_true + branch_false + in + let error, (handler, rep) = + generic_zeroary allocate handler depreciated error parameters + in + let error, rep = + downgrade parameters error __POS__ (fun () -> mvbdu_input) rep + in + error, (handler, rep) + | None -> error, (handler, enriched_branch_true) + in + redefine_range allocate memoized_fun error parameters handler rep + list.List_sig.tail) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler + (mvbdu_input, list_input) mvbdu_output in - match output with - | None -> - error, (handler, None) - | Some mvbdu_output -> - let error, handler = - memoized_fun.Memo_sig.store - parameters - error - handler - (mvbdu_input, list_input) - mvbdu_output - in - error, (handler, Some (mvbdu_output:'mvbdu)) - end + error, (handler, Some (mvbdu_output : 'mvbdu))) -let rec monotonicaly_rename allocate memoized_fun error parameters handler mvbdu_input list_input = - match memoized_fun.Memo_sig.get parameters error handler (mvbdu_input,list_input) +let rec redefine allocate memoized_fun error parameters handler mvbdu_input + list_input = + match + memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) with - | error, (handler,Some output) -> error, (handler, Some output) - | error, (handler,None) -> - begin - let error, (handler,output) = - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) - | Mvbdu_sig.Node mvbdu -> - begin - match list_input.List_sig.value with - | List_sig.Empty -> - begin - Exception.warn parameters error __POS__ Exit (handler, None) - end - | List_sig.Cons(list) -> - begin - let cmp = compare list.List_sig.variable mvbdu.Mvbdu_sig.variable in - if cmp < 0 - then - monotonicaly_rename - allocate - memoized_fun error parameters handler - mvbdu_input - list.List_sig.tail - else if cmp = 0 - then - let error, (handler,b_true) = - monotonicaly_rename - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_true - list_input - in - let error, mvbdu_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_true) - b_true - in - let error, (handler,b_false) = - monotonicaly_rename - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_false - list_input - in - let error, mvbdu_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_false) - b_false - in - begin - match Mvbdu_core.compress_node - allocate - error - handler - (Mvbdu_sig.Node - {mvbdu with - Mvbdu_sig.variable = list.List_sig.association ; - Mvbdu_sig.branch_true = mvbdu_true; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error, None -> - error, (handler, None) - | error, Some(_id, _cell, mvbdu, handler) -> - error, (handler, Some(mvbdu)) - end - else - Exception.warn - parameters error __POS__ Exit (handler,None) - end - end - in - match output with - | None -> error, (handler, None) - | Some mvbdu_output -> - let error, handler = - memoized_fun.Memo_sig.store - parameters - error - handler - (mvbdu_input, list_input) - mvbdu_output + | error, (handler, Some output) -> error, (handler, Some output) + | error, (handler, None) -> + let error, (handler, output) = + match list_input.List_sig.value with + | List_sig.Empty -> + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error) + .Memo_sig.empty_association_list in - error, (handler, Some (mvbdu_output:'mvbdu)) - end - -let rec project_keep_only allocate memoized_fun bdu_true error parameters handler mvbdu_input list_input = - match memoized_fun.Memo_sig.get parameters error handler (mvbdu_input,list_input) - with - | error, (handler,Some output) -> error, (handler, Some output) - | error, (handler,None) -> - begin - let error, (handler,output) = - match list_input.List_sig.value with - | List_sig.Empty -> - let error,_depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.empty_association_list + generic_unary allocate depreciated handler error parameters mvbdu_input + | List_sig.Cons list -> + (match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Node mvbdu + when compare list.List_sig.variable mvbdu.Mvbdu_sig.variable > 0 -> + let error, (handler, b_true) = + redefine allocate memoized_fun error parameters handler + mvbdu.Mvbdu_sig.branch_true list_input in - begin - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) - | Mvbdu_sig.Node _ -> - bdu_true parameters handler error parameters - end - | List_sig.Cons(list) -> - begin + let error, mvbdu_true = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_true) + b_true + in + let error, (handler, b_false) = + redefine allocate memoized_fun error parameters handler + mvbdu.Mvbdu_sig.branch_false list_input + in + let error, mvbdu_false = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_false) + b_false + in + (match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + mvbdu with + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu)) + | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> + let error, (handler, branch_true) = match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> + | Mvbdu_sig.Node x + when compare list.List_sig.variable x.Mvbdu_sig.variable = 0 -> + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head + in + generic_unary allocate depreciated handler error parameters + mvbdu_input + | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) - | Mvbdu_sig.Node mvbdu -> - let cmp = compare list.List_sig.variable mvbdu.Mvbdu_sig.variable in - if cmp > 0 - then - let error, depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head - in - let error, (handler, output) = - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_input - in - let error, mvbdu = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - output - in - project_keep_only - allocate - memoized_fun - bdu_true - error - parameters - handler - mvbdu - list_input - else if cmp = 0 - then let error, (handler,b_true) = - project_keep_only - allocate - memoized_fun - bdu_true - error - parameters - handler - mvbdu.Mvbdu_sig.branch_true - list_input - in - let error, mvbdu_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_true) - b_true - in - let error, (handler,b_false) = - project_keep_only - allocate - memoized_fun - bdu_true - error - parameters - handler - mvbdu.Mvbdu_sig.branch_false - list_input - in - let error, mvbdu_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_false) - b_false - in - begin - match Mvbdu_core.compress_node - allocate - error - handler - (Mvbdu_sig.Node - {mvbdu with Mvbdu_sig.branch_true = mvbdu_true; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error, None -> - error, (handler, None) - | error, Some(_id, _cell, mvbdu, handler) -> - error, (handler, Some(mvbdu)) - end - - else - project_keep_only - allocate - memoized_fun - bdu_true - error - parameters - handler - mvbdu_input - list.List_sig.tail - end + in + let error, branch_true = + downgrade parameters error __POS__ + (fun () -> mvbdu_input) + branch_true + in + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_false + list.List_sig.variable list.List_sig.association + in + let error, (handler, branch_false) = + generic_zeroary allocate handler depreciated error parameters + in + let error, branch_false = + downgrade parameters error __POS__ + (fun () -> mvbdu_input) + branch_false + in + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_true + list.List_sig.variable list.List_sig.association branch_false + branch_true + in + let error, (handler, enriched_branch_true) = + generic_zeroary allocate handler depreciated error parameters + in + let error, enriched_branch_true = + downgrade parameters error __POS__ + (fun () -> mvbdu_input) + enriched_branch_true + in + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.build_true + list.List_sig.variable + (list.List_sig.association - 1) + enriched_branch_true branch_false + in + let error, (handler, rep) = + generic_zeroary allocate handler depreciated error parameters + in + let error, rep = + downgrade parameters error __POS__ (fun () -> mvbdu_input) rep + in + redefine allocate memoized_fun error parameters handler rep + list.List_sig.tail) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler + (mvbdu_input, list_input) mvbdu_output in - match output with - | None -> error, (handler, None) - | Some mvbdu_output -> - let error, handler = - memoized_fun.Memo_sig.store - parameters - error - handler - (mvbdu_input, list_input) - mvbdu_output - in - error, (handler, Some (mvbdu_output:'mvbdu)) - end + error, (handler, Some (mvbdu_output : 'mvbdu))) -let rec project_abstract_away allocate memoized_fun error parameters handler mvbdu_input list_input = - match memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) +let rec monotonicaly_rename allocate memoized_fun error parameters handler + mvbdu_input list_input = + match + memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) with | error, (handler, Some output) -> error, (handler, Some output) | error, (handler, None) -> - begin - let error, (handler, output) = - match list_input.List_sig.value with + let error, (handler, output) = + match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) + | Mvbdu_sig.Node mvbdu -> + (match list_input.List_sig.value with | List_sig.Empty -> - let error, depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.empty_association_list - in - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_input - | List_sig.Cons(list) -> - begin - match mvbdu_input.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) - | Mvbdu_sig.Node mvbdu -> - let cmp = compare list.List_sig.variable mvbdu.Mvbdu_sig.variable in - if cmp > 0 - then - let error, (handler, b_true) = - project_abstract_away - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_true - list_input - in - let error, mvbdu_true = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_true) - b_true - in - let error, (handler, b_false) = - project_abstract_away - allocate - memoized_fun - error - parameters - handler - mvbdu.Mvbdu_sig.branch_false - list_input - in - let error, mvbdu_false = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu.Mvbdu_sig.branch_false) - b_false - in - begin - match Mvbdu_core.compress_node - allocate - error - handler - (Mvbdu_sig.Node - {mvbdu with Mvbdu_sig.branch_true = mvbdu_true; - Mvbdu_sig.branch_false = mvbdu_false}) - with - | error, None -> - error, (handler, None) - | error, Some(_id, _cell, mvbdu, handler) -> - error, (handler, Some (mvbdu)) - end - else - if cmp = 0 - then - let error, depreciated = - (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head - in - let error, (handler, output) = - generic_unary - allocate - depreciated - handler - error - parameters - mvbdu_input - in - let error, mvbdu = - downgrade - parameters - error - __POS__ - (fun () -> mvbdu_input) - output - in - project_abstract_away - allocate - memoized_fun - error - parameters - handler - mvbdu - list_input - else - project_abstract_away - allocate - memoized_fun - error - parameters - handler - mvbdu_input - list.List_sig.tail - end + Exception.warn parameters error __POS__ Exit (handler, None) + | List_sig.Cons list -> + let cmp = compare list.List_sig.variable mvbdu.Mvbdu_sig.variable in + if cmp < 0 then + monotonicaly_rename allocate memoized_fun error parameters handler + mvbdu_input list.List_sig.tail + else if cmp = 0 then ( + let error, (handler, b_true) = + monotonicaly_rename allocate memoized_fun error parameters handler + mvbdu.Mvbdu_sig.branch_true list_input + in + let error, mvbdu_true = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_true) + b_true + in + let error, (handler, b_false) = + monotonicaly_rename allocate memoized_fun error parameters handler + mvbdu.Mvbdu_sig.branch_false list_input + in + let error, mvbdu_false = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_false) + b_false + in + match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + mvbdu with + Mvbdu_sig.variable = list.List_sig.association; + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu) + ) else + Exception.warn parameters error __POS__ Exit (handler, None)) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler + (mvbdu_input, list_input) mvbdu_output in - match output with - | None -> - error, (handler, None) - | Some mvbdu_output -> - let error, handler = - memoized_fun.Memo_sig.store - parameters - error - handler - (mvbdu_input, list_input) - mvbdu_output + error, (handler, Some (mvbdu_output : 'mvbdu))) + +let rec project_keep_only allocate memoized_fun bdu_true error parameters + handler mvbdu_input list_input = + match + memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) + with + | error, (handler, Some output) -> error, (handler, Some output) + | error, (handler, None) -> + let error, (handler, output) = + match list_input.List_sig.value with + | List_sig.Empty -> + let error, _depreciated = + (memoized_fun.Memo_sig.f parameters error) + .Memo_sig.empty_association_list in - error, (handler, Some (mvbdu_output:'mvbdu)) - end + (match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) + | Mvbdu_sig.Node _ -> bdu_true parameters handler error parameters) + | List_sig.Cons list -> + (match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) + | Mvbdu_sig.Node mvbdu -> + let cmp = compare list.List_sig.variable mvbdu.Mvbdu_sig.variable in + if cmp > 0 then ( + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head + in + let error, (handler, output) = + generic_unary allocate depreciated handler error parameters + mvbdu_input + in + let error, mvbdu = + downgrade parameters error __POS__ (fun () -> mvbdu_input) output + in + project_keep_only allocate memoized_fun bdu_true error parameters + handler mvbdu list_input + ) else if cmp = 0 then ( + let error, (handler, b_true) = + project_keep_only allocate memoized_fun bdu_true error parameters + handler mvbdu.Mvbdu_sig.branch_true list_input + in + let error, mvbdu_true = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_true) + b_true + in + let error, (handler, b_false) = + project_keep_only allocate memoized_fun bdu_true error parameters + handler mvbdu.Mvbdu_sig.branch_false list_input + in + let error, mvbdu_false = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_false) + b_false + in + match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + mvbdu with + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu) + ) else + project_keep_only allocate memoized_fun bdu_true error parameters + handler mvbdu_input list.List_sig.tail) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler + (mvbdu_input, list_input) mvbdu_output + in + error, (handler, Some (mvbdu_output : 'mvbdu))) -let mvbdu_identity handler _parameters error mvbdu = error, (handler,Some mvbdu) -let mvbdu_constant a handler _parameters error _ = error, (handler,Some a) +let rec project_abstract_away allocate memoized_fun error parameters handler + mvbdu_input list_input = + match + memoized_fun.Memo_sig.get parameters error handler (mvbdu_input, list_input) + with + | error, (handler, Some output) -> error, (handler, Some output) + | error, (handler, None) -> + let error, (handler, output) = + match list_input.List_sig.value with + | List_sig.Empty -> + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error) + .Memo_sig.empty_association_list + in + generic_unary allocate depreciated handler error parameters mvbdu_input + | List_sig.Cons list -> + (match mvbdu_input.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> error, (handler, Some mvbdu_input) + | Mvbdu_sig.Node mvbdu -> + let cmp = compare list.List_sig.variable mvbdu.Mvbdu_sig.variable in + if cmp > 0 then ( + let error, (handler, b_true) = + project_abstract_away allocate memoized_fun error parameters + handler mvbdu.Mvbdu_sig.branch_true list_input + in + let error, mvbdu_true = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_true) + b_true + in + let error, (handler, b_false) = + project_abstract_away allocate memoized_fun error parameters + handler mvbdu.Mvbdu_sig.branch_false list_input + in + let error, mvbdu_false = + downgrade parameters error __POS__ + (fun () -> mvbdu.Mvbdu_sig.branch_false) + b_false + in + match + Mvbdu_core.compress_node allocate error handler + (Mvbdu_sig.Node + { + mvbdu with + Mvbdu_sig.branch_true = mvbdu_true; + Mvbdu_sig.branch_false = mvbdu_false; + }) + with + | error, None -> error, (handler, None) + | error, Some (_id, _cell, mvbdu, handler) -> + error, (handler, Some mvbdu) + ) else if cmp = 0 then ( + let error, depreciated = + (memoized_fun.Memo_sig.f parameters error).Memo_sig.clean_head + in + let error, (handler, output) = + generic_unary allocate depreciated handler error parameters + mvbdu_input + in + let error, mvbdu = + downgrade parameters error __POS__ (fun () -> mvbdu_input) output + in + project_abstract_away allocate memoized_fun error parameters handler + mvbdu list_input + ) else + project_abstract_away allocate memoized_fun error parameters handler + mvbdu_input list.List_sig.tail) + in + (match output with + | None -> error, (handler, None) + | Some mvbdu_output -> + let error, handler = + memoized_fun.Memo_sig.store parameters error handler + (mvbdu_input, list_input) mvbdu_output + in + error, (handler, Some (mvbdu_output : 'mvbdu))) + +let mvbdu_identity handler _parameters error mvbdu = error, (handler, Some mvbdu) +let mvbdu_constant a handler _parameters error _ = error, (handler, Some a) -let recursive_memoize f get_handler update_handler get_storage set_storage = +let recursive_memoize f get_handler update_handler get_storage set_storage = { - Memo_sig.f = f ; + Memo_sig.f; Memo_sig.store = (fun parameters error handler key value -> - let storage = get_handler handler in - let error, storage' = set_storage parameters error handler key value storage in - let handler' = - if storage' == storage - then handler - else update_handler storage' handler - in - error, handler'); + let storage = get_handler handler in + let error, storage' = + set_storage parameters error handler key value storage + in + let handler' = + if storage' == storage then + handler + else + update_handler storage' handler + in + error, handler'); Memo_sig.get = (fun parameters error handler key -> - let storage = get_handler handler in - let a, (handler, b) = get_storage parameters error handler key storage - in a, (handler, b)) + let storage = get_handler handler in + let a, (handler, b) = + get_storage parameters error handler key storage + in + a, (handler, b)); } let recursive_not_memoize f = { - Memo_sig.f = f; - Memo_sig.store = (fun _parameters error handler _ _ -> error, handler); - Memo_sig.get = (fun _paramters error handler _ -> error, (handler,None)) + Memo_sig.f; + Memo_sig.store = (fun _parameters error handler _ _ -> error, handler); + Memo_sig.get = (fun _paramters error handler _ -> error, (handler, None)); } -let memoize_no_fun a b c d = - (recursive_memoize (fun _ -> raise Exit) - a b c d:('a,'b,'c,'d,'e,'f,'g,'h) Memo_sig.unary_memoized_fun) +let memoize_no_fun a b c d : + ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.unary_memoized_fun = + recursive_memoize (fun _ -> raise Exit) a b c d -let memoize_binary_no_fun a b c d = - (recursive_memoize (fun _ -> raise Exit) - a b c d:('a,'b,'c,'d,'e,'f,'g,'h) Memo_sig.binary_memoized_fun) +let memoize_binary_no_fun a b c d : + ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.binary_memoized_fun = + recursive_memoize (fun _ -> raise Exit) a b c d -let not_recursive_not_memoize_unary f g allocate = - { Memo_sig.f = g; - Memo_sig.store = (fun _parameters error handler _ _ -> error,handler); - Memo_sig.get = (fun parameters error handler x -> - let error,output_wo_id,output = f error x in +let not_recursive_not_memoize_unary f g allocate = + { + Memo_sig.f = g; + Memo_sig.store = (fun _parameters error handler _ _ -> error, handler); + Memo_sig.get = + (fun parameters error handler x -> + let error, output_wo_id, output = f error x in match output with | None -> - (match allocate - parameters - error - compare - (Mvbdu_core.get_skeleton output_wo_id) - output_wo_id - (fun key -> {Mvbdu_sig.id=key; Mvbdu_sig.value =output_wo_id}) - handler + (match + allocate parameters error compare + (Mvbdu_core.get_skeleton output_wo_id) + output_wo_id + (fun key -> + { Mvbdu_sig.id = key; Mvbdu_sig.value = output_wo_id }) + handler with - | _error,None -> (raise Exit) - | error,Some (_i,_a,b,handler) -> error, (handler,Some b)) - | Some _ -> error,(handler,output))} + | _error, None -> raise Exit + | error, Some (_i, _a, b, handler) -> error, (handler, Some b)) + | Some _ -> error, (handler, output)); + } -let not_recursive_memoize_unary - f - g - (get_handler : 'a -> 'b) +let not_recursive_memoize_unary f g (get_handler : 'a -> 'b) (update_handler : 'b -> 'a -> 'a) - (get_storage : - Exception.method_handler -> 'c -> 'b -> Exception.method_handler * ('d option)) - (set_storage : - Exception.method_handler -> 'c -> 'd -> 'b -> Exception.method_handler * 'b) - allocate = - let store = (fun _parameters error handler key value -> - let storage = get_handler handler in - let error, storage' = set_storage error key value storage in - let handler' = - if storage' == storage - then handler - else update_handler storage' handler - in - error, handler') + (get_storage : + Exception.method_handler -> + 'c -> + 'b -> + Exception.method_handler * 'd option) + (set_storage : + Exception.method_handler -> + 'c -> + 'd -> + 'b -> + Exception.method_handler * 'b) allocate = + let store _parameters error handler key value = + let storage = get_handler handler in + let error, storage' = set_storage error key value storage in + let handler' = + if storage' == storage then + handler + else + update_handler storage' handler + in + error, handler' in { - Memo_sig.f = g ; - Memo_sig.store = store; - Memo_sig.get = + Memo_sig.f = g; + Memo_sig.store; + Memo_sig.get = (fun _parameters error handler key -> - let storage = get_handler handler in - let a, b = get_storage error key storage in - match b with - | Some _ -> a, (handler,b) - | None -> - begin - ( - let error, handler, output_wo_id, output = f error handler key in - match output with - | None -> - (match allocate - error - compare - (Mvbdu_core.get_skeleton output_wo_id) - output_wo_id - (fun key -> {Mvbdu_sig.id=key;Mvbdu_sig.value =output_wo_id}) - handler - with - | _error,None -> (raise Exit) - | error,Some (_i,_a,b,handler) -> - let error,handler = storage error handler key b in - error,(handler,Some b)) - | Some _ -> error,(handler,output)) - end) + let storage = get_handler handler in + let a, b = get_storage error key storage in + match b with + | Some _ -> a, (handler, b) + | None -> + let error, handler, output_wo_id, output = f error handler key in + (match output with + | None -> + (match + allocate error compare + (Mvbdu_core.get_skeleton output_wo_id) + output_wo_id + (fun key -> + { Mvbdu_sig.id = key; Mvbdu_sig.value = output_wo_id }) + handler + with + | _error, None -> raise Exit + | error, Some (_i, _a, b, handler) -> + let error, handler = storage error handler key b in + error, (handler, Some b)) + | Some _ -> error, (handler, output))); } -let a = (not_recursive_memoize_unary: (Exception.method_handler -> 'handler -> 'g) -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'e) -> - ('handler -> 'dic) -> ('dic -> 'handler -> 'handler) -> - (Exception.method_handler -> 'c -> 'dic -> - Exception.method_handler * ('d option)) -> - (Exception.method_handler -> 'c -> 'd -> 'dic -> Exception.method_handler * 'dic) - -> 'h -> 'f ) +let a = + (not_recursive_memoize_unary + : (Exception.method_handler -> 'handler -> 'g) -> + (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'e) -> + ('handler -> 'dic) -> + ('dic -> 'handler -> 'handler) -> + (Exception.method_handler -> + 'c -> + 'dic -> + Exception.method_handler * 'd option) -> + (Exception.method_handler -> + 'c -> + 'd -> + 'dic -> + Exception.method_handler * 'dic) -> + 'h -> + 'f) let not_recursive_binary f g allocate = - { Memo_sig.f = g; - Memo_sig.store = (fun _parameters error handler _ _ -> error,handler); - Memo_sig.get = (fun _parameters error handler (x,y) -> + { + Memo_sig.f = g; + Memo_sig.store = (fun _parameters error handler _ _ -> error, handler); + Memo_sig.get = + (fun _parameters error handler (x, y) -> let error, output_wo_id, output = f error x y in match output with | None -> - (match allocate - error - compare - (Mvbdu_core.get_skeleton output_wo_id) - output_wo_id - (fun key -> {Mvbdu_sig.id = key ; Mvbdu_sig.value = output_wo_id}) - handler + (match + allocate error compare + (Mvbdu_core.get_skeleton output_wo_id) + output_wo_id + (fun key -> + { Mvbdu_sig.id = key; Mvbdu_sig.value = output_wo_id }) + handler with - | _error,None -> (raise Exit) - | error,Some (_i,_a,b,handler) -> error, (handler,Some b)) - | Some _ -> error, (handler,output))} + | _error, None -> raise Exit + | error, Some (_i, _a, b, handler) -> error, (handler, Some b)) + | Some _ -> error, (handler, output)); + } let id_of_mvbdu x = x.Mvbdu_sig.id diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.mli b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.mli index 89387eaa82..9026223231 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_algebra.mli @@ -1,464 +1,532 @@ -val generic_zeroary: -('a -> - ('b -> 'b -> int) -> - ((int, 'c) Mvbdu_sig.precell, 'd) Mvbdu_sig.premvbdu -> - 'd Mvbdu_sig.cell -> - (int -> 'd Mvbdu_sig.mvbdu) -> - 'e -> - Exception_without_parameter.method_handler * - ('f * 'g * 'h * 'e) option) -> - 'e -> - ('i -> - 'a * - (('d Mvbdu_sig.mvbdu, 'd) Mvbdu_sig.precell, 'd) - Mvbdu_sig.premvbdu) -> - 'i -> - Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler * ('e * 'h option) - +val generic_zeroary : + ('a -> + ('b -> 'b -> int) -> + ((int, 'c) Mvbdu_sig.precell, 'd) Mvbdu_sig.premvbdu -> + 'd Mvbdu_sig.cell -> + (int -> 'd Mvbdu_sig.mvbdu) -> + 'e -> + Exception_without_parameter.method_handler * ('f * 'g * 'h * 'e) option) -> + 'e -> + ('i -> + 'a * (('d Mvbdu_sig.mvbdu, 'd) Mvbdu_sig.precell, 'd) Mvbdu_sig.premvbdu) -> + 'i -> + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler * ('e * 'h option) -val generic_unary: -(Exception_without_parameter.method_handler -> - ('f -> 'f -> int) -> - ((int, 'i) Mvbdu_sig.precell, 'a) Mvbdu_sig.premvbdu -> - 'a Mvbdu_sig.cell -> - (int -> 'a Mvbdu_sig.mvbdu) -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'a Mvbdu_sig.cell * 'a Mvbdu_sig.mvbdu * - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) - option) -> - ('a, 'b, 'c, 'd, 'e, - (('a Mvbdu_sig.mvbdu, 'a) Mvbdu_sig.precell, 'a) - Mvbdu_sig.premvbdu, 'g, 'h) - Memo_sig.unary_memoized_fun -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - 'a Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * - 'a Mvbdu_sig.mvbdu option) +val generic_unary : + (Exception_without_parameter.method_handler -> + ('f -> 'f -> int) -> + ((int, 'i) Mvbdu_sig.precell, 'a) Mvbdu_sig.premvbdu -> + 'a Mvbdu_sig.cell -> + (int -> 'a Mvbdu_sig.mvbdu) -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'a Mvbdu_sig.cell + * 'a Mvbdu_sig.mvbdu + * ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) + option) -> + ( 'a, + 'b, + 'c, + 'd, + 'e, + (('a Mvbdu_sig.mvbdu, 'a) Mvbdu_sig.precell, 'a) Mvbdu_sig.premvbdu, + 'g, + 'h ) + Memo_sig.unary_memoized_fun -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + 'a Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * 'a Mvbdu_sig.mvbdu option) -val generic_binary: -(Exception_without_parameter.method_handler -> - ('f -> 'f -> int) -> - ((int, 'i) Mvbdu_sig.precell, 'a) Mvbdu_sig.premvbdu -> - 'a Mvbdu_sig.cell -> - (int -> 'a Mvbdu_sig.mvbdu) -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'a Mvbdu_sig.cell * 'a Mvbdu_sig.mvbdu * - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) - option) -> - ('a, 'b, 'c, 'd, 'e, - (('a Mvbdu_sig.mvbdu, 'a) Mvbdu_sig.precell, 'a) - Mvbdu_sig.premvbdu, 'g, 'h) - Memo_sig.binary_memoized_fun -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - 'a Mvbdu_sig.mvbdu -> - 'a Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * - 'a Mvbdu_sig.mvbdu option) -val generic_unary_other: -(Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - 'c Mvbdu_sig.cell -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'c Mvbdu_sig.cell * 'c Mvbdu_sig.mvbdu * - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) - option) -> - ('c, 'e, 'f, 'g, 'h, - 'j -> - 'j Mvbdu_sig.mvbdu -> - 'k * - ('k -> - Exception_without_parameter.method_handler * - (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu), - 'j Mvbdu_sig.mvbdu * 'j Mvbdu_sig.mvbdu, 'd, 'i) - Memo_sig.memoized_fun -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - 'j Mvbdu_sig.mvbdu -> - 'j Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option) +val generic_binary : + (Exception_without_parameter.method_handler -> + ('f -> 'f -> int) -> + ((int, 'i) Mvbdu_sig.precell, 'a) Mvbdu_sig.premvbdu -> + 'a Mvbdu_sig.cell -> + (int -> 'a Mvbdu_sig.mvbdu) -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'a Mvbdu_sig.cell + * 'a Mvbdu_sig.mvbdu + * ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) + option) -> + ( 'a, + 'b, + 'c, + 'd, + 'e, + (('a Mvbdu_sig.mvbdu, 'a) Mvbdu_sig.precell, 'a) Mvbdu_sig.premvbdu, + 'g, + 'h ) + Memo_sig.binary_memoized_fun -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + 'a Mvbdu_sig.mvbdu -> + 'a Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * 'a Mvbdu_sig.mvbdu option) -val clean_head: -'a -> - ('b, 'c, 'd, 'e, 'f, 'g, 'b Mvbdu_sig.mvbdu, 'h, 'i) - Memo_sig.memoized_fun -> - (Remanent_parameters_sig.parameters -> - ('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - 'b Mvbdu_sig.mvbdu -> - 'b Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler * - 'b Mvbdu_sig.mvbdu option)) -> - ('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - 'b Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler * - 'b Mvbdu_sig.mvbdu option) +val generic_unary_other : + (Exception_without_parameter.method_handler -> + ('a -> 'a -> int) -> + ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + 'c Mvbdu_sig.cell -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'c Mvbdu_sig.cell + * 'c Mvbdu_sig.mvbdu + * ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) + option) -> + ( 'c, + 'e, + 'f, + 'g, + 'h, + 'j -> + 'j Mvbdu_sig.mvbdu -> + 'k + * ('k -> + Exception_without_parameter.method_handler + * (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu), + 'j Mvbdu_sig.mvbdu * 'j Mvbdu_sig.mvbdu, + 'd, + 'i ) + Memo_sig.memoized_fun -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + 'j Mvbdu_sig.mvbdu -> + 'j Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option) -val keep_head_only: -(Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - 'c Mvbdu_sig.cell -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'c Mvbdu_sig.cell * 'c Mvbdu_sig.mvbdu * - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) - option) -> - ('c, 'e, 'f, 'g, 'h, 'j, 'c Mvbdu_sig.mvbdu, 'd, 'i) - Memo_sig.memoized_fun -> - (Remanent_parameters_sig.parameters -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option)) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - 'c Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option) +val clean_head : + 'a -> + ('b, 'c, 'd, 'e, 'f, 'g, 'b Mvbdu_sig.mvbdu, 'h, 'i) Memo_sig.memoized_fun -> + (Remanent_parameters_sig.parameters -> + ('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + 'b Mvbdu_sig.mvbdu -> + 'b Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * (('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler * 'b Mvbdu_sig.mvbdu option)) -> + ('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + 'b Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * (('h, 'c, 'd, 'e, 'f, 'b, 'i) Memo_sig.handler * 'b Mvbdu_sig.mvbdu option) -val redefine_range: -(Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - 'c Mvbdu_sig.cell -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'c Mvbdu_sig.cell * 'c Mvbdu_sig.mvbdu * - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) - option) -> - ('c, 'e, 'f, 'g, 'h, - ('c, 'e, 'f, 'g, 'h, - (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu, 'd, 'i) - Memo_sig.reset, - 'c Mvbdu_sig.mvbdu * (int option * int option) List_sig.list, - 'd, 'i) - Memo_sig.memoized_fun -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - 'c Mvbdu_sig.mvbdu -> - (int option * int option) List_sig.list -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option) +val keep_head_only : + (Exception_without_parameter.method_handler -> + ('a -> 'a -> int) -> + ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + 'c Mvbdu_sig.cell -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'c Mvbdu_sig.cell + * 'c Mvbdu_sig.mvbdu + * ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) + option) -> + ('c, 'e, 'f, 'g, 'h, 'j, 'c Mvbdu_sig.mvbdu, 'd, 'i) Memo_sig.memoized_fun -> + (Remanent_parameters_sig.parameters -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option)) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + 'c Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option) -val redefine: -(Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - 'c Mvbdu_sig.cell -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'c Mvbdu_sig.cell * 'c Mvbdu_sig.mvbdu * - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) - option) -> - ('c, 'e, 'f, 'g, 'h, - ('c, 'e, 'f, 'g, 'h, - (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu, 'd, 'i) - Memo_sig.reset, 'c Mvbdu_sig.mvbdu * int List_sig.list, 'd, 'i) - Memo_sig.memoized_fun -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - 'c Mvbdu_sig.mvbdu -> - int List_sig.list -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option) +val redefine_range : + (Exception_without_parameter.method_handler -> + ('a -> 'a -> int) -> + ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + 'c Mvbdu_sig.cell -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'c Mvbdu_sig.cell + * 'c Mvbdu_sig.mvbdu + * ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) + option) -> + ( 'c, + 'e, + 'f, + 'g, + 'h, + ( 'c, + 'e, + 'f, + 'g, + 'h, + (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu, + 'd, + 'i ) + Memo_sig.reset, + 'c Mvbdu_sig.mvbdu * (int option * int option) List_sig.list, + 'd, + 'i ) + Memo_sig.memoized_fun -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + 'c Mvbdu_sig.mvbdu -> + (int option * int option) List_sig.list -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option) +val redefine : + (Exception_without_parameter.method_handler -> + ('a -> 'a -> int) -> + ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + 'c Mvbdu_sig.cell -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'c Mvbdu_sig.cell + * 'c Mvbdu_sig.mvbdu + * ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) + option) -> + ( 'c, + 'e, + 'f, + 'g, + 'h, + ( 'c, + 'e, + 'f, + 'g, + 'h, + (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu, + 'd, + 'i ) + Memo_sig.reset, + 'c Mvbdu_sig.mvbdu * int List_sig.list, + 'd, + 'i ) + Memo_sig.memoized_fun -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + 'c Mvbdu_sig.mvbdu -> + int List_sig.list -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option) -val monotonicaly_rename: -(Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - 'c Mvbdu_sig.cell -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'c Mvbdu_sig.cell * 'c Mvbdu_sig.mvbdu * - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) - option) -> - ('c, 'e, 'f, 'g, 'h, 'j, 'c Mvbdu_sig.mvbdu * int List_sig.list, - 'd, 'i) - Memo_sig.memoized_fun -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - 'c Mvbdu_sig.mvbdu -> - int List_sig.list -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option) +val monotonicaly_rename : + (Exception_without_parameter.method_handler -> + ('a -> 'a -> int) -> + ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + 'c Mvbdu_sig.cell -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'c Mvbdu_sig.cell + * 'c Mvbdu_sig.mvbdu + * ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) + option) -> + ( 'c, + 'e, + 'f, + 'g, + 'h, + 'j, + 'c Mvbdu_sig.mvbdu * int List_sig.list, + 'd, + 'i ) + Memo_sig.memoized_fun -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + 'c Mvbdu_sig.mvbdu -> + int List_sig.list -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option) -val project_keep_only: -(Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - 'c Mvbdu_sig.cell -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'c Mvbdu_sig.cell * 'c Mvbdu_sig.mvbdu * - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) - option) -> - ('c, 'e, 'f, 'g, 'h, - ('c, 'e, 'f, 'g, 'h, - (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu, 'd, 'i) - Memo_sig.reset, 'c Mvbdu_sig.mvbdu * 'j List_sig.list, 'd, 'i) - Memo_sig.memoized_fun -> - (Remanent_parameters_sig.parameters -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option)) -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - 'c Mvbdu_sig.mvbdu -> - 'j List_sig.list -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option) -val project_abstract_away: -(Exception_without_parameter.method_handler -> - ('a -> 'a -> int) -> - ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - 'c Mvbdu_sig.cell -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - Exception_without_parameter.method_handler * - (int * 'c Mvbdu_sig.cell * 'c Mvbdu_sig.mvbdu * - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) - option) -> - ('c, 'e, 'f, 'g, 'h, - ('c, 'e, 'f, 'g, 'h, - (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu, 'd, 'i) - Memo_sig.reset, 'c Mvbdu_sig.mvbdu * 'j List_sig.list, 'd, 'i) - Memo_sig.memoized_fun -> - Exception_without_parameter.method_handler -> - Remanent_parameters_sig.parameters -> - ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> - 'c Mvbdu_sig.mvbdu -> - 'j List_sig.list -> - Exception_without_parameter.method_handler * - (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * - 'c Mvbdu_sig.mvbdu option) +val project_keep_only : + (Exception_without_parameter.method_handler -> + ('a -> 'a -> int) -> + ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + 'c Mvbdu_sig.cell -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'c Mvbdu_sig.cell + * 'c Mvbdu_sig.mvbdu + * ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) + option) -> + ( 'c, + 'e, + 'f, + 'g, + 'h, + ( 'c, + 'e, + 'f, + 'g, + 'h, + (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu, + 'd, + 'i ) + Memo_sig.reset, + 'c Mvbdu_sig.mvbdu * 'j List_sig.list, + 'd, + 'i ) + Memo_sig.memoized_fun -> + (Remanent_parameters_sig.parameters -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option)) -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + 'c Mvbdu_sig.mvbdu -> + 'j List_sig.list -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option) -val mvbdu_identity: -'a -> 'b -> 'c -> 'd -> 'c * ('a * 'd option) -val mvbdu_constant: -'a -> 'b -> 'c -> 'd -> 'e -> 'd * ('b * 'a option) +val project_abstract_away : + (Exception_without_parameter.method_handler -> + ('a -> 'a -> int) -> + ((int, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + 'c Mvbdu_sig.cell -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + Exception_without_parameter.method_handler + * (int + * 'c Mvbdu_sig.cell + * 'c Mvbdu_sig.mvbdu + * ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler) + option) -> + ( 'c, + 'e, + 'f, + 'g, + 'h, + ( 'c, + 'e, + 'f, + 'g, + 'h, + (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu, + 'd, + 'i ) + Memo_sig.reset, + 'c Mvbdu_sig.mvbdu * 'j List_sig.list, + 'd, + 'i ) + Memo_sig.memoized_fun -> + Exception_without_parameter.method_handler -> + Remanent_parameters_sig.parameters -> + ('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler -> + 'c Mvbdu_sig.mvbdu -> + 'j List_sig.list -> + Exception_without_parameter.method_handler + * (('d, 'e, 'f, 'g, 'h, 'c, 'i) Memo_sig.handler * 'c Mvbdu_sig.mvbdu option) +val mvbdu_identity : 'a -> 'b -> 'c -> 'd -> 'c * ('a * 'd option) +val mvbdu_constant : 'a -> 'b -> 'c -> 'd -> 'e -> 'd * ('b * 'a option) +val recursive_not_memoize : + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + 'a) -> + ('b, 'c, 'd, 'e, 'f, 'a, 'g, 'h, 'i) Memo_sig.memoized_fun +val memoize_no_fun : + (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> 'i) -> + ('i -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + 'a Mvbdu_sig.mvbdu -> + 'i -> + Exception_without_parameter.method_handler + * (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * 'a Mvbdu_sig.mvbdu option)) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + 'a Mvbdu_sig.mvbdu -> + 'a Mvbdu_sig.mvbdu -> + 'i -> + Exception_without_parameter.method_handler * 'i) -> + ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.unary_memoized_fun -val recursive_not_memoize: -(Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> 'a) -> - ('b, 'c, 'd, 'e, 'f, 'a, 'g, 'h, 'i) Memo_sig.memoized_fun +val memoize_binary_no_fun : + (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> 'i) -> + ('i -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu -> + 'i -> + Exception_without_parameter.method_handler + * (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * 'a Mvbdu_sig.mvbdu option)) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> + 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu -> + 'a Mvbdu_sig.mvbdu -> + 'i -> + Exception_without_parameter.method_handler * 'i) -> + ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.binary_memoized_fun -val memoize_no_fun: -(('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> 'i) -> - ('i -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - 'a Mvbdu_sig.mvbdu -> - 'i -> - Exception_without_parameter.method_handler * - (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * - 'a Mvbdu_sig.mvbdu option)) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - 'a Mvbdu_sig.mvbdu -> - 'a Mvbdu_sig.mvbdu -> - 'i -> Exception_without_parameter.method_handler * 'i) -> - ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.unary_memoized_fun +val not_recursive_not_memoize_unary : + (Exception_without_parameter.method_handler -> + 'a -> + Exception_without_parameter.method_handler + * (('b Mvbdu_sig.mvbdu, 'b) Mvbdu_sig.precell, 'b) Mvbdu_sig.premvbdu + * 'c Mvbdu_sig.mvbdu option) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + 'd) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ('e -> 'e -> int) -> + ((int, 'f) Mvbdu_sig.precell, 'b) Mvbdu_sig.premvbdu -> + (('b Mvbdu_sig.mvbdu, 'b) Mvbdu_sig.precell, 'b) Mvbdu_sig.premvbdu -> + (int -> 'b Mvbdu_sig.mvbdu) -> + ('g, 'h, 'i, 'j, 'k, 'c, 'l) Memo_sig.handler -> + Exception_without_parameter.method_handler + * ('m + * 'n + * 'c Mvbdu_sig.mvbdu + * ('g, 'h, 'i, 'j, 'k, 'c, 'l) Memo_sig.handler) + option) -> + ('c, 'h, 'i, 'j, 'k, 'd, 'a, 'g, 'l) Memo_sig.memoized_fun -val memoize_binary_no_fun: -(('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> 'i) -> - ('i -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu -> - 'i -> - Exception_without_parameter.method_handler * - (('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler * - 'a Mvbdu_sig.mvbdu option)) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - ('g, 'b, 'c, 'd, 'e, 'a, 'h) Memo_sig.handler -> - 'a Mvbdu_sig.mvbdu * 'a Mvbdu_sig.mvbdu -> - 'a Mvbdu_sig.mvbdu -> - 'i -> Exception_without_parameter.method_handler * 'i) -> - ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.binary_memoized_fun +val recursive_memoize : + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + 'a) -> + (('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> 'i) -> + ('i -> + ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> + ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> + 'j -> + 'i -> + Exception_without_parameter.method_handler + * (('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler * 'g Mvbdu_sig.mvbdu option)) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> + 'j -> + 'g Mvbdu_sig.mvbdu -> + 'i -> + Exception_without_parameter.method_handler * 'i) -> + ('g, 'c, 'd, 'e, 'f, 'a, 'j, 'b, 'h) Memo_sig.memoized_fun +val not_recursive_binary : + (Exception_without_parameter.method_handler -> + 'a -> + 'b -> + Exception_without_parameter.method_handler + * (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu + * 'd Mvbdu_sig.mvbdu option) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + 'e) -> + (Exception_without_parameter.method_handler -> + ('f -> 'f -> int) -> + ((int, 'g) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + (int -> 'c Mvbdu_sig.mvbdu) -> + ('h, 'i, 'j, 'k, 'l, 'd, 'm) Memo_sig.handler -> + Exception_without_parameter.method_handler + * ('n + * 'o + * 'd Mvbdu_sig.mvbdu + * ('h, 'i, 'j, 'k, 'l, 'd, 'm) Memo_sig.handler) + option) -> + ('d, 'i, 'j, 'k, 'l, 'e, 'a * 'b, 'h, 'm) Memo_sig.memoized_fun -val not_recursive_not_memoize_unary: -(Exception_without_parameter.method_handler -> - 'a -> - Exception_without_parameter.method_handler * - (('b Mvbdu_sig.mvbdu, 'b) Mvbdu_sig.precell, 'b) - Mvbdu_sig.premvbdu * 'c Mvbdu_sig.mvbdu option) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> 'd) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - ('e -> 'e -> int) -> - ((int, 'f) Mvbdu_sig.precell, 'b) Mvbdu_sig.premvbdu -> - (('b Mvbdu_sig.mvbdu, 'b) Mvbdu_sig.precell, 'b) - Mvbdu_sig.premvbdu -> - (int -> 'b Mvbdu_sig.mvbdu) -> - ('g, 'h, 'i, 'j, 'k, 'c, 'l) Memo_sig.handler -> - Exception_without_parameter.method_handler * - ('m * 'n * 'c Mvbdu_sig.mvbdu * - ('g, 'h, 'i, 'j, 'k, 'c, 'l) Memo_sig.handler) - option) -> - ('c, 'h, 'i, 'j, 'k, 'd, 'a, 'g, 'l) Memo_sig.memoized_fun +val id_of_mvbdu : 'a Mvbdu_sig.mvbdu -> int -val recursive_memoize: -(Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> 'a) -> - (('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> 'i) -> - ('i -> - ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> - ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> - 'j -> - 'i -> - Exception_without_parameter.method_handler * - (('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler * - 'g Mvbdu_sig.mvbdu option)) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> - 'j -> - 'g Mvbdu_sig.mvbdu -> - 'i -> Exception_without_parameter.method_handler * 'i) -> - ('g, 'c, 'd, 'e, 'f, 'a, 'j, 'b, 'h) Memo_sig.memoized_fun - -val not_recursive_binary: -(Exception_without_parameter.method_handler -> - 'a -> - 'b -> - Exception_without_parameter.method_handler * - (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu * 'd Mvbdu_sig.mvbdu option) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> 'e) -> - (Exception_without_parameter.method_handler -> - ('f -> 'f -> int) -> - ((int, 'g) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> - (('c Mvbdu_sig.mvbdu, 'c) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu -> - (int -> 'c Mvbdu_sig.mvbdu) -> - ('h, 'i, 'j, 'k, 'l, 'd, 'm) Memo_sig.handler -> - Exception_without_parameter.method_handler * - ('n * 'o * 'd Mvbdu_sig.mvbdu * - ('h, 'i, 'j, 'k, 'l, 'd, 'm) Memo_sig.handler) - option) -> - ('d, 'i, 'j, 'k, 'l, 'e, 'a * 'b, 'h, 'm) Memo_sig.memoized_fun - -val id_of_mvbdu: 'a Mvbdu_sig.mvbdu -> int -val a: -(Exception_without_parameter.method_handler -> - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> - 'c -> - Exception_without_parameter.method_handler * - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler * - (('j Mvbdu_sig.mvbdu, 'j) Mvbdu_sig.precell, 'j) - Mvbdu_sig.premvbdu * 'h Mvbdu_sig.mvbdu option) -> - (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> 'e) -> - (('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> - 'k -> - 'l -> - 'c -> - 'h Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> - (('k -> - 'l -> - 'c -> - 'h Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> - (Exception_without_parameter.method_handler -> - 'c -> - ('k -> - 'l -> - 'c -> - 'h Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> - Exception_without_parameter.method_handler * - 'h Mvbdu_sig.mvbdu option) -> - (Exception_without_parameter.method_handler -> - 'c -> - 'h Mvbdu_sig.mvbdu -> - ('k -> - 'l -> - 'c -> - 'h Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> - Exception_without_parameter.method_handler * - ('k -> - 'l -> - 'c -> - 'h Mvbdu_sig.mvbdu -> - Exception_without_parameter.method_handler * - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler)) -> - (Exception_without_parameter.method_handler -> - ('m -> 'm -> int) -> - ((int, 'n) Mvbdu_sig.precell, 'j) Mvbdu_sig.premvbdu -> - (('j Mvbdu_sig.mvbdu, 'j) Mvbdu_sig.precell, 'j) - Mvbdu_sig.premvbdu -> - (int -> 'j Mvbdu_sig.mvbdu) -> - ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> - 'k * ('o * 'p * 'h Mvbdu_sig.mvbdu * 'l) option) -> - ('h, 'b, 'd, 'f, 'g, 'e, 'c, 'a, 'i) Memo_sig.memoized_fun +val a : + (Exception_without_parameter.method_handler -> + ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> + 'c -> + Exception_without_parameter.method_handler + * ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler + * (('j Mvbdu_sig.mvbdu, 'j) Mvbdu_sig.precell, 'j) Mvbdu_sig.premvbdu + * 'h Mvbdu_sig.mvbdu option) -> + (Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + 'e) -> + (('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> + 'k -> + 'l -> + 'c -> + 'h Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> + (('k -> + 'l -> + 'c -> + 'h Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> + ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> + ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> + (Exception_without_parameter.method_handler -> + 'c -> + ('k -> + 'l -> + 'c -> + 'h Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> + Exception_without_parameter.method_handler * 'h Mvbdu_sig.mvbdu option) -> + (Exception_without_parameter.method_handler -> + 'c -> + 'h Mvbdu_sig.mvbdu -> + ('k -> + 'l -> + 'c -> + 'h Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler) -> + Exception_without_parameter.method_handler + * ('k -> + 'l -> + 'c -> + 'h Mvbdu_sig.mvbdu -> + Exception_without_parameter.method_handler + * ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler)) -> + (Exception_without_parameter.method_handler -> + ('m -> 'm -> int) -> + ((int, 'n) Mvbdu_sig.precell, 'j) Mvbdu_sig.premvbdu -> + (('j Mvbdu_sig.mvbdu, 'j) Mvbdu_sig.precell, 'j) Mvbdu_sig.premvbdu -> + (int -> 'j Mvbdu_sig.mvbdu) -> + ('a, 'b, 'd, 'f, 'g, 'h, 'i) Memo_sig.handler -> + 'k * ('o * 'p * 'h Mvbdu_sig.mvbdu * 'l) option) -> + ('h, 'b, 'd, 'f, 'g, 'e, 'c, 'a, 'i) Memo_sig.memoized_fun diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.ml b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.ml index 803b578481..bb1d54e6ec 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.ml @@ -12,137 +12,116 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - let sanity_check = true let test_workbench = false - let get_hash_key mvbdu = mvbdu.Mvbdu_sig.id - -let mvbdu_equal a b = a==b +let mvbdu_equal a b = a == b let get_skeleton cell = match cell with - | Mvbdu_sig.Leaf x -> Mvbdu_sig.Leaf x - | Mvbdu_sig.Node x -> - Mvbdu_sig.Node - {x with - Mvbdu_sig.branch_true = get_hash_key x.Mvbdu_sig.branch_true; - Mvbdu_sig.branch_false = get_hash_key x.Mvbdu_sig.branch_false - } + | Mvbdu_sig.Leaf x -> Mvbdu_sig.Leaf x + | Mvbdu_sig.Node x -> + Mvbdu_sig.Node + { + x with + Mvbdu_sig.branch_true = get_hash_key x.Mvbdu_sig.branch_true; + Mvbdu_sig.branch_false = get_hash_key x.Mvbdu_sig.branch_false; + } let print_flag parameters bool = - if bool - then Loggers.fprintf (Remanent_parameters.get_logger parameters) "Yes" - else Loggers.fprintf (Remanent_parameters.get_logger parameters) "No" + if bool then + Loggers.fprintf (Remanent_parameters.get_logger parameters) "Yes" + else + Loggers.fprintf (Remanent_parameters.get_logger parameters) "No" -let build_already_compressed_cell allocate - error handler skeleton cell = - allocate - error - compare - skeleton - cell - (fun key -> {Mvbdu_sig.id=key; Mvbdu_sig.value=cell}) +let build_already_compressed_cell allocate error handler skeleton cell = + allocate error compare skeleton cell + (fun key -> { Mvbdu_sig.id = key; Mvbdu_sig.value = cell }) handler let compress_node allocate error handler cell = match cell with - | Mvbdu_sig.Leaf _a as x -> - build_already_compressed_cell - allocate - error - handler - x - x - | Mvbdu_sig.Node x -> - let variable = x.Mvbdu_sig.variable in - let bound = x.Mvbdu_sig.upper_bound in - let branch_true = x.Mvbdu_sig.branch_true in - let branch_false = x.Mvbdu_sig.branch_false in - if mvbdu_equal branch_true branch_false - then error, - Some (get_hash_key branch_true, - branch_true.Mvbdu_sig.value, - branch_true, - handler) - else - match branch_false.Mvbdu_sig.value with - | Mvbdu_sig.Node x - when mvbdu_equal x.Mvbdu_sig.branch_true branch_true -> - error, Some (get_hash_key branch_false, - branch_false.Mvbdu_sig.value, - branch_false, - handler) - | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> - (build_already_compressed_cell - allocate - error - handler - (Mvbdu_sig.Node - { - Mvbdu_sig.variable = variable; - Mvbdu_sig.upper_bound = bound; - Mvbdu_sig.branch_true = branch_true.Mvbdu_sig.id; - Mvbdu_sig.branch_false = branch_false.Mvbdu_sig.id; - }) - (Mvbdu_sig.Node - { - Mvbdu_sig.variable = variable; - Mvbdu_sig.upper_bound = bound; - Mvbdu_sig.branch_true = branch_true; - Mvbdu_sig.branch_false = branch_false ; - })) + | Mvbdu_sig.Leaf _a as x -> + build_already_compressed_cell allocate error handler x x + | Mvbdu_sig.Node x -> + let variable = x.Mvbdu_sig.variable in + let bound = x.Mvbdu_sig.upper_bound in + let branch_true = x.Mvbdu_sig.branch_true in + let branch_false = x.Mvbdu_sig.branch_false in + if mvbdu_equal branch_true branch_false then + ( error, + Some + ( get_hash_key branch_true, + branch_true.Mvbdu_sig.value, + branch_true, + handler ) ) + else ( + match branch_false.Mvbdu_sig.value with + | Mvbdu_sig.Node x when mvbdu_equal x.Mvbdu_sig.branch_true branch_true -> + ( error, + Some + ( get_hash_key branch_false, + branch_false.Mvbdu_sig.value, + branch_false, + handler ) ) + | Mvbdu_sig.Node _ | Mvbdu_sig.Leaf _ -> + build_already_compressed_cell allocate error handler + (Mvbdu_sig.Node + { + Mvbdu_sig.variable; + Mvbdu_sig.upper_bound = bound; + Mvbdu_sig.branch_true = branch_true.Mvbdu_sig.id; + Mvbdu_sig.branch_false = branch_false.Mvbdu_sig.id; + }) + (Mvbdu_sig.Node + { + Mvbdu_sig.variable; + Mvbdu_sig.upper_bound = bound; + Mvbdu_sig.branch_true; + Mvbdu_sig.branch_false; + }) + ) let rec print_mvbdu error print_leaf string_of_var parameters mvbdu = match mvbdu.Mvbdu_sig.value with - | Mvbdu_sig.Leaf a -> print_leaf error parameters a - | Mvbdu_sig.Node x -> - let parameters' = Remanent_parameters.update_prefix parameters " " in - let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s if(mvbdu_id:%d) %s < %d then " - parameters.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix - mvbdu.Mvbdu_sig.id - (string_of_var x.Mvbdu_sig.variable) - (x.Mvbdu_sig.upper_bound + 1) - in - let _ = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let error = - print_mvbdu - error - print_leaf - string_of_var - parameters' - x.Mvbdu_sig.branch_true - in - let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s else " - parameters.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix - in - let _ = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let error = - print_mvbdu - error - print_leaf - string_of_var - parameters' - x.Mvbdu_sig.branch_false - in - error + | Mvbdu_sig.Leaf a -> print_leaf error parameters a + | Mvbdu_sig.Node x -> + let parameters' = Remanent_parameters.update_prefix parameters " " in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s if(mvbdu_id:%d) %s < %d then " + parameters.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix mvbdu.Mvbdu_sig.id + (string_of_var x.Mvbdu_sig.variable) + (x.Mvbdu_sig.upper_bound + 1) + in + let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let error = + print_mvbdu error print_leaf string_of_var parameters' + x.Mvbdu_sig.branch_true + in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s else " + parameters.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix + in + let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let error = + print_mvbdu error print_leaf string_of_var parameters' + x.Mvbdu_sig.branch_false + in + error let id_of_mvbdu x = x.Mvbdu_sig.id let update_dictionary handler dictionary = - if handler.Memo_sig.mvbdu_dictionary == dictionary - then + if handler.Memo_sig.mvbdu_dictionary == dictionary then handler else - {handler with Memo_sig.mvbdu_dictionary = dictionary} + { handler with Memo_sig.mvbdu_dictionary = dictionary } let last_entry parameter handler error last_entry = let dic = handler.Memo_sig.mvbdu_dictionary in diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.mli b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.mli index 17406a1a42..c961651e87 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_core.mli @@ -1,42 +1,58 @@ -val sanity_check: bool -val test_workbench: bool - -val print_flag: Remanent_parameters_sig.parameters -> bool -> unit -val get_skeleton: -(('a Mvbdu_sig.mvbdu, 'b) Mvbdu_sig.precell, 'c) - Mvbdu_sig.premvbdu -> - ((int, 'd) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu - -val compress_node: -('a -> - ('b -> 'b -> int) -> - ((int, 'c) Mvbdu_sig.precell, 'd) Mvbdu_sig.premvbdu -> - 'd Mvbdu_sig.cell -> - (int -> 'd Mvbdu_sig.mvbdu) -> - 'e -> - 'a * (int * 'd Mvbdu_sig.cell * 'd Mvbdu_sig.mvbdu * 'e) option) -> - 'a -> - 'e -> - (('d Mvbdu_sig.mvbdu, 'f) Mvbdu_sig.precell, 'd) - Mvbdu_sig.premvbdu -> - 'a * (int * 'd Mvbdu_sig.cell * 'd Mvbdu_sig.mvbdu * 'e) option -val build_already_compressed_cell: -('a -> - ('b -> 'b -> int) -> - 'c -> - 'd Mvbdu_sig.cell -> (int -> 'd Mvbdu_sig.mvbdu) -> 'e -> 'f) -> - 'a -> 'e -> 'c -> 'd Mvbdu_sig.cell -> 'f -val print_mvbdu: - 'a -> - ('a -> Remanent_parameters_sig.parameters -> 'b -> 'a) -> - (int -> string) -> - Remanent_parameters_sig.parameters -> 'b Mvbdu_sig.mvbdu -> 'a -val id_of_mvbdu: 'a Mvbdu_sig.mvbdu -> int -val update_dictionary: -('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> - 'b -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -val last_entry: 'a -> - ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> - 'i -> ('a -> 'i -> 'c -> 'j) -> 'j - -val mvbdu_equal: 'a -> 'a -> bool +val sanity_check : bool +val test_workbench : bool +val print_flag : Remanent_parameters_sig.parameters -> bool -> unit + +val get_skeleton : + (('a Mvbdu_sig.mvbdu, 'b) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu -> + ((int, 'd) Mvbdu_sig.precell, 'c) Mvbdu_sig.premvbdu + +val compress_node : + ('a -> + ('b -> 'b -> int) -> + ((int, 'c) Mvbdu_sig.precell, 'd) Mvbdu_sig.premvbdu -> + 'd Mvbdu_sig.cell -> + (int -> 'd Mvbdu_sig.mvbdu) -> + 'e -> + 'a * (int * 'd Mvbdu_sig.cell * 'd Mvbdu_sig.mvbdu * 'e) option) -> + 'a -> + 'e -> + (('d Mvbdu_sig.mvbdu, 'f) Mvbdu_sig.precell, 'd) Mvbdu_sig.premvbdu -> + 'a * (int * 'd Mvbdu_sig.cell * 'd Mvbdu_sig.mvbdu * 'e) option + +val build_already_compressed_cell : + ('a -> + ('b -> 'b -> int) -> + 'c -> + 'd Mvbdu_sig.cell -> + (int -> 'd Mvbdu_sig.mvbdu) -> + 'e -> + 'f) -> + 'a -> + 'e -> + 'c -> + 'd Mvbdu_sig.cell -> + 'f + +val print_mvbdu : + 'a -> + ('a -> Remanent_parameters_sig.parameters -> 'b -> 'a) -> + (int -> string) -> + Remanent_parameters_sig.parameters -> + 'b Mvbdu_sig.mvbdu -> + 'a + +val id_of_mvbdu : 'a Mvbdu_sig.mvbdu -> int + +val update_dictionary : + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler -> + 'b -> + ('a, 'b, 'c, 'd, 'e, 'f, 'g) Memo_sig.handler + +val last_entry : + 'a -> + ('b, 'c, 'd, 'e, 'f, 'g, 'h) Memo_sig.handler -> + 'i -> + ('a -> 'i -> 'c -> 'j) -> + 'j + +val mvbdu_equal : 'a -> 'a -> bool diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.ml b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.ml index c9d105ea73..1453a6bf69 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.ml @@ -12,28 +12,18 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type variable = int (*Ckappa_sig.c_site_name*) type upper_bound = int type hash_key = int -type ('a,'b) precell = - { - variable : variable; - upper_bound : upper_bound; - branch_true : 'a; - branch_false : 'a - } - -and ('a,'b) premvbdu = - | Leaf of 'b - | Node of 'a - -and 'b mvbdu = - { - id : hash_key; - value : 'b cell - } +type ('a, 'b) precell = { + variable: variable; + upper_bound: upper_bound; + branch_true: 'a; + branch_false: 'a; +} +and ('a, 'b) premvbdu = Leaf of 'b | Node of 'a +and 'b mvbdu = { id: hash_key; value: 'b cell } and 'b skeleton = ((hash_key, 'b) precell, 'b) premvbdu -and 'b cell = (('b mvbdu, 'b) precell, 'b) premvbdu +and 'b cell = (('b mvbdu, 'b) precell, 'b) premvbdu diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.mli b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.mli index dec8d6cec7..40e392d59e 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_sig.mli @@ -1,25 +1,15 @@ - type variable = int (*Ckappa_sig.c_site_name*) type upper_bound = int type hash_key = int -type ('a,'b) precell = - { - variable : variable; - upper_bound : upper_bound; - branch_true : 'a; - branch_false : 'a - } - -and ('a,'b) premvbdu = - | Leaf of 'b - | Node of 'a - -and 'b mvbdu = - { - id : hash_key; - value : 'b cell - } +type ('a, 'b) precell = { + variable: variable; + upper_bound: upper_bound; + branch_true: 'a; + branch_false: 'a; +} +and ('a, 'b) premvbdu = Leaf of 'b | Node of 'a +and 'b mvbdu = { id: hash_key; value: 'b cell } and 'b skeleton = ((hash_key, 'b) precell, 'b) premvbdu -and 'b cell = (('b mvbdu, 'b) precell, 'b) premvbdu +and 'b cell = (('b mvbdu, 'b) precell, 'b) premvbdu diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml index 75c4ebd44b..eb90c13a3e 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml @@ -12,1106 +12,1242 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Mvbdu = -sig +module type Mvbdu = sig type key type value - type handler = (Boolean_mvbdu.memo_tables,Boolean_mvbdu.mvbdu_dic,Boolean_mvbdu.association_list_dic,Boolean_mvbdu.range_list_dic,Boolean_mvbdu.variables_list_dic,bool,int) Memo_sig.handler + + type handler = + ( Boolean_mvbdu.memo_tables, + Boolean_mvbdu.mvbdu_dic, + Boolean_mvbdu.association_list_dic, + Boolean_mvbdu.range_list_dic, + Boolean_mvbdu.variables_list_dic, + bool, + int ) + Memo_sig.handler + type mvbdu type hconsed_range_list type hconsed_association_list type hconsed_variables_list type hconsed_renaming_list + type 'output constant = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + Exception.method_handler * handler * 'output + + type ('input, 'output) unary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input -> + Exception.method_handler * handler * 'output + + type ('input1, 'input2, 'output) binary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input1 -> + 'input2 -> + Exception.method_handler * handler * 'output + + type ('input1, 'input2, 'input3, 'output) ternary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input1 -> + 'input2 -> + 'input3 -> + Exception.method_handler * handler * 'output + + val init : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Exception.method_handler * handler + + val is_init : unit -> bool + + val get_handler : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Exception.method_handler * handler + + val reset : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Exception.method_handler * handler + + val equal : mvbdu -> mvbdu -> bool + val equal_with_logs : (mvbdu, mvbdu, bool) binary + val mvbdu_false : mvbdu constant + val mvbdu_true : mvbdu constant + val mvbdu_not : (mvbdu, mvbdu) unary + val mvbdu_id : (mvbdu, mvbdu) unary + val mvbdu_unary_true : (mvbdu, mvbdu) unary + val mvbdu_unary_false : (mvbdu, mvbdu) unary + val mvbdu_and : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_or : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_xor : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nand : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nor : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_imply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_rev_imply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_equiv : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nimply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nrev_imply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_bi_true : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_bi_false : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_fst : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_snd : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nfst : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nsnd : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_redefine : (mvbdu, hconsed_association_list, mvbdu) binary + val mvbdu_redefine_range : (mvbdu, hconsed_range_list, mvbdu) binary + val mvbdu_subseteq : (mvbdu, mvbdu, bool) binary + val mvbdu_of_hconsed_asso : (hconsed_association_list, mvbdu) unary + val mvbdu_of_association_list : ((key * value) list, mvbdu) unary + val mvbdu_of_sorted_association_list : ((key * value) list, mvbdu) unary + + val mvbdu_of_reverse_sorted_association_list : + ((key * value) list, mvbdu) unary + + val mvbdu_of_hconsed_range : (hconsed_range_list, mvbdu) unary + + val mvbdu_of_range_list : + ((key * (value option * value option)) list, mvbdu) unary + + val mvbdu_of_sorted_range_list : + ((key * (value option * value option)) list, mvbdu) unary + + val mvbdu_of_reverse_sorted_range_list : + ((key * (value option * value option)) list, mvbdu) unary + + val mvbdu_rename : (mvbdu, hconsed_renaming_list, mvbdu) binary + val mvbdu_project_keep_only : (mvbdu, hconsed_variables_list, mvbdu) binary + + val mvbdu_project_abstract_away : + (mvbdu, hconsed_variables_list, mvbdu) binary + + val mvbdu_cartesian_decomposition_depth : + (mvbdu, int, mvbdu option * mvbdu list) binary + + val mvbdu_full_cartesian_decomposition : (mvbdu, mvbdu list) unary + val mvbdu_cartesian_abstraction : (mvbdu, mvbdu list) unary + + val build_association_list : + ((key * value) list, hconsed_association_list) unary + + val build_sorted_association_list : + ((key * value) list, hconsed_association_list) unary + + val build_reverse_sorted_association_list : + ((key * value) list, hconsed_association_list) unary - type 'output constant = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> Exception.method_handler * handler * 'output - type ('input,'output) unary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input -> Exception.method_handler * handler * 'output - type ('input1,'input2,'output) binary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input1 -> 'input2 -> Exception.method_handler * handler * 'output - type ('input1,'input2,'input3,'output) ternary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input1 -> 'input2 -> 'input3 -> Exception.method_handler * handler * 'output - - val init: Remanent_parameters_sig.parameters -> Exception.method_handler -> Exception.method_handler * handler - val is_init: unit -> bool - val get_handler: Remanent_parameters_sig.parameters -> Exception.method_handler -> Exception.method_handler * handler - val reset: Remanent_parameters_sig.parameters -> Exception.method_handler -> Exception.method_handler * handler - val equal: mvbdu -> mvbdu -> bool - val equal_with_logs: (mvbdu,mvbdu,bool) binary - val mvbdu_false: mvbdu constant - val mvbdu_true: mvbdu constant - val mvbdu_not: (mvbdu,mvbdu) unary - val mvbdu_id: (mvbdu,mvbdu) unary - val mvbdu_unary_true: (mvbdu,mvbdu) unary - val mvbdu_unary_false: (mvbdu,mvbdu) unary - val mvbdu_and: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_or: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_xor: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nand: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nor: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_imply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_rev_imply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_equiv: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nimply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nrev_imply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_bi_true: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_bi_false: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_fst: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_snd: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nfst: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nsnd: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_redefine: (mvbdu,hconsed_association_list,mvbdu) binary - val mvbdu_redefine_range: (mvbdu,hconsed_range_list,mvbdu) binary - val mvbdu_subseteq: (mvbdu,mvbdu,bool) binary - val mvbdu_of_hconsed_asso: (hconsed_association_list,mvbdu) unary - val mvbdu_of_association_list: ((key * value) list,mvbdu) unary - val mvbdu_of_sorted_association_list: ((key * value) list,mvbdu) unary - val mvbdu_of_reverse_sorted_association_list: ((key * value) list,mvbdu) unary - val mvbdu_of_hconsed_range: (hconsed_range_list,mvbdu) unary - val mvbdu_of_range_list: ((key * (value option * value option)) list,mvbdu) unary - val mvbdu_of_sorted_range_list: ((key * (value option * value option)) list,mvbdu) unary - val mvbdu_of_reverse_sorted_range_list: ((key * (value option * value option)) list,mvbdu) unary - - val mvbdu_rename: (mvbdu,hconsed_renaming_list,mvbdu) binary - - val mvbdu_project_keep_only: (mvbdu,hconsed_variables_list,mvbdu) binary - val mvbdu_project_abstract_away: (mvbdu,hconsed_variables_list,mvbdu) binary - val mvbdu_cartesian_decomposition_depth: (mvbdu,int,mvbdu option * mvbdu list) binary - val mvbdu_full_cartesian_decomposition: (mvbdu,mvbdu list) unary - - val mvbdu_cartesian_abstraction: (mvbdu,mvbdu list) unary - - val build_association_list: ((key * value) list,hconsed_association_list) unary - val build_sorted_association_list: ((key * value) list,hconsed_association_list) unary - val build_reverse_sorted_association_list: ((key * value) list,hconsed_association_list) unary val empty_association_list : hconsed_association_list constant - val build_range_list: ((key * (value option * value option)) list,hconsed_range_list) unary - val build_sorted_range_list: ((key * (value option* value option)) list,hconsed_range_list) unary - val build_reverse_sorted_range_list: ((key * (value option* value option)) list,hconsed_range_list) unary + val build_range_list : + ((key * (value option * value option)) list, hconsed_range_list) unary + + val build_sorted_range_list : + ((key * (value option * value option)) list, hconsed_range_list) unary + + val build_reverse_sorted_range_list : + ((key * (value option * value option)) list, hconsed_range_list) unary + val empty_range_list : hconsed_range_list constant + val build_variables_list : (key list, hconsed_variables_list) unary + val build_sorted_variables_list : (key list, hconsed_variables_list) unary + val build_reverse_sorted_variables_list : + (key list, hconsed_variables_list) unary - val build_variables_list: (key list,hconsed_variables_list) unary - val build_sorted_variables_list: (key list,hconsed_variables_list) unary - val build_reverse_sorted_variables_list: (key list,hconsed_variables_list) unary - val empty_variables_list: hconsed_variables_list constant + val empty_variables_list : hconsed_variables_list constant + val build_renaming_list : ((key * key) list, hconsed_renaming_list) unary + + val build_sorted_renaming_list : + ((key * key) list, hconsed_renaming_list) unary + + val build_reverse_sorted_renaming_list : + ((key * key) list, hconsed_renaming_list) unary - val build_renaming_list: ((key * key) list,hconsed_renaming_list) unary - val build_sorted_renaming_list: ((key * key) list,hconsed_renaming_list) unary - val build_reverse_sorted_renaming_list: ((key * key) list,hconsed_renaming_list) unary val empty_renaming_list : hconsed_renaming_list constant - val overwrite_association_lists: (hconsed_association_list,hconsed_association_list,hconsed_association_list) binary - val merge_variables_lists: (hconsed_variables_list,hconsed_variables_list,hconsed_variables_list) binary - val nbr_variables: (hconsed_variables_list,int) unary - val extensional_of_variables_list: (hconsed_variables_list,key list) unary - val extensional_of_association_list: (hconsed_association_list,(key*value) list) unary - val extensional_of_range_list: (hconsed_range_list,(key*(value option *value option)) list) unary - val extensional_of_mvbdu: (mvbdu,(key * value) list list) unary - - val variables_list_of_mvbdu: (mvbdu,hconsed_variables_list) unary - - val print: Remanent_parameters_sig.parameters -> mvbdu -> unit - val print_association_list: Remanent_parameters_sig.parameters -> hconsed_association_list -> unit - val print_variables_list: Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit - - val store_by_variables_list: - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - 'data -> - List_sig.hash_key -> - 'map -> - Exception.method_handler * 'data) -> - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - List_sig.hash_key -> - 'data -> - 'map -> - Exception.method_handler * 'map) -> + val overwrite_association_lists : + ( hconsed_association_list, + hconsed_association_list, + hconsed_association_list ) + binary + + val merge_variables_lists : + ( hconsed_variables_list, + hconsed_variables_list, + hconsed_variables_list ) + binary + + val nbr_variables : (hconsed_variables_list, int) unary + val extensional_of_variables_list : (hconsed_variables_list, key list) unary + + val extensional_of_association_list : + (hconsed_association_list, (key * value) list) unary + + val extensional_of_range_list : + (hconsed_range_list, (key * (value option * value option)) list) unary + + val extensional_of_mvbdu : (mvbdu, (key * value) list list) unary + val variables_list_of_mvbdu : (mvbdu, hconsed_variables_list) unary + val print : Remanent_parameters_sig.parameters -> mvbdu -> unit + + val print_association_list : + Remanent_parameters_sig.parameters -> hconsed_association_list -> unit + + val print_variables_list : + Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit + + val store_by_variables_list : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'data -> + List_sig.hash_key -> + 'map -> + Exception.method_handler * 'data) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + List_sig.hash_key -> 'data -> - ('data,'data,'data) binary -> - (hconsed_variables_list,'data,'map,'map) ternary - - val store_by_mvbdu: - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - 'data -> - Mvbdu_sig.hash_key -> - 'map -> - Exception.method_handler * 'data) -> - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - Mvbdu_sig.hash_key -> - 'data -> - 'map -> - Exception.method_handler * 'map) -> + 'map -> + Exception.method_handler * 'map) -> 'data -> - ('data,'data,'data) binary -> - (mvbdu,'data,'map,'map) ternary + ('data, 'data, 'data) binary -> + (hconsed_variables_list, 'data, 'map, 'map) ternary - val last_entry: (unit,int) unary - val hash_of_range_list: hconsed_range_list -> int - val hash_of_association_list: hconsed_association_list -> int - val hash_of_variables_list: hconsed_variables_list -> int + val store_by_mvbdu : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'data -> + Mvbdu_sig.hash_key -> + 'map -> + Exception.method_handler * 'data) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Mvbdu_sig.hash_key -> + 'data -> + 'map -> + Exception.method_handler * 'map) -> + 'data -> + ('data, 'data, 'data) binary -> + (mvbdu, 'data, 'map, 'map) ternary + val last_entry : (unit, int) unary + val hash_of_range_list : hconsed_range_list -> int + val hash_of_association_list : hconsed_association_list -> int + val hash_of_variables_list : hconsed_variables_list -> int end -module type Internalized_mvbdu = -sig +module type Internalized_mvbdu = sig type key type value type mvbdu + type handler = - (Boolean_mvbdu.memo_tables,Boolean_mvbdu.mvbdu_dic,Boolean_mvbdu.association_list_dic,Boolean_mvbdu.range_list_dic,Boolean_mvbdu.variables_list_dic,bool,int) Memo_sig.handler + ( Boolean_mvbdu.memo_tables, + Boolean_mvbdu.mvbdu_dic, + Boolean_mvbdu.association_list_dic, + Boolean_mvbdu.range_list_dic, + Boolean_mvbdu.variables_list_dic, + bool, + int ) + Memo_sig.handler + type hconsed_range_list type hconsed_association_list type hconsed_variables_list type hconsed_renaming_list - val init: Remanent_parameters_sig.parameters -> unit - val import_handler: handler -> unit - val export_handler: Exception.method_handler-> Exception.method_handler * handler option - val is_init: unit -> bool - val equal: mvbdu -> mvbdu -> bool - val mvbdu_false: unit -> mvbdu - val mvbdu_true: unit -> mvbdu - val mvbdu_not: mvbdu -> mvbdu - val mvbdu_id: mvbdu -> mvbdu - val mvbdu_unary_true: mvbdu -> mvbdu - val mvbdu_unary_false: mvbdu -> mvbdu - val mvbdu_and: mvbdu -> mvbdu -> mvbdu - val mvbdu_or: mvbdu -> mvbdu -> mvbdu - val mvbdu_xor: mvbdu -> mvbdu -> mvbdu - val mvbdu_nand: mvbdu -> mvbdu -> mvbdu - val mvbdu_nor: mvbdu -> mvbdu -> mvbdu - val mvbdu_imply: mvbdu -> mvbdu -> mvbdu - val mvbdu_rev_imply: mvbdu -> mvbdu -> mvbdu - val mvbdu_equiv: mvbdu -> mvbdu -> mvbdu - val mvbdu_nimply: mvbdu -> mvbdu -> mvbdu - val mvbdu_nrev_imply: mvbdu -> mvbdu -> mvbdu - val mvbdu_bi_true: mvbdu -> mvbdu -> mvbdu - val mvbdu_bi_false: mvbdu -> mvbdu -> mvbdu - val mvbdu_fst: mvbdu -> mvbdu -> mvbdu - val mvbdu_snd: mvbdu -> mvbdu -> mvbdu - val mvbdu_nfst: mvbdu -> mvbdu -> mvbdu - val mvbdu_nsnd: mvbdu -> mvbdu -> mvbdu - val mvbdu_redefine: mvbdu -> hconsed_association_list -> mvbdu - val mvbdu_redefine_range: mvbdu -> hconsed_range_list -> mvbdu - val mvbdu_subseteq: mvbdu -> mvbdu -> bool - val mvbdu_of_hconsed_asso: hconsed_association_list -> mvbdu - val mvbdu_of_association_list: (key * value) list -> mvbdu - val mvbdu_of_sorted_association_list: (key * value) list -> mvbdu - val mvbdu_of_reverse_sorted_association_list: (key * value) list -> mvbdu - val mvbdu_of_hconsed_range: hconsed_range_list -> mvbdu - val mvbdu_of_range_list: (key * (value option * value option)) list -> mvbdu - val mvbdu_of_sorted_range_list: (key * (value option * value option)) list -> mvbdu - val mvbdu_of_reverse_sorted_range_list: (key * (value option * value option)) list -> mvbdu - - - val mvbdu_rename: mvbdu -> hconsed_renaming_list -> mvbdu - val mvbdu_project_abstract_away: mvbdu -> hconsed_variables_list -> mvbdu - val mvbdu_project_keep_only: mvbdu -> hconsed_variables_list -> mvbdu - val mvbdu_cartesian_abstraction: mvbdu -> mvbdu list - val mvbdu_cartesian_decomposition_depth: mvbdu -> int -> mvbdu option * mvbdu list - val mvbdu_full_cartesian_decomposition: mvbdu -> mvbdu list - - val build_association_list: (key * value) list -> hconsed_association_list - val build_sorted_association_list: (key * value) list -> hconsed_association_list - val build_reverse_sorted_association_list: (key * value) list -> hconsed_association_list + val init : Remanent_parameters_sig.parameters -> unit + val import_handler : handler -> unit + + val export_handler : + Exception.method_handler -> Exception.method_handler * handler option + + val is_init : unit -> bool + val equal : mvbdu -> mvbdu -> bool + val mvbdu_false : unit -> mvbdu + val mvbdu_true : unit -> mvbdu + val mvbdu_not : mvbdu -> mvbdu + val mvbdu_id : mvbdu -> mvbdu + val mvbdu_unary_true : mvbdu -> mvbdu + val mvbdu_unary_false : mvbdu -> mvbdu + val mvbdu_and : mvbdu -> mvbdu -> mvbdu + val mvbdu_or : mvbdu -> mvbdu -> mvbdu + val mvbdu_xor : mvbdu -> mvbdu -> mvbdu + val mvbdu_nand : mvbdu -> mvbdu -> mvbdu + val mvbdu_nor : mvbdu -> mvbdu -> mvbdu + val mvbdu_imply : mvbdu -> mvbdu -> mvbdu + val mvbdu_rev_imply : mvbdu -> mvbdu -> mvbdu + val mvbdu_equiv : mvbdu -> mvbdu -> mvbdu + val mvbdu_nimply : mvbdu -> mvbdu -> mvbdu + val mvbdu_nrev_imply : mvbdu -> mvbdu -> mvbdu + val mvbdu_bi_true : mvbdu -> mvbdu -> mvbdu + val mvbdu_bi_false : mvbdu -> mvbdu -> mvbdu + val mvbdu_fst : mvbdu -> mvbdu -> mvbdu + val mvbdu_snd : mvbdu -> mvbdu -> mvbdu + val mvbdu_nfst : mvbdu -> mvbdu -> mvbdu + val mvbdu_nsnd : mvbdu -> mvbdu -> mvbdu + val mvbdu_redefine : mvbdu -> hconsed_association_list -> mvbdu + val mvbdu_redefine_range : mvbdu -> hconsed_range_list -> mvbdu + val mvbdu_subseteq : mvbdu -> mvbdu -> bool + val mvbdu_of_hconsed_asso : hconsed_association_list -> mvbdu + val mvbdu_of_association_list : (key * value) list -> mvbdu + val mvbdu_of_sorted_association_list : (key * value) list -> mvbdu + val mvbdu_of_reverse_sorted_association_list : (key * value) list -> mvbdu + val mvbdu_of_hconsed_range : hconsed_range_list -> mvbdu + val mvbdu_of_range_list : (key * (value option * value option)) list -> mvbdu + + val mvbdu_of_sorted_range_list : + (key * (value option * value option)) list -> mvbdu + + val mvbdu_of_reverse_sorted_range_list : + (key * (value option * value option)) list -> mvbdu + + val mvbdu_rename : mvbdu -> hconsed_renaming_list -> mvbdu + val mvbdu_project_abstract_away : mvbdu -> hconsed_variables_list -> mvbdu + val mvbdu_project_keep_only : mvbdu -> hconsed_variables_list -> mvbdu + val mvbdu_cartesian_abstraction : mvbdu -> mvbdu list + + val mvbdu_cartesian_decomposition_depth : + mvbdu -> int -> mvbdu option * mvbdu list + + val mvbdu_full_cartesian_decomposition : mvbdu -> mvbdu list + val build_association_list : (key * value) list -> hconsed_association_list + + val build_sorted_association_list : + (key * value) list -> hconsed_association_list + + val build_reverse_sorted_association_list : + (key * value) list -> hconsed_association_list + val empty_association_list : unit -> hconsed_association_list - val build_range_list: (key * (value option * value option)) list -> hconsed_range_list - val build_sorted_range_list: (key * (value option * value option)) list -> hconsed_range_list - val build_reverse_sorted_range_list: (key * (value option * value option)) list -> hconsed_range_list - val empty_range_list : unit -> hconsed_range_list + val build_range_list : + (key * (value option * value option)) list -> hconsed_range_list - val build_variables_list: key list -> hconsed_variables_list - val build_sorted_variables_list: key list -> hconsed_variables_list - val build_reverse_sorted_variables_list: key list -> hconsed_variables_list - val empty_variables_list : unit -> hconsed_variables_list - val build_renaming_list: (key * key) list -> hconsed_renaming_list - val build_sorted_renaming_list: (key * key) list -> hconsed_renaming_list - val build_reverse_sorted_renaming_list: (key * key) list -> hconsed_renaming_list - val empty_renaming_list : unit -> hconsed_renaming_list + val build_sorted_range_list : + (key * (value option * value option)) list -> hconsed_range_list - val overwrite_association_lists: hconsed_association_list -> hconsed_association_list -> hconsed_association_list - val merge_variables_lists: hconsed_variables_list -> hconsed_variables_list -> hconsed_variables_list - val nbr_variables: hconsed_variables_list -> int - val extensional_of_variables_list: hconsed_variables_list -> key list - val extensional_of_association_list: hconsed_association_list -> (key*value) list - val extensional_of_mvbdu: mvbdu -> (key * value) list list + val build_reverse_sorted_range_list : + (key * (value option * value option)) list -> hconsed_range_list - val variables_list_of_mvbdu: mvbdu -> hconsed_variables_list + val empty_range_list : unit -> hconsed_range_list + val build_variables_list : key list -> hconsed_variables_list + val build_sorted_variables_list : key list -> hconsed_variables_list + val build_reverse_sorted_variables_list : key list -> hconsed_variables_list + val empty_variables_list : unit -> hconsed_variables_list + val build_renaming_list : (key * key) list -> hconsed_renaming_list + val build_sorted_renaming_list : (key * key) list -> hconsed_renaming_list - val print: Remanent_parameters_sig.parameters -> mvbdu -> unit - val print_association_list: Remanent_parameters_sig.parameters -> hconsed_association_list -> unit - val print_variables_list: Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit - val hash_of_association_list: hconsed_association_list -> int - val hash_of_variables_list: hconsed_variables_list -> int + val build_reverse_sorted_renaming_list : + (key * key) list -> hconsed_renaming_list -end + val empty_renaming_list : unit -> hconsed_renaming_list -module type Nul = -sig -end + val overwrite_association_lists : + hconsed_association_list -> + hconsed_association_list -> + hconsed_association_list -module Make (_:Nul) = - (struct - type key = int - type value = int - type handler = (Boolean_mvbdu.memo_tables,Boolean_mvbdu.mvbdu_dic,Boolean_mvbdu.association_list_dic,Boolean_mvbdu.range_list_dic,Boolean_mvbdu.variables_list_dic,bool,int) Memo_sig.handler - type mvbdu = bool Mvbdu_sig.mvbdu - type hconsed_range_list = (value option * value option) List_sig.list - type hconsed_association_list = value List_sig.list - type hconsed_variables_list = unit List_sig.list - type hconsed_renaming_list = key List_sig.list - - type 'output constant = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> Exception.method_handler * handler * 'output - type ('input,'output) unary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input -> Exception.method_handler * handler * 'output - type ('input1,'input2,'output) binary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input1 -> 'input2 -> Exception.method_handler * handler * 'output - type ('input1,'input2,'input3,'output) ternary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input1 -> 'input2 -> 'input3 -> Exception.method_handler * handler * 'output - - let lift0 pos f parameters handler error = - match - f parameters handler error parameters - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn_with_exn - parameters error pos Exit - (fun _ -> - failwith "Cannot recover from bugs in constant initilization") - in - error, handler, a - - let init,is_init,reset,get_handler = - let used = ref None in - let init parameter error = - match - !used - with - | Some a -> - Exception.warn - parameter error __POS__ - ~message:"MVBDU should be initialised once only" Exit a - | None -> - begin - let error,handler = Boolean_mvbdu.init_remanent parameter error in - let error, handler, _ = - lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_false parameter handler error - in - let error, handler, _ = - lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_true parameter handler error - in - - let () = used := Some handler in - error,handler - end - in - let is_init () = !used != None in - let get_handler parameter error = - match !used with - | None -> - let error,handler = init parameter error in - Exception.warn - parameter error __POS__ - ~message:"Uninitialised handler" - Exit handler - | Some a -> error,a - in - let reset parameter error = - match - !used - with - | None -> - begin - let error,handler = init parameter error in - Exception.warn - parameter error __POS__ - ~message:"Uninitialised handler" - Exit handler - end - | Some _ -> - begin - let error,handler = Boolean_mvbdu.init_remanent parameter error in - let () = used := Some handler in - error,handler - end - in - init,is_init,reset,get_handler + val merge_variables_lists : + hconsed_variables_list -> hconsed_variables_list -> hconsed_variables_list + val nbr_variables : hconsed_variables_list -> int + val extensional_of_variables_list : hconsed_variables_list -> key list + val extensional_of_association_list : + hconsed_association_list -> (key * value) list + val extensional_of_mvbdu : mvbdu -> (key * value) list list + val variables_list_of_mvbdu : mvbdu -> hconsed_variables_list + val print : Remanent_parameters_sig.parameters -> mvbdu -> unit + val print_association_list : + Remanent_parameters_sig.parameters -> hconsed_association_list -> unit - let equal = Mvbdu_core.mvbdu_equal - let equal_with_logs _p h e a b = e,h,equal a b + val print_variables_list : + Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit - let last_entry parameters handler error () = - let error,int = Boolean_mvbdu.last_entry parameters handler error in - error,handler,int + val hash_of_association_list : hconsed_association_list -> int + val hash_of_variables_list : hconsed_variables_list -> int +end - let mvbdu_true = lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_true - let mvbdu_false = lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_false +module type Nul = sig end - let lift1 pos f parameters handler error a = - match - f parameters handler error parameters a - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit a - in - error, handler, a - - let lift1bis _string f parameters handler error a = - let a,(b,c) = - f (Boolean_mvbdu.association_list_allocate parameters) error parameters handler a - in a,b,c - - let lift1bisbis _string f parameters handler error (a:(int * (int option * int option)) list) = - let a,(b,c) = - f (Boolean_mvbdu.range_list_allocate parameters) error parameters handler a - in a,b,c - - let lift1ter _string f parameters handler error a = - let a,(b,c) = - f (Boolean_mvbdu.association_list_allocate parameters) parameters error handler a - in a,b,c - - let lift1terter _string f parameters handler error a = - let a,(b,c) = - f (Boolean_mvbdu.range_list_allocate parameters) parameters error handler a - in a,b,c - - let liftvbis _string f parameters handler error a = - let a,(b,c) = - f (Boolean_mvbdu.variables_list_allocate parameters) error parameters handler (List.rev_map (fun x -> (x,())) a) - in a,b,c - - let liftvter _string f parameters handler error a = - let a,(b,c) = - f (Boolean_mvbdu.variables_list_allocate parameters) parameters error handler (List.rev_map (fun x -> (x,())) a) - in a,b,c - - let lift1_ pos f parameters handler error a = - match - f parameters handler error a - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit a - in - error, handler, a - - let lift1__ _string f parameters handler error a = - match - f parameters handler error a - with - | error,(handler,a) -> error,handler,a - - - let lift1four buildlist pos f parameters handler error a = - match - f parameters error handler a - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error,handler,list = - buildlist parameters handler error [] - in - let error, a = - Exception.warn parameters error pos Exit list - in - error, handler, (a:unit List_sig.list) - - let lift1five pos f parameters handler error a = - match - f parameters error parameters handler a - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit [] - in - error, handler, a - - let lift1_seven _string f parameters handler error a = - match - f parameters error handler a - with - | error,(handler,int) -> error,handler,int - - let lift2 pos f parameters handler error a b = - match - f parameters handler error parameters a b - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit a - in - error, handler, a - - let lift2bis pos f parameters handler error a b = - match - f parameters error parameters handler a b - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit a - in - error, handler, a - - let lift2ter pos f parameters handler error a b = - match - f parameters error parameters handler a b - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit a - in - error, handler, a - - let lift2four pos f parameters handler error a b = - match - f parameters error handler a b - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit a +module Make (_ : Nul) : Mvbdu with type key = int and type value = int = struct + type key = int + type value = int + + type handler = + ( Boolean_mvbdu.memo_tables, + Boolean_mvbdu.mvbdu_dic, + Boolean_mvbdu.association_list_dic, + Boolean_mvbdu.range_list_dic, + Boolean_mvbdu.variables_list_dic, + bool, + int ) + Memo_sig.handler + + type mvbdu = bool Mvbdu_sig.mvbdu + type hconsed_range_list = (value option * value option) List_sig.list + type hconsed_association_list = value List_sig.list + type hconsed_variables_list = unit List_sig.list + type hconsed_renaming_list = key List_sig.list + + type 'output constant = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + Exception.method_handler * handler * 'output + + type ('input, 'output) unary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input -> + Exception.method_handler * handler * 'output + + type ('input1, 'input2, 'output) binary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input1 -> + 'input2 -> + Exception.method_handler * handler * 'output + + type ('input1, 'input2, 'input3, 'output) ternary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input1 -> + 'input2 -> + 'input3 -> + Exception.method_handler * handler * 'output + + let lift0 pos f parameters handler error = + match f parameters handler error parameters with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = + Exception.warn_with_exn parameters error pos Exit (fun _ -> + failwith "Cannot recover from bugs in constant initilization") + in + error, handler, a + + let init, is_init, reset, get_handler = + let used = ref None in + let init parameter error = + match !used with + | Some a -> + Exception.warn parameter error __POS__ + ~message:"MVBDU should be initialised once only" Exit a + | None -> + let error, handler = Boolean_mvbdu.init_remanent parameter error in + let error, handler, _ = + lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_false parameter handler + error in - error, handler, a - - let lift2five pos f parameters handler error a b = - match - f parameters error handler a b - with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error pos Exit a + let error, handler, _ = + lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_true parameter handler error in - error, handler, a - - let (mvbdu_not: (mvbdu,mvbdu) unary) = lift1 __POS__ Boolean_mvbdu.boolean_mvbdu_not - - let mvbdu_id _parameters handler error a = error, handler, a - let mvbdu_unary_true parameters handler error _ = - mvbdu_true parameters handler error - let mvbdu_unary_false parameters handler error _ = - mvbdu_false parameters handler error - - let mvbdu_and = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_and - let mvbdu_or = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_or - let mvbdu_xor = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_xor - let mvbdu_nand = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nand - let mvbdu_nor = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nor - let mvbdu_imply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_imply - let mvbdu_rev_imply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_is_implied - let mvbdu_equiv = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_equiv - let mvbdu_nimply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nimply - let mvbdu_nrev_imply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nis_implied - let mvbdu_bi_true = lift2 __POS__ Boolean_mvbdu.boolean_constant_bi_true - let mvbdu_bi_false = lift2 __POS__ Boolean_mvbdu.boolean_constant_bi_false - let mvbdu_fst _parameters handler error a _b = error,handler,a - let mvbdu_snd _parameters handler error _a b = error,handler,b - let mvbdu_nfst = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nfst - let mvbdu_nsnd = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nsnd - let mvbdu_redefine = lift2bis __POS__ Boolean_mvbdu.redefine - let mvbdu_redefine_range = lift2bis __POS__ Boolean_mvbdu.redefine_range + let () = used := Some handler in + error, handler + in + let is_init () = !used != None in + let get_handler parameter error = + match !used with + | None -> + let error, handler = init parameter error in + Exception.warn parameter error __POS__ ~message:"Uninitialised handler" + Exit handler + | Some a -> error, a + in + let reset parameter error = + match !used with + | None -> + let error, handler = init parameter error in + Exception.warn parameter error __POS__ ~message:"Uninitialised handler" + Exit handler + | Some _ -> + let error, handler = Boolean_mvbdu.init_remanent parameter error in + let () = used := Some handler in + error, handler + in + init, is_init, reset, get_handler + + let equal = Mvbdu_core.mvbdu_equal + let equal_with_logs _p h e a b = e, h, equal a b + + let last_entry parameters handler error () = + let error, int = Boolean_mvbdu.last_entry parameters handler error in + error, handler, int + + let mvbdu_true = lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_true + let mvbdu_false = lift0 __POS__ Boolean_mvbdu.boolean_mvbdu_false + + let lift1 pos f parameters handler error a = + match f parameters handler error parameters a with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit a in + error, handler, a + + let lift1bis _string f parameters handler error a = + let a, (b, c) = + f + (Boolean_mvbdu.association_list_allocate parameters) + error parameters handler a + in + a, b, c + + let lift1bisbis _string f parameters handler error + (a : (int * (int option * int option)) list) = + let a, (b, c) = + f + (Boolean_mvbdu.range_list_allocate parameters) + error parameters handler a + in + a, b, c + + let lift1ter _string f parameters handler error a = + let a, (b, c) = + f + (Boolean_mvbdu.association_list_allocate parameters) + parameters error handler a + in + a, b, c + + let lift1terter _string f parameters handler error a = + let a, (b, c) = + f + (Boolean_mvbdu.range_list_allocate parameters) + parameters error handler a + in + a, b, c + + let liftvbis _string f parameters handler error a = + let a, (b, c) = + f + (Boolean_mvbdu.variables_list_allocate parameters) + error parameters handler + (List.rev_map (fun x -> x, ()) a) + in + a, b, c + + let liftvter _string f parameters handler error a = + let a, (b, c) = + f + (Boolean_mvbdu.variables_list_allocate parameters) + parameters error handler + (List.rev_map (fun x -> x, ()) a) + in + a, b, c + + let lift1_ pos f parameters handler error a = + match f parameters handler error a with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit a in + error, handler, a + + let lift1__ _string f parameters handler error a = + match f parameters handler error a with + | error, (handler, a) -> error, handler, a + + let lift1four buildlist pos f parameters handler error a = + match f parameters error handler a with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, handler, list = buildlist parameters handler error [] in + let error, a = Exception.warn parameters error pos Exit list in + error, handler, (a : unit List_sig.list) + + let lift1five pos f parameters handler error a = + match f parameters error parameters handler a with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit [] in + error, handler, a + + let lift1_seven _string f parameters handler error a = + match f parameters error handler a with + | error, (handler, int) -> error, handler, int + + let lift2 pos f parameters handler error a b = + match f parameters handler error parameters a b with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit a in + error, handler, a + + let lift2bis pos f parameters handler error a b = + match f parameters error parameters handler a b with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit a in + error, handler, a + + let lift2ter pos f parameters handler error a b = + match f parameters error parameters handler a b with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit a in + error, handler, a + + let lift2four pos f parameters handler error a b = + match f parameters error handler a b with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit a in + error, handler, a + + let lift2five pos f parameters handler error a b = + match f parameters error handler a b with + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error pos Exit a in + error, handler, a + + let (mvbdu_not : (mvbdu, mvbdu) unary) = + lift1 __POS__ Boolean_mvbdu.boolean_mvbdu_not + + let mvbdu_id _parameters handler error a = error, handler, a + + let mvbdu_unary_true parameters handler error _ = + mvbdu_true parameters handler error + + let mvbdu_unary_false parameters handler error _ = + mvbdu_false parameters handler error + + let mvbdu_and = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_and + let mvbdu_or = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_or + let mvbdu_xor = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_xor + let mvbdu_nand = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nand + let mvbdu_nor = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nor + let mvbdu_imply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_imply + let mvbdu_rev_imply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_is_implied + let mvbdu_equiv = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_equiv + let mvbdu_nimply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nimply + let mvbdu_nrev_imply = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nis_implied + let mvbdu_bi_true = lift2 __POS__ Boolean_mvbdu.boolean_constant_bi_true + let mvbdu_bi_false = lift2 __POS__ Boolean_mvbdu.boolean_constant_bi_false + let mvbdu_fst _parameters handler error a _b = error, handler, a + let mvbdu_snd _parameters handler error _a b = error, handler, b + let mvbdu_nfst = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nfst + let mvbdu_nsnd = lift2 __POS__ Boolean_mvbdu.boolean_mvbdu_nsnd + let mvbdu_redefine = lift2bis __POS__ Boolean_mvbdu.redefine + let mvbdu_redefine_range = lift2bis __POS__ Boolean_mvbdu.redefine_range + let mvbdu_rename = lift2bis __POS__ Boolean_mvbdu.monotonicaly_rename + let mvbdu_project_keep_only = lift2ter __POS__ Boolean_mvbdu.project_keep_only + + let mvbdu_project_abstract_away = + lift2ter __POS__ Boolean_mvbdu.project_abstract_away + + let build_association_list = lift1bis __POS__ List_algebra.build_list + + let build_sorted_association_list = + lift1ter __POS__ List_algebra.build_sorted_list + + let build_reverse_sorted_association_list = + lift1ter __POS__ List_algebra.build_reversed_sorted_list + + let build_range_list = lift1bisbis __POS__ List_algebra.build_list + + let build_sorted_range_list = + lift1terter __POS__ List_algebra.build_sorted_list + + let build_reverse_sorted_range_list = + lift1terter __POS__ List_algebra.build_reversed_sorted_list + + let empty_range_list parameter handler error = + build_range_list parameter handler error [] + + let empty_association_list parameter handler error = + build_association_list parameter handler error [] + + let mvbdu_subseteq parameter handler error mvbdu1 mvbdu2 = + let error, handler, union = + mvbdu_or parameter handler error mvbdu1 mvbdu2 + in + error, handler, equal mvbdu2 union + + let mvbdu_of_hconsed_asso parameter handler error asso = + let error, handler, mvbdu_true = mvbdu_true parameter handler error in + mvbdu_redefine parameter handler error mvbdu_true asso + + let mvbdu_of_hconsed_range parameter handler error asso = + let error, handler, mvbdu_true = mvbdu_true parameter handler error in + mvbdu_redefine_range parameter handler error mvbdu_true asso + + let mvbdu_of_asso_gen f parameter handler error asso = + let error, handler, hconsed_list = f parameter handler error asso in + mvbdu_of_hconsed_asso parameter handler error hconsed_list + + let mvbdu_of_range_gen f parameter handler error asso = + let error, handler, hconsed_list = f parameter handler error asso in + mvbdu_of_hconsed_range parameter handler error hconsed_list + + let mvbdu_of_hconsed_range parameter handler error asso = + let error, handler, mvbdu_true = mvbdu_true parameter handler error in + mvbdu_redefine_range parameter handler error mvbdu_true asso + + let mvbdu_of_association_list = mvbdu_of_asso_gen build_association_list + let mvbdu_of_range_list = mvbdu_of_range_gen build_range_list - let mvbdu_rename = lift2bis __POS__ Boolean_mvbdu.monotonicaly_rename - let mvbdu_project_keep_only = lift2ter __POS__ Boolean_mvbdu.project_keep_only - let mvbdu_project_abstract_away = lift2ter __POS__ Boolean_mvbdu.project_abstract_away + let mvbdu_of_sorted_association_list = + mvbdu_of_asso_gen build_sorted_association_list - let build_association_list = lift1bis __POS__ List_algebra.build_list + let mvbdu_of_sorted_range_list = mvbdu_of_range_gen build_sorted_range_list - let build_sorted_association_list = - lift1ter __POS__ List_algebra.build_sorted_list + let mvbdu_of_reverse_sorted_association_list = + mvbdu_of_asso_gen build_reverse_sorted_association_list - let build_reverse_sorted_association_list = - lift1ter __POS__ List_algebra.build_reversed_sorted_list + let mvbdu_of_reverse_sorted_range_list = + mvbdu_of_range_gen build_reverse_sorted_range_list - let build_range_list = - lift1bisbis - __POS__ - List_algebra.build_list + let build_renaming_list = build_association_list + let build_sorted_renaming_list = build_sorted_association_list + let build_reverse_sorted_renaming_list = build_sorted_renaming_list + let empty_renaming_list = empty_association_list - let build_sorted_range_list = - lift1terter __POS__ List_algebra.build_sorted_list + let build_variables_list = + liftvbis "line 257, build_list" List_algebra.build_list - let build_reverse_sorted_range_list = - lift1terter __POS__ List_algebra.build_reversed_sorted_list + let build_sorted_variables_list = + liftvter "line 259, build_list" List_algebra.build_reversed_sorted_list + let build_reverse_sorted_variables_list = + liftvter "line 261, build_list" List_algebra.build_sorted_list - let empty_range_list parameter handler error = - build_range_list parameter handler error [] - let empty_association_list parameter handler error = build_association_list parameter handler error [] + let empty_variables_list parameter handler error = + build_variables_list parameter handler error [] - let mvbdu_subseteq parameter handler error mvbdu1 mvbdu2 = - let error, handler, union = mvbdu_or parameter handler error mvbdu1 mvbdu2 in - error, handler, equal mvbdu2 union + let variables_list_of_mvbdu parameter handler error mvbdu = + lift1four build_sorted_variables_list __POS__ + Boolean_mvbdu.variables_of_mvbdu parameter handler error mvbdu - let mvbdu_of_hconsed_asso parameter handler error asso = - let error, handler, mvbdu_true = mvbdu_true parameter handler error in - mvbdu_redefine parameter handler error mvbdu_true asso + let extensional_of_association_list parameters handler error l = + lift1five __POS__ Boolean_mvbdu.extensional_description_of_association_list + parameters handler error l - let mvbdu_of_hconsed_range parameter handler error asso = - let error, handler, mvbdu_true = mvbdu_true parameter handler error in - mvbdu_redefine_range parameter handler error mvbdu_true asso + let extensional_of_range_list parameters handler error l = + lift1five __POS__ Boolean_mvbdu.extensional_description_of_range_list + parameters handler error l - let mvbdu_of_asso_gen f parameter handler error asso = - let error, handler, hconsed_list = f parameter handler error asso in - mvbdu_of_hconsed_asso parameter handler error hconsed_list + let extensional_of_variables_list parameters handler error l = + lift1five __POS__ Boolean_mvbdu.extensional_description_of_variables_list + parameters handler error l - let mvbdu_of_range_gen f parameter handler error asso = - let error, handler, hconsed_list = f parameter handler error asso in - mvbdu_of_hconsed_range parameter handler error hconsed_list + let extensional_of_mvbdu parameters handler error mvbdu = + lift1__ __POS__ Boolean_mvbdu.extensional_description_of_mvbdu parameters + handler error mvbdu - let mvbdu_of_hconsed_range parameter handler error asso = - let error, handler, mvbdu_true = mvbdu_true parameter handler error in - mvbdu_redefine_range parameter handler error mvbdu_true asso + let print = Boolean_mvbdu.print_mvbdu + let print_association_list = List_algebra.print_association_list + let print_variables_list = List_algebra.print_variables_list + let mvbdu_clean_head = lift1_ __POS__ Boolean_mvbdu.clean_head + let mvbdu_keep_head_only = lift1_ __POS__ Boolean_mvbdu.keep_head_only + let mvbdu_cartesian_abstraction parameters handler error bdu = + let error, handler, bdd_true = mvbdu_true parameters handler error in + (*let error = Exception.check_point + Exception.warn parameters error error' __POS__ Exit + in*) + let error, handler, bdd_false = mvbdu_false parameters handler error in + (*let error = Exception.check_point + Exception.warn parameters error error'' __POS__ Exit + in*) + let rec aux error handler bdu list = + if equal bdu bdd_true || equal bdu bdd_false then + error, handler, List.rev list + else ( + let error, handler, head = + mvbdu_keep_head_only parameters error handler bdu + in + (*let error = Exception.check_point + Exception.warn parameters error error' __POS__ Exit + in*) + let error, handler, tail = + mvbdu_clean_head parameters error handler bdu + in + (*let error = Exception.check_point + Exception.warn parameters error error'' __POS__ Exit + in*) + aux error handler tail (head :: list) + ) + in + aux error handler bdu [] + + let mvbdu_cartesian_decomposition_depth parameters handler error bdu int = + Boolean_mvbdu.mvbdu_cartesian_decomposition_depth variables_list_of_mvbdu + extensional_of_variables_list build_sorted_variables_list + mvbdu_project_keep_only mvbdu_project_abstract_away mvbdu_and equal + parameters handler error bdu int + + let mvbdu_full_cartesian_decomposition parameters handler error bdu = + let error, handler, l = + variables_list_of_mvbdu parameters handler error bdu + in + (*let error = Exception.check_point + Exception.warn parameters error error' __POS__ Exit + in*) + let error, handler, list = + extensional_of_variables_list parameters handler error l + in + (*let error = Exception.check_point + Exception.warn parameters error error'' __POS__ Exit + in*) + let size = List.length list in + let error, handler, (bdu_opt, list) = + mvbdu_cartesian_decomposition_depth parameters handler error bdu (size / 2) + in + (*let error = Exception.check_point + Exception.warn parameters error error_3 __POS__ Exit + in*) + match bdu_opt with + | None -> error, handler, list + | Some bdu -> error, handler, bdu :: list + + let merge_variables_lists parameters handler error l1 l2 = + lift2four __POS__ Boolean_mvbdu.merge_variables_lists parameters handler + error l1 l2 + + let overwrite_association_lists parameters handler error l1 l2 = + lift2five __POS__ Boolean_mvbdu.overwrite_association_lists parameters + handler error l1 l2 + + let nbr_variables parameter handler error l = + lift1_seven "line 539" Boolean_mvbdu.length parameter handler error l + + let store_by_gen get_id get set default join parameters handler error + hash_consed_object data storage = + let id = get_id hash_consed_object in + let error, old_data = get parameters error default id storage in + let error, handler, data = join parameters handler error old_data data in + let error, storage = set parameters error id data storage in + error, handler, storage + + let store_by_variables_list get set default join parameters handler error + hash_consed_object data storage = + store_by_gen List_core.id_of_list get set default join parameters handler + error hash_consed_object data storage + + let store_by_mvbdu get set default join parameters handler error + hash_consed_object data storage = + store_by_gen Mvbdu_core.id_of_mvbdu get set default join parameters handler + error hash_consed_object data storage + + let hash_of_association_list x = List_core.id_of_list x + let hash_of_variables_list x = List_core.id_of_list x + let hash_of_range_list x = List_core.id_of_list x +end - let mvbdu_of_association_list = mvbdu_of_asso_gen build_association_list +module Internalize (M : Mvbdu with type key = int and type value = int) : + Internalized_mvbdu + with type key = int + and type value = int + and type mvbdu = M.mvbdu = struct + module Mvbdu = M + include Mvbdu + + let handler = ref None + + let parameter = + ref + (Remanent_parameters.get_parameters + ~called_from:Remanent_parameters_sig.Internalised ()) + + let import_handler h = handler := Some h + + let export_handler error = + match !handler with + | None -> Exception.warn !parameter error __POS__ Exit None + | Some _ -> error, !handler + + let check pos error error' handler' = + let () = handler := Some handler' in + if error' == error then + () + else ( + let error', () = Exception.warn !parameter error pos Exit () in + Exception.print !parameter error' + ) + + let init parameters = + let error = Exception.empty_error_handler in + let error', output = init parameters error in + let () = parameter := parameters in + check __POS__ error error' output + + let is_init () = None != !handler + let equal = M.equal + + let get_handler pos error = + match !handler with + | None -> + let () = init !parameter in + let error', () = + Exception.warn !parameter error pos ~message:" uninitialised mvbdu" Exit + () + in + (match !handler with + | None -> failwith "unrecoverable errors in bdu get_handler" + | Some h -> error', h) + | Some h -> error, h + + let lift_const s f = + let error = Exception.empty_error_handler in + let error', handler = get_handler s error in + let error', handler, mvbdu = f !parameter handler error' in + let _ = check s error error' handler in + mvbdu + + let mvbdu_true () = lift_const __POS__ M.mvbdu_true + let mvbdu_false () = lift_const __POS__ M.mvbdu_false + + let lift_unary s f x = + let error = Exception.empty_error_handler in + let error', handler = get_handler s error in + let error', handler, mvbdu = f !parameter handler error' x in + let _ = check s error error' handler in + mvbdu + + let mvbdu_id = lift_unary __POS__ M.mvbdu_id + let mvbdu_not = lift_unary __POS__ M.mvbdu_not + let mvbdu_unary_true _ = mvbdu_true () + let mvbdu_unary_false _ = mvbdu_false () + let mvbdu_bi_true _ _ = mvbdu_true () + let mvbdu_bi_false _ _ = mvbdu_false () + + let lift_binary s f x y = + let error = Exception.empty_error_handler in + let error', handler = get_handler s error in + let error', handler, mvbdu = f !parameter handler error' x y in + let _ = check s error error' handler in + mvbdu + + let lift_binary''' s f x y = + let error = Exception.empty_error_handler in + let error', handler = get_handler s error in + let error', handler, mvbdu = f !parameter handler error' x y in + let _ = check s error error' handler in + mvbdu + + let lift_binary'''' s f x y = + let error = Exception.empty_error_handler in + let error', handler = get_handler s error in + let error', handler, mvbdu = f !parameter handler error' x y in + let _ = check s error error' handler in + mvbdu + + let mvbdu_and = lift_binary __POS__ M.mvbdu_and + let mvbdu_or = lift_binary __POS__ M.mvbdu_or + let mvbdu_nand = lift_binary __POS__ M.mvbdu_nand + let mvbdu_snd _ b = b + let mvbdu_nsnd _ b = mvbdu_not b + let mvbdu_fst a _ = a + let mvbdu_nfst a _ = mvbdu_not a + let mvbdu_xor = lift_binary __POS__ M.mvbdu_xor + let mvbdu_nor = lift_binary __POS__ M.mvbdu_nor + let mvbdu_imply = lift_binary __POS__ M.mvbdu_imply + let mvbdu_nimply = lift_binary __POS__ M.mvbdu_nimply + let mvbdu_rev_imply = lift_binary __POS__ M.mvbdu_rev_imply + let mvbdu_nrev_imply = lift_binary __POS__ M.mvbdu_nrev_imply + let mvbdu_equiv = lift_binary __POS__ M.mvbdu_equiv + let mvbdu_redefine = lift_binary __POS__ M.mvbdu_redefine + let mvbdu_redefine_range = lift_binary __POS__ M.mvbdu_redefine_range + let mvbdu_rename = lift_binary __POS__ Mvbdu.mvbdu_rename + let mvbdu_project_keep_only = lift_binary __POS__ M.mvbdu_project_keep_only + + let mvbdu_project_abstract_away = + lift_binary __POS__ M.mvbdu_project_abstract_away + + let build_association_list = lift_unary __POS__ M.build_association_list + + let build_sorted_association_list = + lift_unary __POS__ M.build_sorted_association_list + + let build_reverse_sorted_association_list = + lift_unary __POS__ M.build_reverse_sorted_association_list + + let empty_association_list () = build_association_list [] + let build_renaming_list = lift_unary __POS__ M.build_renaming_list + + let build_sorted_renaming_list = + lift_unary __POS__ M.build_sorted_renaming_list + + let build_reverse_sorted_renaming_list = + lift_unary __POS__ M.build_reverse_sorted_renaming_list + + let empty_renaming_list () = build_renaming_list [] + let build_range_list = lift_unary __POS__ M.build_range_list + let build_sorted_range_list = lift_unary __POS__ M.build_sorted_range_list + + let build_reverse_sorted_range_list = + lift_unary __POS__ M.build_reverse_sorted_range_list + + let empty_range_list () = build_range_list [] + let mvbdu_subseteq mvbdu1 mvbdu2 = equal (mvbdu_or mvbdu1 mvbdu2) mvbdu2 + let mvbdu_of_asso_gen f asso = mvbdu_redefine (mvbdu_true ()) (f asso) + let mvbdu_of_hconsed_asso = mvbdu_of_asso_gen (fun x -> x) + let mvbdu_of_association_list = mvbdu_of_asso_gen build_association_list + + let mvbdu_of_sorted_association_list = + mvbdu_of_asso_gen build_sorted_association_list + + let mvbdu_of_reverse_sorted_association_list = + mvbdu_of_asso_gen build_reverse_sorted_association_list + + let mvbdu_of_range_gen f asso = mvbdu_redefine_range (mvbdu_true ()) (f asso) + let mvbdu_of_hconsed_range = mvbdu_of_range_gen (fun x -> x) + let mvbdu_of_range_list = mvbdu_of_range_gen build_range_list + let mvbdu_of_sorted_range_list = mvbdu_of_range_gen build_sorted_range_list + + let mvbdu_of_reverse_sorted_range_list = + mvbdu_of_range_gen build_reverse_sorted_range_list + + let build_variables_list = lift_unary __POS__ M.build_variables_list + + let build_sorted_variables_list = + lift_unary __POS__ M.build_sorted_variables_list - let mvbdu_of_range_list = - mvbdu_of_range_gen - build_range_list + let build_reverse_sorted_variables_list = + lift_unary __POS__ M.build_reverse_sorted_variables_list + let empty_variables_list () = build_variables_list [] - let mvbdu_of_sorted_association_list = mvbdu_of_asso_gen build_sorted_association_list - let mvbdu_of_sorted_range_list = mvbdu_of_range_gen - build_sorted_range_list - let mvbdu_of_reverse_sorted_association_list = mvbdu_of_asso_gen build_reverse_sorted_association_list - let mvbdu_of_reverse_sorted_range_list = mvbdu_of_range_gen - build_reverse_sorted_range_list + let merge_variables_lists l1 l2 = + lift_binary''' __POS__ M.merge_variables_lists l1 l2 - let build_renaming_list = build_association_list - let build_sorted_renaming_list = build_sorted_association_list - let build_reverse_sorted_renaming_list = build_sorted_renaming_list - let empty_renaming_list = empty_association_list + let nbr_variables l = lift_unary __POS__ M.nbr_variables l - let build_variables_list = - liftvbis "line 257, build_list" - List_algebra.build_list - - let build_sorted_variables_list = liftvter "line 259, build_list" List_algebra.build_reversed_sorted_list - - let build_reverse_sorted_variables_list = liftvter "line 261, build_list" List_algebra.build_sorted_list - - let empty_variables_list parameter handler error = build_variables_list parameter handler error [] - - let variables_list_of_mvbdu parameter handler error mvbdu = - lift1four - build_sorted_variables_list - __POS__ - Boolean_mvbdu.variables_of_mvbdu - parameter handler error mvbdu + let overwrite_association_lists l1 l2 = + lift_binary'''' __POS__ M.overwrite_association_lists l1 l2 - let extensional_of_association_list parameters handler error l = - lift1five - __POS__ - Boolean_mvbdu.extensional_description_of_association_list parameters handler error l + let variables_list_of_mvbdu l = lift_unary __POS__ M.variables_list_of_mvbdu l - let extensional_of_range_list parameters handler error l = - lift1five - __POS__ - Boolean_mvbdu.extensional_description_of_range_list parameters handler error l + let mvbdu_cartesian_abstraction = + lift_unary __POS__ M.mvbdu_cartesian_abstraction - let extensional_of_variables_list parameters handler error l = - lift1five - __POS__ - Boolean_mvbdu.extensional_description_of_variables_list parameters handler error l + let extensional_of_association_list l = + lift_unary __POS__ M.extensional_of_association_list l - let extensional_of_mvbdu parameters handler error mvbdu = - lift1__ __POS__ - Boolean_mvbdu.extensional_description_of_mvbdu parameters handler error mvbdu + let extensional_of_variables_list l = + lift_unary __POS__ M.extensional_of_variables_list l - let print = Boolean_mvbdu.print_mvbdu - let print_association_list = List_algebra.print_association_list - let print_variables_list = List_algebra.print_variables_list + let extensional_of_mvbdu mvbdu = + lift_unary __POS__ M.extensional_of_mvbdu mvbdu - let mvbdu_clean_head = - lift1_ __POS__ Boolean_mvbdu.clean_head - let mvbdu_keep_head_only = lift1_ __POS__ Boolean_mvbdu.keep_head_only + let mvbdu_full_cartesian_decomposition = + lift_unary __POS__ M.mvbdu_full_cartesian_decomposition - let mvbdu_cartesian_abstraction parameters handler error bdu = - let error,handler,bdd_true = mvbdu_true parameters handler error in - (*let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in*) - let error,handler,bdd_false = mvbdu_false parameters handler error in - (*let error = Exception.check_point - Exception.warn parameters error error'' __POS__ Exit - in*) - let rec aux error handler bdu list = - if equal bdu bdd_true || equal bdu bdd_false - then - error,handler,List.rev list - else - let error,handler,head = mvbdu_keep_head_only parameters error handler bdu in - (*let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in*) - let error,handler,tail = mvbdu_clean_head parameters error handler bdu in - (*let error = Exception.check_point - Exception.warn parameters error error'' __POS__ Exit - in*) - aux error handler tail (head::list) - in aux error handler bdu [] + let mvbdu_cartesian_decomposition_depth = + lift_binary __POS__ M.mvbdu_cartesian_decomposition_depth +end - let mvbdu_cartesian_decomposition_depth parameters handler error bdu int = - Boolean_mvbdu.mvbdu_cartesian_decomposition_depth variables_list_of_mvbdu extensional_of_variables_list build_sorted_variables_list mvbdu_project_keep_only mvbdu_project_abstract_away mvbdu_and equal parameters handler error bdu int +module Optimize (M : Mvbdu with type key = int and type value = int) : + Mvbdu with type mvbdu = M.mvbdu and type key = int and type value = int = +struct + module Mvbdu = M + include Mvbdu + + let mvbdu_not parameters handler error a = + mvbdu_nand parameters handler error a a + + let mvbdu_unary_true parameters handler error a = + let error, handler, nota = mvbdu_not parameters handler error a in + mvbdu_nand parameters handler error a nota + + let mvbdu_unary_false parameters handler error a = + let error, handler, mvtrue = mvbdu_unary_true parameters handler error a in + mvbdu_not parameters handler error mvtrue + + let mvbdu_and parameters handler error a b = + let error, handler, ab = mvbdu_nand parameters handler error a b in + mvbdu_not parameters handler error ab + + let mvbdu_or parameters handler error a b = + let error, handler, na = mvbdu_not parameters handler error a in + let error, handler, nb = mvbdu_not parameters handler error b in + mvbdu_nand parameters handler error na nb + + let mvbdu_imply parameters handler error a b = + let error, handler, notb = mvbdu_not parameters handler error b in + mvbdu_nand parameters handler error a notb + + let mvbdu_rev_imply parameters handler error a b = + let error, handler, nota = mvbdu_not parameters handler error a in + mvbdu_nand parameters handler error nota b + + let mvbdu_nor parameters handler error a b = + let error, handler, bddor = mvbdu_or parameters handler error a b in + mvbdu_not parameters handler error bddor + + let mvbdu_equiv parameters handler error a b = + let error, handler, direct = mvbdu_imply parameters handler error a b in + let error, handler, indirect = mvbdu_imply parameters handler error b a in + mvbdu_and parameters handler error direct indirect + + let mvbdu_xor parameters handler error a b = + let error, handler, equiv = mvbdu_equiv parameters handler error a b in + mvbdu_not parameters handler error equiv + + let mvbdu_nimply parameters handler error a b = + let error, handler, imply = mvbdu_imply parameters handler error a b in + mvbdu_not parameters handler error imply + + let mvbdu_nrev_imply parameters handler error a b = + mvbdu_nimply parameters handler error b a + + let mvbdu_bi_true parameters handler error a _ = + M.mvbdu_unary_true parameters handler error a + + let mvbdu_bi_false parameters handler error a _ = + M.mvbdu_unary_false parameters handler error a + + let mvbdu_nfst parameters handler error a _ = + mvbdu_not parameters handler error a + + let mvbdu_nsnd parameters handler error _ a = + mvbdu_not parameters handler error a + + let mvbdu_cartesian_decomposition_depth parameters handler error bdu int = + Boolean_mvbdu.mvbdu_cartesian_decomposition_depth variables_list_of_mvbdu + extensional_of_variables_list build_sorted_variables_list + mvbdu_project_keep_only mvbdu_project_abstract_away mvbdu_and equal + parameters handler error bdu int + + let mvbdu_full_cartesian_decomposition parameters handler error bdu = + let error, handler, l = + variables_list_of_mvbdu parameters handler error bdu + in + let error, handler, list = + extensional_of_variables_list parameters handler error l + in + let size = List.length list in + let error, handler, (bdu_opt, list) = + mvbdu_cartesian_decomposition_depth parameters handler error bdu (size / 2) + in + match bdu_opt with + | None -> error, handler, list + | Some bdu -> error, handler, bdu :: list +end - let mvbdu_full_cartesian_decomposition parameters handler error bdu = - let error,handler,l = - variables_list_of_mvbdu parameters handler error bdu in - (*let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in*) - let error,handler,list = - extensional_of_variables_list parameters handler error l in - (*let error = Exception.check_point - Exception.warn parameters error error'' __POS__ Exit - in*) - let size = List.length list in - let error,handler,(bdu_opt,list) = - mvbdu_cartesian_decomposition_depth parameters handler error bdu - (size/2) - in - (*let error = Exception.check_point - Exception.warn parameters error error_3 __POS__ Exit - in*) - match - bdu_opt - with - | None -> error,handler,list - | Some bdu -> error,handler,bdu::list - - let merge_variables_lists parameters handler error l1 l2 = - lift2four __POS__ Boolean_mvbdu.merge_variables_lists parameters handler error l1 l2 - - let overwrite_association_lists parameters handler error l1 l2 = - lift2five __POS__ Boolean_mvbdu.overwrite_association_lists parameters handler error l1 l2 - - let nbr_variables parameter handler error l = - lift1_seven "line 539" Boolean_mvbdu.length parameter handler error l - - let store_by_gen get_id get set default join parameters handler error hash_consed_object data storage = - let id = get_id hash_consed_object in - let error, old_data = get parameters error default id storage in - let error, handler, data = join parameters handler error old_data data in - let error, storage = set parameters error id data storage in - error, handler, storage - - let store_by_variables_list get set default join parameters handler error hash_consed_object data storage = - store_by_gen List_core.id_of_list - get - set - default - join - parameters - handler - error - hash_consed_object - data - storage - - let store_by_mvbdu get set default join parameters handler error hash_consed_object data storage = - store_by_gen Mvbdu_core.id_of_mvbdu - get - set - default - join - parameters - handler - error - hash_consed_object - data - storage - - let hash_of_association_list x = List_core.id_of_list x - let hash_of_variables_list x = List_core.id_of_list x - let hash_of_range_list x = List_core.id_of_list x - - end: Mvbdu with type key = int and type value = int) - -module Internalize(M:Mvbdu - with type key = int - and type value = int) = - (struct - - module Mvbdu = M - include Mvbdu - - let handler = ref None - let parameter = ref (Remanent_parameters.get_parameters ~called_from:Remanent_parameters_sig.Internalised ()) - let import_handler h = handler:=Some h - let export_handler error = - match !handler with - | None -> - Exception.warn !parameter error __POS__ Exit None - | Some _ -> error, !handler - - let check pos error error' handler' = - let () = handler:= Some handler' in - if error'== error - then - () - else - let error',() = - Exception.warn !parameter error pos Exit () - in - Exception.print !parameter error' - - let init parameters = - let error = Exception.empty_error_handler in - let error',output = init parameters error in - let () = parameter := parameters in - check __POS__ error error' output - - let is_init () = None != !handler - let equal = M.equal - let get_handler pos error = - match - !handler - with - | None -> - let () = init !parameter in - let error',() = - Exception.warn !parameter error pos - ~message:" uninitialised mvbdu" Exit () - in - begin - match !handler with - | None -> failwith "unrecoverable errors in bdu get_handler" - | Some h -> error',h - end - | Some h -> error,h - let lift_const s f = - let error = Exception.empty_error_handler in - let error',handler = get_handler s error in - let error',handler,mvbdu = f !parameter handler error' in - let _ = check s error error' handler in - mvbdu - let mvbdu_true () = lift_const __POS__ M.mvbdu_true - let mvbdu_false () = lift_const __POS__ M.mvbdu_false - - let lift_unary s f x = - let error = Exception.empty_error_handler in - let error',handler = get_handler s error in - let error',handler,mvbdu = f !parameter handler error' x in - let _ = check s error error' handler in - mvbdu - - - let mvbdu_id = lift_unary __POS__ M.mvbdu_id - let mvbdu_not = lift_unary __POS__ M.mvbdu_not - - let mvbdu_unary_true _ = mvbdu_true () - let mvbdu_unary_false _ = mvbdu_false () - let mvbdu_bi_true _ _ = mvbdu_true () - let mvbdu_bi_false _ _ = mvbdu_false () - - let lift_binary s f x y = - let error = Exception.empty_error_handler in - let error',handler = get_handler s error in - let error',handler,mvbdu = f !parameter handler error' x y in - let _ = check s error error' handler in - mvbdu - - let lift_binary''' s f x y = - let error = Exception.empty_error_handler in - let error',handler = get_handler s error in - let error',handler,mvbdu = f !parameter handler error' x y in - let _ = check s error error' handler in - mvbdu - - let lift_binary'''' s f x y = - let error = Exception.empty_error_handler in - let error',handler = get_handler s error in - let error',handler,mvbdu = f !parameter handler error' x y in - let _ = check s error error' handler in - mvbdu - - let mvbdu_and = lift_binary __POS__ M.mvbdu_and - let mvbdu_or = lift_binary __POS__ M.mvbdu_or - let mvbdu_nand = lift_binary __POS__ M.mvbdu_nand - let mvbdu_snd _ b = b - let mvbdu_nsnd _ b = mvbdu_not b - let mvbdu_fst a _ = a - let mvbdu_nfst a _ = mvbdu_not a - let mvbdu_xor = lift_binary __POS__ M.mvbdu_xor - let mvbdu_nor = lift_binary __POS__ M.mvbdu_nor - let mvbdu_imply = lift_binary __POS__ M.mvbdu_imply - let mvbdu_nimply = lift_binary __POS__ M.mvbdu_nimply - let mvbdu_rev_imply = lift_binary __POS__ M.mvbdu_rev_imply - let mvbdu_nrev_imply = lift_binary __POS__ M.mvbdu_nrev_imply - let mvbdu_equiv = lift_binary __POS__ M.mvbdu_equiv - let mvbdu_redefine = lift_binary __POS__ M.mvbdu_redefine - let mvbdu_redefine_range = lift_binary __POS__ M.mvbdu_redefine_range - let mvbdu_rename = lift_binary __POS__ Mvbdu.mvbdu_rename - let mvbdu_project_keep_only = lift_binary __POS__ M.mvbdu_project_keep_only - let mvbdu_project_abstract_away = - lift_binary __POS__ M.mvbdu_project_abstract_away - - let build_association_list = lift_unary __POS__ M.build_association_list - let build_sorted_association_list = - lift_unary __POS__ M.build_sorted_association_list - let build_reverse_sorted_association_list = - lift_unary __POS__ M.build_reverse_sorted_association_list - let empty_association_list () = build_association_list [] - - let build_renaming_list = lift_unary __POS__ M.build_renaming_list - let build_sorted_renaming_list = - lift_unary __POS__ M.build_sorted_renaming_list - let build_reverse_sorted_renaming_list = - lift_unary __POS__ M.build_reverse_sorted_renaming_list - let empty_renaming_list () = build_renaming_list [] - - let build_range_list = lift_unary __POS__ M.build_range_list - let build_sorted_range_list = - lift_unary __POS__ M.build_sorted_range_list - let build_reverse_sorted_range_list = - lift_unary __POS__ M.build_reverse_sorted_range_list - let empty_range_list () = build_range_list [] - - let mvbdu_subseteq mvbdu1 mvbdu2 = - equal (mvbdu_or mvbdu1 mvbdu2) mvbdu2 - - let mvbdu_of_asso_gen f asso = - mvbdu_redefine (mvbdu_true ()) (f asso) - let mvbdu_of_hconsed_asso = mvbdu_of_asso_gen (fun x -> x) - let mvbdu_of_association_list = mvbdu_of_asso_gen (build_association_list) - let mvbdu_of_sorted_association_list = mvbdu_of_asso_gen (build_sorted_association_list) - let mvbdu_of_reverse_sorted_association_list = mvbdu_of_asso_gen (build_reverse_sorted_association_list) - let mvbdu_of_range_gen f asso = - mvbdu_redefine_range (mvbdu_true ()) (f asso) - - let mvbdu_of_hconsed_range = mvbdu_of_range_gen (fun x -> x) - let mvbdu_of_range_list = mvbdu_of_range_gen (build_range_list) - let mvbdu_of_sorted_range_list = mvbdu_of_range_gen (build_sorted_range_list) - let mvbdu_of_reverse_sorted_range_list = mvbdu_of_range_gen (build_reverse_sorted_range_list) - - - let build_variables_list = lift_unary __POS__ M.build_variables_list - let build_sorted_variables_list = - lift_unary __POS__ M.build_sorted_variables_list - let build_reverse_sorted_variables_list = - lift_unary __POS__ M.build_reverse_sorted_variables_list - let empty_variables_list () = build_variables_list [] - - let merge_variables_lists l1 l2 = - lift_binary''' __POS__ - M.merge_variables_lists - l1 l2 - - let nbr_variables l = lift_unary __POS__ M.nbr_variables l - - let overwrite_association_lists l1 l2 = - lift_binary'''' __POS__ M.overwrite_association_lists l1 l2 - - let variables_list_of_mvbdu l = - lift_unary __POS__ M.variables_list_of_mvbdu l - - let mvbdu_cartesian_abstraction = - lift_unary __POS__ M.mvbdu_cartesian_abstraction - - let extensional_of_association_list l = - lift_unary __POS__ M.extensional_of_association_list l - let extensional_of_variables_list l = - lift_unary __POS__ M.extensional_of_variables_list l - - let extensional_of_mvbdu mvbdu = - lift_unary __POS__ M.extensional_of_mvbdu mvbdu - - let mvbdu_full_cartesian_decomposition = - lift_unary __POS__ M.mvbdu_full_cartesian_decomposition - let mvbdu_cartesian_decomposition_depth = - lift_binary __POS__ M.mvbdu_cartesian_decomposition_depth - - end:Internalized_mvbdu - with - type key = int - and type value = int - and type mvbdu= M.mvbdu ) - - -module Optimize(M:Mvbdu with type key = int and type value = int) = - (struct - module Mvbdu = M - include Mvbdu - - let mvbdu_not parameters handler error a = mvbdu_nand parameters handler error a a - - let mvbdu_unary_true parameters handler error a = - let error,handler,nota = mvbdu_not parameters handler error a in - mvbdu_nand parameters handler error a nota - let mvbdu_unary_false parameters handler error a = - let error,handler,mvtrue = mvbdu_unary_true parameters handler error a in - mvbdu_not parameters handler error mvtrue - let mvbdu_and parameters handler error a b = - let error,handler,ab = mvbdu_nand parameters handler error a b in - mvbdu_not parameters handler error ab - let mvbdu_or parameters handler error a b = - let error,handler,na = mvbdu_not parameters handler error a in - let error,handler,nb = mvbdu_not parameters handler error b in - mvbdu_nand parameters handler error na nb - let mvbdu_imply parameters handler error a b = - let error,handler,notb = mvbdu_not parameters handler error b in - mvbdu_nand parameters handler error a notb - let mvbdu_rev_imply parameters handler error a b = - let error,handler,nota = mvbdu_not parameters handler error a in - mvbdu_nand parameters handler error nota b - let mvbdu_nor parameters handler error a b = - let error,handler,bddor = mvbdu_or parameters handler error a b in - mvbdu_not parameters handler error bddor - let mvbdu_equiv parameters handler error a b = - let error,handler,direct = mvbdu_imply parameters handler error a b in - let error,handler,indirect = mvbdu_imply parameters handler error b a in - mvbdu_and parameters handler error direct indirect - let mvbdu_xor parameters handler error a b = - let error,handler,equiv = mvbdu_equiv parameters handler error a b in - mvbdu_not parameters handler error equiv - let mvbdu_nimply parameters handler error a b = - let error,handler,imply = mvbdu_imply parameters handler error a b in - mvbdu_not parameters handler error imply - let mvbdu_nrev_imply parameters handler error a b = mvbdu_nimply parameters handler error b a - let mvbdu_bi_true parameters handler error a _ = M.mvbdu_unary_true parameters handler error a - let mvbdu_bi_false parameters handler error a _ = M.mvbdu_unary_false parameters handler error a - let mvbdu_nfst parameters handler error a _ = mvbdu_not parameters handler error a - let mvbdu_nsnd parameters handler error _ a = mvbdu_not parameters handler error a - - let mvbdu_cartesian_decomposition_depth parameters handler error bdu int = - Boolean_mvbdu.mvbdu_cartesian_decomposition_depth - variables_list_of_mvbdu extensional_of_variables_list - build_sorted_variables_list - mvbdu_project_keep_only - mvbdu_project_abstract_away - mvbdu_and - equal - parameters handler - error - bdu - int - - let mvbdu_full_cartesian_decomposition parameters handler error bdu = - let error,handler,l = variables_list_of_mvbdu parameters handler error bdu in - let error,handler,list = extensional_of_variables_list parameters handler error l in - let size = List.length list in - let error,handler,(bdu_opt,list) = mvbdu_cartesian_decomposition_depth parameters handler error bdu (size/2) in - match - bdu_opt - with - | None -> error,handler,list - | Some bdu -> error,handler,bdu::list - - end:Mvbdu with type mvbdu = M.mvbdu and type key = int and type value = int) - -module Optimize_internalized(M:Internalized_mvbdu with type key = int and type value = int) = - (struct - module Mvbdu = M - - type key = Mvbdu.key - type value = Mvbdu.value - type mvbdu = Mvbdu.mvbdu - type hconsed_association_list = Mvbdu.hconsed_association_list - type hconsed_variables_list = Mvbdu.hconsed_variables_list - type hconsed_renaming_list = Mvbdu.hconsed_renaming_list - type hconsed_range_list = Mvbdu.hconsed_range_list - type handler = Mvbdu.handler - - let import_handler = Mvbdu.import_handler - let export_handler = Mvbdu.export_handler - let init = Mvbdu.init - let is_init = Mvbdu.is_init - let equal = Mvbdu.equal - let mvbdu_nand a = Mvbdu.mvbdu_nand a - let mvbdu_not a = mvbdu_nand a a - let mvbdu_id = Mvbdu.mvbdu_id - let mvbdu_true = Mvbdu.mvbdu_true - let mvbdu_false = Mvbdu.mvbdu_false - let mvbdu_unary_true a = mvbdu_nand a (mvbdu_not a) - let mvbdu_unary_false a = mvbdu_not (mvbdu_unary_true a) - let mvbdu_and a b = mvbdu_not (mvbdu_nand a b) - let mvbdu_or a b = mvbdu_nand (mvbdu_not a) (mvbdu_not b) - let mvbdu_imply a b = mvbdu_nand a (mvbdu_not b) - let mvbdu_rev_imply a b = mvbdu_imply b a - let mvbdu_nor a b = mvbdu_not (mvbdu_or a b) - let mvbdu_equiv a b = mvbdu_and (mvbdu_imply a b) (mvbdu_imply b a) - - let mvbdu_xor a b = mvbdu_not (mvbdu_equiv a b) - let mvbdu_nimply a b = mvbdu_not (mvbdu_imply a b) - let mvbdu_nrev_imply a b = mvbdu_nimply b a - let mvbdu_bi_true _ _ = M.mvbdu_true () - let mvbdu_bi_false _ _ = M.mvbdu_false () - let mvbdu_fst a _ = a - let mvbdu_snd _ b = b - let mvbdu_nfst a _ = mvbdu_not a - let mvbdu_nsnd _ a = mvbdu_not a - - let build_association_list = M.build_association_list - let build_sorted_association_list = M.build_sorted_association_list - let build_reverse_sorted_association_list = M.build_reverse_sorted_association_list - let build_renaming_list = M.build_renaming_list - let build_sorted_renaming_list = M.build_sorted_renaming_list - let build_reverse_sorted_renaming_list = M.build_reverse_sorted_renaming_list - let build_range_list = M.build_range_list - let build_sorted_range_list = M.build_sorted_range_list - let build_reverse_sorted_range_list = M.build_reverse_sorted_range_list - let mvbdu_redefine = M.mvbdu_redefine - let mvbdu_redefine_range = M.mvbdu_redefine_range - let mvbdu_subseteq = M.mvbdu_subseteq - let mvbdu_of_hconsed_asso = M.mvbdu_of_hconsed_asso - let mvbdu_of_association_list = M.mvbdu_of_association_list - let mvbdu_of_sorted_association_list = M.mvbdu_of_sorted_association_list - let mvbdu_of_reverse_sorted_association_list= M.mvbdu_of_reverse_sorted_association_list - let mvbdu_of_reverse_sorted_range_list = M.mvbdu_of_reverse_sorted_range_list - let mvbdu_of_sorted_range_list = - M.mvbdu_of_sorted_range_list - let mvbdu_of_range_list = M.mvbdu_of_range_list - let mvbdu_of_hconsed_range = M.mvbdu_of_hconsed_range - let mvbdu_rename = M.mvbdu_rename - let mvbdu_project_keep_only = M.mvbdu_project_keep_only - let mvbdu_project_abstract_away = M.mvbdu_project_abstract_away - let build_variables_list = M.build_variables_list - let build_sorted_variables_list = M.build_sorted_variables_list - let build_reverse_sorted_variables_list = M.build_reverse_sorted_variables_list - let empty_renaming_list = M.empty_renaming_list - let empty_variables_list = M.empty_variables_list - let empty_association_list = M.empty_association_list - let empty_range_list = M.empty_range_list - let merge_variables_lists = M.merge_variables_lists - let overwrite_association_lists = M.overwrite_association_lists - let print = M.print - let print_association_list = M.print_association_list - let print_variables_list = M.print_variables_list - let mvbdu_cartesian_abstraction = M.mvbdu_cartesian_abstraction - let extensional_of_association_list = M.extensional_of_association_list - let extensional_of_variables_list = M.extensional_of_variables_list - let extensional_of_mvbdu = M.extensional_of_mvbdu - let variables_list_of_mvbdu = M.variables_list_of_mvbdu - - let mvbdu_cartesian_decomposition_depth = M.mvbdu_cartesian_decomposition_depth - - let mvbdu_full_cartesian_decomposition = M.mvbdu_full_cartesian_decomposition - - let hash_of_association_list = M.hash_of_association_list - let hash_of_variables_list = M.hash_of_variables_list - let nbr_variables = M.nbr_variables - - end:Internalized_mvbdu with type mvbdu = M.mvbdu and type key = int and type value = int) +module Optimize_internalized + (M : Internalized_mvbdu with type key = int and type value = int) : + Internalized_mvbdu + with type mvbdu = M.mvbdu + and type key = int + and type value = int = struct + module Mvbdu = M + + type key = Mvbdu.key + type value = Mvbdu.value + type mvbdu = Mvbdu.mvbdu + type hconsed_association_list = Mvbdu.hconsed_association_list + type hconsed_variables_list = Mvbdu.hconsed_variables_list + type hconsed_renaming_list = Mvbdu.hconsed_renaming_list + type hconsed_range_list = Mvbdu.hconsed_range_list + type handler = Mvbdu.handler + + let import_handler = Mvbdu.import_handler + let export_handler = Mvbdu.export_handler + let init = Mvbdu.init + let is_init = Mvbdu.is_init + let equal = Mvbdu.equal + let mvbdu_nand a = Mvbdu.mvbdu_nand a + let mvbdu_not a = mvbdu_nand a a + let mvbdu_id = Mvbdu.mvbdu_id + let mvbdu_true = Mvbdu.mvbdu_true + let mvbdu_false = Mvbdu.mvbdu_false + let mvbdu_unary_true a = mvbdu_nand a (mvbdu_not a) + let mvbdu_unary_false a = mvbdu_not (mvbdu_unary_true a) + let mvbdu_and a b = mvbdu_not (mvbdu_nand a b) + let mvbdu_or a b = mvbdu_nand (mvbdu_not a) (mvbdu_not b) + let mvbdu_imply a b = mvbdu_nand a (mvbdu_not b) + let mvbdu_rev_imply a b = mvbdu_imply b a + let mvbdu_nor a b = mvbdu_not (mvbdu_or a b) + let mvbdu_equiv a b = mvbdu_and (mvbdu_imply a b) (mvbdu_imply b a) + let mvbdu_xor a b = mvbdu_not (mvbdu_equiv a b) + let mvbdu_nimply a b = mvbdu_not (mvbdu_imply a b) + let mvbdu_nrev_imply a b = mvbdu_nimply b a + let mvbdu_bi_true _ _ = M.mvbdu_true () + let mvbdu_bi_false _ _ = M.mvbdu_false () + let mvbdu_fst a _ = a + let mvbdu_snd _ b = b + let mvbdu_nfst a _ = mvbdu_not a + let mvbdu_nsnd _ a = mvbdu_not a + let build_association_list = M.build_association_list + let build_sorted_association_list = M.build_sorted_association_list + + let build_reverse_sorted_association_list = + M.build_reverse_sorted_association_list + + let build_renaming_list = M.build_renaming_list + let build_sorted_renaming_list = M.build_sorted_renaming_list + let build_reverse_sorted_renaming_list = M.build_reverse_sorted_renaming_list + let build_range_list = M.build_range_list + let build_sorted_range_list = M.build_sorted_range_list + let build_reverse_sorted_range_list = M.build_reverse_sorted_range_list + let mvbdu_redefine = M.mvbdu_redefine + let mvbdu_redefine_range = M.mvbdu_redefine_range + let mvbdu_subseteq = M.mvbdu_subseteq + let mvbdu_of_hconsed_asso = M.mvbdu_of_hconsed_asso + let mvbdu_of_association_list = M.mvbdu_of_association_list + let mvbdu_of_sorted_association_list = M.mvbdu_of_sorted_association_list + + let mvbdu_of_reverse_sorted_association_list = + M.mvbdu_of_reverse_sorted_association_list + + let mvbdu_of_reverse_sorted_range_list = M.mvbdu_of_reverse_sorted_range_list + let mvbdu_of_sorted_range_list = M.mvbdu_of_sorted_range_list + let mvbdu_of_range_list = M.mvbdu_of_range_list + let mvbdu_of_hconsed_range = M.mvbdu_of_hconsed_range + let mvbdu_rename = M.mvbdu_rename + let mvbdu_project_keep_only = M.mvbdu_project_keep_only + let mvbdu_project_abstract_away = M.mvbdu_project_abstract_away + let build_variables_list = M.build_variables_list + let build_sorted_variables_list = M.build_sorted_variables_list + + let build_reverse_sorted_variables_list = + M.build_reverse_sorted_variables_list + + let empty_renaming_list = M.empty_renaming_list + let empty_variables_list = M.empty_variables_list + let empty_association_list = M.empty_association_list + let empty_range_list = M.empty_range_list + let merge_variables_lists = M.merge_variables_lists + let overwrite_association_lists = M.overwrite_association_lists + let print = M.print + let print_association_list = M.print_association_list + let print_variables_list = M.print_variables_list + let mvbdu_cartesian_abstraction = M.mvbdu_cartesian_abstraction + let extensional_of_association_list = M.extensional_of_association_list + let extensional_of_variables_list = M.extensional_of_variables_list + let extensional_of_mvbdu = M.extensional_of_mvbdu + let variables_list_of_mvbdu = M.variables_list_of_mvbdu + + let mvbdu_cartesian_decomposition_depth = + M.mvbdu_cartesian_decomposition_depth + + let mvbdu_full_cartesian_decomposition = M.mvbdu_full_cartesian_decomposition + let hash_of_association_list = M.hash_of_association_list + let hash_of_variables_list = M.hash_of_variables_list + let nbr_variables = M.nbr_variables +end module Vd = struct end -module Mvbdu = Make(Vd) -module IntMvbdu = Internalize(Make(Vd)) -module Optimized_Mvbdu = Optimize(Make(Vd)) -module Optimized_IntMvbdu = Internalize(Optimize(Make (Vd))) -module Optimized_IntMvbdu_bis = Optimize_internalized(Internalize(Make(Vd))) +module Mvbdu = Make (Vd) +module IntMvbdu = Internalize (Make (Vd)) +module Optimized_Mvbdu = Optimize (Make (Vd)) +module Optimized_IntMvbdu = Internalize (Optimize (Make (Vd))) +module Optimized_IntMvbdu_bis = Optimize_internalized (Internalize (Make (Vd))) diff --git a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.mli b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.mli index eafea63050..fac2286a4f 100644 --- a/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.mli +++ b/core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.mli @@ -11,264 +11,410 @@ * Copyright 2010 Institut National de Recherche en Informatique et * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) + (** API of the multi-valued binary decision diagrams library *) -module type Mvbdu = - sig - type key - type value - type handler = (Boolean_mvbdu.memo_tables,Boolean_mvbdu.mvbdu_dic,Boolean_mvbdu.association_list_dic,Boolean_mvbdu.range_list_dic,Boolean_mvbdu.variables_list_dic,bool,int) Memo_sig.handler - type mvbdu - type hconsed_range_list - type hconsed_association_list - type hconsed_variables_list - type hconsed_renaming_list - - - type 'output constant = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> Exception.method_handler * handler * 'output - type ('input,'output) unary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input -> Exception.method_handler * handler * 'output - type ('input1,'input2,'output) binary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input1 -> 'input2 -> Exception.method_handler * handler * 'output - type ('input1,'input2,'input3,'output) ternary = Remanent_parameters_sig.parameters -> handler -> Exception.method_handler -> 'input1 -> 'input2 -> 'input3 -> Exception.method_handler * handler * 'output - - val init: Remanent_parameters_sig.parameters -> Exception.method_handler -> Exception.method_handler * handler - val is_init: unit -> bool - val get_handler: Remanent_parameters_sig.parameters -> Exception.method_handler -> Exception.method_handler * handler - val reset: Remanent_parameters_sig.parameters -> Exception.method_handler -> Exception.method_handler * handler - val equal: mvbdu -> mvbdu -> bool - val equal_with_logs: (mvbdu,mvbdu,bool) binary - val mvbdu_false: mvbdu constant - val mvbdu_true: mvbdu constant - val mvbdu_not: (mvbdu,mvbdu) unary - val mvbdu_id: (mvbdu,mvbdu) unary - val mvbdu_unary_true: (mvbdu,mvbdu) unary - val mvbdu_unary_false: (mvbdu,mvbdu) unary - val mvbdu_and: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_or: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_xor: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nand: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nor: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_imply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_rev_imply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_equiv: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nimply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nrev_imply: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_bi_true: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_bi_false: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_fst: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_snd: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nfst: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_nsnd: (mvbdu,mvbdu,mvbdu) binary - val mvbdu_redefine: (mvbdu,hconsed_association_list,mvbdu) binary - val mvbdu_redefine_range: (mvbdu,hconsed_range_list,mvbdu) binary - val mvbdu_subseteq: (mvbdu,mvbdu,bool) binary - val mvbdu_of_hconsed_asso: (hconsed_association_list,mvbdu) unary - val mvbdu_of_association_list: ((key * value) list,mvbdu) unary - val mvbdu_of_sorted_association_list: ((key * value) list,mvbdu) unary - val mvbdu_of_reverse_sorted_association_list: ((key * value) list,mvbdu) unary - val mvbdu_of_hconsed_range: (hconsed_range_list,mvbdu) unary - val mvbdu_of_range_list: ((key * (value option * value option)) list,mvbdu) unary - val mvbdu_of_sorted_range_list: ((key * (value option * value option)) list,mvbdu) unary - val mvbdu_of_reverse_sorted_range_list: ((key * (value option * value option)) list,mvbdu) unary - - val mvbdu_rename: (mvbdu,hconsed_renaming_list,mvbdu) binary - - val mvbdu_project_keep_only: (mvbdu,hconsed_variables_list,mvbdu) binary - val mvbdu_project_abstract_away: (mvbdu,hconsed_variables_list,mvbdu) binary - val mvbdu_cartesian_decomposition_depth: (mvbdu,int,mvbdu option * mvbdu list) binary - val mvbdu_full_cartesian_decomposition: (mvbdu,mvbdu list) unary - - val mvbdu_cartesian_abstraction: (mvbdu,mvbdu list) unary - - val build_association_list: ((key * value) list,hconsed_association_list) unary - val build_sorted_association_list: ((key * value) list,hconsed_association_list) unary - val build_reverse_sorted_association_list: ((key * value) list,hconsed_association_list) unary - val empty_association_list : hconsed_association_list constant - - val build_range_list: ((key * (value option * value option)) list,hconsed_range_list) unary - val build_sorted_range_list: ((key * (value option * value option)) list,hconsed_range_list) unary - val build_reverse_sorted_range_list: ((key * (value option * value option)) list,hconsed_range_list) unary - val empty_range_list : hconsed_range_list constant - - - val build_variables_list: (key list,hconsed_variables_list) unary - val build_sorted_variables_list: (key list,hconsed_variables_list) unary - val build_reverse_sorted_variables_list: (key list,hconsed_variables_list) unary - val empty_variables_list: hconsed_variables_list constant - - val build_renaming_list: ((key * key) list,hconsed_renaming_list) unary - val build_sorted_renaming_list: ((key * key) list,hconsed_renaming_list) unary - val build_reverse_sorted_renaming_list: ((key * key) list,hconsed_renaming_list) unary - val empty_renaming_list : hconsed_renaming_list constant - - val overwrite_association_lists: (hconsed_association_list,hconsed_association_list,hconsed_association_list) binary - val merge_variables_lists: (hconsed_variables_list,hconsed_variables_list,hconsed_variables_list) binary - val nbr_variables: (hconsed_variables_list,int) unary - val extensional_of_variables_list: (hconsed_variables_list,key list) unary - val extensional_of_association_list: (hconsed_association_list,(key*value) list) unary - val extensional_of_range_list: (hconsed_range_list,(key*(value option*value option)) list) unary - val extensional_of_mvbdu: (mvbdu,(key * value) list list) unary - - val variables_list_of_mvbdu: (mvbdu,hconsed_variables_list) unary - - val print: Remanent_parameters_sig.parameters -> mvbdu -> unit - val print_association_list: Remanent_parameters_sig.parameters -> hconsed_association_list -> unit - val print_variables_list: Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit - - val store_by_variables_list: - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - 'data -> - List_sig.hash_key -> - 'map -> - Exception.method_handler * 'data) -> - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - List_sig.hash_key -> - 'data -> - 'map -> - Exception.method_handler * 'map) -> - 'data -> - ('data,'data,'data) binary -> - (hconsed_variables_list,'data,'map,'map) ternary - - val store_by_mvbdu: - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - 'data -> - Mvbdu_sig.hash_key -> - 'map -> - Exception.method_handler * 'data) -> - ( Remanent_parameters_sig.parameters -> - Exception.method_handler -> - Mvbdu_sig.hash_key -> - 'data -> - 'map -> - Exception.method_handler * 'map) -> - 'data -> - ('data,'data,'data) binary -> - (mvbdu,'data,'map,'map) ternary - - val last_entry: (unit,int) unary - val hash_of_range_list: hconsed_range_list -> int - val hash_of_association_list: hconsed_association_list -> int - val hash_of_variables_list: hconsed_variables_list -> int - - end - -module type Internalized_mvbdu = - sig - type key - type value - type mvbdu - type handler = - (Boolean_mvbdu.memo_tables,Boolean_mvbdu.mvbdu_dic,Boolean_mvbdu.association_list_dic,Boolean_mvbdu.range_list_dic,Boolean_mvbdu.variables_list_dic,bool,int) Memo_sig.handler - type hconsed_range_list - type hconsed_association_list - type hconsed_variables_list - type hconsed_renaming_list - - val init: Remanent_parameters_sig.parameters -> unit - val import_handler: handler -> unit - val export_handler: Exception.method_handler-> Exception.method_handler * handler option - val is_init: unit -> bool - val equal: mvbdu -> mvbdu -> bool - val mvbdu_false: unit -> mvbdu - val mvbdu_true: unit -> mvbdu - val mvbdu_not: mvbdu -> mvbdu - val mvbdu_id: mvbdu -> mvbdu - val mvbdu_unary_true: mvbdu -> mvbdu - val mvbdu_unary_false: mvbdu -> mvbdu - val mvbdu_and: mvbdu -> mvbdu -> mvbdu - val mvbdu_or: mvbdu -> mvbdu -> mvbdu - val mvbdu_xor: mvbdu -> mvbdu -> mvbdu - val mvbdu_nand: mvbdu -> mvbdu -> mvbdu - val mvbdu_nor: mvbdu -> mvbdu -> mvbdu - val mvbdu_imply: mvbdu -> mvbdu -> mvbdu - val mvbdu_rev_imply: mvbdu -> mvbdu -> mvbdu - val mvbdu_equiv: mvbdu -> mvbdu -> mvbdu - val mvbdu_nimply: mvbdu -> mvbdu -> mvbdu - val mvbdu_nrev_imply: mvbdu -> mvbdu -> mvbdu - val mvbdu_bi_true: mvbdu -> mvbdu -> mvbdu - val mvbdu_bi_false: mvbdu -> mvbdu -> mvbdu - val mvbdu_fst: mvbdu -> mvbdu -> mvbdu - val mvbdu_snd: mvbdu -> mvbdu -> mvbdu - val mvbdu_nfst: mvbdu -> mvbdu -> mvbdu - val mvbdu_nsnd: mvbdu -> mvbdu -> mvbdu - val mvbdu_redefine: mvbdu -> hconsed_association_list -> mvbdu - val mvbdu_redefine_range: mvbdu -> hconsed_range_list -> mvbdu - val mvbdu_subseteq: mvbdu -> mvbdu -> bool - val mvbdu_of_hconsed_asso: hconsed_association_list -> mvbdu - val mvbdu_of_association_list: (key * value) list -> mvbdu - val mvbdu_of_sorted_association_list: (key * value) list -> mvbdu - val mvbdu_of_reverse_sorted_association_list: (key * value) list -> mvbdu - val mvbdu_of_hconsed_range: hconsed_range_list -> mvbdu - val mvbdu_of_range_list: (key * (value option * value option)) list -> mvbdu - val mvbdu_of_sorted_range_list: (key * (value option * value option)) list -> mvbdu - val mvbdu_of_reverse_sorted_range_list: (key * (value option * value option)) list -> mvbdu - - - val mvbdu_rename: mvbdu -> hconsed_renaming_list -> mvbdu - val mvbdu_project_abstract_away: mvbdu -> hconsed_variables_list -> mvbdu - val mvbdu_project_keep_only: mvbdu -> hconsed_variables_list -> mvbdu - val mvbdu_cartesian_abstraction: mvbdu -> mvbdu list - val mvbdu_cartesian_decomposition_depth: mvbdu -> int -> mvbdu option * mvbdu list - val mvbdu_full_cartesian_decomposition: mvbdu -> mvbdu list - - val build_association_list: (key * value) list -> hconsed_association_list - val build_sorted_association_list: (key * value) list -> hconsed_association_list - val build_reverse_sorted_association_list: (key * value) list -> hconsed_association_list - val empty_association_list : unit -> hconsed_association_list - - val build_range_list: (key * (value option * value option)) list -> hconsed_range_list - val build_sorted_range_list: (key * (value option * value option)) list -> hconsed_range_list - val build_reverse_sorted_range_list: (key * (value option * value option)) list -> hconsed_range_list - val empty_range_list : unit -> hconsed_range_list - - val build_variables_list: key list -> hconsed_variables_list - val build_sorted_variables_list: key list -> hconsed_variables_list - val build_reverse_sorted_variables_list: key list -> hconsed_variables_list - val empty_variables_list : unit -> hconsed_variables_list - val build_renaming_list: (key * key) list -> hconsed_renaming_list - val build_sorted_renaming_list: (key * key) list -> hconsed_renaming_list - val build_reverse_sorted_renaming_list: (key * key) list -> hconsed_renaming_list - val empty_renaming_list : unit -> hconsed_renaming_list - - val overwrite_association_lists: hconsed_association_list -> hconsed_association_list -> hconsed_association_list - val merge_variables_lists: hconsed_variables_list -> hconsed_variables_list -> hconsed_variables_list - val nbr_variables: hconsed_variables_list -> int - val extensional_of_variables_list: hconsed_variables_list -> key list - val extensional_of_association_list: hconsed_association_list -> (key*value) list - val extensional_of_mvbdu: mvbdu -> (key * value) list list - - val variables_list_of_mvbdu: mvbdu -> hconsed_variables_list - - val print: Remanent_parameters_sig.parameters -> mvbdu -> unit - val print_association_list: Remanent_parameters_sig.parameters -> hconsed_association_list -> unit - val print_variables_list: Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit - val hash_of_association_list: hconsed_association_list -> int - val hash_of_variables_list: hconsed_variables_list -> int - - end - -module type Nul = - sig - end - -module Optimize (M:Mvbdu with type key = int and type value = int) : - Mvbdu - with type mvbdu = M.mvbdu and type key = int and type value = int - -module Internalize (M:Mvbdu with type key = int and type value = int) : +module type Mvbdu = sig + type key + type value + + type handler = + ( Boolean_mvbdu.memo_tables, + Boolean_mvbdu.mvbdu_dic, + Boolean_mvbdu.association_list_dic, + Boolean_mvbdu.range_list_dic, + Boolean_mvbdu.variables_list_dic, + bool, + int ) + Memo_sig.handler + + type mvbdu + type hconsed_range_list + type hconsed_association_list + type hconsed_variables_list + type hconsed_renaming_list + + type 'output constant = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + Exception.method_handler * handler * 'output + + type ('input, 'output) unary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input -> + Exception.method_handler * handler * 'output + + type ('input1, 'input2, 'output) binary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input1 -> + 'input2 -> + Exception.method_handler * handler * 'output + + type ('input1, 'input2, 'input3, 'output) ternary = + Remanent_parameters_sig.parameters -> + handler -> + Exception.method_handler -> + 'input1 -> + 'input2 -> + 'input3 -> + Exception.method_handler * handler * 'output + + val init : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Exception.method_handler * handler + + val is_init : unit -> bool + + val get_handler : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Exception.method_handler * handler + + val reset : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Exception.method_handler * handler + + val equal : mvbdu -> mvbdu -> bool + val equal_with_logs : (mvbdu, mvbdu, bool) binary + val mvbdu_false : mvbdu constant + val mvbdu_true : mvbdu constant + val mvbdu_not : (mvbdu, mvbdu) unary + val mvbdu_id : (mvbdu, mvbdu) unary + val mvbdu_unary_true : (mvbdu, mvbdu) unary + val mvbdu_unary_false : (mvbdu, mvbdu) unary + val mvbdu_and : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_or : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_xor : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nand : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nor : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_imply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_rev_imply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_equiv : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nimply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nrev_imply : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_bi_true : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_bi_false : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_fst : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_snd : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nfst : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_nsnd : (mvbdu, mvbdu, mvbdu) binary + val mvbdu_redefine : (mvbdu, hconsed_association_list, mvbdu) binary + val mvbdu_redefine_range : (mvbdu, hconsed_range_list, mvbdu) binary + val mvbdu_subseteq : (mvbdu, mvbdu, bool) binary + val mvbdu_of_hconsed_asso : (hconsed_association_list, mvbdu) unary + val mvbdu_of_association_list : ((key * value) list, mvbdu) unary + val mvbdu_of_sorted_association_list : ((key * value) list, mvbdu) unary + + val mvbdu_of_reverse_sorted_association_list : + ((key * value) list, mvbdu) unary + + val mvbdu_of_hconsed_range : (hconsed_range_list, mvbdu) unary + + val mvbdu_of_range_list : + ((key * (value option * value option)) list, mvbdu) unary + + val mvbdu_of_sorted_range_list : + ((key * (value option * value option)) list, mvbdu) unary + + val mvbdu_of_reverse_sorted_range_list : + ((key * (value option * value option)) list, mvbdu) unary + + val mvbdu_rename : (mvbdu, hconsed_renaming_list, mvbdu) binary + val mvbdu_project_keep_only : (mvbdu, hconsed_variables_list, mvbdu) binary + + val mvbdu_project_abstract_away : + (mvbdu, hconsed_variables_list, mvbdu) binary + + val mvbdu_cartesian_decomposition_depth : + (mvbdu, int, mvbdu option * mvbdu list) binary + + val mvbdu_full_cartesian_decomposition : (mvbdu, mvbdu list) unary + val mvbdu_cartesian_abstraction : (mvbdu, mvbdu list) unary + + val build_association_list : + ((key * value) list, hconsed_association_list) unary + + val build_sorted_association_list : + ((key * value) list, hconsed_association_list) unary + + val build_reverse_sorted_association_list : + ((key * value) list, hconsed_association_list) unary + + val empty_association_list : hconsed_association_list constant + + val build_range_list : + ((key * (value option * value option)) list, hconsed_range_list) unary + + val build_sorted_range_list : + ((key * (value option * value option)) list, hconsed_range_list) unary + + val build_reverse_sorted_range_list : + ((key * (value option * value option)) list, hconsed_range_list) unary + + val empty_range_list : hconsed_range_list constant + val build_variables_list : (key list, hconsed_variables_list) unary + val build_sorted_variables_list : (key list, hconsed_variables_list) unary + + val build_reverse_sorted_variables_list : + (key list, hconsed_variables_list) unary + + val empty_variables_list : hconsed_variables_list constant + val build_renaming_list : ((key * key) list, hconsed_renaming_list) unary + + val build_sorted_renaming_list : + ((key * key) list, hconsed_renaming_list) unary + + val build_reverse_sorted_renaming_list : + ((key * key) list, hconsed_renaming_list) unary + + val empty_renaming_list : hconsed_renaming_list constant + + val overwrite_association_lists : + ( hconsed_association_list, + hconsed_association_list, + hconsed_association_list ) + binary + + val merge_variables_lists : + ( hconsed_variables_list, + hconsed_variables_list, + hconsed_variables_list ) + binary + + val nbr_variables : (hconsed_variables_list, int) unary + val extensional_of_variables_list : (hconsed_variables_list, key list) unary + + val extensional_of_association_list : + (hconsed_association_list, (key * value) list) unary + + val extensional_of_range_list : + (hconsed_range_list, (key * (value option * value option)) list) unary + + val extensional_of_mvbdu : (mvbdu, (key * value) list list) unary + val variables_list_of_mvbdu : (mvbdu, hconsed_variables_list) unary + val print : Remanent_parameters_sig.parameters -> mvbdu -> unit + + val print_association_list : + Remanent_parameters_sig.parameters -> hconsed_association_list -> unit + + val print_variables_list : + Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit + + val store_by_variables_list : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'data -> + List_sig.hash_key -> + 'map -> + Exception.method_handler * 'data) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + List_sig.hash_key -> + 'data -> + 'map -> + Exception.method_handler * 'map) -> + 'data -> + ('data, 'data, 'data) binary -> + (hconsed_variables_list, 'data, 'map, 'map) ternary + + val store_by_mvbdu : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'data -> + Mvbdu_sig.hash_key -> + 'map -> + Exception.method_handler * 'data) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Mvbdu_sig.hash_key -> + 'data -> + 'map -> + Exception.method_handler * 'map) -> + 'data -> + ('data, 'data, 'data) binary -> + (mvbdu, 'data, 'map, 'map) ternary + + val last_entry : (unit, int) unary + val hash_of_range_list : hconsed_range_list -> int + val hash_of_association_list : hconsed_association_list -> int + val hash_of_variables_list : hconsed_variables_list -> int +end + +module type Internalized_mvbdu = sig + type key + type value + type mvbdu + + type handler = + ( Boolean_mvbdu.memo_tables, + Boolean_mvbdu.mvbdu_dic, + Boolean_mvbdu.association_list_dic, + Boolean_mvbdu.range_list_dic, + Boolean_mvbdu.variables_list_dic, + bool, + int ) + Memo_sig.handler + + type hconsed_range_list + type hconsed_association_list + type hconsed_variables_list + type hconsed_renaming_list + + val init : Remanent_parameters_sig.parameters -> unit + val import_handler : handler -> unit + + val export_handler : + Exception.method_handler -> Exception.method_handler * handler option + + val is_init : unit -> bool + val equal : mvbdu -> mvbdu -> bool + val mvbdu_false : unit -> mvbdu + val mvbdu_true : unit -> mvbdu + val mvbdu_not : mvbdu -> mvbdu + val mvbdu_id : mvbdu -> mvbdu + val mvbdu_unary_true : mvbdu -> mvbdu + val mvbdu_unary_false : mvbdu -> mvbdu + val mvbdu_and : mvbdu -> mvbdu -> mvbdu + val mvbdu_or : mvbdu -> mvbdu -> mvbdu + val mvbdu_xor : mvbdu -> mvbdu -> mvbdu + val mvbdu_nand : mvbdu -> mvbdu -> mvbdu + val mvbdu_nor : mvbdu -> mvbdu -> mvbdu + val mvbdu_imply : mvbdu -> mvbdu -> mvbdu + val mvbdu_rev_imply : mvbdu -> mvbdu -> mvbdu + val mvbdu_equiv : mvbdu -> mvbdu -> mvbdu + val mvbdu_nimply : mvbdu -> mvbdu -> mvbdu + val mvbdu_nrev_imply : mvbdu -> mvbdu -> mvbdu + val mvbdu_bi_true : mvbdu -> mvbdu -> mvbdu + val mvbdu_bi_false : mvbdu -> mvbdu -> mvbdu + val mvbdu_fst : mvbdu -> mvbdu -> mvbdu + val mvbdu_snd : mvbdu -> mvbdu -> mvbdu + val mvbdu_nfst : mvbdu -> mvbdu -> mvbdu + val mvbdu_nsnd : mvbdu -> mvbdu -> mvbdu + val mvbdu_redefine : mvbdu -> hconsed_association_list -> mvbdu + val mvbdu_redefine_range : mvbdu -> hconsed_range_list -> mvbdu + val mvbdu_subseteq : mvbdu -> mvbdu -> bool + val mvbdu_of_hconsed_asso : hconsed_association_list -> mvbdu + val mvbdu_of_association_list : (key * value) list -> mvbdu + val mvbdu_of_sorted_association_list : (key * value) list -> mvbdu + val mvbdu_of_reverse_sorted_association_list : (key * value) list -> mvbdu + val mvbdu_of_hconsed_range : hconsed_range_list -> mvbdu + val mvbdu_of_range_list : (key * (value option * value option)) list -> mvbdu + + val mvbdu_of_sorted_range_list : + (key * (value option * value option)) list -> mvbdu + + val mvbdu_of_reverse_sorted_range_list : + (key * (value option * value option)) list -> mvbdu + + val mvbdu_rename : mvbdu -> hconsed_renaming_list -> mvbdu + val mvbdu_project_abstract_away : mvbdu -> hconsed_variables_list -> mvbdu + val mvbdu_project_keep_only : mvbdu -> hconsed_variables_list -> mvbdu + val mvbdu_cartesian_abstraction : mvbdu -> mvbdu list + + val mvbdu_cartesian_decomposition_depth : + mvbdu -> int -> mvbdu option * mvbdu list + + val mvbdu_full_cartesian_decomposition : mvbdu -> mvbdu list + val build_association_list : (key * value) list -> hconsed_association_list + + val build_sorted_association_list : + (key * value) list -> hconsed_association_list + + val build_reverse_sorted_association_list : + (key * value) list -> hconsed_association_list + + val empty_association_list : unit -> hconsed_association_list + + val build_range_list : + (key * (value option * value option)) list -> hconsed_range_list + + val build_sorted_range_list : + (key * (value option * value option)) list -> hconsed_range_list + + val build_reverse_sorted_range_list : + (key * (value option * value option)) list -> hconsed_range_list + + val empty_range_list : unit -> hconsed_range_list + val build_variables_list : key list -> hconsed_variables_list + val build_sorted_variables_list : key list -> hconsed_variables_list + val build_reverse_sorted_variables_list : key list -> hconsed_variables_list + val empty_variables_list : unit -> hconsed_variables_list + val build_renaming_list : (key * key) list -> hconsed_renaming_list + val build_sorted_renaming_list : (key * key) list -> hconsed_renaming_list + + val build_reverse_sorted_renaming_list : + (key * key) list -> hconsed_renaming_list + + val empty_renaming_list : unit -> hconsed_renaming_list + + val overwrite_association_lists : + hconsed_association_list -> + hconsed_association_list -> + hconsed_association_list + + val merge_variables_lists : + hconsed_variables_list -> hconsed_variables_list -> hconsed_variables_list + + val nbr_variables : hconsed_variables_list -> int + val extensional_of_variables_list : hconsed_variables_list -> key list + + val extensional_of_association_list : + hconsed_association_list -> (key * value) list + + val extensional_of_mvbdu : mvbdu -> (key * value) list list + val variables_list_of_mvbdu : mvbdu -> hconsed_variables_list + val print : Remanent_parameters_sig.parameters -> mvbdu -> unit + + val print_association_list : + Remanent_parameters_sig.parameters -> hconsed_association_list -> unit + + val print_variables_list : + Remanent_parameters_sig.parameters -> hconsed_variables_list -> unit + + val hash_of_association_list : hconsed_association_list -> int + val hash_of_variables_list : hconsed_variables_list -> int +end + +module type Nul = sig end + +module Optimize (M : Mvbdu with type key = int and type value = int) : + Mvbdu with type mvbdu = M.mvbdu and type key = int and type value = int + +module Internalize (M : Mvbdu with type key = int and type value = int) : Internalized_mvbdu - with type mvbdu = M.mvbdu and type key = int and type value = int + with type mvbdu = M.mvbdu + and type key = int + and type value = int -module Optimize_internalized (M:Internalized_mvbdu with type key = int and type value = int) : +module Optimize_internalized + (M : Internalized_mvbdu with type key = int and type value = int) : Internalized_mvbdu - with type mvbdu = M.mvbdu and type key = int and type value = int - -module Make : Nul -> Mvbdu with type key = int and type value = int -module Mvbdu:Mvbdu with type key = int and type value = int -module IntMvbdu:Internalized_mvbdu with type key = int and type value = int and type mvbdu= Mvbdu.mvbdu -module Optimized_Mvbdu:Mvbdu with type key = int and type value = int -module Optimized_IntMvbdu:Internalized_mvbdu with type key = int and type value = int -module Optimized_IntMvbdu_bis:Internalized_mvbdu with type key = int and type value = int + with type mvbdu = M.mvbdu + and type key = int + and type value = int + +module Make : functor (_ : Nul) -> + Mvbdu with type key = int and type value = int + +module Mvbdu : Mvbdu with type key = int and type value = int + +module IntMvbdu : + Internalized_mvbdu + with type key = int + and type value = int + and type mvbdu = Mvbdu.mvbdu + +module Optimized_Mvbdu : Mvbdu with type key = int and type value = int + +module Optimized_IntMvbdu : + Internalized_mvbdu with type key = int and type value = int + +module Optimized_IntMvbdu_bis : + Internalized_mvbdu with type key = int and type value = int diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.ml b/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.ml index 663ee5aec7..970ce8d576 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.ml @@ -1,7 +1,6 @@ type comparison_op = LTEQ | LT | GT | GTEQ | EQ -let string_of_op = - function +let string_of_op = function | LTEQ -> "<=" | LT -> "<" | GT -> ">" @@ -10,324 +9,324 @@ let string_of_op = let string_of_var = Occu1.string_of_trans -type restriction = - { - tests: (Occu1.trans * comparison_op * int) list ; - invertible_assignments : (Occu1.trans * int) list ; - non_invertible_assignments : (Occu1.trans * int) list ; - } +type restriction = { + tests: (Occu1.trans * comparison_op * int) list; + invertible_assignments: (Occu1.trans * int) list; + non_invertible_assignments: (Occu1.trans * int) list; +} let empty_restriction = - {tests=[];invertible_assignments=[];non_invertible_assignments=[]} + { tests = []; invertible_assignments = []; non_invertible_assignments = [] } -type static = - { - counters: Ckappa_sig.AgentSite_map_and_set.Set.t ; - packs: - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t ; - backward_pointers: - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t ; - rule_restrictions: - restriction - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t ; - rule_creation: - (Occu1.trans * int) list list - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t; - } +type static = { + counters: Ckappa_sig.AgentSite_map_and_set.Set.t; + packs: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + backward_pointers: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t; + rule_restrictions: + restriction Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t; + rule_creation: + (Occu1.trans * int) list list + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .t + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t; +} - - let print_packs parameters handler error (packs, _backward_dependences) = - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sPacks (counters)" - (Remanent_parameters.get_prefix parameters) - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let error = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error agent a -> - let error, agent_string = - Handler.translate_agent - parameters error handler - agent - in - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error counter s -> - let error, counter_string = +let print_packs parameters handler error (packs, _backward_dependences) = + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sPacks (counters)" + (Remanent_parameters.get_prefix parameters) + in + let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let error = + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.iter parameters error + (fun parameters error agent a -> + let error, agent_string = + Handler.translate_agent parameters error handler agent + in + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error counter s -> + let error, counter_string = + match + Handler.translate_site parameters error handler agent counter + with + | error, Ckappa_sig.Counter s -> error, s + | error, (Ckappa_sig.Internal _ | Ckappa_sig.Binding _) -> + Exception.warn parameters error __POS__ Exit "??" + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s %s.%s" + (Remanent_parameters.get_prefix parameters) + agent_string counter_string + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s " + (Remanent_parameters.get_prefix parameters) + in + Ckappa_sig.Site_map_and_set.Set.fold + (fun site error -> + let error, site_string = match - Handler.translate_site - parameters error handler - agent counter + Handler.translate_site parameters error handler agent site with - | error, Ckappa_sig.Counter s -> error, s - | error, (Ckappa_sig.Internal _ | Ckappa_sig.Binding _ ) - -> - Exception.warn parameters error __POS__ Exit "??" - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) + | ( error, + ( Ckappa_sig.Internal s + | Ckappa_sig.Binding s + | Ckappa_sig.Counter s ) ) -> + error, s in let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s %s.%s" - (Remanent_parameters.get_prefix parameters) - agent_string - counter_string + "%s," site_string in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s " - (Remanent_parameters.get_prefix parameters) - in - Ckappa_sig.Site_map_and_set.Set.fold - (fun site error -> - let error, site_string = - match - Handler.translate_site - parameters error handler - agent site - with - | error, - (Ckappa_sig.Internal s - | Ckappa_sig.Binding s - | Ckappa_sig.Counter s) -> error, s - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s," - site_string - in - error - ) s error - ) a) - packs - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - error + error) + s error) + a) + packs + in + let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + error let print_restriction parameters _handler error restriction = let () = - if restriction.tests = [] - then () - else + if restriction.tests = [] then + () + else ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s test: " (Remanent_parameters.get_prefix parameters) in let () = List.iter - (fun (var,op,int) -> - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s%s%i," - (string_of_var var) - (string_of_op op) - int) + (fun (var, op, int) -> + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s%i," (string_of_var var) (string_of_op op) int) restriction.tests in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () + ) in let () = - if restriction.invertible_assignments = [] - then () - else + if restriction.invertible_assignments = [] then + () + else ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s inversible_assignemets: " (Remanent_parameters.get_prefix parameters) in let () = List.iter - (fun (var,int) -> - if int=0 then () else - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s%s%i," - (string_of_var var) - (if int>0 then "+=" else if int<0 then "-=" else "") - (if int>0 then int else -int)) + (fun (var, int) -> + if int = 0 then + () + else + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s%i," (string_of_var var) + (if int > 0 then + "+=" + else if int < 0 then + "-=" + else + "") + (if int > 0 then + int + else + -int)) restriction.invertible_assignments in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () + ) in let () = - if restriction.non_invertible_assignments = [] - then () - else + if restriction.non_invertible_assignments = [] then + () + else ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s non_inversible_assignemets: " (Remanent_parameters.get_prefix parameters) in let () = List.iter - (fun (var,int) -> - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s:=%i," - (string_of_var var) - int) + (fun (var, int) -> + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s:=%i," (string_of_var var) int) restriction.non_invertible_assignments in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () + ) in error let print_agent_restriction parameters handler error agent_restriction = -Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters error - (fun parameters error site_id restriction -> - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s Pack %i" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.int_of_site_name site_id) - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - print_restriction - parameters handler error restriction) - agent_restriction - -let print_rule_restriction parameters handler error rule_restriction - = -Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.iter - parameters error - (fun parameters error agent_id agent_restriction -> - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s Agent %i" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.int_of_agent_id agent_id) - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - print_agent_restriction - parameters handler error - agent_restriction) - rule_restriction - -let print_restrictions parameters handler error restrictions = + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error site_id restriction -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%srule restrictions (counters)" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s Pack %i" (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.int_of_site_name site_id) in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let error = - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters error - (fun parameters error rule_id rule_restriction -> - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s Rule %i" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.int_of_rule_id rule_id) - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - print_rule_restriction parameters handler error rule_restriction - ) - restrictions + print_restriction parameters handler error restriction) + agent_restriction + +let print_rule_restriction parameters handler error rule_restriction = + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.iter parameters error + (fun parameters error agent_id agent_restriction -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s Agent %i" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.int_of_agent_id agent_id) in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + print_agent_restriction parameters handler error agent_restriction) + rule_restriction + +let print_restrictions parameters handler error restrictions = + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%srule restrictions (counters)" + (Remanent_parameters.get_prefix parameters) + in + let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let error = + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.iter parameters error + (fun parameters error rule_id rule_restriction -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s Rule %i" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.int_of_rule_id rule_id) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + print_rule_restriction parameters handler error rule_restriction) + restrictions + in + error - let print_creations parameters _handler error creations = +let print_creations parameters _handler error creations = + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%srule creations (counters)" + (Remanent_parameters.get_prefix parameters) + in + let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let error = + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error rule_id rule_creation -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%srule creations (counters)" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s Rule %i" (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.int_of_rule_id rule_id) in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let error = - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters error - (fun parameters error rule_id rule_creation -> - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s Rule %i" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.int_of_rule_id rule_id) - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.iter - parameters error - (fun parameters error (agent_type,counter) creation -> + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .iter parameters error + (fun parameters error (agent_type, counter) creation -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s Agent_type %i Counter %i " + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.int_of_agent_name agent_type) + (Ckappa_sig.int_of_site_name counter) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + List.iter + (fun list -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s Agent_type %i Counter %i " + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s " (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.int_of_agent_name agent_type) - (Ckappa_sig.int_of_site_name counter) in let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) + List.iter + (fun (site, state) -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s:=%i," + (Occu1.string_of_trans site) + state + in + ()) + list in let () = - List.iter - (fun list -> - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s " - (Remanent_parameters.get_prefix parameters) - in - let () = - List.iter - (fun (site, state) -> - - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s:=%i," - (Occu1.string_of_trans site) - state - in ()) list - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in () - ) - creation in error) - - rule_creation) - creations - in - error + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + ()) + creation + in + error) + rule_creation) + creations + in + error let print parameters handler error static = let packs = static.packs in diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.mli b/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.mli index 2b9cc1e0b7..52b85d3ede 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/counters_domain_type.mli @@ -1,65 +1,66 @@ type comparison_op = LTEQ | LT | GT | GTEQ | EQ -type restriction = - { - tests: (Occu1.trans * comparison_op * int) list ; - invertible_assignments : (Occu1.trans * int) list ; - non_invertible_assignments : (Occu1.trans * int) list ; - } +type restriction = { + tests: (Occu1.trans * comparison_op * int) list; + invertible_assignments: (Occu1.trans * int) list; + non_invertible_assignments: (Occu1.trans * int) list; +} -val empty_restriction: restriction +val empty_restriction : restriction -type static = - { - counters: Ckappa_sig.AgentSite_map_and_set.Set.t ; - packs: - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t ; - backward_pointers: - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t ; - rule_restrictions: - restriction - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t ; - rule_creation: - (Occu1.trans * int) list list - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t; - } +type static = { + counters: Ckappa_sig.AgentSite_map_and_set.Set.t; + packs: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + backward_pointers: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t; + rule_restrictions: + restriction Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t; + rule_creation: + (Occu1.trans * int) list list + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .t + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t; +} - val print_restriction: - Remanent_parameters_sig.parameters -> - Cckappa_sig.kappa_handler -> - Exception.method_handler -> - restriction -> - Exception.method_handler +val print_restriction : + Remanent_parameters_sig.parameters -> + Cckappa_sig.kappa_handler -> + Exception.method_handler -> + restriction -> + Exception.method_handler -val print_agent_restriction: +val print_agent_restriction : Remanent_parameters_sig.parameters -> Cckappa_sig.kappa_handler -> Exception.method_handler -> restriction Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t -> Exception.method_handler -val print_rule_restriction: +val print_rule_restriction : Remanent_parameters_sig.parameters -> Cckappa_sig.kappa_handler -> Exception.method_handler -> - restriction Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t-> + restriction Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t -> Exception.method_handler -val print_restrictions: -Remanent_parameters_sig.parameters -> -Cckappa_sig.kappa_handler -> -Exception.method_handler -> -restriction Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t -Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t -> -Exception.method_handler +val print_restrictions : + Remanent_parameters_sig.parameters -> + Cckappa_sig.kappa_handler -> + Exception.method_handler -> + restriction Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.t -> + Exception.method_handler -val print: +val print : Remanent_parameters_sig.parameters -> Cckappa_sig.kappa_handler -> Exception.method_handler -> diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/dune b/core/KaSa_rep/abstract_domains/numerical_domains/dune index eb8d0e432b..7e5d94465b 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/dune +++ b/core/KaSa_rep/abstract_domains/numerical_domains/dune @@ -1,11 +1,19 @@ (library - (name kappa_numerical_domains) - (libraries kappa_kasa_frontend) - (flags (:standard -w @a - -open Kappa_parameters - -open Kappa_errors - -open Kappa_logging - -open Kappa_kasa_kastor_toolset - -open Kappa_generic_toolset - -open Kappa_kasa_frontend - ))) + (name kappa_numerical_domains) + (libraries kappa_kasa_frontend) + (flags + (:standard + -w + @a + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_logging + -open + Kappa_kasa_kastor_toolset + -open + Kappa_generic_toolset + -open + Kappa_kasa_frontend))) diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/fraction.ml b/core/KaSa_rep/abstract_domains/numerical_domains/fraction.ml index 9157b39bef..3c39270486 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/fraction.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/fraction.ml @@ -1,131 +1,146 @@ -type fraction={num:int;den:int} -type ffraction=Frac of fraction| Infinity | Unknown | Minfinity +type fraction = { num: int; den: int } +type ffraction = Frac of fraction | Infinity | Unknown | Minfinity let trunc a = match a with - | Frac{num=x;den=y}->x/y - | Infinity | Unknown | Minfinity -> raise Exit + | Frac { num = x; den = y } -> x / y + | Infinity | Unknown | Minfinity -> raise Exit -let rec floor_int a = +let rec floor_int a = match a with - | Frac{num=x;den=y}-> - begin - match x>=0,y>0 with - | true,true -> x/y - | false,false -> floor_int (Frac{num=(-x);den=(-y)}) - | true,false -> - cell_int (Frac{num=x;den=(-y)}) - | false,true -> - cell_int (Frac{num=(-x);den=y}) - end + | Frac { num = x; den = y } -> + (match x >= 0, y > 0 with + | true, true -> x / y + | false, false -> floor_int (Frac { num = -x; den = -y }) + | true, false -> -cell_int (Frac { num = x; den = -y }) + | false, true -> -cell_int (Frac { num = -x; den = y })) | Infinity | Unknown | Minfinity -> raise Exit -and cell_int a = - match a with - | Frac{num=x;den=y}-> - begin - match x>=0,y>0 with - | true,true -> - let q = x/y in - if q*y = x then q else q+1 - | false,false -> cell_int (Frac{num=(-x);den=(-y)}) - | true,false -> - floor_int (Frac{num=x;den=(-y)}) - | false,true -> - floor_int (Frac{num=(-x);den=y}) - end - | Infinity | Unknown | Minfinity -> raise Exit - -let zero = {num=0;den=1} -let pgcd a b = - let rec aux a b = - if b=0 then a - else aux b (a mod b) - in - let a,b=(abs a,abs b) in - if a + (match x >= 0, y > 0 with + | true, true -> + let q = x / y in + if q * y = x then + q + else + q + 1 + | false, false -> cell_int (Frac { num = -x; den = -y }) + | true, false -> -floor_int (Frac { num = x; den = -y }) + | false, true -> -floor_int (Frac { num = -x; den = y })) + | Infinity | Unknown | Minfinity -> raise Exit -let reduit {num=n;den=d} = - if n=0 then {num=0;den=1} - else let e=pgcd n d in - let n,d=n/e,d/e in - if d<0 then {num=(-n);den=(-d)} - else {num=n;den=d} +let zero = { num = 0; den = 1 } -let finf a b = ((a.num)*(b.den))<((a.den)*(b.num)) -let finfeq a b = ((a.num)*(b.den))<=((a.den)*(b.num)) +let pgcd a b = + let rec aux a b = + if b = 0 then + a + else + aux b (a mod b) + in + let a, b = abs a, abs b in + if a < b then + aux b a + else + aux a b + +let reduit { num = n; den = d } = + if n = 0 then + { num = 0; den = 1 } + else ( + let e = pgcd n d in + let n, d = n / e, d / e in + if d < 0 then + { num = -n; den = -d } + else + { num = n; den = d } + ) + +let finf a b = a.num * b.den < a.den * b.num +let finfeq a b = a.num * b.den <= a.den * b.num let fplus a b = - reduit {num=(a.num)*(b.den)+(a.den)*(b.num);den=(a.den)*(b.den)} + reduit { num = (a.num * b.den) + (a.den * b.num); den = a.den * b.den } let fmoins a b = - reduit {num=(a.num)*(b.den)-(a.den)*(b.num);den=(a.den)*(b.den)} - -let ffois a b = - reduit {num=(a.num)*(b.num);den=(a.den)*(b.den)} + reduit { num = (a.num * b.den) - (a.den * b.num); den = a.den * b.den } -let fdiv a b = - reduit {num=(a.num)*(b.den);den=(a.den)*(b.num)} +let ffois a b = reduit { num = a.num * b.num; den = a.den * b.den } +let fdiv a b = reduit { num = a.num * b.den; den = a.den * b.num } let ffdiv a b = - match (a,b) with - | Frac(a),Frac(b)->Frac(fdiv a b) - | Infinity,Frac(a) when a.num>0 -> Infinity - | Infinity,Frac(a) when a.num<0 -> Minfinity - | Minfinity,Frac(a) when a.num<0 -> Infinity - | Minfinity,Frac(a) when a.num>0 -> Minfinity - | Frac(_),Infinity -> Frac{num=0;den=1} - | Frac(_),Minfinity -> Frac{num=0;den=1} - | (Unknown, _) | (_, Unknown) - | (Infinity | Minfinity ),(Infinity | Minfinity | Frac _) -> Unknown - + match a, b with + | Frac a, Frac b -> Frac (fdiv a b) + | Infinity, Frac a when a.num > 0 -> Infinity + | Infinity, Frac a when a.num < 0 -> Minfinity + | Minfinity, Frac a when a.num < 0 -> Infinity + | Minfinity, Frac a when a.num > 0 -> Minfinity + | Frac _, Infinity -> Frac { num = 0; den = 1 } + | Frac _, Minfinity -> Frac { num = 0; den = 1 } + | Unknown, _ + | _, Unknown + | (Infinity | Minfinity), (Infinity | Minfinity | Frac _) -> + Unknown let ffplus a i b = - if (i.num)=0 then a - else (let c = (match b with Unknown -> Unknown - | Infinity when i.num>0 -> Infinity - | Minfinity when i.num>0 -> Minfinity - | Infinity -> Minfinity - | Minfinity -> Infinity - | Frac b -> Frac (ffois i b)) - in match a,c with (_,Frac c) when c.num=0 -> a - | (Unknown,_) -> Unknown - | _,Unknown -> Unknown - | Infinity,Minfinity -> Unknown - | Infinity,_ -> Infinity - | Minfinity,Infinity -> Unknown - | _,Infinity -> Infinity - | Minfinity,_ -> Minfinity - | _,Minfinity -> Minfinity - | Frac a,Frac b -> Frac(fplus a b)) - - -let ffneg a = ffplus (Frac zero) {num = -1; den =1} a + if i.num = 0 then + a + else ( + let c = + match b with + | Unknown -> Unknown + | Infinity when i.num > 0 -> Infinity + | Minfinity when i.num > 0 -> Minfinity + | Infinity -> Minfinity + | Minfinity -> Infinity + | Frac b -> Frac (ffois i b) + in + match a, c with + | _, Frac c when c.num = 0 -> a + | Unknown, _ -> Unknown + | _, Unknown -> Unknown + | Infinity, Minfinity -> Unknown + | Infinity, _ -> Infinity + | Minfinity, Infinity -> Unknown + | _, Infinity -> Infinity + | Minfinity, _ -> Minfinity + | _, Minfinity -> Minfinity + | Frac a, Frac b -> Frac (fplus a b) + ) + +let ffneg a = ffplus (Frac zero) { num = -1; den = 1 } a let ffmin a b = - match a,b with - | Unknown,_ - | _,Unknown -> raise Exit - | Minfinity,_ | _,Infinity -> a - | Frac(x),Frac(y) when ((fmoins x y).num<0) -> a - | (Infinity | Frac _),b -> b - -let ffinf a b = - match a,b with Unknown,_ | _,Unknown -> raise Exit - | Minfinity,_ | _,Infinity -> true - | Frac(x),Frac(y) when ((fmoins x y).num<0) -> true - | (Infinity | Frac _),_ -> false - + match a, b with + | Unknown, _ | _, Unknown -> raise Exit + | Minfinity, _ | _, Infinity -> a + | Frac x, Frac y when (fmoins x y).num < 0 -> a + | (Infinity | Frac _), b -> b + +let ffinf a b = + match a, b with + | Unknown, _ | _, Unknown -> raise Exit + | Minfinity, _ | _, Infinity -> true + | Frac x, Frac y when (fmoins x y).num < 0 -> true + | (Infinity | Frac _), _ -> false let ffmax a b = - match a,b with Unknown,_ | _,Unknown -> raise Exit - | Minfinity,_ | _,Infinity -> b - | Frac(x),Frac(y) when ((fmoins x y).num<0) -> b - | (a, (Minfinity | Frac _)) -> a - - - -let fsup a b =if (finf a b) then b else a + match a, b with + | Unknown, _ | _, Unknown -> raise Exit + | Minfinity, _ | _, Infinity -> b + | Frac x, Frac y when (fmoins x y).num < 0 -> b + | a, (Minfinity | Frac _) -> a + +let fsup a b = + if finf a b then + b + else + a let string_of a = if a.den = 1 then string_of_int a.num else - ("("^(string_of_int a.num)^"/"^(string_of_int a.den)^")") + "(" ^ string_of_int a.num ^ "/" ^ string_of_int a.den ^ ")" diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/fraction.mli b/core/KaSa_rep/abstract_domains/numerical_domains/fraction.mli index f2193d3384..2c305356fe 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/fraction.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/fraction.mli @@ -1,22 +1,20 @@ -type fraction={num:int;den:int} -type ffraction=Frac of fraction| Infinity | Unknown | Minfinity +type fraction = { num: int; den: int } +type ffraction = Frac of fraction | Infinity | Unknown | Minfinity -val zero:fraction -val string_of: fraction -> string - -val fsup: fraction -> fraction -> fraction -val finfeq: fraction -> fraction -> bool -val fplus: fraction -> fraction -> fraction -val ffois: fraction -> fraction -> fraction -val fmoins: fraction -> fraction -> fraction -val fdiv: fraction -> fraction -> fraction - -val ffmax: ffraction -> ffraction -> ffraction -val ffinf: ffraction -> ffraction -> bool -val ffmin: ffraction -> ffraction -> ffraction -val ffneg: ffraction -> ffraction -val ffdiv: ffraction -> ffraction -> ffraction -val ffplus: ffraction -> fraction -> ffraction -> ffraction -val cell_int: ffraction -> int -val floor_int: ffraction -> int -val trunc: ffraction -> int +val zero : fraction +val string_of : fraction -> string +val fsup : fraction -> fraction -> fraction +val finfeq : fraction -> fraction -> bool +val fplus : fraction -> fraction -> fraction +val ffois : fraction -> fraction -> fraction +val fmoins : fraction -> fraction -> fraction +val fdiv : fraction -> fraction -> fraction +val ffmax : ffraction -> ffraction -> ffraction +val ffinf : ffraction -> ffraction -> bool +val ffmin : ffraction -> ffraction -> ffraction +val ffneg : ffraction -> ffraction +val ffdiv : ffraction -> ffraction -> ffraction +val ffplus : ffraction -> fraction -> ffraction -> ffraction +val cell_int : ffraction -> int +val floor_int : ffraction -> int +val trunc : ffraction -> int diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/integer.ml b/core/KaSa_rep/abstract_domains/numerical_domains/integer.ml index 1ac4b4a8b8..dbf289c5bd 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/integer.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/integer.ml @@ -1,36 +1,46 @@ type unbounded = Bounded of int | Infinity -let plus x y = - match x,y with - Bounded(x),Bounded(y) -> Bounded(x+y) - | (Infinity | Bounded _), Infinity - | Infinity, Bounded _ -> Infinity -let min a b = - match a,b with - Bounded(x),Bounded(y) -> (if x a - | Infinity, _ -> b +let plus x y = + match x, y with + | Bounded x, Bounded y -> Bounded (x + y) + | (Infinity | Bounded _), Infinity | Infinity, Bounded _ -> Infinity -let minl l1 = - let rec aux q rep = - match q with [] -> rep - | a::b -> aux b (min a rep) - in match l1 with a::b -> aux b a - | _ -> raise Exit +let min a b = + match a, b with + | Bounded x, Bounded y -> + if x < y then + a + else + b + | Bounded _, Infinity -> a + | Infinity, _ -> b -let max a b = - match a,b with - Bounded(x),Bounded(y) -> (if x Infinity +let minl l1 = + let rec aux q rep = + match q with + | [] -> rep + | a :: b -> aux b (min a rep) + in + match l1 with + | a :: b -> aux b a + | _ -> raise Exit -let div2 x = - match x with - Bounded(x) -> Bounded(x/2) +let max a b = + match a, b with + | Bounded x, Bounded y -> + if x < y then + b + else + a + | (Infinity | Bounded _), Infinity | Infinity, Bounded _ -> Infinity + +let div2 x = + match x with + | Bounded x -> Bounded (x / 2) | Infinity -> Infinity -let p x y = - match x,y with - Bounded(x),Bounded(y) -> x>y - | (Infinity | Bounded _) , Infinity -> false - | Infinity, Bounded _ -> true +let p x y = + match x, y with + | Bounded x, Bounded y -> x > y + | (Infinity | Bounded _), Infinity -> false + | Infinity, Bounded _ -> true diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/integer.mli b/core/KaSa_rep/abstract_domains/numerical_domains/integer.mli index 724a1c723d..0e10597d8b 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/integer.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/integer.mli @@ -1,8 +1,8 @@ type unbounded = Bounded of int | Infinity -val plus: unbounded -> unbounded -> unbounded -val minl: unbounded list -> unbounded -val max: unbounded -> unbounded -> unbounded -val min: unbounded -> unbounded -> unbounded -val div2: unbounded -> unbounded -val p: unbounded -> unbounded -> bool +val plus : unbounded -> unbounded -> unbounded +val minl : unbounded list -> unbounded +val max : unbounded -> unbounded -> unbounded +val min : unbounded -> unbounded -> unbounded +val div2 : unbounded -> unbounded +val p : unbounded -> unbounded -> bool diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/intertab.ml b/core/KaSa_rep/abstract_domains/numerical_domains/intertab.ml index c307db5125..83f15ac0fb 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/intertab.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/intertab.ml @@ -2,222 +2,255 @@ open Intervalles open Fraction open Occu1 -module type Tabinter = -sig +module type Tabinter = sig type var type intervalle type intervalle_tab + val make : int -> intervalle_tab - val set : intervalle_tab -> var -> intervalle -> unit + val set : intervalle_tab -> var -> intervalle -> unit val read : intervalle_tab -> var -> intervalle - val affiche: + + val affiche : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> Exception.method_handler + intervalle_tab -> + Exception.method_handler + val copy : Remanent_parameters_sig.parameters -> Exception.method_handler -> intervalle_tab -> Exception.method_handler * intervalle_tab + val clef : intervalle_tab -> var list + val wide_place : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * var list + val union_place : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * var list + val union : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * intervalle_tab + val inter : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * intervalle_tab + val somme : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * intervalle_tab + val int_of_var_list : Remanent_parameters_sig.parameters -> - Exception.method_handler ->var list -> + Exception.method_handler -> + var list -> Exception.method_handler * intervalle_tab - val push : intervalle_tab -> var -> Fraction.fraction -> intervalle_tab + + val push : intervalle_tab -> var -> Fraction.fraction -> intervalle_tab val pushbool : intervalle_tab -> var -> intervalle_tab val equal : intervalle_tab -> intervalle_tab -> bool + val merge : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * intervalle_tab - val abstract_away: + val abstract_away : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> var list -> + intervalle_tab -> + var list -> Exception.method_handler * intervalle_tab - end -module Tabinter = - struct - type var = trans - type intervalle=Intervalles.intervalle +module Tabinter = struct + type var = trans + type intervalle = Intervalles.intervalle - type intervalle_tab = - { - i:(var,intervalle) Hashtbl.t; - k:var Working_list_imperative.working_list - } + type intervalle_tab = { + i: (var, intervalle) Hashtbl.t; + k: var Working_list_imperative.working_list; + } - - let make n = - { - i=Hashtbl.create n; - k=Working_list_imperative.make n - } + let make n = { i = Hashtbl.create n; k = Working_list_imperative.make n } let set t lambda v = - Working_list_imperative.push lambda (t.k) ; - (try (Hashtbl.remove (t.i) lambda) - with _ -> ()); - Hashtbl.add (t.i) lambda v + Working_list_imperative.push lambda t.k; + (try Hashtbl.remove t.i lambda with _ -> ()); + Hashtbl.add t.i lambda v let read t lambda = - try (Hashtbl.find (t.i) lambda) - with _ -> (let v = Intervalles.zero in - (set t lambda v;v)) + try Hashtbl.find t.i lambda + with _ -> + let v = Intervalles.zero in + set t lambda v; + v let copy parameter error t = - let j = - make (Remanent_parameters.get_empty_hashtbl_size - parameter) in - let () = List.iter - (fun x->set j x (read t x)) - (Working_list_imperative.list (t.k)) + let j = make (Remanent_parameters.get_empty_hashtbl_size parameter) in + let () = + List.iter (fun x -> set j x (read t x)) (Working_list_imperative.list t.k) in - error,j - - - let affiche parameters error t = - let error = - List.fold_left - (fun error x -> - if not (x = Occu1.Affine_cst) - then - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in - let () = Occu1.print_trans parameters x in - let error, inter_string = - Intervalles.string_of_intervalle parameters error (read t x) - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) ": %s" - inter_string - in error - else error - ) - error (Working_list_imperative.list t.k) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in error - - - let clef t = Working_list_imperative.list t.k - let wide_place parameters error t1 t2 = - let l= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let spe_push p = Working_list_imperative.push p l in - let changed=(ref false) in - let traite p = - let () = changed:=false in - let rep= - { - inf= - ( - if ffinf ((read t2 p).inf) ((read t1 p).inf) - then - if ffinf ((read t1 p).inf) (Fraction.ffneg (Frac !wide_max)) - then - if (read t1 p).inf = Minfinity - then Minfinity - else - (changed:=true;Minfinity ) - else - (changed:=true;(read t2 p).inf) - else ((read t1 p).inf)); - sup= - ( - if ffinf ((read t1 p).sup) (read t2 p).sup - then - if ffinf (Frac (!wide_max)) (read t1 p).sup - then - if (read t1 p).sup=Infinity - then Infinity - else (changed:=true;Infinity) - else (changed:=true;(read t2 p).sup) - else ((read t1 p).sup))} in - if (!changed) then (spe_push p;set t1 p rep) else () - in (List.iter traite (clef t2); - List.iter traite (clef t1); - error, Working_list_imperative.list l) - - let union_place parameters error t1 t2 = - let l= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let spe_push p = Working_list_imperative.push p l in - let changed=(ref false) in - let traite p = - let () = changed:=false in - let rep= - { - inf= - ( - if (ffinf ((read t2 p).inf) ((read t1 p).inf)) - then - (changed:=true;(read t2 p).inf) - else ((read t1 p).inf)); - sup= - ( - if (ffinf ((read t1 p).sup) (read t2 p).sup) - then - (changed:=true;(read t2 p).sup) - else ((read t1 p).sup))} - in - if (!changed) then (spe_push p;set t1 p rep) else () - in (List.iter traite (clef t2); - List.iter traite (clef t1); - error, Working_list_imperative.list l) - -let somme parameters error t1 t2 = - let l = - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let spe_push p = Working_list_imperative.push p l in - let () = List.iter spe_push (clef t1);List.iter spe_push (clef t2) in - let rep = make (Remanent_parameters.get_empty_hashtbl_size parameters) in - let () = - List.iter - (fun x->set rep x (iiplus (read t1 x) {num=1;den=1} (read t2 x))) (Working_list_imperative.list l) - in - error, rep + error, j + + let affiche parameters error t = + let error = + List.fold_left + (fun error x -> + if not (x = Occu1.Affine_cst) then ( + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = Occu1.print_trans parameters x in + let error, inter_string = + Intervalles.string_of_intervalle parameters error (read t x) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + ": %s" inter_string + in + error + ) else + error) + error + (Working_list_imperative.list t.k) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error + + let clef t = Working_list_imperative.list t.k + + let wide_place parameters error t1 t2 = + let l = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let spe_push p = Working_list_imperative.push p l in + let changed = ref false in + let traite p = + let () = changed := false in + let rep = + { + inf = + (if ffinf (read t2 p).inf (read t1 p).inf then + if ffinf (read t1 p).inf (Fraction.ffneg (Frac !wide_max)) then + if (read t1 p).inf = Minfinity then + Minfinity + else ( + changed := true; + Minfinity + ) + else ( + changed := true; + (read t2 p).inf + ) + else + (read t1 p).inf); + sup = + (if ffinf (read t1 p).sup (read t2 p).sup then + if ffinf (Frac !wide_max) (read t1 p).sup then + if (read t1 p).sup = Infinity then + Infinity + else ( + changed := true; + Infinity + ) + else ( + changed := true; + (read t2 p).sup + ) + else + (read t1 p).sup); + } + in + if !changed then ( + spe_push p; + set t1 p rep + ) else + () + in + List.iter traite (clef t2); + List.iter traite (clef t1); + error, Working_list_imperative.list l + + let union_place parameters error t1 t2 = + let l = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let spe_push p = Working_list_imperative.push p l in + let changed = ref false in + let traite p = + let () = changed := false in + let rep = + { + inf = + (if ffinf (read t2 p).inf (read t1 p).inf then ( + changed := true; + (read t2 p).inf + ) else + (read t1 p).inf); + sup = + (if ffinf (read t1 p).sup (read t2 p).sup then ( + changed := true; + (read t2 p).sup + ) else + (read t1 p).sup); + } + in + if !changed then ( + spe_push p; + set t1 p rep + ) else + () + in + List.iter traite (clef t2); + List.iter traite (clef t1); + error, Working_list_imperative.list l + + let somme parameters error t1 t2 = + let l = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let spe_push p = Working_list_imperative.push p l in + let () = + List.iter spe_push (clef t1); + List.iter spe_push (clef t2) + in + let rep = make (Remanent_parameters.get_empty_hashtbl_size parameters) in + let () = + List.iter + (fun x -> + set rep x (iiplus (read t1 x) { num = 1; den = 1 } (read t2 x))) + (Working_list_imperative.list l) + in + error, rep let inter parameters error t1 t2 = let l = @@ -225,64 +258,64 @@ let somme parameters error t1 t2 = (Remanent_parameters.get_empty_hashtbl_size parameters) in let spe_push p = Working_list_imperative.push p l in - let () = List.iter spe_push (clef t1);List.iter spe_push (clef t2) in + let () = + List.iter spe_push (clef t1); + List.iter spe_push (clef t2) + in let rep = make (Remanent_parameters.get_empty_hashtbl_size parameters) in let () = List.iter - (fun x->set rep x (cap_inter (read t1 x) (read t2 x))) (Working_list_imperative.list l) + (fun x -> set rep x (cap_inter (read t1 x) (read t2 x))) + (Working_list_imperative.list l) in error, rep - let union parameters error t1 t2 = - let l = - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let spe_push p = Working_list_imperative.push p l in - let () = - List.iter spe_push (clef t1) - in - let () = - List.iter spe_push (clef t2) - in - let rep = make (Remanent_parameters.get_empty_hashtbl_size parameters) in - let () = - List.iter - (fun x->set rep x (union (read t1 x) (read t2 x))) - (Working_list_imperative.list l) - in - error, rep + let union parameters error t1 t2 = + let l = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let spe_push p = Working_list_imperative.push p l in + let () = List.iter spe_push (clef t1) in + let () = List.iter spe_push (clef t2) in + let rep = make (Remanent_parameters.get_empty_hashtbl_size parameters) in + let () = + List.iter + (fun x -> set rep x (union (read t1 x) (read t2 x))) + (Working_list_imperative.list l) + in + error, rep let merge _parameters error t1 t2 = - List.iter (fun x->set t1 x (read t2 x)) (clef t2); + List.iter (fun x -> set t1 x (read t2 x)) (clef t2); error, t1 - let int_of_var_list parameters error l = - let i= - make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - List.iter (fun x->set i x {inf=Frac{num=1;den=1};sup=Frac{num=1;den=1}}) l; + let i = make (Remanent_parameters.get_empty_hashtbl_size parameters) in + List.iter + (fun x -> + set i x + { inf = Frac { num = 1; den = 1 }; sup = Frac { num = 1; den = 1 } }) + l; error, i - let push i x k = - set i x (iiplus (read i x) k {inf=Frac{num=1;den=1};sup=Frac{num=1;den=1}});i - -let pushbool i x = - set i x {inf=Frac{num=1;den=1};sup=Frac{num=1;den=1}};i + let push i x k = + set i x + (iiplus (read i x) k + { inf = Frac { num = 1; den = 1 }; sup = Frac { num = 1; den = 1 } }); + i -let equal i1 i2 = - List.for_all (fun x-> (read i1 x)=(read i2 x)) ((clef i1)@(clef i2)) + let pushbool i x = + set i x { inf = Frac { num = 1; den = 1 }; sup = Frac { num = 1; den = 1 } }; + i -let abstract_away _parameters (error,mat) key = - let () = set mat key {inf=Minfinity;sup=Infinity} in - error, mat + let equal i1 i2 = + List.for_all (fun x -> read i1 x = read i2 x) (clef i1 @ clef i2) -let abstract_away parameters error mat key = - List.fold_left - (abstract_away parameters) - (error, mat) - key + let abstract_away _parameters (error, mat) key = + let () = set mat key { inf = Minfinity; sup = Infinity } in + error, mat + let abstract_away parameters error mat key = + List.fold_left (abstract_away parameters) (error, mat) key end diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/intertab.mli b/core/KaSa_rep/abstract_domains/numerical_domains/intertab.mli index a8641ddaf8..0acefbc58a 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/intertab.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/intertab.mli @@ -1,68 +1,87 @@ -module type Tabinter = -sig +module type Tabinter = sig type var type intervalle type intervalle_tab + val make : int -> intervalle_tab - val set : intervalle_tab -> var -> intervalle -> unit + val set : intervalle_tab -> var -> intervalle -> unit val read : intervalle_tab -> var -> intervalle - val affiche: + + val affiche : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> Exception.method_handler + intervalle_tab -> + Exception.method_handler + val copy : Remanent_parameters_sig.parameters -> Exception.method_handler -> intervalle_tab -> Exception.method_handler * intervalle_tab + val clef : intervalle_tab -> var list + val wide_place : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * var list + val union_place : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * var list + val union : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * intervalle_tab + val inter : - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - intervalle_tab -> intervalle_tab -> - Exception.method_handler * intervalle_tab + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + intervalle_tab -> + intervalle_tab -> + Exception.method_handler * intervalle_tab + val somme : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * intervalle_tab val int_of_var_list : Remanent_parameters_sig.parameters -> - Exception.method_handler ->var list -> + Exception.method_handler -> + var list -> Exception.method_handler * intervalle_tab - val push : intervalle_tab -> var -> Fraction.fraction -> intervalle_tab + val push : intervalle_tab -> var -> Fraction.fraction -> intervalle_tab val pushbool : intervalle_tab -> var -> intervalle_tab val equal : intervalle_tab -> intervalle_tab -> bool + val merge : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> intervalle_tab -> + intervalle_tab -> + intervalle_tab -> Exception.method_handler * intervalle_tab - val abstract_away: + val abstract_away : Remanent_parameters_sig.parameters -> Exception.method_handler -> - intervalle_tab -> var list -> + intervalle_tab -> + var list -> Exception.method_handler * intervalle_tab - end -module Tabinter:Tabinter with type var = Occu1.trans - and type intervalle = Intervalles.intervalle +module Tabinter : + Tabinter + with type var = Occu1.trans + and type intervalle = Intervalles.intervalle diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.ml b/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.ml index f6fec90170..e51278c268 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.ml @@ -1,187 +1,227 @@ -open Fraction;; +open Fraction -type intervalle = {inf:ffraction;sup:ffraction} ;; +type intervalle = { inf: ffraction; sup: ffraction } -exception Intervalle_vide ;; +exception Intervalle_vide -let wide_max = ref {num=2;den=1} ;; - -let get_wide_max () = !wide_max ;; -let set_wide_max f = wide_max:=f ;; - - -let sub_convexe a b = - not ((ffinf (a.inf) (b.inf)) || (ffinf (b.sup) (a.sup))) ;; +let wide_max = ref { num = 2; den = 1 } +let get_wide_max () = !wide_max +let set_wide_max f = wide_max := f +let sub_convexe a b = not (ffinf a.inf b.inf || ffinf b.sup a.sup) let trans_convexe i t = let inff = - (match i.inf with - | Frac(a)-> - ffmax (Frac {num=0;den=1}) - (Frac (fplus a t)) - - | Unknown | Infinity -> raise Exit - | Minfinity as a -> a) + match i.inf with + | Frac a -> ffmax (Frac { num = 0; den = 1 }) (Frac (fplus a t)) + | Unknown | Infinity -> raise Exit + | Minfinity as a -> a in let supf = - (match i.sup with - | Frac(a)->(Frac (fplus a t)) - | Unknown | Minfinity -> raise Exit - | Infinity as a -> a) + match i.sup with + | Frac a -> Frac (fplus a t) + | Unknown | Minfinity -> raise Exit + | Infinity as a -> a in - {inf=ffmax inff (Frac {num=0;den=1});sup=supf};; + { inf = ffmax inff (Frac { num = 0; den = 1 }); sup = supf } -let zero = {inf= Frac Fraction.zero; sup=Frac Fraction.zero} +let zero = { inf = Frac Fraction.zero; sup = Frac Fraction.zero } -let union_convexe t1 t2 = - let n=Array.length t1 in - let ts=Array.make n {inf=Frac {num=0;den=1} ;sup=Frac{num=0;den=1}} in - for i=0 to (n-1) do - ts.(i)<-{inf=ffmin (t1.(i).inf) (t2.(i).inf);sup=ffmax (t1.(i).sup) (t2.(i).sup)} - done; - ts;; +let union_convexe t1 t2 = + let n = Array.length t1 in + let ts = + Array.make n + { inf = Frac { num = 0; den = 1 }; sup = Frac { num = 0; den = 1 } } + in + for i = 0 to n - 1 do + ts.(i) <- + { inf = ffmin t1.(i).inf t2.(i).inf; sup = ffmax t1.(i).sup t2.(i).sup } + done; + ts -let union i1 i2 = {inf=ffmin (i1.inf) (i2.inf);sup=ffmax (i1.sup) (i2.sup)};; +let union i1 i2 = { inf = ffmin i1.inf i2.inf; sup = ffmax i1.sup i2.sup } let wide_union_convexe t1 t2 = - let n=Array.length t1 in - let ts=Array.make n {inf=Frac {num=0;den=1} ;sup=Frac{num=0;den=1}} in - for i=0 to (n-1) do - ts.(i)<-{inf=(if (ffinf (t2.(i).inf) (t1.(i).inf)) then - if (ffinf t2.(i).inf (Fraction.ffneg (Frac (!wide_max)))) - then Minfinity - else t2.(i).inf - else (t1.(i).inf)); - sup=(if (ffinf (t1.(i).sup) (t2.(i).sup)) then - (if (ffinf (Frac (!wide_max)) t2.(i).sup) then Infinity - else t2.(i).sup) - else (t1.(i).sup))} - done; - ts;; - -let hashnumber = 1 -let wide_en_place t1 t2 = - let n=Array.length t1 in - let l=Working_list_imperative.make hashnumber in - let changed=(ref false) in - for i=0 to (n-1) do - changed:=false; - let rep={inf=( - if (ffinf (t2.(i).inf) (t1.(i).inf)) - then - if (ffinf t2.(i).inf (Fraction.ffneg (Frac (!wide_max)))) - then - if t1.(i).inf=Minfinity - then Minfinity - else (changed:=true;Minfinity) - else - (changed:=true;t2.(i).inf) - else (t1.(i).inf)); - sup=( - if (ffinf (t1.(i).sup) (t2.(i).sup)) - then - (if (ffinf (Frac (!wide_max)) t2.(i).sup) - then - (if t1.(i).sup=Infinity - then Infinity - else (changed:=true;Infinity)) - - else (changed:=true;t2.(i).sup)) - else (t1.(i).sup))} in - if (!changed) then (Working_list_imperative.push i l;t1.(i)<-rep) else () - done;Working_list_imperative.list l ;; + let n = Array.length t1 in + let ts = + Array.make n + { inf = Frac { num = 0; den = 1 }; sup = Frac { num = 0; den = 1 } } + in + for i = 0 to n - 1 do + ts.(i) <- + { + inf = + (if ffinf t2.(i).inf t1.(i).inf then + if ffinf t2.(i).inf (Fraction.ffneg (Frac !wide_max)) then + Minfinity + else + t2.(i).inf + else + t1.(i).inf); + sup = + (if ffinf t1.(i).sup t2.(i).sup then + if ffinf (Frac !wide_max) t2.(i).sup then + Infinity + else + t2.(i).sup + else + t1.(i).sup); + } + done; + ts + +let hashnumber = 1 +let wide_en_place t1 t2 = + let n = Array.length t1 in + let l = Working_list_imperative.make hashnumber in + let changed = ref false in + for i = 0 to n - 1 do + changed := false; + let rep = + { + inf = + (if ffinf t2.(i).inf t1.(i).inf then + if ffinf t2.(i).inf (Fraction.ffneg (Frac !wide_max)) then + if t1.(i).inf = Minfinity then + Minfinity + else ( + changed := true; + Minfinity + ) + else ( + changed := true; + t2.(i).inf + ) + else + t1.(i).inf); + sup = + (if ffinf t1.(i).sup t2.(i).sup then + if ffinf (Frac !wide_max) t2.(i).sup then + if t1.(i).sup = Infinity then + Infinity + else ( + changed := true; + Infinity + ) + else ( + changed := true; + t2.(i).sup + ) + else + t1.(i).sup); + } + in + if !changed then ( + Working_list_imperative.push i l; + t1.(i) <- rep + ) else + () + done; + Working_list_imperative.list l let cap_inter i1 i2 = - let is={inf=ffmax (i1.inf) (i2.inf);sup=ffmin (i1.sup) (i2.sup)} in - if ffinf (is.sup) (is.inf) then raise Intervalle_vide - else is ;; + let is = { inf = ffmax i1.inf i2.inf; sup = ffmin i1.sup i2.sup } in + if ffinf is.sup is.inf then + raise Intervalle_vide + else + is let inter_convexe t1 t2 = - let n=Array.length t1 in - let ts=Array.make n {inf=Frac{num=0;den=1} ;sup=Frac{num=0;den=1}} in - for i=0 to (n-1) do - ts.(i)<-cap_inter t1.(i) t2.(i) - done; - ts;; + let n = Array.length t1 in + let ts = + Array.make n + { inf = Frac { num = 0; den = 1 }; sup = Frac { num = 0; den = 1 } } + in + for i = 0 to n - 1 do + ts.(i) <- cap_inter t1.(i) t2.(i) + done; + ts let iiplus i1 alpha i2 = - if alpha.num=0 then i1 - else (if (alpha.num<0) then {inf=ffplus i1.inf alpha i2.sup; - sup=ffplus i1.sup alpha i2.inf} - else {inf=ffplus i1.inf alpha i2.inf; - sup=ffplus i1.sup alpha i2.sup}) ;; - -let combinaison_lineaire_convexe ((l,resultat),s) = - let resultat={num=(-1)*resultat.num;den=resultat.den} in - let rec aux l sol = - match l with - | ((i,k)::q) when (k.num<0) -> - (match (ffplus sol k (s.(i).sup) ) with - | Unknown ->Minfinity - | (Infinity | Minfinity | Frac _) as k -> aux q k ) - | ((i,k)::q) when (k.num>0) -> - (match (ffplus sol k (s.(i).inf)) with - | Unknown -> Unknown - | (Infinity | Minfinity | Frac _) as k -> aux q k ) - | _::q -> aux q sol - | [] -> sol - - in - let inff=(aux l (Frac resultat)) in - let rec aux l sol = - match l with - | ((i,k)::q) when (k.num<0) -> - (match (ffplus sol k (s.(i).inf) ) with - | Unknown ->Infinity - | (Infinity | Minfinity | Frac _) as k -> aux q k ) - | ((i,k)::q) (*when (k.num>0)*) -> - (match (ffplus sol k (s.(i).sup) ) with - | Unknown ->Unknown - | (Infinity | Minfinity | Frac _) as k -> aux q k ) - | [] -> sol - in - let supf=(aux l (Frac resultat)) in - if (ffinf supf inff) then raise Intervalle_vide else {inf=inff;sup=supf};; - + if alpha.num = 0 then + i1 + else if alpha.num < 0 then + { inf = ffplus i1.inf alpha i2.sup; sup = ffplus i1.sup alpha i2.inf } + else + { inf = ffplus i1.inf alpha i2.inf; sup = ffplus i1.sup alpha i2.sup } + +let combinaison_lineaire_convexe ((l, resultat), s) = + let resultat = { num = -1 * resultat.num; den = resultat.den } in + let rec aux l sol = + match l with + | (i, k) :: q when k.num < 0 -> + (match ffplus sol k s.(i).sup with + | Unknown -> Minfinity + | (Infinity | Minfinity | Frac _) as k -> aux q k) + | (i, k) :: q when k.num > 0 -> + (match ffplus sol k s.(i).inf with + | Unknown -> Unknown + | (Infinity | Minfinity | Frac _) as k -> aux q k) + | _ :: q -> aux q sol + | [] -> sol + in + let inff = aux l (Frac resultat) in + let rec aux l sol = + match l with + | (i, k) :: q when k.num < 0 -> + (match ffplus sol k s.(i).inf with + | Unknown -> Infinity + | (Infinity | Minfinity | Frac _) as k -> aux q k) + | (i, k) :: q (*when (k.num>0)*) -> + (match ffplus sol k s.(i).sup with + | Unknown -> Unknown + | (Infinity | Minfinity | Frac _) as k -> aux q k) + | [] -> sol + in + let supf = aux l (Frac resultat) in + if ffinf supf inff then + raise Intervalle_vide + else + { inf = inff; sup = supf } let contient_zero i = let aux1 () = - (match i.inf with - | Infinity -> false - | Frac a when a.num>0 -> false - | Unknown -> raise Exit - | Minfinity | Frac _ -> true) in + match i.inf with + | Infinity -> false + | Frac a when a.num > 0 -> false + | Unknown -> raise Exit + | Minfinity | Frac _ -> true + in match i.sup with | Minfinity -> false - | Frac a when a.num<0 -> false + | Frac a when a.num < 0 -> false | Unknown -> raise Exit - | Infinity | Frac _ -> aux1 ();; - - + | Infinity | Frac _ -> aux1 () let string_of_intervalle parameters error i = let error, inf_string = match i.inf with - | Infinity | Unknown -> - Exception.warn parameters error __POS__ Exit "BUG" + | Infinity | Unknown -> Exception.warn parameters error __POS__ Exit "BUG" | Frac _ -> - error, ((Remanent_parameters.get_open_int_interval_inclusive_symbol parameters )^(string_of_int(cell_int (i.inf)))) + ( error, + Remanent_parameters.get_open_int_interval_inclusive_symbol parameters + ^ string_of_int (cell_int i.inf) ) | Minfinity -> - error, ((Remanent_parameters.get_open_int_interval_infinity_symbol parameters)^ - (Remanent_parameters.get_minus_infinity_symbol parameters)) + ( error, + Remanent_parameters.get_open_int_interval_infinity_symbol parameters + ^ Remanent_parameters.get_minus_infinity_symbol parameters ) in let error, sup_string = match i.sup with - | Minfinity | Unknown -> - Exception.warn parameters error __POS__ Exit "BUG" + | Minfinity | Unknown -> Exception.warn parameters error __POS__ Exit "BUG" | Frac _ -> - error, ((string_of_int(floor_int (i.sup)))^ - (Remanent_parameters.get_close_int_interval_inclusive_symbol parameters)) + ( error, + string_of_int (floor_int i.sup) + ^ Remanent_parameters.get_close_int_interval_inclusive_symbol parameters + ) | Infinity -> - error, ( - (Remanent_parameters.get_plus_infinity_symbol parameters)^ - (Remanent_parameters.get_close_int_interval_infinity_symbol parameters)) + ( error, + Remanent_parameters.get_plus_infinity_symbol parameters + ^ Remanent_parameters.get_close_int_interval_infinity_symbol parameters + ) in - error, inf_string^(Remanent_parameters.get_int_interval_separator_symbol parameters)^sup_string + ( error, + inf_string + ^ Remanent_parameters.get_int_interval_separator_symbol parameters + ^ sup_string ) diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.mli b/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.mli index 87fd874f8c..575546a481 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/intervalles.mli @@ -1,29 +1,33 @@ exception Intervalle_vide -type intervalle = {inf:Fraction.ffraction;sup:Fraction.ffraction} +type intervalle = { inf: Fraction.ffraction; sup: Fraction.ffraction } -val zero: intervalle +val zero : intervalle +val set_wide_max : Fraction.fraction -> unit +val get_wide_max : unit -> Fraction.fraction +val trans_convexe : intervalle -> Fraction.fraction -> intervalle +val sub_convexe : intervalle -> intervalle -> bool -val set_wide_max: Fraction.fraction -> unit -val get_wide_max: unit -> Fraction.fraction -val trans_convexe: intervalle -> Fraction.fraction -> intervalle -val sub_convexe: intervalle -> intervalle -> bool - -val string_of_intervalle: +val string_of_intervalle : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - intervalle -> Exception_without_parameter.method_handler * string - -val contient_zero: intervalle -> bool -val combinaison_lineaire_convexe: - ((int * Fraction.fraction) list * Fraction.fraction) * - intervalle array -> intervalle - -val iiplus: intervalle -> Fraction.fraction -> intervalle -> intervalle -val inter_convexe: intervalle array -> intervalle array -> intervalle array -val wide_en_place: intervalle array -> intervalle array -> int list -val wide_union_convexe: intervalle array -> intervalle array -> intervalle array -val union: intervalle -> intervalle -> intervalle -val union_convexe: intervalle array -> intervalle array -> intervalle array -val cap_inter: intervalle -> intervalle -> intervalle -val wide_max: Fraction.fraction ref + intervalle -> + Exception_without_parameter.method_handler * string + +val contient_zero : intervalle -> bool + +val combinaison_lineaire_convexe : + ((int * Fraction.fraction) list * Fraction.fraction) * intervalle array -> + intervalle + +val iiplus : intervalle -> Fraction.fraction -> intervalle -> intervalle +val inter_convexe : intervalle array -> intervalle array -> intervalle array +val wide_en_place : intervalle array -> intervalle array -> int list + +val wide_union_convexe : + intervalle array -> intervalle array -> intervalle array + +val union : intervalle -> intervalle -> intervalle +val union_convexe : intervalle array -> intervalle array -> intervalle array +val cap_inter : intervalle -> intervalle -> intervalle +val wide_max : Fraction.fraction ref diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.ml b/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.ml index c9bcdcc70f..199a5e45d5 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.ml @@ -4,49 +4,57 @@ open Matrices open Intertab open Occu1 -module type Mat_inter = -sig +module type Mat_inter = sig type prod type var + val addzero : bool val list_var : Remanent_parameters_sig.parameters -> prod -> var list - val solve_inf: + + val solve_inf : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var list-> Exception.method_handler * prod option + prod -> + var list -> + Exception.method_handler * prod option val create : Remanent_parameters_sig.parameters -> int -> prod + val plonge : Remanent_parameters_sig.parameters -> - Exception.method_handler -> prod -> var list -> + Exception.method_handler -> + prod -> + var list -> Exception.method_handler * prod val copy : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod-> + prod -> Exception.method_handler * prod - (* val exclusion: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - prod -> var list -> - Exception.method_handler * bool + (* val exclusion: + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + prod -> var list -> + Exception.method_handler * bool - val all_here : - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - prod -> var list -> Exception.method_handler * prod option*) + val all_here : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + prod -> var list -> Exception.method_handler * prod option*) val guard : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> (var * Counters_domain_type.comparison_op * int) list -> Exception.method_handler * prod option + prod -> + (var * Counters_domain_type.comparison_op * int) list -> + Exception.method_handler * prod option val solve_all : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod-> + prod -> Exception.method_handler * prod option val compt_of_var_list : @@ -58,82 +66,97 @@ sig val affiche_mat : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> Exception.method_handler + prod -> + Exception.method_handler - val merge: + val merge : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * prod option - val is_vide: prod -> var->bool - val string_of_pro: + val is_vide : prod -> var -> bool + + val string_of_pro : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var -> Exception.method_handler * string - val interval_of_pro: + prod -> + var -> + Exception.method_handler * string + + val interval_of_pro : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var -> Exception.method_handler * - (Fraction.ffraction * Fraction.ffraction) option + prod -> + var -> + Exception.method_handler * (Fraction.ffraction * Fraction.ffraction) option + val is_infinite : prod -> var -> bool - val is_infinite:prod->var->bool - val union: + val union : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * prod + (*val plus: Remanent_parameters_sig.parameters -> Exception.method_handler -> prod->prod-> Exception.method_handler * prod*) - val widen: + val widen : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * (prod * bool) - val union_incr: + + val union_incr : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * (prod * bool) - val push: + val push : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->var -> Fraction.fraction-> + prod -> + var -> + Fraction.fraction -> Exception.method_handler * prod - val abstract_away: + val abstract_away : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var list -> + prod -> + var list -> Exception.method_handler * prod - end module Mat_inter = - functor (M:Matrice with type var=Occu1.trans) -> - functor (I:Tabinter with type var=Occu1.trans and type intervalle=Intervalles.intervalle) -> - (struct - +functor + (M : Matrice with type var = Occu1.trans) + (I : Tabinter + with type var = Occu1.trans + and type intervalle = Intervalles.intervalle) + -> + ( + struct type matrice = M.matrice type intertab = I.intervalle_tab - type prod = {mat:matrice;i:intertab} + type prod = { mat: matrice; i: intertab } type var = Occu1.trans - let addzero=true + let addzero = true let _n_ligne p = M.n_ligne p.mat - let compt_of_var_list parameters error l - = - let error, mat = M.mat_of_var_list parameters error l in + let compt_of_var_list parameters error l = + let error, mat = M.mat_of_var_list parameters error l in let error, i = I.int_of_var_list parameters error l in - error, - {mat=mat; - i=i} + error, { mat; i } let affiche_mat parameters error x = let error = I.affiche parameters error x.i in @@ -141,462 +164,434 @@ module Mat_inter = error let is_vide prod x = - (I.read (prod.i) x)={inf=Frac({num=0;den=1});sup=Frac({num=0;den=1})} - - let is_infinite m x = - (I.read (m.i) x).sup=Fraction.Infinity + I.read prod.i x + = { inf = Frac { num = 0; den = 1 }; sup = Frac { num = 0; den = 1 } } - let is_minfinite m x = - (I.read (m.i) x).inf=Fraction.Minfinity - - let is_both_infinite m x = - is_infinite m x && is_minfinite m x - - let is_either_infinite m x = - is_infinite m x || is_minfinite m x + let is_infinite m x = (I.read m.i x).sup = Fraction.Infinity + let is_minfinite m x = (I.read m.i x).inf = Fraction.Minfinity + let is_both_infinite m x = is_infinite m x && is_minfinite m x + let is_either_infinite m x = is_infinite m x || is_minfinite m x type side = Upper | Lower let reduce_lower _parameters error inter t b = - let () = - I.set inter t - (cap_inter - (I.read inter t) - {inf=b; - sup=Infinity}) - in error + let () = + I.set inter t (cap_inter (I.read inter t) { inf = b; sup = Infinity }) + in + error let reduce_upper _parameters error inter t b = let () = I.set inter t - (cap_inter - (I.read inter t) - {inf=Minfinity; - sup=b}) + (cap_inter (I.read inter t) { inf = Minfinity; sup = b }) in error (* improve this algorithm in the presence of -oo ?? *) - let solve_inf parameters error prod l = + let solve_inf parameters error prod l = let m = prod.mat in - let inter =prod.i in - let error, m= M.copy parameters error m in - let li=ref (List.filter (fun x->(is_either_infinite prod x)) l) in - let nli=ref (1) in + let inter = prod.i in + let error, m = M.copy parameters error m in + let li = ref (List.filter (fun x -> is_either_infinite prod x) l) in + let nli = ref 1 in let error_ref = ref error in - while (!nli)<>0 do - let l=(!li) in - let error, posm=M.copy parameters (!error_ref) m in - let () = error_ref:=error in + while !nli <> 0 do + let l = !li in + let error, posm = M.copy parameters !error_ref m in + let () = error_ref := error in let rec aux_174 liste = - match liste - with + match liste with | [] -> () - | j::q when (not(is_either_infinite prod j)) -> aux_174 q - | j::q when is_both_infinite prod j -> aux_174 q - - | j::q -> - ( - let rec aux2 i lneg lpos = - if - i> M.n_ligne m - then lneg, lpos + | j :: q when not (is_either_infinite prod j) -> aux_174 q + | j :: q when is_both_infinite prod j -> aux_174 q + | j :: q -> + let rec aux2 i lneg lpos = + if i > M.n_ligne m then + lneg, lpos + else ( + let s = (M.read_val posm i j).num in + if s = 0 then + aux2 (i + 1) lneg lpos + else if s > 0 then + aux2 (i + 1) lneg (i :: lpos) else - let s = (M.read_val posm i j).num in - if s = 0 then - aux2 (i+1) lneg lpos - else if s>0 then aux2 (i+1) lneg (i::lpos) - else aux2 (i+1) (i::lneg) (i::lpos) - in - let rec aux3 i l = - match l with - | t::q -> - let k= - fmoins - {num=0;den=1} - (fdiv - (M.read_val posm t j) - (M.read_val posm i j)) - in - (M.addligne posm t k i; - aux3 i q) - | [] -> () - in - let lneg,lpos = aux2 1 [] [] in - match lneg,lpos, is_infinite prod j with - | l, posref::_,true | posref::_, l, false -> - let () = aux3 posref l in - aux_174 q - | _,[],true | [],_,false -> - aux_174 q - ) + aux2 (i + 1) (i :: lneg) (i :: lpos) + ) + in + let rec aux3 i l = + match l with + | t :: q -> + let k = + fmoins { num = 0; den = 1 } + (fdiv (M.read_val posm t j) (M.read_val posm i j)) + in + M.addligne posm t k i; + aux3 i q + | [] -> () + in + let lneg, lpos = aux2 1 [] [] in + (match lneg, lpos, is_infinite prod j with + | l, posref :: _, true | posref :: _, l, false -> + let () = aux3 posref l in + aux_174 q + | _, [], true | [], _, false -> aux_174 q) in let () = aux_174 l in - let lprob = List.filter (fun j -> - (let rec aux_214 q = - if (M.read_val posm q j).num<0 && is_infinite prod j then true - else if (M.read_val posm q j).num>0 && is_minfinite prod j then true - else if q<=2 then false - else aux_214 (q-1) - in aux_214 (M.n_ligne posm))) - (l) + let rec aux_214 q = + if (M.read_val posm q j).num < 0 && is_infinite prod j then + true + else if (M.read_val posm q j).num > 0 && is_minfinite prod j + then + true + else if q <= 2 then + false + else + aux_214 (q - 1) + in + aux_214 (M.n_ligne posm)) + l in List.iter (fun j -> - (try - (let size = M.n_ligne posm in - for i1=1 to size do - for i2=i1+1 to size do - let a=M.read_val posm i1 j in - let b=M.read_val posm i2 j in - if (a={num=0;den=1} || b={num=0;den=1}) - then () - else - ( let f x y = (fmoins x (ffois a (fdiv - y b))) - in - if (List.for_all (fun x->(f (M.read_val posm i1 x) - (M.read_val posm i2 x)).num >= 0) l) - then ( - let error = M.new_empty_ligne parameters - (!error_ref) posm in - let () = error_ref:=error in - let size = M.n_ligne posm in - M.addligne posm size {num=1;den=1} i1; - M.addligne posm size (ffois {num=(-1);den=1} (fdiv - a b)) i2; - raise Exit) - else - let g x y = (fmoins x (ffois b (fdiv y a))) in - if (List.for_all (fun x->(g (M.read_val posm i2 - x) (M.read_val posm i1 x)).num>=0) l) - then ( - let error = M.new_empty_ligne parameters - (!error_ref) posm in - let () = error_ref:=error in - let size = M.n_ligne posm in - M.addligne posm size {num=1;den=1} i2; - M.addligne posm size (ffois {num=(-1);den=1} (fdiv a b)) i1; - raise Exit)) - done;done) with Exit -> ())) lprob; - - let n= Remanent_parameters.get_empty_hashtbl_size parameters in - let pos=Hashtbl.create n in (* variable -> contraintes o� il apparait positivement*) - let neg=Hashtbl.create n in (* variable -> contraintes o� il apparait n�gativement*) - let nb_inf=Array.make ((M.n_ligne posm)+1) 0 in (* contrainte -> nb de monomes non major�e *) - let nb_minf=Array.make ((M.n_ligne posm)+1) 0 in (* contrainte -> nb de monome non minor�e *) - let good_line=Working_list_imperative.make n in (*contraintes � r�duire*) + try + let size = M.n_ligne posm in + for i1 = 1 to size do + for i2 = i1 + 1 to size do + let a = M.read_val posm i1 j in + let b = M.read_val posm i2 j in + if a = { num = 0; den = 1 } || b = { num = 0; den = 1 } then + () + else ( + let f x y = fmoins x (ffois a (fdiv y b)) in + if + List.for_all + (fun x -> + (f (M.read_val posm i1 x) (M.read_val posm i2 x)) + .num >= 0) + l + then ( + let error = + M.new_empty_ligne parameters !error_ref posm + in + let () = error_ref := error in + let size = M.n_ligne posm in + M.addligne posm size { num = 1; den = 1 } i1; + M.addligne posm size + (ffois { num = -1; den = 1 } (fdiv a b)) + i2; + raise Exit + ) else ( + let g x y = fmoins x (ffois b (fdiv y a)) in + if + List.for_all + (fun x -> + (g (M.read_val posm i2 x) (M.read_val posm i1 x)) + .num >= 0) + l + then ( + let error = + M.new_empty_ligne parameters !error_ref posm + in + let () = error_ref := error in + let size = M.n_ligne posm in + M.addligne posm size { num = 1; den = 1 } i2; + M.addligne posm size + (ffois { num = -1; den = 1 } (fdiv a b)) + i1; + raise Exit + ) + ) + ) + done + done + with Exit -> ()) + lprob; + + let n = Remanent_parameters.get_empty_hashtbl_size parameters in + let pos = Hashtbl.create n in + (* variable -> contraintes o� il apparait positivement*) + let neg = Hashtbl.create n in + (* variable -> contraintes o� il apparait n�gativement*) + let nb_inf = Array.make (M.n_ligne posm + 1) 0 in + (* contrainte -> nb de monomes non major�e *) + let nb_minf = Array.make (M.n_ligne posm + 1) 0 in + (* contrainte -> nb de monome non minor�e *) + let good_line = Working_list_imperative.make n in + (*contraintes � r�duire*) (*let solved=Working_list_imperative.make n in (*variable trouv�e*)*) - let visited_line=Working_list_imperative.make n in (*contraintes r�duites ou en cours*) - (* let read_t t x = - try (Working_list_imperative.list (Hashtbl.find t x)) - with _ -> [] in*) + let visited_line = Working_list_imperative.make n in + (*contraintes r�duites ou en cours*) + (* let read_t t x = + try (Working_list_imperative.list (Hashtbl.find t x)) + with _ -> [] in*) let update t x y = - let l= - try (Hashtbl.find t x) + let l = + try Hashtbl.find t x with _ -> - let l=Working_list_imperative.make n in - Hashtbl.add t x l;l + let l = Working_list_imperative.make n in + Hashtbl.add t x l; + l in Working_list_imperative.push y l in - let view (k,v) = + let view (k, v) = (*met en attente une contrainte*) - if (not (Working_list_imperative.member k visited_line)) - then - (Working_list_imperative.push k visited_line; - Working_list_imperative.push (k,v) good_line) + if not (Working_list_imperative.member k visited_line) then ( + Working_list_imperative.push k visited_line; + Working_list_imperative.push (k, v) good_line + ) in let rec vide () = (*traite les contraintes en attentes*) try - (let k = - match Working_list_imperative.pop good_line - with - |Some (k,_) -> k - | None -> raise Exit - in - begin - let rec check_double_infinity error list - ~has_seen_minus_infinity + let k = + match Working_list_imperative.pop good_line with + | Some (k, _) -> k + | None -> raise Exit + in + (let rec check_double_infinity error list ~has_seen_minus_infinity + ~has_seen_plus_infinity + ~has_seen_unsimplifiable_plus_infinity + ~has_seen_unsimplifiable_minus_infinity = + match list with + | [] -> + ( error, + ( has_seen_unsimplifiable_minus_infinity, + has_seen_unsimplifiable_plus_infinity ) ) + | Affine_cst :: q -> + check_double_infinity error q ~has_seen_minus_infinity ~has_seen_plus_infinity ~has_seen_unsimplifiable_plus_infinity ~has_seen_unsimplifiable_minus_infinity - = - match list with - | [] -> error, - (has_seen_unsimplifiable_minus_infinity, - has_seen_unsimplifiable_plus_infinity) - | Affine_cst::q -> - check_double_infinity error q - ~has_seen_minus_infinity + | ((Bool _ | Counter _ | Site _) as t) :: q -> + let delta = M.read_val posm k t in + (match compare delta.num 0 with + | 0 -> + check_double_infinity error q ~has_seen_minus_infinity ~has_seen_plus_infinity ~has_seen_unsimplifiable_plus_infinity ~has_seen_unsimplifiable_minus_infinity - | (Bool _ | Counter _ | Site _ as t)::q -> - let delta=(M.read_val posm k t) in - begin - match compare delta.num 0 - with - | 0 -> - check_double_infinity error q - ~has_seen_minus_infinity - ~has_seen_plus_infinity - ~has_seen_unsimplifiable_plus_infinity - ~has_seen_unsimplifiable_minus_infinity - | -1 -> - begin - let error, new_plus_infinity = - match (I.read inter t).inf with - | Minfinity -> error, true - | Frac _ -> error, false - | Infinity | Unknown -> - Exception.warn parameters error __POS__ Exit false - in - let error, new_minus_infinity = - match (I.read inter t).sup with - | Infinity -> error, true - | Frac _ -> error, false - | Minfinity | Unknown -> - Exception.warn parameters error __POS__ Exit false - in - let has_seen_unsimplifiable_plus_infinity = - has_seen_unsimplifiable_plus_infinity - || - (new_plus_infinity && has_seen_minus_infinity) - in - let has_seen_unsimplifiable_minus_infinity = - has_seen_unsimplifiable_minus_infinity - || - (new_minus_infinity && has_seen_plus_infinity) - in - let has_seen_plus_infinity = - has_seen_plus_infinity || new_plus_infinity - in - let has_seen_minus_infinity = - has_seen_minus_infinity || new_minus_infinity - in - if has_seen_unsimplifiable_minus_infinity && - has_seen_unsimplifiable_plus_infinity - then - error, (true, true) - else - check_double_infinity error q - ~has_seen_minus_infinity - ~has_seen_plus_infinity - ~has_seen_unsimplifiable_plus_infinity - ~has_seen_unsimplifiable_minus_infinity - end - | 1 -> - begin - let error, new_minus_infinity = - match (I.read inter t).inf with - | Minfinity -> error, true - | Frac _ -> error, false - | Infinity | Unknown -> - Exception.warn parameters error __POS__ Exit false - in - let error, new_plus_infinity = - match (I.read inter t).sup with - | Infinity -> error, true - | Frac _ -> error, false - | Minfinity | Unknown -> - Exception.warn parameters error __POS__ Exit false - in - let has_seen_unsimplifiable_plus_infinity = - has_seen_unsimplifiable_plus_infinity - || - (new_plus_infinity && has_seen_minus_infinity) - in - let has_seen_unsimplifiable_minus_infinity = - has_seen_unsimplifiable_minus_infinity - || - (new_minus_infinity && has_seen_plus_infinity) - in - let has_seen_plus_infinity = - has_seen_plus_infinity || new_plus_infinity - in - let has_seen_minus_infinity = - has_seen_minus_infinity || new_minus_infinity - in - if has_seen_unsimplifiable_minus_infinity && - has_seen_unsimplifiable_plus_infinity - then - error, (true, true) - else - check_double_infinity error q - ~has_seen_minus_infinity - ~has_seen_plus_infinity - ~has_seen_unsimplifiable_plus_infinity - ~has_seen_unsimplifiable_minus_infinity - end - | _ -> - Exception.warn parameters error __POS__ Exit (true,true) - end - in - let rec vide error side list somme waiting = - match list - with - | [] -> - vide_waiting error side somme waiting - | Affine_cst::q -> - vide error side q - (match side with - | Lower -> - ffplus - somme - {num=(-1);den=1} - (Frac((M.read_val posm k Affine_cst))) - | Upper -> - ffplus - somme - {num=(-1);den=1} - (Frac((M.read_val posm k Affine_cst)))) - waiting - - | (Bool _ | Counter _ | Site _ as t)::q -> - let delta=(M.read_val posm k t) in - (match compare delta.num 0, side - with - | 0,_ -> - vide error side q somme waiting - | -1, Lower | 1, Upper -> - begin - match (I.read inter t).inf with - | Minfinity -> - let error = vide2 error side (t,Upper) delta q somme in - begin - match (I.read inter t).inf with - | Minfinity | Infinity | Unknown -> - (*let error, () = - Exception.warn parameters error __POS__ Exit () - in*) - error - | Frac _ as f -> - vide error side q - (ffplus somme - {num=(-(delta.num));den=delta.den} - f) waiting - end - | Frac _ as f -> - vide error side q - (ffplus somme - {num=(-(delta.num));den=delta.den} - f) ((delta,f,t,Upper)::waiting) - | Infinity | Unknown -> - (*let error, () = - Exception.warn parameters error __POS__ Exit () - in*) - error - end - | 1, Lower | (-1), Upper -> - begin - match (I.read inter t).sup with - | Infinity -> - let error = vide2 error side (t,Lower) delta q somme in - begin - match (I.read inter t).sup with - | Minfinity | Infinity | Unknown -> - (*let error, () = - Exception.warn parameters error __POS__ Exit () - in*) - error - | Frac _ as f -> - vide error side q - (ffplus somme - {num=(-(delta.num));den=delta.den} - f) waiting - end - | Frac _ as f -> - vide error side q - (ffplus somme - {num=(-(delta.num));den=delta.den} - f) ((delta,f,t,Lower)::waiting) - | Minfinity | Unknown -> - (*let error, () = - Exception.warn parameters error __POS__ Exit () - in*) - error - end - | _, (Lower | Upper) -> - (*let error, () = - Exception.warn parameters error __POS__ Exit () - in*) - error - ) - and vide2 error side t t_delta q somme = - match q with - | [] -> - let (t,side_t) = t in - begin - let new_bound = ffdiv somme (Frac(t_delta)) in - match side_t with - | Lower -> reduce_lower parameters error inter t new_bound - | Upper -> reduce_upper parameters error inter t new_bound - end - | head::tail -> - let delta=(M.read_val posm k head) in - (match compare delta.num 0, side - with - | 0,_ -> vide2 error side t t_delta tail somme - | -1, Lower | 1, Upper -> - vide2 error side t t_delta tail - (ffplus somme - {num=(-(delta.num));den=delta.den} - ((I.read inter head).inf)) - | 1, Lower | -1, Upper -> - vide2 error side t t_delta tail - (ffplus somme - {num=(-(delta.num));den=delta.den} - ((I.read inter head).sup)) - | _, (Lower | Upper) -> - (*let error, () = - Exception.warn parameters error __POS__ Exit () - in*) - error) - and vide_waiting error _side somme waiting = - List.fold_left - (fun error (delta,f,t,side) -> - let somme = ffplus somme delta f in - let somme = ffdiv somme (Frac delta) in - match side with - | Lower -> - reduce_lower parameters error inter t somme - | Upper -> - reduce_upper parameters error inter t somme - ) - error + | -1 -> + let error, new_plus_infinity = + match (I.read inter t).inf with + | Minfinity -> error, true + | Frac _ -> error, false + | Infinity | Unknown -> + Exception.warn parameters error __POS__ Exit false + in + let error, new_minus_infinity = + match (I.read inter t).sup with + | Infinity -> error, true + | Frac _ -> error, false + | Minfinity | Unknown -> + Exception.warn parameters error __POS__ Exit false + in + let has_seen_unsimplifiable_plus_infinity = + has_seen_unsimplifiable_plus_infinity + || (new_plus_infinity && has_seen_minus_infinity) + in + let has_seen_unsimplifiable_minus_infinity = + has_seen_unsimplifiable_minus_infinity + || (new_minus_infinity && has_seen_plus_infinity) + in + let has_seen_plus_infinity = + has_seen_plus_infinity || new_plus_infinity + in + let has_seen_minus_infinity = + has_seen_minus_infinity || new_minus_infinity + in + if + has_seen_unsimplifiable_minus_infinity + && has_seen_unsimplifiable_plus_infinity + then + error, (true, true) + else + check_double_infinity error q ~has_seen_minus_infinity + ~has_seen_plus_infinity + ~has_seen_unsimplifiable_plus_infinity + ~has_seen_unsimplifiable_minus_infinity + | 1 -> + let error, new_minus_infinity = + match (I.read inter t).inf with + | Minfinity -> error, true + | Frac _ -> error, false + | Infinity | Unknown -> + Exception.warn parameters error __POS__ Exit false + in + let error, new_plus_infinity = + match (I.read inter t).sup with + | Infinity -> error, true + | Frac _ -> error, false + | Minfinity | Unknown -> + Exception.warn parameters error __POS__ Exit false + in + let has_seen_unsimplifiable_plus_infinity = + has_seen_unsimplifiable_plus_infinity + || (new_plus_infinity && has_seen_minus_infinity) + in + let has_seen_unsimplifiable_minus_infinity = + has_seen_unsimplifiable_minus_infinity + || (new_minus_infinity && has_seen_plus_infinity) + in + let has_seen_plus_infinity = + has_seen_plus_infinity || new_plus_infinity + in + let has_seen_minus_infinity = + has_seen_minus_infinity || new_minus_infinity + in + if + has_seen_unsimplifiable_minus_infinity + && has_seen_unsimplifiable_plus_infinity + then + error, (true, true) + else + check_double_infinity error q ~has_seen_minus_infinity + ~has_seen_plus_infinity + ~has_seen_unsimplifiable_plus_infinity + ~has_seen_unsimplifiable_minus_infinity + | _ -> + Exception.warn parameters error __POS__ Exit (true, true)) + in + let rec vide error side list somme waiting = + match list with + | [] -> vide_waiting error side somme waiting + | Affine_cst :: q -> + vide error side q + (match side with + | Lower -> + ffplus somme { num = -1; den = 1 } + (Frac (M.read_val posm k Affine_cst)) + | Upper -> + ffplus somme { num = -1; den = 1 } + (Frac (M.read_val posm k Affine_cst))) waiting - in - let error, line = M.get_line parameters (!error_ref) posm k in - let error, (blocked_minus_infinity, blocked_plus_infinity) = - check_double_infinity error (M.get_trans_list line) - ~has_seen_plus_infinity:false - ~has_seen_minus_infinity:false - ~has_seen_unsimplifiable_plus_infinity:false - ~has_seen_unsimplifiable_minus_infinity:false - in - let error = - if not blocked_minus_infinity then - vide error Lower (M.get_trans_list line) - (Frac{num=0;den=1}) [] - else error - in - let error = - if not blocked_plus_infinity then - vide error Upper (M.get_trans_list line) - (Frac{num=0;den=1}) [] - else error - in - let () = error_ref:=error in - () - end ; - (* begin + | ((Bool _ | Counter _ | Site _) as t) :: q -> + let delta = M.read_val posm k t in + (match compare delta.num 0, side with + | 0, _ -> vide error side q somme waiting + | -1, Lower | 1, Upper -> + (match (I.read inter t).inf with + | Minfinity -> + let error = vide2 error side (t, Upper) delta q somme in + (match (I.read inter t).inf with + | Minfinity | Infinity | Unknown -> + (*let error, () = + Exception.warn parameters error __POS__ Exit () + in*) + error + | Frac _ as f -> + vide error side q + (ffplus somme + { num = -delta.num; den = delta.den } + f) + waiting) + | Frac _ as f -> + vide error side q + (ffplus somme { num = -delta.num; den = delta.den } f) + ((delta, f, t, Upper) :: waiting) + | Infinity | Unknown -> + (*let error, () = + Exception.warn parameters error __POS__ Exit () + in*) + error) + | 1, Lower | -1, Upper -> + (match (I.read inter t).sup with + | Infinity -> + let error = vide2 error side (t, Lower) delta q somme in + (match (I.read inter t).sup with + | Minfinity | Infinity | Unknown -> + (*let error, () = + Exception.warn parameters error __POS__ Exit () + in*) + error + | Frac _ as f -> + vide error side q + (ffplus somme + { num = -delta.num; den = delta.den } + f) + waiting) + | Frac _ as f -> + vide error side q + (ffplus somme { num = -delta.num; den = delta.den } f) + ((delta, f, t, Lower) :: waiting) + | Minfinity | Unknown -> + (*let error, () = + Exception.warn parameters error __POS__ Exit () + in*) + error) + | _, (Lower | Upper) -> + (*let error, () = + Exception.warn parameters error __POS__ Exit () + in*) + error) + and vide2 error side t t_delta q somme = + match q with + | [] -> + let t, side_t = t in + let new_bound = ffdiv somme (Frac t_delta) in + (match side_t with + | Lower -> reduce_lower parameters error inter t new_bound + | Upper -> reduce_upper parameters error inter t new_bound) + | head :: tail -> + let delta = M.read_val posm k head in + (match compare delta.num 0, side with + | 0, _ -> vide2 error side t t_delta tail somme + | -1, Lower | 1, Upper -> + vide2 error side t t_delta tail + (ffplus somme + { num = -delta.num; den = delta.den } + (I.read inter head).inf) + | 1, Lower | -1, Upper -> + vide2 error side t t_delta tail + (ffplus somme + { num = -delta.num; den = delta.den } + (I.read inter head).sup) + | _, (Lower | Upper) -> + (*let error, () = + Exception.warn parameters error __POS__ Exit () + in*) + error) + and vide_waiting error _side somme waiting = + List.fold_left + (fun error (delta, f, t, side) -> + let somme = ffplus somme delta f in + let somme = ffdiv somme (Frac delta) in + match side with + | Lower -> reduce_lower parameters error inter t somme + | Upper -> reduce_upper parameters error inter t somme) + error waiting + in + let error, line = M.get_line parameters !error_ref posm k in + let error, (blocked_minus_infinity, blocked_plus_infinity) = + check_double_infinity error (M.get_trans_list line) + ~has_seen_plus_infinity:false ~has_seen_minus_infinity:false + ~has_seen_unsimplifiable_plus_infinity:false + ~has_seen_unsimplifiable_minus_infinity:false + in + let error = + if not blocked_minus_infinity then + vide error Lower (M.get_trans_list line) + (Frac { num = 0; den = 1 }) + [] + else + error + in + let error = + if not blocked_plus_infinity then + vide error Upper (M.get_trans_list line) + (Frac { num = 0; den = 1 }) + [] + else + error + in + let () = error_ref := error in + ()); + (* begin (if nb_inf.(k)=0 then ( @@ -749,199 +744,273 @@ module Mat_inter = vide2 (M.get_trans_list line))) end;*) - vide ()) + vide () with _ -> () in - for i=1 to (M.n_ligne posm) do - let rep=ref Affine_cst in - let error, line =M.get_line parameters error posm i in + for i = 1 to M.n_ligne posm do + let rep = ref Affine_cst in + let error, line = M.get_line parameters error posm i in let k = M.get_trans_list line in - let () = error_ref:=error in - (List.iter - (fun j-> - if p j Affine_cst>0 then - (match - (((I.read inter j).sup), - ((M.read_val posm i j).num)) - with - | Infinity,a when a>0 -> (update pos j i;rep:=j; - nb_inf.(i)<-1+nb_inf.(i)) - | Infinity,a when a<0 -> (update neg j i;rep:=j; - nb_minf.(i)<-1+nb_minf.(i)) - | (Minfinity | Infinity | Unknown | Frac _), _ -> ())) k; - if (nb_inf.(i)=0 || nb_minf.(i)=0) then (view (i,!rep);vide ())) + let () = error_ref := error in + List.iter + (fun j -> + if p j Affine_cst > 0 then ( + match (I.read inter j).sup, (M.read_val posm i j).num with + | Infinity, a when a > 0 -> + update pos j i; + rep := j; + nb_inf.(i) <- 1 + nb_inf.(i) + | Infinity, a when a < 0 -> + update neg j i; + rep := j; + nb_minf.(i) <- 1 + nb_minf.(i) + | (Minfinity | Infinity | Unknown | Frac _), _ -> () + )) + k; + if nb_inf.(i) = 0 || nb_minf.(i) = 0 then ( + view (i, !rep); + vide () + ) done; - nli:=List.length (!li) ; - li:= (List.filter (fun x->(is_infinite prod x))) l ; - nli:=(!nli) - (List.length (!li)) + nli := List.length !li; + li := (List.filter (fun x -> is_infinite prod x)) l; + nli := !nli - List.length !li done; (**************************************************************************************) let transcribe_constraint k = - (*t_i k; t_s "\n";*) - let error, (k,c)= M.get_line parameters (!error_ref) m k in - let () = error_ref:=error in - let rec cop_line (k,c) = + (*t_i k; t_s "\n";*) + let error, (k, c) = M.get_line parameters !error_ref m k in + let () = error_ref := error in + let rec cop_line (k, c) = match k with - | Affine_cst::q -> cop_line (q,c) - | [] | (Bool _ | Counter _ | Site _)::_ -> - let nl= + | Affine_cst :: q -> cop_line (q, c) + | [] | (Bool _ | Counter _ | Site _) :: _ -> + let nl = Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters) in - (List.iter (fun x->(Hashtbl.add nl x (try (Hashtbl.find c x) with _ -> {num=0;den=1}))) k; - (k,nl,let a=(try (let a=(Hashtbl.find c Affine_cst) in - (Frac{num=(-(a.num));den=a.den})) - with _ -> Frac{num=0;den=1}) in {inf=a;sup=a})) in - cop_line (k,c) in - let n=(Remanent_parameters.get_empty_hashtbl_size parameters) in - let nm=M.make parameters n in - let aff=Hashtbl.create n in + List.iter + (fun x -> + Hashtbl.add nl x + (try Hashtbl.find c x with _ -> { num = 0; den = 1 })) + k; + ( k, + nl, + let a = + try + let a = Hashtbl.find c Affine_cst in + Frac { num = -a.num; den = a.den } + with _ -> Frac { num = 0; den = 1 } + in + { inf = a; sup = a } ) + in + cop_line (k, c) + in + let n = Remanent_parameters.get_empty_hashtbl_size parameters in + let nm = M.make parameters n in + let aff = Hashtbl.create n in let read_aff i = - try (Hashtbl.find aff i) with _ -> {inf=Frac{num=0;den=1}; - sup=Frac{num=0;den=1}} in + try Hashtbl.find aff i + with _ -> + { inf = Frac { num = 0; den = 1 }; sup = Frac { num = 0; den = 1 } } + in let change_aff i i2 = - ((try (Hashtbl.remove aff i) with _ -> ()); - Hashtbl.add aff i i2) in - let n_copy_line (k,c,b) = - let error = M.new_copy_ligne parameters (!error_ref) nm (k,c) in - let () = error_ref:= error in - let n=M.n_ligne nm in + (try Hashtbl.remove aff i with _ -> ()); + Hashtbl.add aff i i2 + in + let n_copy_line (k, c, b) = + let error = M.new_copy_ligne parameters !error_ref nm (k, c) in + let () = error_ref := error in + let n = M.n_ligne nm in change_aff n b in - for l=1 to (M.n_ligne m) do - let k=(transcribe_constraint l) in - (n_copy_line k) + for l = 1 to M.n_ligne m do + let k = transcribe_constraint l in + n_copy_line k done; let simplify_pivot ligne = - let ((error,(k,c)),b)= - (M.get_line parameters (!error_ref) nm ligne,read_aff ligne) + let (error, (k, c)), b = + M.get_line parameters !error_ref nm ligne, read_aff ligne in - let () = error_ref:= error in + let () = error_ref := error in let rec vide l sol = match l with - | t::q -> - (let delta= - (try (Hashtbl.find c t) - with _ -> - {num=0;den=1}) in - vide q - {inf=(ffplus (sol.inf) - {num=(-delta.num);den=delta.den} - (if (delta.num<0) - then ((I.read inter (t)).inf) - else ((I.read inter (t)).sup))); - sup=(ffplus (sol.sup) - {num=(-delta.num);den=delta.den} - (if (delta.num<0) - then ((I.read inter (t)).sup) - else ((I.read inter (t)).inf)))}) - | [] -> sol - in match k with [] -> () - | t::q -> - let rep=vide q b in - let i={inf=(match (rep.inf) - with - | Frac(a) -> Frac(a) - | Infinity | Minfinity | Unknown -> Minfinity) ; - sup=match rep.sup with - | Frac(a) -> Frac(a) - | Infinity | Minfinity | Unknown -> Infinity} in - match (try (Hashtbl.find c t) with _ -> {num=0;den=1}) with - delta when delta.num>0 -> - let new_i=cap_inter (I.read inter t) {inf=ffdiv (i.inf) (Frac delta);sup=ffdiv (i.sup) (Frac delta)} in - (I.set inter t new_i) - | delta when delta.num<0 -> - let new_i=cap_inter (I.read inter t) {inf=ffdiv (i.sup) (Frac delta);sup=ffdiv (i.inf) (Frac delta)} in - (I.set inter t new_i) - | _ -> () + | t :: q -> + let delta = + try Hashtbl.find c t with _ -> { num = 0; den = 1 } + in + vide q + { + inf = + ffplus sol.inf + { num = -delta.num; den = delta.den } + (if delta.num < 0 then + (I.read inter t).inf + else + (I.read inter t).sup); + sup = + ffplus sol.sup + { num = -delta.num; den = delta.den } + (if delta.num < 0 then + (I.read inter t).sup + else + (I.read inter t).inf); + } + | [] -> sol + in + match k with + | [] -> () + | t :: q -> + let rep = vide q b in + let i = + { + inf = + (match rep.inf with + | Frac a -> Frac a + | Infinity | Minfinity | Unknown -> Minfinity); + sup = + (match rep.sup with + | Frac a -> Frac a + | Infinity | Minfinity | Unknown -> Infinity); + } + in + (match try Hashtbl.find c t with _ -> { num = 0; den = 1 } with + | delta when delta.num > 0 -> + let new_i = + cap_inter (I.read inter t) + { + inf = ffdiv i.inf (Frac delta); + sup = ffdiv i.sup (Frac delta); + } + in + I.set inter t new_i + | delta when delta.num < 0 -> + let new_i = + cap_inter (I.read inter t) + { + inf = ffdiv i.sup (Frac delta); + sup = ffdiv i.inf (Frac delta); + } + in + I.set inter t new_i + | _ -> ()) in - let reduit deb fin = + let reduit deb fin = let rec aux k = - (if k>fin then (M.del_last_ligne nm) - else (let rec search_good_ligne l rep wei = - if (l>fin) then (rep,wei) - else ( - try (let cur=(M.pivot m l) in - if p cur wei < 0 || wei=Affine_cst - then (search_good_ligne (l+1) l cur) - else (search_good_ligne (1+l) rep wei) - ) with _ -> search_good_ligne (1+l) rep wei) in - let new_ligne,wei=search_good_ligne deb (-1) Affine_cst in - if wei=Affine_cst then aux (fin+1) else - begin - let col=M.pivot m new_ligne in - (let error = - M.swap parameters (!error_ref) nm k (new_ligne) in - error_ref:= error; - let tmp= - try (Hashtbl.find aff (k)) with _ -> + if k > fin then + M.del_last_ligne nm + else ( + let rec search_good_ligne l rep wei = + if l > fin then + rep, wei + else ( + try + let cur = M.pivot m l in + if p cur wei < 0 || wei = Affine_cst then + search_good_ligne (l + 1) l cur + else + search_good_ligne (1 + l) rep wei + with _ -> search_good_ligne (1 + l) rep wei + ) + in + let new_ligne, wei = search_good_ligne deb (-1) Affine_cst in + if wei = Affine_cst then + aux (fin + 1) + else ( + let col = M.pivot m new_ligne in + let error = M.swap parameters !error_ref nm k new_ligne in + error_ref := error; + let tmp = + try Hashtbl.find aff k + with _ -> + let error = !error_ref in + let error, a = + Exception.warn parameters error __POS__ Exit + { + inf = Fraction.Frac Fraction.zero; + sup = Fraction.Frac Fraction.zero; + } + in + let () = error_ref := error in + a + in + Hashtbl.remove aff k; + Hashtbl.add aff k + (try Hashtbl.find aff new_ligne + with _ -> + let error = !error_ref in + let error, a = + Exception.warn parameters error __POS__ Exit + { + inf = Fraction.Frac Fraction.zero; + sup = Fraction.Frac Fraction.zero; + } + in + let () = error_ref := error in + a); + Hashtbl.remove aff new_ligne; + Hashtbl.add aff new_ligne tmp; + let error = + M.mulligne parameters !error_ref nm k + (fdiv { num = 1; den = 1 } (M.read_val m k col)) + in + error_ref := error; + (let tmp = + try Hashtbl.find aff k + with _ -> + let error = !error_ref in + let error, a = + Exception.warn parameters error __POS__ Exit + { + inf = Fraction.Frac Fraction.zero; + sup = Fraction.Frac Fraction.zero; + } + in + let () = error_ref := error in + a + in + Hashtbl.remove aff k; + Hashtbl.add aff k + (iiplus + { + inf = Frac { num = 0; den = 1 }; + sup = Frac { num = 0; den = 1 }; + } + (fdiv { num = 1; den = 1 } (M.read_val nm k col)) + tmp)); + + for i = deb to fin do + if i = k then + () + else ( + let alpha = + ffois { num = -1; den = 1 } (M.read_val m i col) + in + M.addligne m i alpha k; + let tmp = Hashtbl.find aff i in + Hashtbl.remove aff i; + Hashtbl.add aff i + (iiplus tmp alpha + (try Hashtbl.find aff k + with _ -> let error = !error_ref in - let error, a = - Exception.warn parameters error __POS__ Exit {inf=Fraction.Frac Fraction.zero;sup=Fraction.Frac Fraction.zero} + let error, a = + Exception.warn parameters error __POS__ Exit + { + inf = Fraction.Frac Fraction.zero; + sup = Fraction.Frac Fraction.zero; + } in - let () = error_ref:= error in - a - - in (Hashtbl.remove aff k; - Hashtbl.add aff k ( - try Hashtbl.find aff (new_ligne) - with - _ -> - let error = !error_ref in - let error, a = - Exception.warn parameters error __POS__ Exit - {inf=Fraction.Frac Fraction.zero; - sup=Fraction.Frac Fraction.zero} - in - let () = error_ref:= error in - a - ); - Hashtbl.remove aff new_ligne; - Hashtbl.add aff new_ligne tmp); - let error = - M.mulligne parameters (!error_ref) - nm k (fdiv {num=1;den=1} (M.read_val m k col)) in - error_ref:= error; - (let tmp= - try - (Hashtbl.find aff k) - with _ -> - let error = !error_ref in - let error, a = - Exception.warn parameters error __POS__ Exit {inf=Fraction.Frac Fraction.zero;sup=Fraction.Frac Fraction.zero} - in - let () = error_ref:= error in - a - in - (Hashtbl.remove aff k; - Hashtbl.add aff k (iiplus {inf=Frac {num=0;den=1}; - sup=Frac{num=0;den=1}} - (fdiv {num=1;den=1} (M.read_val nm k col)) tmp))); - - for i=deb to fin do - if i=k then () - else - (let alpha=ffois {num=(-1);den=1} - - (M.read_val m i col) in - M.addligne m i alpha k; - let tmp=Hashtbl.find aff i in - (Hashtbl.remove aff i; - Hashtbl.add aff i (iiplus tmp alpha ( - try Hashtbl.find aff k - with _ -> - let error = !error_ref in - let error, a = - Exception.warn parameters error __POS__ Exit {inf=Fraction.Frac Fraction.zero;sup=Fraction.Frac Fraction.zero} - in - let () = error_ref:= error in - a - )))) - done; - aux (k+1)) - end)) in + let () = error_ref := error in + a)) + ) + done; + aux (k + 1) + ) + ) + in aux deb in let reduce_pivot ligne = @@ -950,214 +1019,204 @@ module Mat_inter = with _ -> let error = !error_ref in let error, a = - Exception.warn parameters error __POS__ Exit {inf=Fraction.Frac Fraction.zero;sup=Fraction.Frac Fraction.zero} + Exception.warn parameters error __POS__ Exit + { + inf = Fraction.Frac Fraction.zero; + sup = Fraction.Frac Fraction.zero; + } in - let () = error_ref:= error in + let () = error_ref := error in a in - let (error, ((k,c))) = - (M.get_line parameters (!error_ref) nm ligne) - in - let () = error_ref:=error in - ((*affiche_cons (k,c,b);*) - match k - with - | t::q -> - (let cop_line (k,c,b) = - let nl=Hashtbl.create n in - (List.iter - (fun x-> - (if p x Affine_cst > 0 - then (Hashtbl.add - nl x - (try - (Hashtbl.find c x) - with _ -> {num=0;den=1})))) k; - (k,nl,b)) in - let (_k,c,i)=cop_line (k,c,b) in - let delta=try (Hashtbl.find c t) with _ -> {num=0;den=1} in - ( - (try (Hashtbl.remove c t) with _ -> ()); - let i=(iiplus i {num=(-(delta.num));den=delta.den} (I.read inter t)) in - (Hashtbl.add aff ((M.n_ligne nm) +1) i; - let error = M.new_copy_ligne parameters (!error_ref) nm (q,c) - in + let error, (k, c) = M.get_line parameters !error_ref nm ligne in + let () = error_ref := error in + (*affiche_cons (k,c,b);*) + match k with + | t :: q -> + let cop_line (k, c, b) = + let nl = Hashtbl.create n in + List.iter + (fun x -> + if p x Affine_cst > 0 then + Hashtbl.add nl x + (try Hashtbl.find c x with _ -> { num = 0; den = 1 })) + k; + k, nl, b + in + let _k, c, i = cop_line (k, c, b) in + let delta = try Hashtbl.find c t with _ -> { num = 0; den = 1 } in + (try Hashtbl.remove c t with _ -> ()); + let i = + iiplus i { num = -delta.num; den = delta.den } (I.read inter t) + in + Hashtbl.add aff (M.n_ligne nm + 1) i; + let error = M.new_copy_ligne parameters !error_ref nm (q, c) in - let () = error_ref := error in () ))) - | [] -> ()) + let () = error_ref := error in + () + | [] -> () in - let deb=ref 1 in - let fin=ref (M.n_ligne nm) in - while (!deb)<((!fin)+1) do - for i=(!deb) to (!fin) do + let deb = ref 1 in + let fin = ref (M.n_ligne nm) in + while !deb < !fin + 1 do + for i = !deb to !fin do let () = simplify_pivot i in let () = reduce_pivot i in () done; - reduit ((!fin)+1) (M.n_ligne nm); - deb:=(!fin+1); - fin:=(M.n_ligne nm)(*;*) + reduit (!fin + 1) (M.n_ligne nm); + deb := !fin + 1; + fin := M.n_ligne nm (*;*) done; - for k=1 to (M.n_ligne nm) do - simplify_pivot ((M.n_ligne nm)+1-k) + for k = 1 to M.n_ligne nm do + simplify_pivot (M.n_ligne nm + 1 - k) done; !error_ref - let classe p _l = - M.get_all_key (p.mat) - let create parameters n = - {mat= (M.make parameters n); - i = (I.make n)} - let f_un = {num=1;den=1} - let f_zero = {num=0;den=1} - let _un ={inf = Frac f_un;sup=Frac f_un} - let _zero = {inf = Frac f_zero;sup=Frac f_zero} + let classe p _l = M.get_all_key p.mat + let create parameters n = { mat = M.make parameters n; i = I.make n } + let f_un = { num = 1; den = 1 } + let f_zero = { num = 0; den = 1 } + let _un = { inf = Frac f_un; sup = Frac f_un } + let _zero = { inf = Frac f_zero; sup = Frac f_zero } + let list_var parameters p = let rep = - Working_list_imperative.make (Remanent_parameters.get_empty_hashtbl_size parameters) + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) in - (List.iter (fun x -> Working_list_imperative.push x rep) - ((M.get_all_key (p.mat))); - List.iter (fun x -> Working_list_imperative.push x rep) ((I.clef (p.i))); - List.filter (fun x-> not(x=Affine_cst)) (Working_list_imperative.list rep)) - - let red2 mi = mi - - -let solve_inf parameters error mi c = - let rec aux k error = - (* let error = affiche_mat parameters error mi in*) - if k>5 then error, mi - else - let error, tmp=I.copy parameters error (mi.i) in - let error = solve_inf parameters error mi c in - let _ = red2 mi in - (if I.equal tmp (mi.i) - then + List.iter + (fun x -> Working_list_imperative.push x rep) + (M.get_all_key p.mat); + List.iter (fun x -> Working_list_imperative.push x rep) (I.clef p.i); + List.filter + (fun x -> not (x = Affine_cst)) + (Working_list_imperative.list rep) + + let red2 mi = mi + + let solve_inf parameters error mi c = + let rec aux k error = + (* let error = affiche_mat parameters error mi in*) + if k > 5 then error, mi - else aux (k+1) error) - in - aux 0 error - -let solve_inf parameters error mi c = - try - let error, mi = solve_inf parameters error mi c in - error, Some mi - with - Intervalle_vide -> error, None (*to do: propagate error *) - - - -let guard parameters error p l = - let classe=classe p (List.rev_map (fun (a,_,_) -> a) (List.rev l)) in - let error, m2= M.copy parameters error (p.mat) in - let error, i2=I.copy parameters error (p.i) in - try - let () = - List.iter - (fun (j,cmp,i) -> - I.set i2 - j - (cap_inter - (I.read i2 j) - (match cmp with - | Counters_domain_type.EQ -> - {inf= Frac{num=i;den=1}; - sup= Frac{num=i;den=1}} - | Counters_domain_type.GT -> - {inf= Frac{num=i+1;den=1}; - sup=Infinity} - | Counters_domain_type.GTEQ -> - {inf= Frac{num=i;den=1}; - sup=Infinity} - | Counters_domain_type.LT -> - {inf=Minfinity; - sup= - Frac{num=i-1;den=1}} - | Counters_domain_type.LTEQ -> - {sup= Frac{num=i;den=1}; - inf=Minfinity} - ))) l - in - solve_inf parameters - error {mat=m2;i=i2} classe - with - | Intervalle_vide -> error, None - - - - - let gen_bin f_m f_i parameters error p q = - let error, mat = f_m parameters error p.mat q.mat in - let error, i = f_i parameters error p.i q.i in - error, {mat;i} - - let union parameters error p q = - gen_bin M.union I.union parameters error p q - let merge parameters error p q = - try let error, a = gen_bin M.merge I.merge parameters error p q in - error, Some a - with - Intervalle_vide -> error, None - - let plonge parameters error m l = - let error, mat = M.plonge parameters error m.mat l in - error, {m with mat} - - let bin_incr gen parameters error p q = - let n=(M.n_ligne (p.mat)) in - let error, newm= M.union parameters error p.mat q.mat in - (* to do, test if newm <> p.mat *) - let error, i= gen parameters error p.i q.i in - if ((n=(M.n_ligne (newm))) && i=[]) then - error, ({mat=newm;i=p.i},false) - else error, ({mat=newm;i=p.i},true) - let widen parameters error p q = - bin_incr I.wide_place parameters error p q - let union_incr parameters error p q = - bin_incr I.union_place parameters error p q - - let solve_all parameters error m = - solve_inf parameters error m (list_var parameters m) - - let interval_of_pro _parameters error m x = - error, I.read (m.i) x - - let string_of_pro parameters error m x = - let error, interv = interval_of_pro parameters error m x in - Intervalles.string_of_intervalle parameters error interv - - let interval_of_pro parameters error m x = - let error, interv = interval_of_pro parameters error m x in - error, Some (interv.inf, interv.sup) - - - let push parameters error m x f = - let _ =I.push (m.i) x f in - let error = M.push parameters error (m.mat) x f in - error, m - - let _translate parameters error m l = - List.fold_left - (fun (error, m) (x,i) -> - push parameters error m x {num=i;den=1}) - (error, m) - l (* TO DO -> do more efficiently *) - - - - let copy parameters error m = - let error, mat = M.copy parameters error m.mat in - let error, i = I.copy parameters error m.i in - error, {mat;i} - - - let abstract_away parameters error m l = - let error, mat = M.abstract_away parameters error m.mat l in - let error, i = I.abstract_away parameters error m.i l in - error, {mat;i} - - end:Mat_inter with type var=Occu1.trans) - - -module Mat_int= Mat_inter(Matrices.Matrice)(Intertab.Tabinter) + else ( + let error, tmp = I.copy parameters error mi.i in + let error = solve_inf parameters error mi c in + let _ = red2 mi in + if I.equal tmp mi.i then + error, mi + else + aux (k + 1) error + ) + in + aux 0 error + + let solve_inf parameters error mi c = + try + let error, mi = solve_inf parameters error mi c in + error, Some mi + with Intervalle_vide -> error, None (*to do: propagate error *) + + let guard parameters error p l = + let classe = + classe p (List.rev_map (fun (a, _, _) -> a) (List.rev l)) + in + let error, m2 = M.copy parameters error p.mat in + let error, i2 = I.copy parameters error p.i in + try + let () = + List.iter + (fun (j, cmp, i) -> + I.set i2 j + (cap_inter (I.read i2 j) + (match cmp with + | Counters_domain_type.EQ -> + { + inf = Frac { num = i; den = 1 }; + sup = Frac { num = i; den = 1 }; + } + | Counters_domain_type.GT -> + { inf = Frac { num = i + 1; den = 1 }; sup = Infinity } + | Counters_domain_type.GTEQ -> + { inf = Frac { num = i; den = 1 }; sup = Infinity } + | Counters_domain_type.LT -> + { inf = Minfinity; sup = Frac { num = i - 1; den = 1 } } + | Counters_domain_type.LTEQ -> + { sup = Frac { num = i; den = 1 }; inf = Minfinity }))) + l + in + solve_inf parameters error { mat = m2; i = i2 } classe + with Intervalle_vide -> error, None + + let gen_bin f_m f_i parameters error p q = + let error, mat = f_m parameters error p.mat q.mat in + let error, i = f_i parameters error p.i q.i in + error, { mat; i } + + let union parameters error p q = + gen_bin M.union I.union parameters error p q + + let merge parameters error p q = + try + let error, a = gen_bin M.merge I.merge parameters error p q in + error, Some a + with Intervalle_vide -> error, None + + let plonge parameters error m l = + let error, mat = M.plonge parameters error m.mat l in + error, { m with mat } + + let bin_incr gen parameters error p q = + let n = M.n_ligne p.mat in + let error, newm = M.union parameters error p.mat q.mat in + (* to do, test if newm <> p.mat *) + let error, i = gen parameters error p.i q.i in + if n = M.n_ligne newm && i = [] then + error, ({ mat = newm; i = p.i }, false) + else + error, ({ mat = newm; i = p.i }, true) + + let widen parameters error p q = + bin_incr I.wide_place parameters error p q + + let union_incr parameters error p q = + bin_incr I.union_place parameters error p q + + let solve_all parameters error m = + solve_inf parameters error m (list_var parameters m) + + let interval_of_pro _parameters error m x = error, I.read m.i x + + let string_of_pro parameters error m x = + let error, interv = interval_of_pro parameters error m x in + Intervalles.string_of_intervalle parameters error interv + + let interval_of_pro parameters error m x = + let error, interv = interval_of_pro parameters error m x in + error, Some (interv.inf, interv.sup) + + let push parameters error m x f = + let _ = I.push m.i x f in + let error = M.push parameters error m.mat x f in + error, m + + let _translate parameters error m l = + List.fold_left + (fun (error, m) (x, i) -> + push parameters error m x { num = i; den = 1 }) + (error, m) l (* TO DO -> do more efficiently *) + + let copy parameters error m = + let error, mat = M.copy parameters error m.mat in + let error, i = I.copy parameters error m.i in + error, { mat; i } + + let abstract_away parameters error m l = + let error, mat = M.abstract_away parameters error m.mat l in + let error, i = I.abstract_away parameters error m.i l in + error, { mat; i } + end : + Mat_inter with type var = Occu1.trans) + +module Mat_int = Mat_inter (Matrices.Matrice) (Intertab.Tabinter) diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.mli b/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.mli index 0b99b349de..e0f977872c 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/mat_inter.mli @@ -1,47 +1,54 @@ - -module type Mat_inter = -sig +module type Mat_inter = sig type prod type var + val addzero : bool val list_var : Remanent_parameters_sig.parameters -> prod -> var list - val solve_inf: + + val solve_inf : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var list-> Exception.method_handler * prod option + prod -> + var list -> + Exception.method_handler * prod option val create : Remanent_parameters_sig.parameters -> int -> prod + val plonge : Remanent_parameters_sig.parameters -> - Exception.method_handler -> prod -> var list -> + Exception.method_handler -> + prod -> + var list -> Exception.method_handler * prod val copy : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod-> + prod -> Exception.method_handler * prod (*val exclusion: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - prod -> var list -> - Exception.method_handler * bool + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + prod -> var list -> + Exception.method_handler * bool - val all_here : - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - prod -> var list -> Exception.method_handler * prod option*) + val all_here : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + prod -> var list -> Exception.method_handler * prod option*) val guard : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> (var * Counters_domain_type.comparison_op * int) list -> Exception.method_handler * prod option + prod -> + (var * Counters_domain_type.comparison_op * int) list -> + Exception.method_handler * prod option val solve_all : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod-> + prod -> Exception.method_handler * prod option val compt_of_var_list : @@ -53,58 +60,69 @@ sig val affiche_mat : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> Exception.method_handler + prod -> + Exception.method_handler - val merge: + val merge : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * prod option - val is_vide: prod -> var->bool - val string_of_pro: + val is_vide : prod -> var -> bool + + val string_of_pro : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var -> Exception.method_handler * string - val interval_of_pro: + prod -> + var -> + Exception.method_handler * string + + val interval_of_pro : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var -> Exception.method_handler * - (Fraction.ffraction * Fraction.ffraction) option - + prod -> + var -> + Exception.method_handler * (Fraction.ffraction * Fraction.ffraction) option - val is_infinite:prod->var->bool + val is_infinite : prod -> var -> bool - val union: + val union : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * prod - val widen: + val widen : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * (prod * bool) - val union_incr: + val union_incr : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->prod-> + prod -> + prod -> Exception.method_handler * (prod * bool) - val push: + val push : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod->var -> Fraction.fraction-> + prod -> + var -> + Fraction.fraction -> Exception.method_handler * prod - val abstract_away: + val abstract_away : Remanent_parameters_sig.parameters -> Exception.method_handler -> - prod -> var list -> + prod -> + var list -> Exception.method_handler * prod - end -module Mat_int:(Mat_inter with type var = Occu1.trans) +module Mat_int : Mat_inter with type var = Occu1.trans diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/matrices.ml b/core/KaSa_rep/abstract_domains/numerical_domains/matrices.ml index e3fc884e7a..411e085631 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/matrices.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/matrices.ml @@ -4,851 +4,932 @@ open Fraction open Intervalles open Occu1 -module type Matrice = - sig -type point -type line = Occu1.trans list * (Occu1.trans, Fraction.fraction) Hashtbl.t - -type matrice -type var - -val mat_of_var_list : - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - var list -> Exception.method_handler * matrice - -val make: - Remanent_parameters_sig.parameters -> - int-> - matrice - -val affiche: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice-> - Exception.method_handler - -val affiche_cons: - Remanent_parameters_sig.parameters -> - int list * (int, Fraction.fraction) Hashtbl.t * - Intervalles.intervalle -> unit - -val get_all_entry: - matrice-> var Working_list_imperative.working_list -val add_entry: - matrice-> var->unit - -val plonge: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice-> var list -> Exception.method_handler * matrice - -val copy: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice -> - Exception.method_handler * matrice - -val normalise: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> matrice -> Exception.method_handler - -val push: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> var-> Fraction.fraction->Exception.method_handler - -val pushbool: - Remanent_parameters_sig.parameters -> Exception.method_handler-> - matrice -> var -> - Exception.method_handler * matrice - -val new_copy_ligne: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> line->Exception.method_handler - -val new_empty_ligne: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice->Exception.method_handler - -val n_ligne: matrice->int - -val get_line: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice->int->Exception.method_handler*line - -val get_trans_list: line -> Occu1.trans list - -val merge: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> matrice->Exception.method_handler * matrice - -val pivot: matrice->int->var -val read_val: matrice->int->var->Fraction.fraction -val addligne: matrice->int->Fraction.fraction->int->unit - -val swap: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> matrice->int->int->Exception.method_handler - -val mulligne: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice->int->Fraction.fraction->Exception.method_handler - -val del_ligne: matrice->int->unit -val del_last_ligne: matrice->unit -val union: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> matrice->Exception.method_handler * matrice - -val get_all_key: matrice->var list -val is_key: matrice->var->bool - -val decomp_affine: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> matrice-> - Exception.method_handler*(point * matrice) - -val somme_affine: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> matrice->Exception.method_handler * matrice - - val insert_0: +module type Matrice = sig + type point + type line = Occu1.trans list * (Occu1.trans, Fraction.fraction) Hashtbl.t + type matrice + type var + + val mat_of_var_list : Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> Exception.method_handler * matrice + Exception.method_handler -> + var list -> + Exception.method_handler * matrice + + val make : Remanent_parameters_sig.parameters -> int -> matrice - val equal: + val affiche : Remanent_parameters_sig.parameters -> Exception.method_handler -> - matrice -> matrice -> - Exception.method_handler * bool + matrice -> + Exception.method_handler + + val affiche_cons : + Remanent_parameters_sig.parameters -> + int list * (int, Fraction.fraction) Hashtbl.t * Intervalles.intervalle -> + unit + + val get_all_entry : matrice -> var Working_list_imperative.working_list + val add_entry : matrice -> var -> unit - val abstract_away: + val plonge : Remanent_parameters_sig.parameters -> Exception.method_handler -> - matrice -> var list -> + matrice -> + var list -> Exception.method_handler * matrice -end -module Matrice = - struct -let trace=false ;; -let _t_i parameters i = - if trace || Remanent_parameters.get_trace parameters then - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i" i in - Loggers.print_newline (Remanent_parameters.get_logger parameters) - -let _t_s parameters _error x = - if trace || Remanent_parameters.get_trace parameters then - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" x in - Loggers.print_newline (Remanent_parameters.get_logger parameters) - -let print_frac parameters f = - let () = - if f.den = 1 then - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%i" f.num - else - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "(%i/%i)" f.num f.den - in - () + val copy : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler * matrice -let affiche_frac parameters f = - if trace || Remanent_parameters.get_trace parameters then - print_frac parameters f + val normalise : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler + val push : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + var -> + Fraction.fraction -> + Exception.method_handler -let affiche_int parameters i = - if trace || Remanent_parameters.get_trace parameters then - let () = - match i.inf with - | Frac a-> - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s" - (Remanent_parameters.get_open_int_interval_inclusive_symbol parameters); - affiche_frac parameters a - | Minfinity -> - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s%s" - (Remanent_parameters.get_open_int_interval_infinity_symbol parameters) - (Remanent_parameters.get_minus_infinity_symbol parameters) - | Unknown | Infinity -> - Loggers.fprintf (Remanent_parameters.get_logger parameters) "!U!" - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s" (Remanent_parameters.get_int_interval_separator_symbol parameters) - in - let () = - match i.sup with - | Frac a-> - affiche_frac parameters a; - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s" (Remanent_parameters.get_close_int_interval_inclusive_symbol parameters) - | Infinity -> - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s%s" - - (Remanent_parameters.get_plus_infinity_symbol parameters) - (Remanent_parameters.get_close_int_interval_infinity_symbol parameters) - | Unknown | Minfinity -> Loggers.fprintf (Remanent_parameters.get_logger parameters) "!U!" - in () - -let _affiche_inter = affiche_int - -let affiche_cons parameters (k,c,b) = - let () = - List.iter - (fun x-> - let a=(try (find c x) with _ -> {num=0;den=1}) in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i" x - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let () = affiche_frac parameters a in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - ()) k - in - affiche_int parameters b - -type point = - {coord:unit -> (trans*fraction) list; - (*proj:trans -> fraction;*) - set:trans->fraction->unit; - (*affiche_point:unit -> unit;*) - somme_point:point->unit};; - -type line = (trans list * (trans, Fraction.fraction) Hashtbl.t);; - -let get_trans_list line = fst line -let new_point parameters n = - let entry= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let content=Hashtbl.create n in - let read k = - try (find content k) with _ -> {num=0;den=1} in - let set k f = - ((try (remove content k) with _ -> ()); - Hashtbl.add content k f; - Working_list_imperative.push k entry) in - - let somme_point ob = - List.iter (fun (x,y)->set x (fplus y (read x))) (ob.coord ()) in - { - (*proj=read;*) - set=set; - coord= - (fun () -> - (List.map - (fun x->(x,read x)) - (List.sort p - (Working_list_imperative.list entry)))); - (* affiche_point = - (fun () -> - List.iter - (fun x-> - affiche_frac parameters (read x)) - (List.sort p (Working_list_imperative.list entry)));*) - somme_point=somme_point} - - - - type var = Occu1.trans - type matrice = {entry:(int,var list) Hashtbl.t; - content:(int,(var,fraction)Hashtbl.t) Hashtbl.t; - all_entry:var Working_list_imperative.working_list; - nligne:int ref; - sorted_entry:var list ref} - let make parameters n = - {entry=Hashtbl.create n; - content=Hashtbl.create n; - - nligne=ref 0; - all_entry= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters); - sorted_entry=ref []} - let get_all_entry m =(m.all_entry) - - let is_key m i = - Working_list_imperative.member i m.all_entry - let get_all_key m = (!(m.sorted_entry)) - let n_ligne m =(!(m.nligne)) - let add_entry m j = - if is_key m j - then () - else - (Working_list_imperative.push j m.all_entry; - m.sorted_entry:=insert_sort po (!(m.sorted_entry)) j) - let copy_var m n = - List.iter (add_entry n) (Working_list_imperative.list m.all_entry) - - let new_empty_ligne parameters error m = - let () = - (m.nligne:=(!(m.nligne))+1; - Hashtbl.add m.entry (!(m.nligne)) []; - Hashtbl.add m.content - (!(m.nligne)) - (Hashtbl.create - (Remanent_parameters.get_empty_hashtbl_size parameters))) - in - error + val pushbool : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + var -> + Exception.method_handler * matrice - let new_copy_ligne parameters error m (ent,cont) = - let () = m.nligne:=(!(m.nligne))+1 in - let () = Hashtbl.add m.entry (!(m.nligne)) ent in - let tmp= - Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let () = - List.iter - (fun x-> - try - Hashtbl.add tmp x (find cont x); - add_entry m x - with Not_found -> () - ) - ent in - let () = Hashtbl.add m.content (!(m.nligne)) tmp in - error + val new_copy_ligne : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + line -> + Exception.method_handler + + val new_empty_ligne : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler + + val n_ligne : matrice -> int + + val get_line : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + int -> + Exception.method_handler * line + + val get_trans_list : line -> Occu1.trans list + + val merge : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * matrice + + val pivot : matrice -> int -> var + val read_val : matrice -> int -> var -> Fraction.fraction + val addligne : matrice -> int -> Fraction.fraction -> int -> unit + val swap : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + int -> + int -> + Exception.method_handler - let read_val m i j = - try (find (find m.content i) j) with _ -> {num=0;den=1} + val mulligne : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + int -> + Fraction.fraction -> + Exception.method_handler - let affiche parameters error m = + val del_ligne : matrice -> int -> unit + val del_last_ligne : matrice -> unit + + val union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * matrice + + val get_all_key : matrice -> var list + val is_key : matrice -> var -> bool + + val decomp_affine : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler * (point * matrice) + + val somme_affine : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * matrice + + val insert_0 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler * matrice + + val equal : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * bool + + val abstract_away : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + var list -> + Exception.method_handler * matrice +end + +module Matrice = struct + let trace = false + + let _t_i parameters i = + if trace || Remanent_parameters.get_trace parameters then ( let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i" i + in + Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) + + let _t_s parameters _error x = + if trace || Remanent_parameters.get_trace parameters then ( + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" x + in + Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) + + let print_frac parameters f = + let () = + if f.den = 1 then + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i" f.num + else Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Variables:" - in + "(%i/%i)" f.num f.den + in + () + + let affiche_frac parameters f = + if trace || Remanent_parameters.get_trace parameters then + print_frac parameters f + + let affiche_int parameters i = + if trace || Remanent_parameters.get_trace parameters then ( let () = - List.iter - (fun i-> - let () = print_trans parameters i in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - ", " - in - ()) - ((get_all_key m)) + match i.inf with + | Frac a -> + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_open_int_interval_inclusive_symbol + parameters); + affiche_frac parameters a + | Minfinity -> + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s" + (Remanent_parameters.get_open_int_interval_infinity_symbol + parameters) + (Remanent_parameters.get_minus_infinity_symbol parameters) + | Unknown | Infinity -> + Loggers.fprintf (Remanent_parameters.get_logger parameters) "!U!" in let () = - Loggers.print_newline + Loggers.fprintf (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_int_interval_separator_symbol parameters) in - for i=1 to (!(m.nligne)) do - let ()= + let () = + match i.sup with + | Frac a -> + affiche_frac parameters a; Loggers.fprintf (Remanent_parameters.get_logger parameters) - "---" - in - let () = - Loggers.print_newline + "%s" + (Remanent_parameters.get_close_int_interval_inclusive_symbol + parameters) + | Infinity -> + Loggers.fprintf (Remanent_parameters.get_logger parameters) - in - let _ = - List.fold_left - (fun b x-> - let () = - if b then - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - " + " - in - let () = - let f = read_val m i x in - if f.num=1 && f.den=1 && not (Occu1.Affine_cst=x) - then () - else - let () = print_frac parameters f in - if not (Occu1.Affine_cst=x) - then - Loggers.fprintf - (Remanent_parameters.get_logger parameters) "." - in - let () = print_trans parameters x in - true) false - (find m.entry i) - in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) " = 0" in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - () - done; - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in error + "%s%s" + (Remanent_parameters.get_plus_infinity_symbol parameters) + (Remanent_parameters.get_close_int_interval_infinity_symbol + parameters) + | Unknown | Minfinity -> + Loggers.fprintf (Remanent_parameters.get_logger parameters) "!U!" + in + () + ) + let _affiche_inter = affiche_int + + let affiche_cons parameters (k, c, b) = + let () = + List.iter + (fun x -> + let a = try find c x with _ -> { num = 0; den = 1 } in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i" x + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = affiche_frac parameters a in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + ()) + k + in + affiche_int parameters b + type point = { + coord: unit -> (trans * fraction) list; + (*proj:trans -> fraction;*) + set: trans -> fraction -> unit; + (*affiche_point:unit -> unit;*) + somme_point: point -> unit; + } + type line = trans list * (trans, Fraction.fraction) Hashtbl.t + + let get_trans_list line = fst line + + let new_point parameters n = + let entry = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let content = Hashtbl.create n in + let read k = try find content k with _ -> { num = 0; den = 1 } in + let set k f = + (try remove content k with _ -> ()); + Hashtbl.add content k f; + Working_list_imperative.push k entry + in + + let somme_point ob = + List.iter (fun (x, y) -> set x (fplus y (read x))) (ob.coord ()) + in + { + (*proj=read;*) + set; + coord = + (fun () -> + List.map + (fun x -> x, read x) + (List.sort p (Working_list_imperative.list entry))); + (* affiche_point = + (fun () -> + List.iter + (fun x-> + affiche_frac parameters (read x)) + (List.sort p (Working_list_imperative.list entry)));*) + somme_point; + } + + type var = Occu1.trans + + type matrice = { + entry: (int, var list) Hashtbl.t; + content: (int, (var, fraction) Hashtbl.t) Hashtbl.t; + all_entry: var Working_list_imperative.working_list; + nligne: int ref; + sorted_entry: var list ref; + } + + let make parameters n = + { + entry = Hashtbl.create n; + content = Hashtbl.create n; + nligne = ref 0; + all_entry = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters); + sorted_entry = ref []; + } + + let get_all_entry m = m.all_entry + let is_key m i = Working_list_imperative.member i m.all_entry + let get_all_key m = !(m.sorted_entry) + let n_ligne m = !(m.nligne) + + let add_entry m j = + if is_key m j then + () + else ( + Working_list_imperative.push j m.all_entry; + m.sorted_entry := insert_sort po !(m.sorted_entry) j + ) + + let copy_var m n = + List.iter (add_entry n) (Working_list_imperative.list m.all_entry) + + let new_empty_ligne parameters error m = + let () = + m.nligne := !(m.nligne) + 1; + Hashtbl.add m.entry !(m.nligne) []; + Hashtbl.add m.content !(m.nligne) + (Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters)) + in + error + + let new_copy_ligne parameters error m (ent, cont) = + let () = m.nligne := !(m.nligne) + 1 in + let () = Hashtbl.add m.entry !(m.nligne) ent in + let tmp = + Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let () = + List.iter + (fun x -> + try + Hashtbl.add tmp x (find cont x); + add_entry m x + with Not_found -> ()) + ent + in + let () = Hashtbl.add m.content !(m.nligne) tmp in + error + + let read_val m i j = + try find (find m.content i) j with _ -> { num = 0; den = 1 } + + let affiche parameters error m = + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "Variables:" + in + let () = + List.iter + (fun i -> + let () = print_trans parameters i in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) ", " + in + ()) + (get_all_key m) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + for i = 1 to !(m.nligne) do + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "---" + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let _ = + List.fold_left + (fun b x -> + let () = + if b then + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + " + " + in + let () = + let f = read_val m i x in + if f.num = 1 && f.den = 1 && not (Occu1.Affine_cst = x) then + () + else ( + let () = print_frac parameters f in + if not (Occu1.Affine_cst = x) then + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "." + ) + in + let () = print_trans parameters x in + true) + false (find m.entry i) + in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) " = 0" + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + () + done; + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error let new_eps_matrice parameters error l n = - let m=make parameters n in + let m = make parameters n in let error = List.fold_left - (fun error x-> - if (not (Affine_cst=x)) then - (new_copy_ligne parameters error m - ([x], - (let h = Hashtbl.create n in - (Hashtbl.add h x {num=1;den=1};h)))) - else error ) - error (List.sort (fun x->fun y->p y x) l) in + (fun error x -> + if not (Affine_cst = x) then + new_copy_ligne parameters error m + ( [ x ], + let h = Hashtbl.create n in + Hashtbl.add h x { num = 1; den = 1 }; + h ) + else + error) + error + (List.sort (fun x y -> p y x) l) + in error, m + let safe_assign m i (j : var) k = + let l = find m.entry i in + remove m.entry i; + (try remove (find m.content i) j with _ -> ()); + if k.num = 0 then + Hashtbl.add m.entry i (sub_list po l j) + else ( + add_entry m j; + Hashtbl.add (find m.content i) j k; + Hashtbl.add m.entry i (insert_sort po l j) + ) + + let del_ligne m i = + if i < !(m.nligne) + 1 then ( + Hashtbl.remove m.entry i; + Hashtbl.remove m.content i; + for j = i + 1 to !(m.nligne) do + Hashtbl.add m.entry (j - 1) (Hashtbl.find m.entry j); + Hashtbl.add m.content (j - 1) (Hashtbl.find m.content j); + Hashtbl.remove m.entry j; + Hashtbl.remove m.content j + done; + m.nligne := !(m.nligne) - 1 + ) + + let rec set_val parameters error m i j k = + if i > !(m.nligne) then ( + let error = new_empty_ligne parameters error m in + set_val parameters error m i j k + ) else ( + let () = safe_assign m i j k in + error + ) + let rec swap parameters error m i j = + if i = j then + error + else if i > !(m.nligne) || j > !(m.nligne) then ( + let error = new_empty_ligne parameters error m in + let error = swap parameters error m i j in + error + ) else ( + let entryi = find m.entry i in + let contenti = find m.content i in + let () = remove m.entry i in + let () = remove m.content i in + let () = Hashtbl.add m.entry i (find m.entry j) in + let () = Hashtbl.add m.content i (find m.content j) in + let () = remove m.entry j in + let () = remove m.content j in + let () = Hashtbl.add m.entry j entryi in + let () = Hashtbl.add m.content j contenti in + error + ) - let safe_assign m i (j:var) k = - let l=find m.entry i in - (remove m.entry i; - (try (remove (find m.content i) j) with _ -> ()); - if k.num=0 then (Hashtbl.add m.entry i (sub_list po l j)) - else (add_entry m j; - Hashtbl.add (find m.content i) j k; - Hashtbl.add m.entry i (insert_sort po l j))) - - let del_ligne m i = - (if i<(!(m.nligne)+1) then (Hashtbl.remove m.entry i; - Hashtbl.remove m.content i; - for j=(i+1) to (!(m.nligne)) do - Hashtbl.add m.entry (j-1) (Hashtbl.find m.entry j); - Hashtbl.add m.content (j-1) (Hashtbl.find m.content j); - Hashtbl.remove m.entry j; - Hashtbl.remove m.content j - done; - m.nligne:=(!(m.nligne))-1)) - - let rec set_val parameters error m i j k = - if i>(!(m.nligne)) then - (let error = new_empty_ligne parameters error m in - set_val parameters error m i j k) - else let () = safe_assign m i j k in error - - let rec swap parameters error m i j = - if (i=j) then error else - (if (i>(!(m.nligne))) || (j>(!(m.nligne))) - then - (let error = new_empty_ligne parameters error m in - let error = swap parameters error m i j in - error) - else - (let entryi=find m.entry i in - let contenti=find m.content i in - let () = remove m.entry i in - let () = remove m.content i in - let () = Hashtbl.add m.entry i (find m.entry j) in - let () = Hashtbl.add m.content i (find m.content j) in - let () = remove m.entry j in - let () = remove m.content j in - let () = Hashtbl.add m.entry j entryi in - let () = Hashtbl.add m.content j contenti in - error)) - - let mulligne parameters error m i alpha = - if ((i>(!(m.nligne)))) then error - else - List.fold_left - (fun error j-> - let k=read_val m i j in - set_val parameters error m i j (ffois alpha k)) - error - (find m.entry i) - - let addligne m i alpha j = - if (alpha.num=0) then () else - (let li=find m.entry i in - let lrep=merge po li (find m.entry j) in - (remove m.entry i; - if (j>(!(m.nligne))) then () - else - (List.iter - (fun x-> - (let k=fplus (ffois alpha (read_val m j - x)) (read_val m i x) in - ((try (remove (find m.content i) x) with _ -> ()); - add (find m.content i) x k))) lrep; - Hashtbl.add m.entry i (vide (fun x->((read_val m i x).num=0)) -lrep)))) - - let rec del_last_ligne m = - if (!(m.nligne)>0) then - (match (find m.entry (!(m.nligne))) with [] -> (remove m.entry (!(m.nligne)); - remove m.content (!(m.nligne)); - m.nligne:=(!(m.nligne))-1; - del_last_ligne m) - | _ -> ()) - else () - - let pivot m i = - if i>(!(m.nligne)) - then failwith "compteur_pivot_1" - else - ( - match (find m.entry i) - with (Affine_cst)::k::_ -> k - | [Affine_cst] -> failwith "compteur_pivot_2" - | (Bool _ | Counter _ | Site _ as k)::_ -> k - | [] -> failwith "compteur_pivot_3" + let mulligne parameters error m i alpha = + if i > !(m.nligne) then + error + else + List.fold_left + (fun error j -> + let k = read_val m i j in + set_val parameters error m i j (ffois alpha k)) + error (find m.entry i) + + let addligne m i alpha j = + if alpha.num = 0 then + () + else ( + let li = find m.entry i in + let lrep = merge po li (find m.entry j) in + remove m.entry i; + if j > !(m.nligne) then + () + else ( + List.iter + (fun x -> + let k = fplus (ffois alpha (read_val m j x)) (read_val m i x) in + (try remove (find m.content i) x with _ -> ()); + add (find m.content i) x k) + lrep; + Hashtbl.add m.entry i (vide (fun x -> (read_val m i x).num = 0) lrep) + ) + ) + + let rec del_last_ligne m = + if !(m.nligne) > 0 then ( + match find m.entry !(m.nligne) with + | [] -> + remove m.entry !(m.nligne); + remove m.content !(m.nligne); + m.nligne := !(m.nligne) - 1; + del_last_ligne m + | _ -> () + ) else + () + + let pivot m i = + if i > !(m.nligne) then + failwith "compteur_pivot_1" + else ( + match find m.entry i with + | Affine_cst :: k :: _ -> k + | [ Affine_cst ] -> failwith "compteur_pivot_2" + | ((Bool _ | Counter _ | Site _) as k) :: _ -> k + | [] -> failwith "compteur_pivot_3" + ) + + let normalise parameters (error : Exception.method_handler) m = + let rec aux (error : Exception.method_handler) k = + if k > !(m.nligne) then ( + del_last_ligne m; + error + ) else ( + let rec search_good_ligne l rep wei = + if l > !(m.nligne) then + rep, wei + else ( + try + let cur = pivot m l in + if po cur wei || wei = Affine_cst then + search_good_ligne (l + 1) l cur + else + search_good_ligne (1 + l) rep wei + with _ -> search_good_ligne (1 + l) rep wei + ) + in + let new_ligne, wei = search_good_ligne k (-1) Affine_cst in + let error = + if wei = Affine_cst then + aux error (!(m.nligne) + 1) + else ( + let col = pivot m new_ligne in + let error = swap parameters error m k new_ligne in + let error = + mulligne parameters error m k + (fdiv { num = 1; den = 1 } (read_val m k col)) + in + for i = 1 to !(m.nligne) do + if i = k then + () + else ( + let alpha = ffois { num = -1; den = 1 } (read_val m i col) in + addligne m i alpha k + ) + done; + aux error (k + 1) + ) + in + error + ) + in + aux error 1 + + let rec push parameters (error : Exception.method_handler) m j k = + if Working_list_imperative.member j (get_all_entry m) then ( + let rec aux error i = + if i > !(m.nligne) then + (error : Exception.method_handler) + else ( + let rep = read_val m i Affine_cst in + let r = read_val m i j in + let error = + set_val parameters error m i Affine_cst + (fplus rep + (let f = ffois r k in + { num = -f.num; den = f.den })) + in + aux error (i + 1) ) + in + aux error 1 + ) else ( + (*print_trans j;*) + let error = + new_copy_ligne parameters error m + ( [ j ], + let h = + Hashtbl.create + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + Hashtbl.add h j { Fraction.num = 1; Fraction.den = 1 }; + h ) + in + let error = normalise parameters error m in + let error = push parameters error m j k in + error + ) + + let get_line parameters error m k = + try error, (find m.entry k, find m.content k) + with _ -> + ( error, + ( [], + Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters) + ) ) + + let merge parameters error m m2 = + let new_m = + make parameters (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let () = + List.iter (add_entry new_m) + (Working_list_imperative.list (get_all_entry m)) + in + let () = + List.iter (add_entry new_m) + (Working_list_imperative.list (get_all_entry m2)) + in + let n2 = n_ligne m2 in + let n1 = n_ligne m in + let avant k1 k2 = + match + ( (try pivot m k1 with _ -> Affine_cst), + try pivot m2 k2 with _ -> Affine_cst ) + with + | Affine_cst, Affine_cst -> true + | Affine_cst, _ -> false + | _, Affine_cst -> true + | ( ((Bool _ | Counter _ | Site _) as a), + ((Bool _ | Counter _ | Site _) as b) ) -> + po a b + in + let rec aux k1 k2 error = + match k2 > n2, k1 > n1, avant k1 k2 with + | true, true, _ -> error, new_m + | _, _, true -> + let error, (la, lb) = get_line parameters error m k1 in + let error = new_copy_ligne parameters error new_m (la, lb) in + aux (k1 + 1) k2 error + | _ -> + let error, (la, lb) = get_line parameters error m2 k2 in + let error = new_copy_ligne parameters error new_m (la, lb) in + aux k1 (k2 + 1) error + in + aux 1 1 error + let _safe_merge parameters error m m2 = + let error, rep = merge parameters error m m2 in + let error = normalise parameters error rep in + error, rep - let normalise parameters (error:Exception.method_handler) m = - let rec aux (error:Exception.method_handler) k = - (if k>(!(m.nligne)) - then (del_last_ligne m;error) - else (let rec search_good_ligne l rep wei = - if l>(!(m.nligne)) then (rep,wei) - else ( - try (let cur=(pivot m l) in - if po cur wei || wei=Affine_cst - then (search_good_ligne (l+1) l cur) - else (search_good_ligne (1+l) rep wei) - ) with _ -> search_good_ligne (1+l) rep wei) in - let new_ligne,wei=search_good_ligne k (-1) Affine_cst in - let error = - if wei=Affine_cst then aux error ((!(m.nligne))+1) else - begin - let col=pivot m new_ligne in - let error = - swap parameters error m k (new_ligne) - in - let error = - mulligne parameters error m k (fdiv {num=1;den=1} (read_val m k col)) - in - for i=1 to (!(m.nligne)) do - if i=k then () - else (let alpha=ffois {num=(-1);den=1} - (read_val m i col) in addligne m i alpha k) - done; - aux error (k+1) - end - in error)) - in aux error 1 - - - - let rec push parameters (error:Exception.method_handler) m j k = - if Working_list_imperative.member j (get_all_entry m) - then - let rec aux error i = - if i > (!(m.nligne)) then (error:Exception.method_handler) - else - - let rep=read_val m i Affine_cst in - let r = read_val m i j in - let error = - set_val parameters error m i - Affine_cst - (fplus rep - ((let f=(ffois r k) in - { - num=(-f.num); - den=f.den - }))) - in - aux error (i+1) - in aux error 1 - else - (*print_trans j;*) - let error = - new_copy_ligne parameters error - m ([j],(let h=Hashtbl.create - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - Hashtbl.add h j {Fraction.num=1;Fraction.den=1}; - h)) in - let error = - normalise parameters error m - in - let error = - push parameters error m j k - in - error - - let get_line parameters error m k = - try (error, (find m.entry k,find m.content k)) with _ -> - error, - ([], - Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters)) - - let merge parameters error m m2 = - let new_m = - make parameters - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let () = - List.iter (add_entry new_m) (Working_list_imperative.list (get_all_entry m)) - in - let () = - List.iter (add_entry new_m) (Working_list_imperative.list (get_all_entry m2)) - in - let n2=n_ligne m2 in - let n1=n_ligne m in - let avant k1 k2 = - match (try (pivot m k1) with _ -> Affine_cst), - (try (pivot m2 k2) with _ -> Affine_cst) - with Affine_cst,Affine_cst -> true - | Affine_cst,_ -> false - | _ ,Affine_cst -> true - | (Bool _ | Counter _ | Site _ as a), - (Bool _ | Counter _ | Site _ as b) - -> (po a b) in - let rec aux k1 k2 error = - match (k2>n2),(k1>n1),(avant k1 k2) - with - | true,true,_ -> error, new_m - | _,_,true -> - let error, (la, lb) = get_line parameters error m k1 in - let error = new_copy_ligne parameters error new_m (la,lb) in - aux (k1+1) k2 error - | _ -> - let error, (la, lb) = get_line parameters error m2 k2 in - let error = new_copy_ligne parameters error new_m (la,lb) in - aux k1 (k2+1) error - in - aux 1 1 error - - let _safe_merge parameters error m m2 = - let error, rep = merge parameters error m m2 in - let error = normalise parameters error rep in - error, rep - - let copy parameters error m = - let cop_line (k,c) = - let nl= - Hashtbl.create - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - (List.iter - (fun x->(Hashtbl.add nl x (Hashtbl.find c x))) - k; - (k,nl)) - in - let nm= - make parameters (Remanent_parameters.get_empty_hashtbl_size parameters) - in - List.iter - (fun x->add_entry nm x) - (Working_list_imperative.list m.all_entry); - let rec aux error i = - if i> (!(m.nligne)) then error - else - let error, (la,lb) = get_line parameters error m i in - let error = - new_copy_ligne parameters error nm ((cop_line:'b->'b) (la,lb)) - in aux error (i+1) - in - let error = aux error 1 in - error, nm - - let decomp_affine parameters error m = - let n=(Remanent_parameters.get_empty_hashtbl_size parameters) in - let nm=make parameters n in - let () = copy_var m nm in - let o= new_point parameters n in - let cop_line (k,c) = - let nl=Hashtbl.create n in - (List.iter - (fun x->(Hashtbl.add nl x (Hashtbl.find c x))) k; - (k,nl)) - in - let forget_affine l = - match l with - | Affine_cst::q -> q - | [] | (Bool _ | Counter _ | Site _)::_-> l in - let rec aux i error = - if i > (!(m.nligne)) - then error - else - let error, (k, c) = get_line parameters error m i in - let error = new_copy_ligne parameters error nm ((cop_line (forget_affine k,c))) in - let () = - o.set (pivot m i) - (let f=read_val m i Affine_cst in - {num=(-f.num);den=f.den}) - in - aux (i+1) error - in - let error = aux 1 error in - error, (o,nm) + let copy parameters error m = + let cop_line (k, c) = + let nl = + Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters) + in + List.iter (fun x -> Hashtbl.add nl x (Hashtbl.find c x)) k; + k, nl + in + let nm = + make parameters (Remanent_parameters.get_empty_hashtbl_size parameters) + in + List.iter + (fun x -> add_entry nm x) + (Working_list_imperative.list m.all_entry); + let rec aux error i = + if i > !(m.nligne) then + error + else ( + let error, (la, lb) = get_line parameters error m i in + let error = + new_copy_ligne parameters error nm ((cop_line : 'b -> 'b) (la, lb)) + in + aux error (i + 1) + ) + in + let error = aux error 1 in + error, nm + + let decomp_affine parameters error m = + let n = Remanent_parameters.get_empty_hashtbl_size parameters in + let nm = make parameters n in + let () = copy_var m nm in + let o = new_point parameters n in + let cop_line (k, c) = + let nl = Hashtbl.create n in + List.iter (fun x -> Hashtbl.add nl x (Hashtbl.find c x)) k; + k, nl + in + let forget_affine l = + match l with + | Affine_cst :: q -> q + | [] | (Bool _ | Counter _ | Site _) :: _ -> l + in + let rec aux i error = + if i > !(m.nligne) then + error + else ( + let error, (k, c) = get_line parameters error m i in + let error = + new_copy_ligne parameters error nm (cop_line (forget_affine k, c)) + in + let () = + o.set (pivot m i) + (let f = read_val m i Affine_cst in + { num = -f.num; den = f.den }) + in + aux (i + 1) error + ) + in + let error = aux 1 error in + error, (o, nm) let mat_of_var_list parameters error l = - let error, m= - new_eps_matrice parameters error l (Remanent_parameters.get_empty_hashtbl_size parameters) in + let error, m = + new_eps_matrice parameters error l + (Remanent_parameters.get_empty_hashtbl_size parameters) + in let error = List.fold_left - (fun error x->push parameters error m x {num=1;den=1}) error l + (fun error x -> push parameters error m x { num = 1; den = 1 }) + error l in - error, - m + error, m let plonge parameters error m l = - let error, nm= + let error, nm = new_eps_matrice parameters error - (filtre - (fun p-> not (Working_list_imperative.member p m.all_entry)) - l) - (Remanent_parameters.get_empty_hashtbl_size parameters) in + (filtre (fun p -> not (Working_list_imperative.member p m.all_entry)) l) + (Remanent_parameters.get_empty_hashtbl_size parameters) + in merge parameters error m nm - let unify_domain parameters error m m2 = - let key1=List.filter (fun x->(not (List.mem x (get_all_key m) ))) (get_all_key m2) in - let key2=List.filter (fun x->(not (List.mem x (get_all_key m2) ))) (get_all_key m) in - let error, m1 = plonge parameters error m key1 in - let error, m2 = plonge parameters error m2 key2 in - error, m1, m2 - - let union parameters error ma nb = - let error, ma,mb = unify_domain parameters error ma nb in - let _m=max (n_ligne ma) (n_ligne mb) in - let traite (s:trans) (r:int) = - match (read_val ma r s,read_val mb r s) - with - {num=1;den=1},{num=1;den=1} -> (r+1) - | {num=1;den=1},_ -> - begin - for i=1 to (r-1) do - let a=read_val mb i s in - addligne ma i a (r) - done; - del_ligne ma (r); - r - end - | _,{num=1;den=1} -> - begin - for i=1 to (r-1) do - let a=read_val ma i s in - addligne mb i a (r) - done; - del_ligne mb (r); - r - end - | _ -> - ( - let (t:int)= - (let rec find t = - if t<0 - then 0 - else - (if ((read_val ma t s)=(read_val mb t s)) - then find (t-1) - else t) - in find (r-1)) in - (if (t>0) then - (for i=1 to (t-1) do - let a=fdiv (fmoins (read_val ma i s) (read_val mb i s)) - (fmoins (read_val mb t s) (read_val ma t s)) - in - addligne ma i a t; - addligne mb i a t; - done; - del_ligne ma t; - del_ligne mb t;r-1) - else - r)) in - let rec algo r sliste = - match sliste with - Affine_cst::squeue -> algo r squeue - | (Bool _ | Counter _ | Site _ as s)::squeue -> - let rprim = (traite s r ) - in algo rprim squeue - | [] -> ignore (traite Affine_cst r) in - error, (algo 1 - (let l=fusion (fun x->fun y->(po x y)) - (get_all_key ma) (get_all_key mb) in - l); - ma) - - let recomp_affine parameters error ((o:point),m) = - let error, nm= copy parameters error m in - let error = - List.fold_left - (fun error (x,y)->(push parameters error nm x y)) - error (o.coord ()) + let unify_domain parameters error m m2 = + let key1 = + List.filter (fun x -> not (List.mem x (get_all_key m))) (get_all_key m2) + in + let key2 = + List.filter (fun x -> not (List.mem x (get_all_key m2))) (get_all_key m) + in + let error, m1 = plonge parameters error m key1 in + let error, m2 = plonge parameters error m2 key2 in + error, m1, m2 + + let union parameters error ma nb = + let error, ma, mb = unify_domain parameters error ma nb in + let _m = max (n_ligne ma) (n_ligne mb) in + let traite (s : trans) (r : int) = + match read_val ma r s, read_val mb r s with + | { num = 1; den = 1 }, { num = 1; den = 1 } -> r + 1 + | { num = 1; den = 1 }, _ -> + for i = 1 to r - 1 do + let a = read_val mb i s in + addligne ma i a r + done; + del_ligne ma r; + r + | _, { num = 1; den = 1 } -> + for i = 1 to r - 1 do + let a = read_val ma i s in + addligne mb i a r + done; + del_ligne mb r; + r + | _ -> + let (t : int) = + let rec find t = + if t < 0 then + 0 + else if read_val ma t s = read_val mb t s then + find (t - 1) + else + t + in + find (r - 1) in - error, nm - - - - let somme_affine parameters error ma mb = - let error, ma=copy parameters error ma in - let error, mb=copy parameters error mb in - let error, ma,mb = unify_domain parameters error ma mb in - let error, (oa,ma)=decomp_affine parameters error ma in - let error, (ob,mb)=decomp_affine parameters error mb in - let () = oa.somme_point ob in - let error, mc = union parameters error ma mb in - let error, rep = recomp_affine parameters error (oa,mc) in - error, rep - - - - - -let insert_0 parameters error m = - let l=Working_list_imperative.list (get_all_entry m) in - let error,nm= - new_eps_matrice parameters error l - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - union parameters error nm m - -let pushbool parameters (error:Exception.method_handler) m a = - let error, m2 = copy parameters error m in - let error = - new_copy_ligne parameters error m2 - ([a],let h = create 1 in - (add h a {Fraction.num=0;Fraction.den=1};h)) in - let error = push parameters error m2 a {Fraction.num=1;Fraction.den=1} in - let error = normalise parameters error m2 in - let error, m3 = copy parameters error m in - let error = - new_copy_ligne parameters error m3 - ([a],let h = create 1 in - (add h a {Fraction.num=1;Fraction.den=1};h)) in - let error = normalise parameters error m3 in - let error, m = union parameters error m2 m3 in - let error = normalise parameters error m in - error, m - -let equal parameters error m1 m2 = - let error, m1=copy parameters error m1 in - let error, m2=copy parameters error m2 in - let error, union = union parameters error m1 m2 in - error, m2.nligne = union.nligne && m1.nligne = union.nligne - -let abstract_away parameters (error,matrice) var = - let error, matrice_copy = copy parameters error matrice in - let error = - push parameters error matrice_copy var {Fraction.num=1;Fraction.den=1} - in - let error, m = union parameters error matrice matrice_copy in - let error = normalise parameters error m in - error, m - -let abstract_away parameters error matrice list = - List.fold_left - (abstract_away parameters) - (error, matrice) - list + if t > 0 then ( + for i = 1 to t - 1 do + let a = + fdiv + (fmoins (read_val ma i s) (read_val mb i s)) + (fmoins (read_val mb t s) (read_val ma t s)) + in + addligne ma i a t; + addligne mb i a t + done; + del_ligne ma t; + del_ligne mb t; + r - 1 + ) else + r + in + let rec algo r sliste = + match sliste with + | Affine_cst :: squeue -> algo r squeue + | ((Bool _ | Counter _ | Site _) as s) :: squeue -> + let rprim = traite s r in + algo rprim squeue + | [] -> ignore (traite Affine_cst r) + in + ( error, + (algo 1 + (let l = + fusion (fun x y -> po x y) (get_all_key ma) (get_all_key mb) + in + l); + ma) ) + + let recomp_affine parameters error ((o : point), m) = + let error, nm = copy parameters error m in + let error = + List.fold_left + (fun error (x, y) -> push parameters error nm x y) + error (o.coord ()) + in + error, nm + + let somme_affine parameters error ma mb = + let error, ma = copy parameters error ma in + let error, mb = copy parameters error mb in + let error, ma, mb = unify_domain parameters error ma mb in + let error, (oa, ma) = decomp_affine parameters error ma in + let error, (ob, mb) = decomp_affine parameters error mb in + let () = oa.somme_point ob in + let error, mc = union parameters error ma mb in + let error, rep = recomp_affine parameters error (oa, mc) in + error, rep + + let insert_0 parameters error m = + let l = Working_list_imperative.list (get_all_entry m) in + let error, nm = + new_eps_matrice parameters error l + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + union parameters error nm m + + let pushbool parameters (error : Exception.method_handler) m a = + let error, m2 = copy parameters error m in + let error = + new_copy_ligne parameters error m2 + ( [ a ], + let h = create 1 in + add h a { Fraction.num = 0; Fraction.den = 1 }; + h ) + in + let error = + push parameters error m2 a { Fraction.num = 1; Fraction.den = 1 } + in + let error = normalise parameters error m2 in + let error, m3 = copy parameters error m in + let error = + new_copy_ligne parameters error m3 + ( [ a ], + let h = create 1 in + add h a { Fraction.num = 1; Fraction.den = 1 }; + h ) + in + let error = normalise parameters error m3 in + let error, m = union parameters error m2 m3 in + let error = normalise parameters error m in + error, m + + let equal parameters error m1 m2 = + let error, m1 = copy parameters error m1 in + let error, m2 = copy parameters error m2 in + let error, union = union parameters error m1 m2 in + error, m2.nligne = union.nligne && m1.nligne = union.nligne + let abstract_away parameters (error, matrice) var = + let error, matrice_copy = copy parameters error matrice in + let error = + push parameters error matrice_copy var + { Fraction.num = 1; Fraction.den = 1 } + in + let error, m = union parameters error matrice matrice_copy in + let error = normalise parameters error m in + error, m + let abstract_away parameters error matrice list = + List.fold_left (abstract_away parameters) (error, matrice) list end diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/matrices.mli b/core/KaSa_rep/abstract_domains/numerical_domains/matrices.mli index 077ddaad18..78429785ef 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/matrices.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/matrices.mli @@ -1,130 +1,161 @@ -module type Matrice = - sig +module type Matrice = sig + type point + type line = Occu1.trans list * (Occu1.trans, Fraction.fraction) Hashtbl.t + type matrice + type var - type point -type line = Occu1.trans list * (Occu1.trans, Fraction.fraction) Hashtbl.t + val mat_of_var_list : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + var list -> + Exception.method_handler * matrice -type matrice -type var + val make : Remanent_parameters_sig.parameters -> int -> matrice -val mat_of_var_list : - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - var list -> Exception.method_handler * matrice + val affiche : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler -val make: - Remanent_parameters_sig.parameters -> - int-> matrice -val affiche: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice-> Exception.method_handler + val affiche_cons : + Remanent_parameters_sig.parameters -> + int list * (int, Fraction.fraction) Hashtbl.t * Intervalles.intervalle -> + unit -val affiche_cons: - Remanent_parameters_sig.parameters -> - int list * (int, Fraction.fraction) Hashtbl.t * - Intervalles.intervalle -> unit + val get_all_entry : matrice -> var Working_list_imperative.working_list + val add_entry : matrice -> var -> unit -val get_all_entry: matrice-> var Working_list_imperative.working_list -val add_entry: matrice-> var->unit + val plonge : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + var list -> + Exception.method_handler * matrice -val plonge: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice-> var list -> Exception.method_handler * matrice + val copy : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler * matrice -val copy: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice -> - Exception.method_handler * matrice + val normalise : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler - val normalise: + val push : Remanent_parameters_sig.parameters -> Exception.method_handler -> - matrice -> Exception.method_handler + matrice -> + var -> + Fraction.fraction -> + Exception.method_handler - val push: + val pushbool : Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> var->Fraction.fraction->Exception.method_handler + Exception.method_handler -> + matrice -> + var -> + Exception.method_handler * matrice - val pushbool: - Remanent_parameters_sig.parameters -> Exception.method_handler-> - matrice -> var -> Exception.method_handler * matrice + val new_copy_ligne : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + line -> + Exception.method_handler - val new_copy_ligne: + val new_empty_ligne : Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> line->Exception.method_handler + Exception.method_handler -> + matrice -> + Exception.method_handler - val new_empty_ligne: + val n_ligne : matrice -> int + + val get_line : Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice->Exception.method_handler -val n_ligne: matrice->int + Exception.method_handler -> + matrice -> + int -> + Exception.method_handler * line -val get_line: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice->int->Exception.method_handler*line + val get_trans_list : line -> Occu1.trans list -val get_trans_list: line -> Occu1.trans list -val merge: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> matrice->Exception.method_handler * matrice + val merge : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * matrice -val pivot:matrice->int-> var -val read_val:matrice->int-> var->Fraction.fraction -val addligne:matrice->int->Fraction.fraction->int->unit -val swap: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> matrice->int->int->Exception.method_handler + val pivot : matrice -> int -> var + val read_val : matrice -> int -> var -> Fraction.fraction + val addligne : matrice -> int -> Fraction.fraction -> int -> unit -val mulligne: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice->int->Fraction.fraction->Exception.method_handler + val swap : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + int -> + int -> + Exception.method_handler -val del_ligne: matrice->int->unit -val del_last_ligne: matrice->unit + val mulligne : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + int -> + Fraction.fraction -> + Exception.method_handler -val union: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice -> matrice->Exception.method_handler * matrice + val del_ligne : matrice -> int -> unit + val del_last_ligne : matrice -> unit -val get_all_key: matrice-> var list -val is_key: matrice->var->bool + val union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * matrice + + val get_all_key : matrice -> var list + val is_key : matrice -> var -> bool + + val decomp_affine : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler * (point * matrice) -val decomp_affine: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> matrice-> - Exception.method_handler*(point*matrice) + val somme_affine : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * matrice -val somme_affine: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice -> matrice-> Exception.method_handler * matrice - -val insert_0: - Remanent_parameters_sig.parameters -> - Exception.method_handler-> - matrice-> Exception.method_handler * matrice - -val equal: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice -> matrice -> - Exception.method_handler * bool + val insert_0 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + Exception.method_handler * matrice -val abstract_away: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - matrice -> var list -> - Exception.method_handler * matrice + val equal : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + matrice -> + Exception.method_handler * bool + val abstract_away : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + matrice -> + var list -> + Exception.method_handler * matrice end -module Matrice: Matrice with type var = Occu1.trans +module Matrice : Matrice with type var = Occu1.trans diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.ml b/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.ml index ed7c48ee78..102cdf794f 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.ml @@ -3,144 +3,118 @@ open Intervalles open Intertab module NR = - functor (I:Tabinter with type var=Occu1.trans and type intervalle=Intervalles.intervalle) -> - (struct - +functor + (I : Tabinter + with type var = Occu1.trans + and type intervalle = Intervalles.intervalle) + -> + ( + struct type intertab = I.intervalle_tab type prod = intertab type var = Occu1.trans - let addzero=true - let compt_of_var_list parameters error l - = + let addzero = true + + let compt_of_var_list parameters error l = I.int_of_var_list parameters error l - let affiche_mat parameters error x = - I.affiche parameters error x + let affiche_mat parameters error x = I.affiche parameters error x let is_vide prod x = - (I.read prod x)={inf=Frac({num=0;den=1});sup=Frac({num=0;den=1})} - - let is_infinite m x = - (I.read m x).sup=Fraction.Infinity - - let is_minfinite m x = - (I.read m x).inf=Fraction.Minfinity - - let _is_both_infinite m x = - is_infinite m x && is_minfinite m x - - let _is_either_infinite m x = - is_infinite m x || is_minfinite m x - - let create _parameters n = - I.make n - let f_un = {num=1;den=1} - let f_zero = {num=0;den=1} - let _un ={inf = Frac f_un;sup=Frac f_un} - let _zero = {inf = Frac f_zero;sup=Frac f_zero} - - let list_var _parameters p = - I.clef p - - -let guard parameters error p l = - (* let classe=classe p (List.rev_map (fun (a,_,_) -> a) (List.rev l)) in*) - let error, i2=I.copy parameters error p in - try - let () = - List.iter - (fun (j,cmp,i) -> - I.set i2 - j - (cap_inter - (I.read i2 j) - (match cmp with - | Counters_domain_type.EQ -> - {inf= Frac{num=i;den=1}; - sup= Frac{num=i;den=1}} - | Counters_domain_type.GT -> - {inf= Frac{num=i+1;den=1}; - sup=Infinity} - | Counters_domain_type.GTEQ -> - {inf= Frac{num=i;den=1}; - sup=Infinity} - | Counters_domain_type.LT -> - {inf=Minfinity; - sup= - Frac{num=i-1;den=1}} - | Counters_domain_type.LTEQ -> - {sup= Frac{num=i;den=1}; - inf=Minfinity} - ))) l - in - error, Some i2 - with - | Intervalle_vide -> error, None - - - - - - let union parameters error p q = - I.union parameters error p q - let merge parameters error p q = - try let error, a = I.merge parameters error p q in - error, Some a - with - Intervalle_vide -> error, None - - let plonge _parameters error m _l = - error, m - - let bin_incr gen parameters error p q = - let error, i= gen parameters error p q in - if i=[] then - error, (p ,false) - else error, (p,true) - - let widen parameters error p q = - bin_incr I.wide_place parameters error p q - let union_incr parameters error p q = - bin_incr I.union_place parameters error p q - - let interval_of_pro _parameters error m x = - error, I.read m x - - let string_of_pro parameters error m x = - let error, interv = interval_of_pro parameters error m x in - Intervalles.string_of_intervalle parameters error interv - - let interval_of_pro parameters error m x = - let error, interv = interval_of_pro parameters error m x in - error, Some (interv.inf, interv.sup) - - - let push _parameters error m x f = - let _ =I.push m x f in - error, m - - let _translate parameters error m l = - List.fold_left - (fun (error, m) (x,i) -> - push parameters error m x {num=i;den=1}) - (error, m) - l (* TO DO -> do more efficiently *) - - - let solve_all _parameters error m = error, Some m - let solve_inf _parameters error m _l = error, Some m - - - let copy parameters error m = - I.copy parameters error m - - - let abstract_away parameters error m l = - let error, i = I.abstract_away parameters error m l in - error, i - - end:Mat_inter.Mat_inter with type var=Occu1.trans) - - -module Non_rel= NR(Intertab.Tabinter) + I.read prod x + = { inf = Frac { num = 0; den = 1 }; sup = Frac { num = 0; den = 1 } } + + let is_infinite m x = (I.read m x).sup = Fraction.Infinity + let is_minfinite m x = (I.read m x).inf = Fraction.Minfinity + let _is_both_infinite m x = is_infinite m x && is_minfinite m x + let _is_either_infinite m x = is_infinite m x || is_minfinite m x + let create _parameters n = I.make n + let f_un = { num = 1; den = 1 } + let f_zero = { num = 0; den = 1 } + let _un = { inf = Frac f_un; sup = Frac f_un } + let _zero = { inf = Frac f_zero; sup = Frac f_zero } + let list_var _parameters p = I.clef p + + let guard parameters error p l = + (* let classe=classe p (List.rev_map (fun (a,_,_) -> a) (List.rev l)) in*) + let error, i2 = I.copy parameters error p in + try + let () = + List.iter + (fun (j, cmp, i) -> + I.set i2 j + (cap_inter (I.read i2 j) + (match cmp with + | Counters_domain_type.EQ -> + { + inf = Frac { num = i; den = 1 }; + sup = Frac { num = i; den = 1 }; + } + | Counters_domain_type.GT -> + { inf = Frac { num = i + 1; den = 1 }; sup = Infinity } + | Counters_domain_type.GTEQ -> + { inf = Frac { num = i; den = 1 }; sup = Infinity } + | Counters_domain_type.LT -> + { inf = Minfinity; sup = Frac { num = i - 1; den = 1 } } + | Counters_domain_type.LTEQ -> + { sup = Frac { num = i; den = 1 }; inf = Minfinity }))) + l + in + error, Some i2 + with Intervalle_vide -> error, None + + let union parameters error p q = I.union parameters error p q + + let merge parameters error p q = + try + let error, a = I.merge parameters error p q in + error, Some a + with Intervalle_vide -> error, None + + let plonge _parameters error m _l = error, m + + let bin_incr gen parameters error p q = + let error, i = gen parameters error p q in + if i = [] then + error, (p, false) + else + error, (p, true) + + let widen parameters error p q = + bin_incr I.wide_place parameters error p q + + let union_incr parameters error p q = + bin_incr I.union_place parameters error p q + + let interval_of_pro _parameters error m x = error, I.read m x + + let string_of_pro parameters error m x = + let error, interv = interval_of_pro parameters error m x in + Intervalles.string_of_intervalle parameters error interv + + let interval_of_pro parameters error m x = + let error, interv = interval_of_pro parameters error m x in + error, Some (interv.inf, interv.sup) + + let push _parameters error m x f = + let _ = I.push m x f in + error, m + + let _translate parameters error m l = + List.fold_left + (fun (error, m) (x, i) -> + push parameters error m x { num = i; den = 1 }) + (error, m) l (* TO DO -> do more efficiently *) + + let solve_all _parameters error m = error, Some m + let solve_inf _parameters error m _l = error, Some m + let copy parameters error m = I.copy parameters error m + + let abstract_away parameters error m l = + let error, i = I.abstract_away parameters error m l in + error, i + end : + Mat_inter.Mat_inter with type var = Occu1.trans) + +module Non_rel = NR (Intertab.Tabinter) diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.mli b/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.mli index 9275da3c99..07e461ab9b 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/non_rel.mli @@ -1,2 +1 @@ - -module Non_rel:(Mat_inter.Mat_inter with type var = Occu1.trans) +module Non_rel : Mat_inter.Mat_inter with type var = Occu1.trans diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/occu1.ml b/core/KaSa_rep/abstract_domains/numerical_domains/occu1.ml index d5fa253763..ca77d85237 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/occu1.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/occu1.ml @@ -4,55 +4,64 @@ type trans = | Counter of Ckappa_sig.c_site_name | Affine_cst - let p x y = - match x,y with + match x, y with | Affine_cst, Affine_cst -> 0 | _, Affine_cst -> -1 | Affine_cst, _ -> 1 - | Bool (a,b), Bool (a',b') -> - let cmp = Ckappa_sig.compare_site_name a a' in - if cmp = 0 then Ckappa_sig.compare_state_index b b' - else cmp - | Bool _ , _ -> 1 - | _ , Bool _ -> -1 + | Bool (a, b), Bool (a', b') -> + let cmp = Ckappa_sig.compare_site_name a a' in + if cmp = 0 then + Ckappa_sig.compare_state_index b b' + else + cmp + | Bool _, _ -> 1 + | _, Bool _ -> -1 | Site c, Site c' -> Ckappa_sig.compare_site_name c c' | _, Site _ -> -1 | Site _, _ -> 1 | Counter c, Counter c' -> Ckappa_sig.compare_site_name c c' - (*| _, Counter _ -> -1 - | Counter _, _ -> 1*) +(*| _, Counter _ -> -1 + | Counter _, _ -> 1*) -let po x y = ((p x y)>0) +let po x y = p x y > 0 let string_of_trans x = match x with - | Affine_cst -> "Affine constant" - | Counter c -> - "Counter_"^(string_of_int (Ckappa_sig.int_of_site_name c)) - | Bool(a,b) -> - "Is_site_"^(string_of_int (Ckappa_sig.int_of_site_name a))^"_in_state_"^(string_of_int (Ckappa_sig.int_of_state_index b)) - | Site a -> - "Site_"^(string_of_int (Ckappa_sig.int_of_site_name a)) + | Affine_cst -> "Affine constant" + | Counter c -> "Counter_" ^ string_of_int (Ckappa_sig.int_of_site_name c) + | Bool (a, b) -> + "Is_site_" + ^ string_of_int (Ckappa_sig.int_of_site_name a) + ^ "_in_state_" + ^ string_of_int (Ckappa_sig.int_of_state_index b) + | Site a -> "Site_" ^ string_of_int (Ckappa_sig.int_of_site_name a) let print_trans parameters x = match x with - | Affine_cst -> () + | Affine_cst -> () | Counter c -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "Counter_%i" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Counter_%i" (Ckappa_sig.int_of_site_name c) in () | Site c -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "Site_%i" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Site_%i" (Ckappa_sig.int_of_site_name c) in () - | Bool(a,b) -> + | Bool (a, b) -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "Is_site_%i_in_state_%i" - (Ckappa_sig.int_of_site_name a) (Ckappa_sig.int_of_state_index b) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Is_site_%i_in_state_%i" + (Ckappa_sig.int_of_site_name a) + (Ckappa_sig.int_of_state_index b) in - () + () diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/occu1.mli b/core/KaSa_rep/abstract_domains/numerical_domains/occu1.mli index d77797f438..e2cb612418 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/occu1.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/occu1.mli @@ -4,7 +4,7 @@ type trans = | Counter of Ckappa_sig.c_site_name | Affine_cst -val string_of_trans: trans -> string -val print_trans: Remanent_parameters_sig.parameters -> trans -> unit -val po: trans -> trans -> bool -val p: trans -> trans -> int +val string_of_trans : trans -> string +val print_trans : Remanent_parameters_sig.parameters -> trans -> unit +val po : trans -> trans -> bool +val p : trans -> trans -> int diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/octo.ml b/core/KaSa_rep/abstract_domains/numerical_domains/octo.ml index b406a862d1..98e35e891b 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/octo.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/octo.ml @@ -4,448 +4,516 @@ open Mat_inter exception Exit -type unbounded= Bound of int | Infinity - -module Octo = - (struct - type var = Occu1.trans - type var_symb = Plus of var | Moins of var (*| ZERO *) - type prod = {key : (var_symb*var_symb) Working_list_imperative.working_list; - map : (var_symb*var_symb,Integer.unbounded) Hashtbl.t; - var : (var) Working_list_imperative.working_list} - - let addzero = false - let _p i j = - match i,j with -(* ZERO,_ -> true - | _,ZERO -> false*) - | Plus(_),Moins(_) -> true - | Plus(x),Plus(y) -> x false - | Moins(x),Moins(y) -> x - if Working_list_imperative.member t m.var - then () - else - (Working_list_imperative.push t m.var; - begin - (let l=Working_list_imperative.list m.var in - List.iter - (fun z-> - set_cons m (Plus (z)) (Plus(t)) (div2 (get_cons m (Plus z) (Moins(z)))); - set_cons m (Moins (z)) (Plus(t)) (div2 (get_cons m (Moins z) (Plus(z)))); - set_cons m (Plus(t)) (Plus (z)) (div2 (get_cons m (Moins z) (Plus z) )); - set_cons m (Plus(t)) (Moins (z)) (div2 (get_cons m (Plus z) (Moins (z)))); - set_cons m (Plus (z)) (Moins(t)) (div2 (get_cons m (Plus z) (Moins(z)))); - set_cons m (Moins (z)) (Moins(t)) (div2 (get_cons m (Moins z) (Plus(z)))); - set_cons m (Moins(t)) (Plus (z)) (div2 (get_cons m (Moins z) (Plus z) )); - set_cons m (Moins(t)) (Moins (z)) (div2 (get_cons m (Plus z) (Moins (z)))) - ) - l; - Working_list_imperative.push t m.var; - )end ) - - and get_cons m i j = - try (Hashtbl.find m.map (i,j)) with _ -> Integer.Bounded(0) - - - and new_cons m i j k = - Working_list_imperative.push (i,j) m.key ; - add_var m i ; add_var m j; - (try (let a=Hashtbl.find m.map (i,j) in - Hashtbl.remove m.map (i,j); - Hashtbl.add m.map (i,j) (Integer.min a k)) - with _ -> (*(m.key.Working_list_imperative.push) (i,j); - add_var m i;add_var m j;*) - Hashtbl.add (m.map) (i,j) k ) - and set_cons m i j k = - Working_list_imperative.push (i,j) m.key; - add_var m i ; add_var m j; - (try (let _=Hashtbl.find m.map (i,j) in - Hashtbl.remove m.map (i,j); - Hashtbl.add m.map (i,j) k) - with _ -> (*(m.key.Working_list_imperative.push) (i,j); - add_var m i;add_var m j;*) - Hashtbl.add (m.map) (i,j) k ) - - - - let print parameters x = - match x with - | Integer.Bounded(x)->string_of_int x - | Integer.Infinity -> Remanent_parameters.get_plus_infinity_symbol parameters - - let minus x = - match x with - Integer.Bounded(x) -> Integer.Bounded(-x) - | Integer.Infinity -> Integer.Infinity - - - let op x = - match x with Plus(x) -> Moins(x) | Moins(x) -> Plus(x) - let _test_and_set m i j k = - if (Integer.p (minus (get_cons m (op i) (op j))) k) - then raise Exit - else set_cons m i j k - - let interval_of_pro _parameters _error m x = - (minus (div2 (get_cons m (Moins(x)) (Plus(x))))), - (div2 (get_cons m (Plus(x)) (Moins(x)))) - - let string_of_pro parameters error m x = - let inf,sup = interval_of_pro parameters error m x in - error, "[|"^(print parameters inf)^ - ";"^(print parameters sup)^"|]" - - let push _parameters error m x f = - add_var m (Plus(x)); - let k=f.num in - List.iter (fun y -> - List.iter (fun s -> - let y=if s then Plus(y) else Moins(y) in - (set_cons m (Plus(x)) y (Integer.plus (get_cons m (Plus(x)) y) (Bounded(k))); - set_cons m y ((Moins(x))) (Integer.plus (get_cons m y (Moins(x))) - (Bounded(k))); - - set_cons m (Moins(x)) y (Integer.plus (get_cons m (Moins(x)) y) (Bounded(-k))); - set_cons m y (Plus(x)) (Integer.plus (get_cons m y (Plus(x))) (Bounded(-k))))) - [true;false]) - (Working_list_imperative.list m.var);(*print_string (string_of_pro m x);print_string (print (get_cons m (Plus(x)) (Moins(x))));*) - error, m - - let affiche parameters error prod = - print_string "
"; - let error' = List.fold_left - (fun error x-> - let error, s = string_of_pro parameters error prod x in - let () = print_string s in - error) error (Working_list_imperative.list prod.var) in - print_newline (); - print_string "
"; error' - (*List.iter - (fun x-> - (List.iter - (fun y -> - print_newline (); - print_trans x; - print_trans y; - print_newline (); - print_string (print (get_cons prod (Plus(x)) (Plus(y)))^ - print (get_cons prod (Plus(x)) (Moins(y)))^ - print (get_cons prod (Moins(x)) (Plus(y)))^ - print (get_cons prod (Moins(x)) (Moins(y))));print_string "
") - (prod.var.Working_list_imperative.list ()))) - (prod.var.Working_list_imperative.list ()); - print_newline () *) - -let create _parameters n = - { - key = Working_list_imperative.make n; - map = Hashtbl.create n; - var = Working_list_imperative.make n - } +type unbounded = Bound of int | Infinity +module Octo : Mat_inter with type var = Occu1.trans = struct + type var = Occu1.trans + type var_symb = Plus of var | Moins of var (*| ZERO *) - let copy parameters error m = - let rep=create parameters (Remanent_parameters.get_empty_hashtbl_size parameters) in - let () = - List.iter - (fun (i,j) -> set_cons rep i j (get_cons m i j)) - (Working_list_imperative.list m.key) - in - error, rep - - let compt_of_var_list parameters error l = - let tmp=create parameters (Remanent_parameters.get_empty_hashtbl_size parameters) in - let error = - List.fold_left - (fun error x-> - let () = add_var tmp (Plus(x)) in - let error, _=push parameters error tmp x {num=1;den=1} in error) - error l in - error, tmp - - let affiche_mat x = affiche x - let is_vide prod x = not (Integer.p (get_cons prod (Plus(x)) (Moins(x))) (Bounded(0))) - let _is_empty prod = - List.exists (fun x->is_vide prod x) (Working_list_imperative.list prod.var) - - let solve_all _parameters error prod = - let signe s x = if s then Plus(x) else Moins(x) in - let () = - List.iter (fun x->new_cons prod (Plus(x)) (Plus(x)) (Bounded(0)); - new_cons prod (Moins(x)) (Moins(x)) (Bounded(0))) (Working_list_imperative.list prod.var) - in - let () = - List.iter (fun i-> - List.iter (fun x-> - List.iter (fun xsigne -> - List.iter (fun y-> - List.iter (fun ysigne -> - let x=signe xsigne x in - let y=signe ysigne y in - set_cons prod x y - (Integer.minl - [get_cons prod x y; - Integer.plus - (get_cons prod x (Moins(i))) - (get_cons prod (Moins(i)) y); - Integer.plus - (get_cons prod x (Plus(i))) - (get_cons prod (Plus(i)) y); - Integer.plus - (get_cons prod x (Plus(i))) - (Integer.plus - (get_cons prod (Plus(i)) (Moins(i))) (get_cons prod (Moins(i)) y)); - Integer.plus - (get_cons prod x (Moins i)) - (Integer.plus - (get_cons prod (Moins i) (Plus i)) (get_cons prod (Plus i) y)) - ])) - [true;false]) - (Working_list_imperative.list prod.var)) - [true;false]) - (Working_list_imperative.list prod.var); - List.iter (fun x-> - List.iter (fun y-> - set_cons prod (Moins(x)) (Moins(y)) - (Integer.min - (get_cons prod (Moins(x)) (Moins(y))) - (Integer.div2 (Integer.plus - (get_cons prod (Moins(x)) (Plus(x))) (get_cons prod (Plus(y)) (Moins(y)))))); - set_cons prod (Plus(x)) (Moins(y)) - (Integer.min - (get_cons prod (Plus(x)) (Moins(y))) - (Integer.div2 - (Integer.plus - (get_cons prod (Plus(x)) (Moins(x))) - (get_cons prod - (Plus(y)) (Moins(y)))))); - set_cons prod (Plus(x)) (Plus(y)) - (Integer.min - (get_cons prod (Plus(x)) (Plus(y))) - (Integer.div2 (Integer.plus - (get_cons prod (Plus(x)) (Moins(x))) (get_cons prod (Moins(y)) (Plus(y)))))); - set_cons prod (Moins(x)) (Plus(y)) - (Integer.min - (get_cons prod (Moins(x)) (Plus(y))) - (Integer.div2 - (Integer.plus (get_cons prod (Moins(x)) (Plus(x))) - (get_cons prod (Moins(y)) (Plus(y))))))) + type prod = { + key: (var_symb * var_symb) Working_list_imperative.working_list; + map: (var_symb * var_symb, Integer.unbounded) Hashtbl.t; + var: var Working_list_imperative.working_list; + } + + let addzero = false + + let _p i j = + match i, j with + (* ZERO,_ -> true + | _,ZERO -> false*) + | Plus _, Moins _ -> true + | Plus x, Plus y -> x < y + | Moins _, Plus _ -> false + | Moins x, Moins y -> x < y + + let rec add_var m (x : var_symb) = + match x with + | Plus t | Moins t -> + if Working_list_imperative.member t m.var then + () + else ( + Working_list_imperative.push t m.var; + let l = Working_list_imperative.list m.var in + List.iter + (fun z -> + set_cons m (Plus z) (Plus t) (div2 (get_cons m (Plus z) (Moins z))); + set_cons m (Moins z) (Plus t) (div2 (get_cons m (Moins z) (Plus z))); + set_cons m (Plus t) (Plus z) (div2 (get_cons m (Moins z) (Plus z))); + set_cons m (Plus t) (Moins z) (div2 (get_cons m (Plus z) (Moins z))); + set_cons m (Plus z) (Moins t) (div2 (get_cons m (Plus z) (Moins z))); + set_cons m (Moins z) (Moins t) + (div2 (get_cons m (Moins z) (Plus z))); + set_cons m (Moins t) (Plus z) (div2 (get_cons m (Moins z) (Plus z))); + set_cons m (Moins t) (Moins z) + (div2 (get_cons m (Plus z) (Moins z)))) + l; + Working_list_imperative.push t m.var + ) + + and get_cons m i j = + try Hashtbl.find m.map (i, j) with _ -> Integer.Bounded 0 + + and new_cons m i j k = + Working_list_imperative.push (i, j) m.key; + add_var m i; + add_var m j; + try + let a = Hashtbl.find m.map (i, j) in + Hashtbl.remove m.map (i, j); + Hashtbl.add m.map (i, j) (Integer.min a k) + with _ -> + (*(m.key.Working_list_imperative.push) (i,j); + add_var m i;add_var m j;*) + Hashtbl.add m.map (i, j) k + + and set_cons m i j k = + Working_list_imperative.push (i, j) m.key; + add_var m i; + add_var m j; + try + let _ = Hashtbl.find m.map (i, j) in + Hashtbl.remove m.map (i, j); + Hashtbl.add m.map (i, j) k + with _ -> + (*(m.key.Working_list_imperative.push) (i,j); + add_var m i;add_var m j;*) + Hashtbl.add m.map (i, j) k + + let print parameters x = + match x with + | Integer.Bounded x -> string_of_int x + | Integer.Infinity -> + Remanent_parameters.get_plus_infinity_symbol parameters + + let minus x = + match x with + | Integer.Bounded x -> Integer.Bounded (-x) + | Integer.Infinity -> Integer.Infinity + + let op x = + match x with + | Plus x -> Moins x + | Moins x -> Plus x + + let _test_and_set m i j k = + if Integer.p (minus (get_cons m (op i) (op j))) k then + raise Exit + else + set_cons m i j k + + let interval_of_pro _parameters _error m x = + ( minus (div2 (get_cons m (Moins x) (Plus x))), + div2 (get_cons m (Plus x) (Moins x)) ) + + let string_of_pro parameters error m x = + let inf, sup = interval_of_pro parameters error m x in + error, "[|" ^ print parameters inf ^ ";" ^ print parameters sup ^ "|]" + + let push _parameters error m x f = + add_var m (Plus x); + let k = f.num in + List.iter + (fun y -> + List.iter + (fun s -> + let y = + if s then + Plus y + else + Moins y + in + set_cons m (Plus x) y + (Integer.plus (get_cons m (Plus x) y) (Bounded k)); + set_cons m y (Moins x) + (Integer.plus (get_cons m y (Moins x)) (Bounded k)); + + set_cons m (Moins x) y + (Integer.plus (get_cons m (Moins x) y) (Bounded (-k))); + set_cons m y (Plus x) + (Integer.plus (get_cons m y (Plus x)) (Bounded (-k)))) + [ true; false ]) + (Working_list_imperative.list m.var); + (*print_string (string_of_pro m x);print_string (print (get_cons m (Plus(x)) (Moins(x))));*) + error, m + + let affiche parameters error prod = + print_string "
"; + let error' = + List.fold_left + (fun error x -> + let error, s = string_of_pro parameters error prod x in + let () = print_string s in + error) + error + (Working_list_imperative.list prod.var) + in + print_newline (); + print_string "
"; + error' + (*List.iter + (fun x-> + (List.iter + (fun y -> + print_newline (); + print_trans x; + print_trans y; + print_newline (); + print_string (print (get_cons prod (Plus(x)) (Plus(y)))^ + print (get_cons prod (Plus(x)) (Moins(y)))^ + print (get_cons prod (Moins(x)) (Plus(y)))^ + print (get_cons prod (Moins(x)) (Moins(y))));print_string "
") + (prod.var.Working_list_imperative.list ()))) + (prod.var.Working_list_imperative.list ()); + print_newline () *) + + let create _parameters n = + { + key = Working_list_imperative.make n; + map = Hashtbl.create n; + var = Working_list_imperative.make n; + } + + let copy parameters error m = + let rep = + create parameters (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let () = + List.iter + (fun (i, j) -> set_cons rep i j (get_cons m i j)) + (Working_list_imperative.list m.key) + in + error, rep + + let compt_of_var_list parameters error l = + let tmp = + create parameters (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let error = + List.fold_left + (fun error x -> + let () = add_var tmp (Plus x) in + let error, _ = push parameters error tmp x { num = 1; den = 1 } in + error) + error l + in + error, tmp + + let affiche_mat x = affiche x + + let is_vide prod x = + not (Integer.p (get_cons prod (Plus x) (Moins x)) (Bounded 0)) + + let _is_empty prod = + List.exists + (fun x -> is_vide prod x) + (Working_list_imperative.list prod.var) + + let solve_all _parameters error prod = + let signe s x = + if s then + Plus x + else + Moins x + in + let () = + List.iter + (fun x -> + new_cons prod (Plus x) (Plus x) (Bounded 0); + new_cons prod (Moins x) (Moins x) (Bounded 0)) + (Working_list_imperative.list prod.var) + in + let () = + List.iter + (fun i -> + List.iter + (fun x -> + List.iter + (fun xsigne -> + List.iter + (fun y -> + List.iter + (fun ysigne -> + let x = signe xsigne x in + let y = signe ysigne y in + set_cons prod x y + (Integer.minl + [ + get_cons prod x y; + Integer.plus + (get_cons prod x (Moins i)) + (get_cons prod (Moins i) y); + Integer.plus (get_cons prod x (Plus i)) + (get_cons prod (Plus i) y); + Integer.plus (get_cons prod x (Plus i)) + (Integer.plus + (get_cons prod (Plus i) (Moins i)) + (get_cons prod (Moins i) y)); + Integer.plus + (get_cons prod x (Moins i)) + (Integer.plus + (get_cons prod (Moins i) (Plus i)) + (get_cons prod (Plus i) y)); + ])) + [ true; false ]) (Working_list_imperative.list prod.var)) + [ true; false ]) + (Working_list_imperative.list prod.var); + List.iter + (fun x -> + List.iter + (fun y -> + set_cons prod (Moins x) (Moins y) + (Integer.min + (get_cons prod (Moins x) (Moins y)) + (Integer.div2 + (Integer.plus + (get_cons prod (Moins x) (Plus x)) + (get_cons prod (Plus y) (Moins y))))); + set_cons prod (Plus x) (Moins y) + (Integer.min + (get_cons prod (Plus x) (Moins y)) + (Integer.div2 + (Integer.plus + (get_cons prod (Plus x) (Moins x)) + (get_cons prod (Plus y) (Moins y))))); + set_cons prod (Plus x) (Plus y) + (Integer.min + (get_cons prod (Plus x) (Plus y)) + (Integer.div2 + (Integer.plus + (get_cons prod (Plus x) (Moins x)) + (get_cons prod (Moins y) (Plus y))))); + set_cons prod (Moins x) (Plus y) + (Integer.min + (get_cons prod (Moins x) (Plus y)) + (Integer.div2 + (Integer.plus + (get_cons prod (Moins x) (Plus x)) + (get_cons prod (Moins y) (Plus y)))))) (Working_list_imperative.list prod.var)) - (Working_list_imperative.list prod.var) - in - let rep = - if + (Working_list_imperative.list prod.var)) + (Working_list_imperative.list prod.var) + in + let rep = + if + List.exists + (fun x -> List.exists - (fun x -> - List.exists - (fun v -> - let a = get_cons prod v v in - match a with - | Integer.Infinity -> false - | Integer.Bounded a -> a<0 - ) - [Plus x;Moins x]) - (Working_list_imperative.list prod.var) - then None else Some prod - in - error, rep - -(* List.iter (fun (i,j) -> set_cons t1 i j (get_cons t2 i j)) - (t1.key.Working_list_imperative.list ())*) - - - - - let solve_inf parameters error prod _l = - solve_all parameters error prod - - - - let merge p q = - let a=Working_list_imperative.list p.var in - let b=Working_list_imperative.list q.var in - List.iter (fun x->add_var p (Plus x)) b; - List.iter (fun x->add_var q (Plus x)) a - - let list_var _parameters p = Working_list_imperative.list p.var - let _equal m n = - List.for_all (fun (i,j)->(get_cons m i j) = (get_cons n i j)) (Working_list_imperative.list m.key) - && - List.for_all (fun (i,j)->(get_cons m i j) = (get_cons n i j)) (Working_list_imperative.list n.key) - - - - let widen parameters error m n = - merge m n ; - let changed=ref false in - let pro= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let a= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters ) in - let var_pro x = - match x with Plus(x)|Moins(x) -> x in - List.iter - (fun (i,j)->Working_list_imperative.push (i,j) a) ((Working_list_imperative.list n.key)@(Working_list_imperative.list m.key )) ; - List.iter - (fun (i,j) -> - let a,b = (get_cons m i j),(get_cons n i j) in - if Integer.p b a then - (changed:=true; + (fun v -> + let a = get_cons prod v v in + match a with + | Integer.Infinity -> false + | Integer.Bounded a -> a < 0) + [ Plus x; Moins x ]) + (Working_list_imperative.list prod.var) + then + None + else + Some prod + in + error, rep + + (* List.iter (fun (i,j) -> set_cons t1 i j (get_cons t2 i j)) + (t1.key.Working_list_imperative.list ())*) + + let solve_inf parameters error prod _l = solve_all parameters error prod + + let merge p q = + let a = Working_list_imperative.list p.var in + let b = Working_list_imperative.list q.var in + List.iter (fun x -> add_var p (Plus x)) b; + List.iter (fun x -> add_var q (Plus x)) a + + let list_var _parameters p = Working_list_imperative.list p.var + + let _equal m n = + List.for_all + (fun (i, j) -> get_cons m i j = get_cons n i j) + (Working_list_imperative.list m.key) + && List.for_all + (fun (i, j) -> get_cons m i j = get_cons n i j) + (Working_list_imperative.list n.key) + + let widen parameters error m n = + merge m n; + let changed = ref false in + let pro = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let a = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let var_pro x = + match x with + | Plus x | Moins x -> x + in + List.iter + (fun (i, j) -> Working_list_imperative.push (i, j) a) + (Working_list_imperative.list n.key @ Working_list_imperative.list m.key); + List.iter + (fun (i, j) -> + let a, b = get_cons m i j, get_cons n i j in + if Integer.p b a then ( + changed := true; Working_list_imperative.push (var_pro i) pro; Working_list_imperative.push (var_pro j) pro; - if (Integer.p (Integer.Bounded(1)) a) - then - (set_cons m i j b) + if Integer.p (Integer.Bounded 1) a then + set_cons m i j b else - (set_cons m i j Integer.Infinity))) - (Working_list_imperative.list a) ; - error, (m,!changed) - - let union_incr parameters error m n = - merge m n ; - let changed=ref false in - let pro= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) - in - let a= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters ) in - let var_pro x = - match x with Plus(x)|Moins(x) -> x in - List.iter - (fun (i,j)->Working_list_imperative.push (i,j) a) ((Working_list_imperative.list n.key)@(Working_list_imperative.list m.key )) ; - List.iter - (fun (i,j) -> - let a,b = (get_cons m i j),(get_cons n i j) in - if Integer.p b a then - (changed:=true; - Working_list_imperative.push (var_pro i) pro; - Working_list_imperative.push (var_pro j) pro; - (set_cons m i j b) - )) - (Working_list_imperative.list a); - let error, _ = solve_all parameters error m in - error, (m,!changed) - - let union parameters error m n = - merge m n ; - let a= - Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters ) in - List.iter - (fun (i,j)->Working_list_imperative.push (i,j) a) ((Working_list_imperative.list n.key)@(Working_list_imperative.list m.key )) ; - List.iter - (fun (i,j) -> - let a,b = (get_cons m i j),(get_cons n i j) in - if Integer.p b a then - (set_cons m i j b) - ) - (Working_list_imperative.list a); - let error, _ = solve_all parameters error m in - error, m - - let plonge _parameters error m l = - (List.iter (fun x->add_var m (Plus x)) l;error, m) - - - let is_infinite m x = - get_cons m (Plus(x)) (Moins(x)) = Integer.Infinity - let intersection parameters error m n = - let r=create parameters (Remanent_parameters.get_empty_hashtbl_size parameters) in - List.iter (fun (i,j) -> set_cons r i j (get_cons m i j)) (Working_list_imperative.list m.key ); - List.iter (fun (i,j) -> set_cons r i j (get_cons n i j)) (Working_list_imperative.list n.key); - List.iter (fun i -> - List.iter (fun j -> - set_cons r (Plus(i)) (Moins(j)) (Integer.Infinity); - set_cons r (Moins(i)) (Plus(j)) (Integer.Infinity); - set_cons r (Plus(i)) (Plus(j)) Integer.Infinity; - set_cons r (Moins(i)) (Moins(j)) Integer.Infinity; - set_cons r (Plus(j)) (Moins(i)) Integer.Infinity; - set_cons r (Moins(j)) (Plus(i)) Integer.Infinity; - set_cons r (Plus(j)) (Plus(i)) Integer.Infinity; - set_cons r (Moins(j)) (Moins(i)) Integer.Infinity) - (Working_list_imperative.list n.var)) - (Working_list_imperative.list m.var); - List.iter (fun i -> - List.iter (fun j -> - set_cons r (Plus(i)) (Moins(j)) Integer.Infinity; - set_cons r (Moins(i)) (Plus(j)) Integer.Infinity; - set_cons r (Plus(i)) (Plus(j)) Integer.Infinity; - set_cons r (Moins(i)) (Moins(j)) Integer.Infinity; - set_cons r (Plus(j)) (Moins(i)) Integer.Infinity; - set_cons r (Moins(j)) (Plus(i)) Integer.Infinity; - set_cons r (Plus(j)) (Plus(i)) Integer.Infinity; - set_cons r (Moins(j)) (Moins(i)) Integer.Infinity) - (Working_list_imperative.list m.var)) - (Working_list_imperative.list n.var); - solve_all parameters error r - - let guard parameters error prod l = - let () = - List.iter - (fun (x,cmp,i) -> - match cmp with - | Counters_domain_type.GTEQ -> - set_cons prod (Moins(x)) (Plus(x)) (Bounded(-2*i)) - | Counters_domain_type.GT -> - set_cons prod (Moins(x)) (Plus(x)) (Bounded(-2*(i+1))) - - | Counters_domain_type.LTEQ -> - set_cons prod (Plus(x)) (Moins(x)) (Bounded(2*i)) - | Counters_domain_type.LT -> - set_cons prod (Plus(x)) (Moins(x)) (Bounded(2*(i-1))) - | Counters_domain_type.EQ -> - begin - set_cons prod (Plus(x)) (Moins(x)) (Bounded(2*i)); - set_cons prod (Moins(x)) (Plus(x)) (Bounded(-2*i)) - end - ) l - in - solve_all parameters error prod - - let merge=intersection - - let abstract_away _parameters error prod x = - let a = Working_list_imperative.list prod.var in - let () = - List.iter - (fun x -> - List.iter - (fun var -> - List.iter - (fun c1 -> - List.iter - (fun c2 -> - set_cons prod c1 c2 Integer.Infinity; - set_cons prod c2 c1 Integer.Infinity) - [Plus var;Moins var] - ) - [Plus x;Moins x]) - a) - x - in - error, prod - - let interval_of_pro parameters error pro x = - let (inf,sup) = interval_of_pro parameters error pro x in - error, - (Some - ((match inf with - | Integer.Infinity -> Fraction.Minfinity - | Integer.Bounded x -> Fraction.Frac {Fraction.num = x;Fraction.den=1} - ), - match sup with - Integer.Infinity -> Fraction.Infinity - | Integer.Bounded x -> Fraction.Frac {Fraction.num = x ;Fraction.den=1} - + set_cons m i j Integer.Infinity )) - - end:Mat_inter with type var=Occu1.trans) + (Working_list_imperative.list a); + error, (m, !changed) + + let union_incr parameters error m n = + merge m n; + let changed = ref false in + let pro = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let a = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + let var_pro x = + match x with + | Plus x | Moins x -> x + in + List.iter + (fun (i, j) -> Working_list_imperative.push (i, j) a) + (Working_list_imperative.list n.key @ Working_list_imperative.list m.key); + List.iter + (fun (i, j) -> + let a, b = get_cons m i j, get_cons n i j in + if Integer.p b a then ( + changed := true; + Working_list_imperative.push (var_pro i) pro; + Working_list_imperative.push (var_pro j) pro; + set_cons m i j b + )) + (Working_list_imperative.list a); + let error, _ = solve_all parameters error m in + error, (m, !changed) + + let union parameters error m n = + merge m n; + let a = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in + List.iter + (fun (i, j) -> Working_list_imperative.push (i, j) a) + (Working_list_imperative.list n.key @ Working_list_imperative.list m.key); + List.iter + (fun (i, j) -> + let a, b = get_cons m i j, get_cons n i j in + if Integer.p b a then set_cons m i j b) + (Working_list_imperative.list a); + let error, _ = solve_all parameters error m in + error, m + + let plonge _parameters error m l = + List.iter (fun x -> add_var m (Plus x)) l; + error, m + + let is_infinite m x = get_cons m (Plus x) (Moins x) = Integer.Infinity + + let intersection parameters error m n = + let r = + create parameters (Remanent_parameters.get_empty_hashtbl_size parameters) + in + List.iter + (fun (i, j) -> set_cons r i j (get_cons m i j)) + (Working_list_imperative.list m.key); + List.iter + (fun (i, j) -> set_cons r i j (get_cons n i j)) + (Working_list_imperative.list n.key); + List.iter + (fun i -> + List.iter + (fun j -> + set_cons r (Plus i) (Moins j) Integer.Infinity; + set_cons r (Moins i) (Plus j) Integer.Infinity; + set_cons r (Plus i) (Plus j) Integer.Infinity; + set_cons r (Moins i) (Moins j) Integer.Infinity; + set_cons r (Plus j) (Moins i) Integer.Infinity; + set_cons r (Moins j) (Plus i) Integer.Infinity; + set_cons r (Plus j) (Plus i) Integer.Infinity; + set_cons r (Moins j) (Moins i) Integer.Infinity) + (Working_list_imperative.list n.var)) + (Working_list_imperative.list m.var); + List.iter + (fun i -> + List.iter + (fun j -> + set_cons r (Plus i) (Moins j) Integer.Infinity; + set_cons r (Moins i) (Plus j) Integer.Infinity; + set_cons r (Plus i) (Plus j) Integer.Infinity; + set_cons r (Moins i) (Moins j) Integer.Infinity; + set_cons r (Plus j) (Moins i) Integer.Infinity; + set_cons r (Moins j) (Plus i) Integer.Infinity; + set_cons r (Plus j) (Plus i) Integer.Infinity; + set_cons r (Moins j) (Moins i) Integer.Infinity) + (Working_list_imperative.list m.var)) + (Working_list_imperative.list n.var); + solve_all parameters error r + + let guard parameters error prod l = + let () = + List.iter + (fun (x, cmp, i) -> + match cmp with + | Counters_domain_type.GTEQ -> + set_cons prod (Moins x) (Plus x) (Bounded (-2 * i)) + | Counters_domain_type.GT -> + set_cons prod (Moins x) (Plus x) (Bounded (-2 * (i + 1))) + | Counters_domain_type.LTEQ -> + set_cons prod (Plus x) (Moins x) (Bounded (2 * i)) + | Counters_domain_type.LT -> + set_cons prod (Plus x) (Moins x) (Bounded (2 * (i - 1))) + | Counters_domain_type.EQ -> + set_cons prod (Plus x) (Moins x) (Bounded (2 * i)); + set_cons prod (Moins x) (Plus x) (Bounded (-2 * i))) + l + in + solve_all parameters error prod + + let merge = intersection + + let abstract_away _parameters error prod x = + let a = Working_list_imperative.list prod.var in + let () = + List.iter + (fun x -> + List.iter + (fun var -> + List.iter + (fun c1 -> + List.iter + (fun c2 -> + set_cons prod c1 c2 Integer.Infinity; + set_cons prod c2 c1 Integer.Infinity) + [ Plus var; Moins var ]) + [ Plus x; Moins x ]) + a) + x + in + error, prod + + let interval_of_pro parameters error pro x = + let inf, sup = interval_of_pro parameters error pro x in + ( error, + Some + ( (match inf with + | Integer.Infinity -> Fraction.Minfinity + | Integer.Bounded x -> + Fraction.Frac { Fraction.num = x; Fraction.den = 1 }), + match sup with + | Integer.Infinity -> Fraction.Infinity + | Integer.Bounded x -> + Fraction.Frac { Fraction.num = x; Fraction.den = 1 } ) ) +end diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/octo.mli b/core/KaSa_rep/abstract_domains/numerical_domains/octo.mli index 85c8b1300e..a0abc3e710 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/octo.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/octo.mli @@ -1,3 +1,3 @@ -type unbounded= Bound of int | Infinity +type unbounded = Bound of int | Infinity -module Octo:Mat_inter.Mat_inter with type var=Occu1.trans +module Octo : Mat_inter.Mat_inter with type var = Occu1.trans diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.ml b/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.ml index 3f1f8d6f7f..6b68fd411d 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.ml @@ -3,278 +3,313 @@ open List let trace = ref false let t_int parameters x = - if Remanent_parameters.get_trace parameters || !trace - then Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i" x + if Remanent_parameters.get_trace parameters || !trace then + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i" x let t_string parameters x = - if Remanent_parameters.get_trace parameters || !trace - then Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" x - -let comp_pair (a,b) (x,y) = - match (a (-1) - | _ ,true,true -> (-1) - | _ -> (1);; + if Remanent_parameters.get_trace parameters || !trace then + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" x +let comp_pair (a, b) (x, y) = + match a < x, a = x, b < y with + | true, _, _ -> -1 + | _, true, true -> -1 + | _ -> 1 let rec list_it f l b = - match l with t::q -> list_it f q (f t b) - | [] -> b;; - - + match l with + | t :: q -> list_it f q (f t b) + | [] -> b let rec true_map x y = - match y with t::q -> let a=(x t)in a::(true_map x q) - | [] -> [] ;; - + match y with + | t :: q -> + let a = x t in + a :: true_map x q + | [] -> [] let max_of_list parameters error list = match list with - | [] -> - Exception.warn - parameters error __POS__ - Exit None - | t::q -> - error, Some (List.fold_left max t q) - -let sum_list list = - List.fold_left (fun a b -> a+b) 0 list - + | [] -> Exception.warn parameters error __POS__ Exit None + | t :: q -> error, Some (List.fold_left max t q) +let sum_list list = List.fold_left (fun a b -> a + b) 0 list let rec member x l = - match l with [] -> false - |a::b-> if a=x then true - else member x b;; + match l with + | [] -> false + | a :: b -> + if a = x then + true + else + member x b let rec member2 x l = - match l with [] -> false - |(a,_)::b-> if a=x then true - else member2 x b;; + match l with + | [] -> false + | (a, _) :: b -> + if a = x then + true + else + member2 x b let rec all_differents liste = - match liste with a::b -> if (member a b) then false - else (all_differents b) - | [] -> true ;; - - -let rec dolist l a= - match l with t::q -> (dolist q (t a)) - | [] -> a ;; + match liste with + | a :: b -> + if member a b then + false + else + all_differents b + | [] -> true + +let rec dolist l a = + match l with + | t :: q -> dolist q (t a) + | [] -> a let concat liste1 liste2 = - let rec aux liste1 liste2= - match liste1 with a::b -> aux b (a::liste2) - | [] -> liste2 - in aux (rev liste1) liste2;; + let rec aux liste1 liste2 = + match liste1 with + | a :: b -> aux b (a :: liste2) + | [] -> liste2 + in + aux (rev liste1) liste2 let applati liste = - let rec aux1 l rep = - match l with a::b->aux1 b (a::rep) - | [] ->rep - in - let rec aux2 l rep = - match l with a::b->aux2 b (aux1 a rep) - | [] ->rep - in rev(aux2 liste []);; - -let rec forall p l= - match l with a::b -> if (p a) then (forall p b) - else false - | [] -> true ;; - -let rec correspondance parameters error ancien nouveau x= - match ancien,nouveau with - | a::_,p::_ when a=x -> error, Some p - | _::b,_::q -> correspondance parameters error b q x - | [],[] -> error, Some x - |_ -> - Exception.warn parameters error __POS__ Exit None - + let rec aux1 l rep = + match l with + | a :: b -> aux1 b (a :: rep) + | [] -> rep + in + let rec aux2 l rep = + match l with + | a :: b -> aux2 b (aux1 a rep) + | [] -> rep + in + rev (aux2 liste []) + +let rec forall p l = + match l with + | a :: b -> + if p a then + forall p b + else + false + | [] -> true + +let rec correspondance parameters error ancien nouveau x = + match ancien, nouveau with + | a :: _, p :: _ when a = x -> error, Some p + | _ :: b, _ :: q -> correspondance parameters error b q x + | [], [] -> error, Some x + | _ -> Exception.warn parameters error __POS__ Exit None let transfert parameters error ancien nouveau liste = - let rec aux parameters error l = - match l with [] -> error, [] - | a::b -> - let error, h = - correspondance parameters error ancien nouveau a - in - let error, tl = - aux parameters error b - in - error, h::tl - in - aux parameters error liste;; + let rec aux parameters error l = + match l with + | [] -> error, [] + | a :: b -> + let error, h = correspondance parameters error ancien nouveau a in + let error, tl = aux parameters error b in + error, h :: tl + in + aux parameters error liste let tr parameters error ancien nouveau id = - match (transfert parameters error ancien nouveau [id]) - with error, [res]-> error,res - | error, _ -> - Exception.warn parameters error __POS__ Exit None - + match transfert parameters error ancien nouveau [ id ] with + | error, [ res ] -> error, res + | error, _ -> Exception.warn parameters error __POS__ Exit None let paire_of_list liste1 liste2 rep = - let rec aux1 x l2 rep = - match l2 with a::b -> aux1 x b ((x,a)::rep) - | [] -> rep - in - let rec aux2 l1 l2 rep = - match l1 with a::b -> aux2 b l2 (aux1 a l2 rep) - | [] -> rep - in - aux2 liste1 liste2 rep ;; - -let produit_predicat p i j = - match i,j with (a,b),(c,d) -> ((p a c) || ((a=c) && (p b d)));; - -let union_list p liste1 liste2 = - let rec aux liste1 liste2 sol = - match liste1,liste2 with a::b,t::q when a=t -> aux b q (t::sol) - | a::b,t::_q when (p a t)-> aux b liste2 (a::sol) - | _a::_b,t::q -> aux liste1 q (t::sol) - | a::b,[] -> aux b [] (a::sol) - | [],a::b -> aux b [] (a::sol) - | [],[] -> (rev sol) - in aux liste1 liste2 [] + let rec aux1 x l2 rep = + match l2 with + | a :: b -> aux1 x b ((x, a) :: rep) + | [] -> rep + in + let rec aux2 l1 l2 rep = + match l1 with + | a :: b -> aux2 b l2 (aux1 a l2 rep) + | [] -> rep + in + aux2 liste1 liste2 rep +let produit_predicat p i j = + match i, j with + | (a, b), (c, d) -> p a c || (a = c && p b d) +let union_list p liste1 liste2 = + let rec aux liste1 liste2 sol = + match liste1, liste2 with + | a :: b, t :: q when a = t -> aux b q (t :: sol) + | a :: b, t :: _q when p a t -> aux b liste2 (a :: sol) + | _a :: _b, t :: q -> aux liste1 q (t :: sol) + | a :: b, [] -> aux b [] (a :: sol) + | [], a :: b -> aux b [] (a :: sol) + | [], [] -> rev sol + in + aux liste1 liste2 [] let intersec_list p liste1 liste2 = - let rec aux liste1 liste2 sol = - match liste1,liste2 with a::b,t::q -> if (a=t) then aux b q (a::sol) - else - (if (p a t) then aux b liste2 sol - else aux liste1 q sol) - | _ -> (rev sol) - in aux liste1 liste2 [] + let rec aux liste1 liste2 sol = + match liste1, liste2 with + | a :: b, t :: q -> + if a = t then + aux b q (a :: sol) + else if p a t then + aux b liste2 sol + else + aux liste1 q sol + | _ -> rev sol + in + aux liste1 liste2 [] let ajoute t liste = - let rec aux liste rep = - match liste with a::b-> aux b ((concat t a)::rep) - | [] -> rep - in - aux (rev liste) [] + let rec aux liste rep = + match liste with + | a :: b -> aux b (concat t a :: rep) + | [] -> rep + in + aux (rev liste) [] let flat_map f l = - let rec aux l rep = - match l with a::b -> aux b ((f a)@rep) - | [] -> rep - in aux (rev l) [] + let rec aux l rep = + match l with + | a :: b -> aux b (f a @ rep) + | [] -> rep + in + aux (rev l) [] let flat_map_zip f l = let rec aux l rep1 rep2 = - match l with a::b -> let (c,d)=f a in - aux b (c@rep1) (d@rep2) - | [] ->rep1,rep2 - in aux (rev l) [] [] - - -let produit_list liste1 liste2 = - flat_map (fun x->ajoute x liste2) liste1 - + match l with + | a :: b -> + let c, d = f a in + aux b (c @ rep1) (d @ rep2) + | [] -> rep1, rep2 + in + aux (rev l) [] [] +let produit_list liste1 liste2 = flat_map (fun x -> ajoute x liste2) liste1 let rec mix_list liste = - match liste with [] -> [[]] - | t::q -> produit_list t (mix_list q) - + match liste with + | [] -> [ [] ] + | t :: q -> produit_list t (mix_list q) let insert_list p x liste1 = - let rec vide reste fait = - match reste with a::b->vide b (a::fait) - |[] -> fait - in - let rec aux reste vue = - match reste with a::b -> if (p a x) then (aux b (a::vue)) - else (vide (x::vue) reste) - | [] -> vide (x::vue) [] - in aux liste1 [] - + let rec vide reste fait = + match reste with + | a :: b -> vide b (a :: fait) + | [] -> fait + in + let rec aux reste vue = + match reste with + | a :: b -> + if p a x then + aux b (a :: vue) + else + vide (x :: vue) reste + | [] -> vide (x :: vue) [] + in + aux liste1 [] let list_of_table h = - let liste=ref [] in - (Hashtbl.iter - (fun a->fun b->(liste:=(a,b)::(!liste))) - h ; - !liste) + let liste = ref [] in + Hashtbl.iter (fun a b -> liste := (a, b) :: !liste) h; + !liste let copy_table h = let rep = Hashtbl.create 1 in - (Hashtbl.iter (fun a->fun b->(Hashtbl.add rep a b)) h; - rep) - + Hashtbl.iter (fun a b -> Hashtbl.add rep a b) h; + rep let insert_sort p l k = - let rec aux l rep = - match l with - | t::q when (p t k) -> aux q (t::rep) - | t::_q when t=k -> concat (List.rev rep) l - | _ -> concat (List.rev rep) (k::l) - in aux l [] - + let rec aux l rep = + match l with + | t :: q when p t k -> aux q (t :: rep) + | t :: _q when t = k -> concat (List.rev rep) l + | _ -> concat (List.rev rep) (k :: l) + in + aux l [] let merge p l k = let rec aux l1 l2 rep = - match l1,l2 - with t::q,a::_b when p t a -> aux q l2 (t::rep) - | t::q,a::b when p a t -> aux (t::q) b (a::rep) - | t::q,_a::b -> aux q b (t::rep) - | t::q, [] -> aux q l2 (t::rep) - | [] ,a::b -> aux l1 b (a::rep) - | _ -> (List.rev rep) - in aux l k [] + match l1, l2 with + | t :: q, a :: _b when p t a -> aux q l2 (t :: rep) + | t :: q, a :: b when p a t -> aux (t :: q) b (a :: rep) + | t :: q, _a :: b -> aux q b (t :: rep) + | t :: q, [] -> aux q l2 (t :: rep) + | [], a :: b -> aux l1 b (a :: rep) + | _ -> List.rev rep + in + aux l k [] -let fusion=merge +let fusion = merge let sub_list p l k = - let rec aux l rep = - match l with t::q when t=k -> concat (List.rev rep) q - | t::q when p t k -> aux q (t::rep) - | _ -> concat (List.rev rep) l - in aux l [] + let rec aux l rep = + match l with + | t :: q when t = k -> concat (List.rev rep) q + | t :: q when p t k -> aux q (t :: rep) + | _ -> concat (List.rev rep) l + in + aux l [] let vide f l = - let rec aux l rep = - match l with t::q when (f t) -> aux q rep - | t::q -> aux q (t::rep) - | _ -> (List.rev rep) - in aux l [] - -let filtre f l = vide (fun x->not (f x)) l + let rec aux l rep = + match l with + | t :: q when f t -> aux q rep + | t :: q -> aux q (t :: rep) + | _ -> List.rev rep + in + aux l [] +let filtre f l = vide (fun x -> not (f x)) l let rev l = let rec aux res sol = - match res with [] -> sol - | a::b -> aux b (a::sol) - in aux l [] - - + match res with + | [] -> sol + | a :: b -> aux b (a :: sol) + in + aux l [] let flap_map parameters error f l = - let n=Working_list_imperative.make - (Remanent_parameters.get_empty_hashtbl_size parameters) in + let n = + Working_list_imperative.make + (Remanent_parameters.get_empty_hashtbl_size parameters) + in let rec aux l = - match l with t::q -> (Working_list_imperative.push (f t) n;aux q) - | [] -> () - in List.iter aux l; + match l with + | t :: q -> + Working_list_imperative.push (f t) n; + aux q + | [] -> () + in + List.iter aux l; error, Working_list_imperative.list n - -let map_list (f:'a->'b) (l:'a list) = - let rec aux (l:'a list) (rep:'b list) = - match l with [] -> rep - | a::b -> (try (let r = (f a) in (aux b (r::rep))) with _ -> (aux b rep)) - in aux (List.rev l) [] ;; +let map_list (f : 'a -> 'b) (l : 'a list) = + let rec aux (l : 'a list) (rep : 'b list) = + match l with + | [] -> rep + | a :: b -> + (try + let r = f a in + aux b (r :: rep) + with _ -> aux b rep) + in + aux (List.rev l) [] let compte_list parameters error l = - let a= + let a = Hashtbl.create (Remanent_parameters.get_empty_hashtbl_size parameters) in - let get x = - try (Hashtbl.find a x) with _ -> 0 in + let get x = try Hashtbl.find a x with _ -> 0 in let inc x = - let rep=get x in - (Hashtbl.remove a x; - Hashtbl.add a x (rep+1)) in - List.iter (fun x->inc x) l ; - error, list_of_table a;; + let rep = get x in + Hashtbl.remove a x; + Hashtbl.add a x (rep + 1) + in + List.iter (fun x -> inc x) l; + error, list_of_table a diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.mli b/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.mli index fce0a016ff..45b5e6475f 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/tools_aff.mli @@ -1,52 +1,55 @@ -val t_string:Remanent_parameters_sig.parameters -> string -> unit -val t_int:Remanent_parameters_sig.parameters -> int -> unit -val comp_pair:'a * 'b -> 'a * 'b -> int -val list_it:('a -> 'b -> 'b) -> 'a list -> 'b -> 'b -val true_map:('a -> 'b) -> 'a list -> 'b list +val t_string : Remanent_parameters_sig.parameters -> string -> unit +val t_int : Remanent_parameters_sig.parameters -> int -> unit +val comp_pair : 'a * 'b -> 'a * 'b -> int +val list_it : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b +val true_map : ('a -> 'b) -> 'a list -> 'b list -val max_of_list: +val max_of_list : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - 'a list -> Exception_without_parameter.method_handler * 'a option + 'a list -> + Exception_without_parameter.method_handler * 'a option -val sum_list:int list -> int -val member2:'a -> ('a * 'b) list -> bool -val all_differents:int list -> bool -val dolist:('a -> 'a) list -> 'a -> 'a -val applati:'a list list -> 'a list -val forall:('a -> bool) -> 'a list -> bool +val sum_list : int list -> int +val member2 : 'a -> ('a * 'b) list -> bool +val all_differents : int list -> bool +val dolist : ('a -> 'a) list -> 'a -> 'a +val applati : 'a list list -> 'a list +val forall : ('a -> bool) -> 'a list -> bool -val tr: +val tr : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> 'a list -> 'a list -> - 'a -> Exception_without_parameter.method_handler * 'a option - -val paire_of_list: 'a list -> 'b list -> ('a * 'b) list -> ('a * 'b) list -val produit_predicat: ('a -> 'a -> bool) -> 'a * 'a -> 'a * 'a -> bool - -val union_list: ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list - -val intersec_list: ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list - -val flat_map_zip: ('a -> 'b list * 'c list) -> 'a list -> 'b list * 'c list -val mix_list:'a list list list -> 'a list list -val copy_table:('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t -val insert_sort:('a -> 'a -> bool) -> 'a list -> 'a -> 'a list -val insert_list: ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list -val fusion: ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list -val sub_list:('a -> 'a -> bool) -> 'a list -> 'a -> 'a list -val filtre:('a -> bool) -> 'a list -> 'a list -val rev:'a list -> 'a list -val flap_map: + 'a -> + Exception_without_parameter.method_handler * 'a option + +val paire_of_list : 'a list -> 'b list -> ('a * 'b) list -> ('a * 'b) list +val produit_predicat : ('a -> 'a -> bool) -> 'a * 'a -> 'a * 'a -> bool +val union_list : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val intersec_list : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val flat_map_zip : ('a -> 'b list * 'c list) -> 'a list -> 'b list * 'c list +val mix_list : 'a list list list -> 'a list list +val copy_table : ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t +val insert_sort : ('a -> 'a -> bool) -> 'a list -> 'a -> 'a list +val insert_list : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list +val fusion : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val sub_list : ('a -> 'a -> bool) -> 'a list -> 'a -> 'a list +val filtre : ('a -> bool) -> 'a list -> 'a list +val rev : 'a list -> 'a list + +val flap_map : Remanent_parameters_sig.parameters -> - 'a -> ('b -> 'c) -> 'b list list -> 'a * 'c list + 'a -> + ('b -> 'c) -> + 'b list list -> + 'a * 'c list -val map_list:('a -> 'b) -> 'a list -> 'b list -val compte_list: - Remanent_parameters_sig.parameters -> - 'a -> 'b list -> 'a * ('b * int) list +val map_list : ('a -> 'b) -> 'a list -> 'b list + +val compte_list : + Remanent_parameters_sig.parameters -> 'a -> 'b list -> 'a * ('b * int) list -val merge: ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list -val vide: ('a -> bool) -> 'a list -> 'a list +val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val vide : ('a -> bool) -> 'a list -> 'a list diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.ml b/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.ml index 2258b9480d..28870be803 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.ml +++ b/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.ml @@ -1,67 +1,81 @@ open Queue -type 'a working_list = - {indice:int; - clean : unit->unit ; - pop : unit->'a option ; - push : 'a -> unit ; - list : unit -> 'a list; - exists : ('a->bool)->bool; - member : 'a -> bool; - not_empty : unit->bool; - copy : unit->'a working_list} - - +type 'a working_list = { + indice: int; + clean: unit -> unit; + pop: unit -> 'a option; + push: 'a -> unit; + list: unit -> 'a list; + exists: ('a -> bool) -> bool; + member: 'a -> bool; + not_empty: unit -> bool; + copy: unit -> 'a working_list; +} let rec make n = - let h=Hashtbl.create n in - let l=Queue.create () in - let push a = - try (Hashtbl.find h a) - with _ -> (Queue.add a l ; - Hashtbl.add h a ()) in - let pop () = - try (let k=Queue.take l in - Hashtbl.remove h k; Some k) - with _ -> - None - in - let not_empty () = - match pop () with - | Some a -> let () = push a in true - | None -> false - in - let clean () = - try (while true do let _ = pop () in () done) with _ -> () in - let list () = - let rep=ref [] in - iter (fun x->rep:=x::(!rep)) l; - !rep in - let copy () = - let rep = make n in - iter (fun x->rep.push x) l; - rep in - let member x = - try (Hashtbl.find h x;true) with _ -> false in - let exists p = - try (iter (fun x->if p x then raise Exit else ()) l;false) - with _ -> true in - {indice=n; - clean=clean; - list=list; - pop=pop; - push=push; - exists=exists; - member=member; - not_empty=not_empty; - copy=copy };; - + let h = Hashtbl.create n in + let l = Queue.create () in + let push a = + try Hashtbl.find h a + with _ -> + Queue.add a l; + Hashtbl.add h a () + in + let pop () = + try + let k = Queue.take l in + Hashtbl.remove h k; + Some k + with _ -> None + in + let not_empty () = + match pop () with + | Some a -> + let () = push a in + true + | None -> false + in + let clean () = + try + while true do + let _ = pop () in + () + done + with _ -> () + in + let list () = + let rep = ref [] in + iter (fun x -> rep := x :: !rep) l; + !rep + in + let copy () = + let rep = make n in + iter (fun x -> rep.push x) l; + rep + in + let member x = + try + Hashtbl.find h x; + true + with _ -> false + in + let exists p = + try + iter + (fun x -> + if p x then + raise Exit + else + ()) + l; + false + with _ -> true + in + { indice = n; clean; list; pop; push; exists; member; not_empty; copy } let _wmap parameters _error f l = - let rep = - make (Remanent_parameters.get_empty_hashtbl_size parameters) - in - List.map (fun x->rep.push (f x)) (l.list ()) + let rep = make (Remanent_parameters.get_empty_hashtbl_size parameters) in + List.map (fun x -> rep.push (f x)) (l.list ()) let indice wl = wl.indice let clean wl = wl.clean () diff --git a/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.mli b/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.mli index 1eb928f502..4fa459903d 100644 --- a/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.mli +++ b/core/KaSa_rep/abstract_domains/numerical_domains/working_list_imperative.mli @@ -1,13 +1,12 @@ type 'a working_list -val make: int -> 'a working_list - -val indice: 'a working_list -> int -val clean: 'a working_list -> unit -val list: 'a working_list -> 'a list -val pop: 'a working_list -> 'a option -val push: 'a -> 'a working_list -> unit -val exists: ('a -> bool) -> 'a working_list -> bool -val not_empty: 'a working_list -> bool -val copy: 'a working_list -> 'a working_list -val member : 'a -> 'a working_list -> bool +val make : int -> 'a working_list +val indice : 'a working_list -> int +val clean : 'a working_list -> unit +val list : 'a working_list -> 'a list +val pop : 'a working_list -> 'a option +val push : 'a -> 'a working_list -> unit +val exists : ('a -> bool) -> 'a working_list -> bool +val not_empty : 'a working_list -> bool +val copy : 'a working_list -> 'a working_list +val member : 'a -> 'a working_list -> bool diff --git a/core/KaSa_rep/backend/ckappa_site_graph.ml b/core/KaSa_rep/backend/ckappa_site_graph.ml index 45dc7149ff..243dd180a8 100644 --- a/core/KaSa_rep/backend/ckappa_site_graph.ml +++ b/core/KaSa_rep/backend/ckappa_site_graph.ml @@ -15,42 +15,38 @@ (***************************************************************************) - let print_internal_pattern_aux ?logger parameters error _kappa_handler internal_constraints_list = let logger = - match - logger - with + match logger with | None -> Remanent_parameters.get_logger parameters | Some a -> a in - let (domain_name, lemma_list) = internal_constraints_list in + let domain_name, lemma_list = internal_constraints_list in let () = Loggers.fprintf logger "------------------------------------------------------------\n"; Loggers.fprintf logger "* Export %s to JSon (internal constraints_list):\n" domain_name; Loggers.fprintf logger - "------------------------------------------------------------\n"; + "------------------------------------------------------------\n" in - List.fold_left (fun (error, _) lemma -> + List.fold_left + (fun (error, _) lemma -> let hyp = Public_data.get_hyp lemma in let refinement = Public_data.get_refinement lemma in let error = - Site_graphs.KaSa_site_graph.print - logger parameters error - hyp + Site_graphs.KaSa_site_graph.print logger parameters error hyp in let () = Loggers.fprintf logger "=> [" in let error, b = match refinement with | [] -> error, false - | [hyp] -> - Site_graphs.KaSa_site_graph.print logger parameters error - hyp, false - | _::_ as l -> - List.fold_left (fun (error, bool) hyp -> + | [ hyp ] -> + Site_graphs.KaSa_site_graph.print logger parameters error hyp, false + | _ :: _ as l -> + List.fold_left + (fun (error, bool) hyp -> let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) @@ -58,41 +54,39 @@ let print_internal_pattern_aux ?logger parameters error _kappa_handler let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - (if bool then "\t\tv " else "\t\t ") + (if bool then + "\t\tv " + else + "\t\t ") in let error = - Site_graphs.KaSa_site_graph.print logger parameters error - hyp + Site_graphs.KaSa_site_graph.print logger parameters error hyp in - error, true - ) (error, false) (List.rev l) + error, true) + (error, false) (List.rev l) in let () = Loggers.fprintf logger "]" in let () = Loggers.print_newline logger in - error, b - ) (error, false) lemma_list + error, b) + (error, false) lemma_list (*print the information as the output of non relational properties*) -let print_internal_pattern ?logger parameters error kappa_handler - list = +let print_internal_pattern ?logger parameters error kappa_handler list = let logger' = - match - logger - with + match logger with | None -> Remanent_parameters.get_logger parameters | Some a -> a in let error = - List.fold_left (fun error pattern -> + List.fold_left + (fun error pattern -> let error, _ = - print_internal_pattern_aux - ?logger parameters error - kappa_handler + print_internal_pattern_aux ?logger parameters error kappa_handler pattern in let () = Loggers.print_newline logger' in - error - ) error list + error) + error list in error @@ -100,82 +94,76 @@ let print_internal_pattern ?logger parameters error kappa_handler let print_for_list logger parameter error t = let error, _ = - List.fold_left (fun (error, bool) (agent_string, site_map) -> + List.fold_left + (fun (error, bool) (agent_string, site_map) -> let error = Site_graphs.KaSa_site_graph.print_agent logger parameter error agent_string site_map bool in - error, true - ) (error, false) t + error, true) + (error, false) t in let () = Loggers.fprintf logger " " in error -let print_pattern_aux ?logger - parameters error constraints_list - = +let print_pattern_aux ?logger parameters error constraints_list = let logger = - match - logger - with + match logger with | None -> Remanent_parameters.get_logger parameters | Some a -> a in - let (domain_name, lemma_list) = constraints_list in + let domain_name, lemma_list = constraints_list in let () = Loggers.fprintf logger "------------------------------------------------------------\n"; - Loggers.fprintf logger "* Export %s to JSon (constraints_list):\n" domain_name; + Loggers.fprintf logger "* Export %s to JSon (constraints_list):\n" + domain_name; Loggers.fprintf logger - "------------------------------------------------------------\n"; + "------------------------------------------------------------\n" in - List.fold_left (fun (error, _) lemma -> + List.fold_left + (fun (error, _) lemma -> let hyp = Public_data.get_hyp lemma in let refinement = Public_data.get_refinement lemma in - let error = - print_for_list logger parameters error - hyp - in + let error = print_for_list logger parameters error hyp in let () = Loggers.fprintf logger " => [" in (*refinement*) let error, b = - List.fold_left (fun (error, bool) hyp -> + List.fold_left + (fun (error, bool) hyp -> let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) in let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - (if bool then "\t\tv " else "\t\t ") - in - let error = - print_for_list logger parameters error hyp + (if bool then + "\t\tv " + else + "\t\t ") in - error, true - ) (error, false) (List.rev refinement) + let error = print_for_list logger parameters error hyp in + error, true) + (error, false) (List.rev refinement) in let () = Loggers.fprintf logger "]" in let () = Loggers.print_newline logger in - error, b - ) (error, false) lemma_list + error, b) + (error, false) lemma_list let _print_pattern ?logger parameters error _kappa_handler list = let logger' = - match - logger - with + match logger with | None -> Remanent_parameters.get_logger parameters | Some a -> a in let error = - List.fold_left (fun error pattern -> - let error, _ = - print_pattern_aux ?logger parameters error pattern - in + List.fold_left + (fun error pattern -> + let error, _ = print_pattern_aux ?logger parameters error pattern in let () = Loggers.print_newline logger' in - error - ) error list + error) + error list in error @@ -185,80 +173,61 @@ let site_graph_to_list error string_version = let error, current_list = Ckappa_sig.Agent_id_map_and_set.Map.fold (fun _ (agent_string, site_map) (error, current_list) -> - (*-----------------------------------------*) - let site_graph = - (agent_string, site_map) :: current_list - in - error, site_graph - ) string_version (error, []) + (*-----------------------------------------*) + let site_graph = (agent_string, site_map) :: current_list in + error, site_graph) + string_version (error, []) in error, List.rev current_list let site_graph_list_to_list error list = - List.fold_left (fun (error, current_list) t -> + List.fold_left + (fun (error, current_list) t -> let string_version = Site_graphs.KaSa_site_graph.get_string_version t in let error, site_graph = site_graph_to_list error string_version in - error, site_graph :: current_list - ) (error, []) list + error, site_graph :: current_list) + (error, []) list -let _pair_list_to_list parameters error kappa_handler pattern - agent_id1 site_type1' agent_id2 site_type2' - pair_list = - List.fold_left (fun (error, current_list) l -> +let _pair_list_to_list parameters error kappa_handler pattern agent_id1 + site_type1' agent_id2 site_type2' pair_list = + List.fold_left + (fun (error, current_list) l -> match l with - | [siteone, state1; sitetwo, state2] when - siteone == Ckappa_sig.fst_site - && sitetwo == Ckappa_sig.snd_site -> + | [ (siteone, state1); (sitetwo, state2) ] + when siteone == Ckappa_sig.fst_site && sitetwo == Ckappa_sig.snd_site -> let error, pattern = - Site_graphs.KaSa_site_graph.add_state - parameters error kappa_handler - agent_id1 - site_type1' - state1 - pattern + Site_graphs.KaSa_site_graph.add_state parameters error kappa_handler + agent_id1 site_type1' state1 pattern in let error, pattern = - Site_graphs.KaSa_site_graph.add_state - parameters error kappa_handler - agent_id2 - site_type2' - state2 - pattern + Site_graphs.KaSa_site_graph.add_state parameters error kappa_handler + agent_id2 site_type2' state2 pattern in let string_version = - Site_graphs.KaSa_site_graph.get_string_version - pattern + Site_graphs.KaSa_site_graph.get_string_version pattern in let error, site_graph = site_graph_to_list error string_version in error, site_graph :: current_list - | _ -> Exception.warn parameters error __POS__ Exit [] - ) (error, []) pair_list + | _ -> Exception.warn parameters error __POS__ Exit []) + (error, []) pair_list -let internal_pair_list_to_list parameters error kappa_handler pattern - agent_id1 site_type1' agent_id2 site_type2' pair_list = - List.fold_left (fun (error, current_list) l -> +let internal_pair_list_to_list parameters error kappa_handler pattern agent_id1 + site_type1' agent_id2 site_type2' pair_list = + List.fold_left + (fun (error, current_list) l -> match l with - | [siteone, state1; sitetwo, state2] when - siteone == Ckappa_sig.fst_site - && sitetwo == Ckappa_sig.snd_site -> + | [ (siteone, state1); (sitetwo, state2) ] + when siteone == Ckappa_sig.fst_site && sitetwo == Ckappa_sig.snd_site -> let error, pattern = - Site_graphs.KaSa_site_graph.add_state - parameters error kappa_handler - agent_id1 - site_type1' - state1 - pattern + Site_graphs.KaSa_site_graph.add_state parameters error kappa_handler + agent_id1 site_type1' state1 pattern in let error, pattern = - Site_graphs.KaSa_site_graph.add_state - parameters error kappa_handler - agent_id2 - site_type2' - state2 - pattern + Site_graphs.KaSa_site_graph.add_state parameters error kappa_handler + agent_id2 site_type2' state2 pattern in error, pattern :: current_list - | _ -> Exception.warn parameters error __POS__ Exit [] - ) (error, []) pair_list + | _ -> Exception.warn parameters error __POS__ Exit []) + (error, []) pair_list (******************************************************************) diff --git a/core/KaSa_rep/backend/ckappa_site_graph.mli b/core/KaSa_rep/backend/ckappa_site_graph.mli index 59ac1c48be..68b17e7e5e 100644 --- a/core/KaSa_rep/backend/ckappa_site_graph.mli +++ b/core/KaSa_rep/backend/ckappa_site_graph.mli @@ -3,31 +3,36 @@ val print_internal_pattern : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> - Remanent_state.internal_constraints_list -> Exception.method_handler + Remanent_state.internal_constraints_list -> + Exception.method_handler val site_graph_to_list : Exception.method_handler -> - (string * - (string option * - Site_graphs.KaSa_site_graph.binding_state option * - (int option * int option) option) - Wrapped_modules.LoggedStringMap.t) - Ckappa_sig.Agent_id_map_and_set.Map.t -> - Exception.method_handler * - (string * - (string option * - Site_graphs.KaSa_site_graph.binding_state option * - (int option * int option) option) - Wrapped_modules.LoggedStringMap.t) list + (string + * (string option + * Site_graphs.KaSa_site_graph.binding_state option + * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t) + Ckappa_sig.Agent_id_map_and_set.Map.t -> + Exception.method_handler + * (string + * (string option + * Site_graphs.KaSa_site_graph.binding_state option + * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t) + list val site_graph_list_to_list : Exception.method_handler -> Site_graphs.KaSa_site_graph.t list -> - Exception.method_handler * - (string * - (string option * Site_graphs.KaSa_site_graph.binding_state option * (int option * int option) option) - Wrapped_modules.LoggedStringMap.t) - list list + Exception.method_handler + * (string + * (string option + * Site_graphs.KaSa_site_graph.binding_state option + * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t) + list + list val internal_pair_list_to_list : Remanent_parameters_sig.parameters -> @@ -39,5 +44,4 @@ val internal_pair_list_to_list : Site_graphs.KaSa_site_graph.agent_id -> Ckappa_sig.c_site_name -> (Ckappa_sig.c_site_name * Ckappa_sig.c_state) list list -> - Exception.method_handler * - Site_graphs.KaSa_site_graph.t list + Exception.method_handler * Site_graphs.KaSa_site_graph.t list diff --git a/core/KaSa_rep/backend/dune b/core/KaSa_rep/backend/dune index 6f72c5a515..c5c4bd8c2f 100644 --- a/core/KaSa_rep/backend/dune +++ b/core/KaSa_rep/backend/dune @@ -1,14 +1,29 @@ (library - (name kappa_kasa_backend) - (libraries yojson kappa_kasa_frontend kappa_kasa_remanent_state kappa_kasa_site_graphs) - (flags (:standard -w @a - -open Kappa_kasa_frontend - -open Kappa_kasa_kastor_toolset - -open Kappa_parameters - -open Kappa_errors - -open Kappa_logging - -open Kappa_generic_toolset - -open Kappa_kasa_remanent_state - -open Kappa_kasa_site_graphs - -open Kappa_kasa_type_interface - ))) + (name kappa_kasa_backend) + (libraries + yojson + kappa_kasa_frontend + kappa_kasa_remanent_state + kappa_kasa_site_graphs) + (flags + (:standard + -w + @a + -open + Kappa_kasa_frontend + -open + Kappa_kasa_kastor_toolset + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_logging + -open + Kappa_generic_toolset + -open + Kappa_kasa_remanent_state + -open + Kappa_kasa_site_graphs + -open + Kappa_kasa_type_interface))) diff --git a/core/KaSa_rep/counting_enumerating_species/counting_algebrae.ml b/core/KaSa_rep/counting_enumerating_species/counting_algebrae.ml index 9784204d06..12de306f7d 100644 --- a/core/KaSa_rep/counting_enumerating_species/counting_algebrae.ml +++ b/core/KaSa_rep/counting_enumerating_species/counting_algebrae.ml @@ -12,198 +12,200 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - -module type Enumeration = -sig +module type Enumeration = sig type brick type puzzle_hole type abstract_species_set - val size_of_abstract_species_set: abstract_species_set -> Int_inf.bi_intinf - val promote: brick Linear_combination.linear_combination -> abstract_species_set - val combine: abstract_species_set -> puzzle_hole -> puzzle_hole -> abstract_species_set -> abstract_species_set - val sum: abstract_species_set -> abstract_species_set -> abstract_species_set - val square: abstract_species_set -> abstract_species_set - val print: Exception.method_handler -> Cckappa_sig.kappa_handler -> out_channel -> (out_channel -> puzzle_hole -> unit) -> abstract_species_set -> unit - val print_short: Exception.method_handler -> Cckappa_sig.kappa_handler -> out_channel -> (out_channel -> puzzle_hole -> unit) -> abstract_species_set -> unit - val nil: abstract_species_set - val infinity: abstract_species_set + val size_of_abstract_species_set : abstract_species_set -> Int_inf.bi_intinf + + val promote : + brick Linear_combination.linear_combination -> abstract_species_set + + val combine : + abstract_species_set -> + puzzle_hole -> + puzzle_hole -> + abstract_species_set -> + abstract_species_set + + val sum : abstract_species_set -> abstract_species_set -> abstract_species_set + val square : abstract_species_set -> abstract_species_set + + val print : + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + out_channel -> + (out_channel -> puzzle_hole -> unit) -> + abstract_species_set -> + unit + + val print_short : + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + out_channel -> + (out_channel -> puzzle_hole -> unit) -> + abstract_species_set -> + unit + + val nil : abstract_species_set + val infinity : abstract_species_set end -module Explicit_enumeration = - (struct - type brick = int - - type puzzle_hole = (*Kappa.puzzle_hole *) int - - type regular_formula = - | Nil - | Brick of brick - | Sum of (regular_formula*regular_formula) - | Product of (regular_formula*puzzle_hole*puzzle_hole*regular_formula) - | Square of regular_formula - | Infinity - - type abstract_species_set = - {regular_formula:regular_formula; - cardinal:Int_inf.bi_intinf} - - let nil = - { - regular_formula=Nil; - cardinal=Int_inf.bi_zero - } - - let infinity = - { - regular_formula = Infinity; - cardinal = Int_inf.infty - } - - let size_of_abstract_species_set set = set.cardinal - - let print_brick _kappa stdout brick = - Printf.fprintf stdout "%i" brick - - let print_regular_formula _error kappa stdout print_hole set = - let rec aux regular_formula = - match regular_formula - with - Nil -> Printf.fprintf stdout "0" - | Brick b -> - print_brick kappa stdout b - | Sum (a,b) -> - let _ = aux_sum a in - let _ = Printf.fprintf stdout "+" in - let _ = aux_sum b in - () - | Product (a,b,c,d) -> - let _ = aux_in_paren a in - let _ = Printf.fprintf stdout ":" in - let _ = print_hole stdout b in - let _ = Printf.fprintf stdout "-" in - let _ = print_hole stdout c in - let _ = Printf.fprintf stdout ":" in - let _ = aux_in_paren d in - () - | Square (a) -> - let _ = aux_in_paren a in - let _ = Printf.fprintf stdout "^2" in - () - | Infinity -> - let _ = Printf.fprintf stdout "+oo" in - () - and - aux_in_paren regular_formula = - match regular_formula - with - Brick _ | Nil -> - aux regular_formula - | Sum _ | Infinity | Product _ | Square _ -> - let _ = Printf.fprintf stdout "(" in - let _ = aux regular_formula in - let _ = Printf.fprintf stdout ")" in - () - and - aux_itemize p regular_formula = - if p regular_formula - then aux regular_formula - else aux_in_paren regular_formula - and - aux_sum x = - aux_itemize - (fun regular_formula -> - match regular_formula - with - Nil - | Brick _ - | Sum _ -> true - | Product _ | Square _ | Infinity -> false) - x - in - let _ = aux set.regular_formula in - () - - let print error kappa stdout (*hole_array*) print_hole set = - let _ = print_regular_formula error kappa stdout print_hole set in - let _ = Printf.fprintf stdout "\n\n There are %s chemical species.\n" (Int_inf.bi_string_of set.cardinal) in - () - - let print_short error kappa stdout (*hole_array*) print_hole set = - let _ = print_regular_formula error kappa stdout print_hole set in - let _ = Printf.fprintf stdout "(%s)\n" (Int_inf.bi_string_of set.cardinal) in - () - - let combine a b c d = - {regular_formula = Product (a.regular_formula,b,c,d.regular_formula); - cardinal = Int_inf.bi_mult a.cardinal d.cardinal} - - let promote linear_combination = - let regular_expression,cardinal = - match linear_combination - with - [] -> Nil,Int_inf.bi_zero - | (n,t)::q -> - List.fold_left - (fun (regular_expression,cardinal) (n,brick) -> - (Sum(Brick brick,regular_expression),Int_inf.bi_add (Int_inf.bi_of_int n) cardinal)) - (Brick t,Int_inf.bi_of_int n) - q - in +module Explicit_enumeration : + Enumeration with type puzzle_hole = int and type brick = int = struct + type brick = int + type puzzle_hole = (*Kappa.puzzle_hole *) int + + type regular_formula = + | Nil + | Brick of brick + | Sum of (regular_formula * regular_formula) + | Product of (regular_formula * puzzle_hole * puzzle_hole * regular_formula) + | Square of regular_formula + | Infinity + + type abstract_species_set = { + regular_formula: regular_formula; + cardinal: Int_inf.bi_intinf; + } + + let nil = { regular_formula = Nil; cardinal = Int_inf.bi_zero } + let infinity = { regular_formula = Infinity; cardinal = Int_inf.infty } + let size_of_abstract_species_set set = set.cardinal + let print_brick _kappa stdout brick = Printf.fprintf stdout "%i" brick + + let print_regular_formula _error kappa stdout print_hole set = + let rec aux regular_formula = + match regular_formula with + | Nil -> Printf.fprintf stdout "0" + | Brick b -> print_brick kappa stdout b + | Sum (a, b) -> + let _ = aux_sum a in + let _ = Printf.fprintf stdout "+" in + let _ = aux_sum b in + () + | Product (a, b, c, d) -> + let _ = aux_in_paren a in + let _ = Printf.fprintf stdout ":" in + let _ = print_hole stdout b in + let _ = Printf.fprintf stdout "-" in + let _ = print_hole stdout c in + let _ = Printf.fprintf stdout ":" in + let _ = aux_in_paren d in + () + | Square a -> + let _ = aux_in_paren a in + let _ = Printf.fprintf stdout "^2" in + () + | Infinity -> + let _ = Printf.fprintf stdout "+oo" in + () + and aux_in_paren regular_formula = + match regular_formula with + | Brick _ | Nil -> aux regular_formula + | Sum _ | Infinity | Product _ | Square _ -> + let _ = Printf.fprintf stdout "(" in + let _ = aux regular_formula in + let _ = Printf.fprintf stdout ")" in + () + and aux_itemize p regular_formula = + if p regular_formula then + aux regular_formula + else + aux_in_paren regular_formula + and aux_sum x = + aux_itemize + (fun regular_formula -> + match regular_formula with + | Nil | Brick _ | Sum _ -> true + | Product _ | Square _ | Infinity -> false) + x + in + let _ = aux set.regular_formula in + () + + let print error kappa stdout (*hole_array*) print_hole set = + let _ = print_regular_formula error kappa stdout print_hole set in + let _ = + Printf.fprintf stdout "\n\n There are %s chemical species.\n" + (Int_inf.bi_string_of set.cardinal) + in + () + + let print_short error kappa stdout (*hole_array*) print_hole set = + let _ = print_regular_formula error kappa stdout print_hole set in + let _ = + Printf.fprintf stdout "(%s)\n" (Int_inf.bi_string_of set.cardinal) + in + () + + let combine a b c d = + { + regular_formula = Product (a.regular_formula, b, c, d.regular_formula); + cardinal = Int_inf.bi_mult a.cardinal d.cardinal; + } + + let promote linear_combination = + let regular_expression, cardinal = + match linear_combination with + | [] -> Nil, Int_inf.bi_zero + | (n, t) :: q -> + List.fold_left + (fun (regular_expression, cardinal) (n, brick) -> + ( Sum (Brick brick, regular_expression), + Int_inf.bi_add (Int_inf.bi_of_int n) cardinal )) + (Brick t, Int_inf.bi_of_int n) + q + in + { regular_formula = regular_expression; cardinal } + + let sum a b = + if a == nil then + b + else if b == nil then + a + else { - regular_formula = regular_expression; - cardinal = cardinal + regular_formula = Sum (a.regular_formula, b.regular_formula); + cardinal = Int_inf.bi_add a.cardinal b.cardinal; } + let square a = + { + regular_formula = Square a.regular_formula; + cardinal = Int_inf.bi_n_n_plus_1_divided_by_2 a.cardinal; + } +end - let sum a b = - if a==nil - then b - else if b==nil then a - else - { - regular_formula = Sum (a.regular_formula,b.regular_formula); - cardinal = Int_inf.bi_add a.cardinal b.cardinal - } - - let square a = - {regular_formula = Square (a.regular_formula); - cardinal = Int_inf.bi_n_n_plus_1_divided_by_2 a.cardinal} - - end:Enumeration with type puzzle_hole = int and type brick = int ) - -module Counting = - (struct - type brick = int - - type puzzle_hole = (*Kappa.puzzle_hole *) int - - type abstract_species_set = Int_inf.bi_intinf - - let nil = Int_inf.bi_zero - - let infinity = Int_inf.infty - - let size_of_abstract_species_set set = set - - (*let dual _ kappa_handler = kappa_handler.Kappa.dual_of_puzzle_hole *) - - let print _error _kappa stdout _ (*_*) set = - let _ = Printf.fprintf stdout "\n\n There are %s chemical species.\n" (Int_inf.bi_string_of set) in - () +module Counting : Enumeration with type puzzle_hole = int and type brick = int = +struct + type brick = int + type puzzle_hole = (*Kappa.puzzle_hole *) int + type abstract_species_set = Int_inf.bi_intinf - let print_short = print + let nil = Int_inf.bi_zero + let infinity = Int_inf.infty + let size_of_abstract_species_set set = set - let promote linear_combination = - List.fold_left - (fun cardinal (n,_brick) -> Int_inf.bi_add (Int_inf.bi_of_int n) cardinal) - Int_inf.bi_zero - linear_combination + (*let dual _ kappa_handler = kappa_handler.Kappa.dual_of_puzzle_hole *) - let combine a _ _ = Int_inf.bi_mult a + let print _error _kappa stdout _ (*_*) set = + let _ = + Printf.fprintf stdout "\n\n There are %s chemical species.\n" + (Int_inf.bi_string_of set) + in + () - let sum = Int_inf.bi_add + let print_short = print - let square a = Int_inf.bi_n_n_plus_1_divided_by_2 a + let promote linear_combination = + List.fold_left + (fun cardinal (n, _brick) -> + Int_inf.bi_add (Int_inf.bi_of_int n) cardinal) + Int_inf.bi_zero linear_combination - end:Enumeration with type puzzle_hole = int and type brick = int ) + let combine a _ _ = Int_inf.bi_mult a + let sum = Int_inf.bi_add + let square a = Int_inf.bi_n_n_plus_1_divided_by_2 a +end diff --git a/core/KaSa_rep/counting_enumerating_species/counting_engine.ml b/core/KaSa_rep/counting_enumerating_species/counting_engine.ml index f8ace8a379..0a71ab91e1 100644 --- a/core/KaSa_rep/counting_enumerating_species/counting_engine.ml +++ b/core/KaSa_rep/counting_enumerating_species/counting_engine.ml @@ -15,368 +15,440 @@ let verbose_mode = false (* Dump information about intermediary steps *) -type ('hole, 'brick) hole_handler = - { - dual: Exception.method_handler -> 'hole -> Exception.method_handler * 'hole list ; - dual_and_self: Exception.method_handler -> 'hole -> Exception.method_handler * 'hole list * bool ; - interface_of_brick: Exception.method_handler -> 'brick -> Exception.method_handler * ('hole list) ; - print_hole: out_channel -> 'hole -> unit ; - } +type ('hole, 'brick) hole_handler = { + dual: + Exception.method_handler -> 'hole -> Exception.method_handler * 'hole list; + dual_and_self: + Exception.method_handler -> + 'hole -> + Exception.method_handler * 'hole list * bool; + interface_of_brick: + Exception.method_handler -> 'brick -> Exception.method_handler * 'hole list; + print_hole: out_channel -> 'hole -> unit; +} module Count = - (functor (E:Counting_algebrae.Enumeration) -> - struct +functor + (E : Counting_algebrae.Enumeration) + -> + struct + module Puzzle_hole_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = E.puzzle_hole - module Puzzle_hole_map_and_set = - Map_wrapper.Make (SetMap.Make - (struct - type t = E.puzzle_hole - let compare = compare - let print _ _ = () - end)) + let compare = compare + let print _ _ = () + end)) - type hole_multiset = int Puzzle_hole_map_and_set.Map.t + type hole_multiset = int Puzzle_hole_map_and_set.Map.t - module Interfaces = - Map_wrapper.Make (SetMap.Make - (struct - type t = hole_multiset * hole_multiset - let compare = compare - let print _ _ = () - end)) + module Interfaces = Map_wrapper.Make (SetMap.Make (struct + type t = hole_multiset * hole_multiset - type dependence_graph = - {dependences:(hole_multiset*hole_multiset) list Puzzle_hole_map_and_set.Map.t; - interfaces:Interfaces.Set.t} + let compare = compare + let print _ _ = () + end)) - type induction_state = - {error_handler:Exception.method_handler; - dependence_graph:dependence_graph; - to_visit: (E.puzzle_hole*E.abstract_species_set*Puzzle_hole_map_and_set.Set.t*hole_multiset) list; - species: (E.abstract_species_set*Puzzle_hole_map_and_set.Set.t) Interfaces.Map.t} + type dependence_graph = { + dependences: + (hole_multiset * hole_multiset) list Puzzle_hole_map_and_set.Map.t; + interfaces: Interfaces.Set.t; + } - let print_handler error_handler kappa_handler hole_handler = - { - Counting_print.iter_map1=Puzzle_hole_map_and_set.Map.iter; - Counting_print.iter_map2=Interfaces.Map.iter; - Counting_print.iter_map3=Puzzle_hole_map_and_set.Map.iter; - Counting_print.iter_set=Puzzle_hole_map_and_set.Set.iter; - Counting_print.iter_set2=Interfaces.Set.iter; - Counting_print.dependences=(fun a -> a.dependences); - Counting_print.dependence_graph=(fun a -> a.dependence_graph); - Counting_print.print_hole=hole_handler.print_hole; - Counting_print.print_short= - (fun stdout -> - E.print_short error_handler kappa_handler stdout hole_handler.print_hole) ; - Counting_print.interfaces=(fun a -> a.interfaces); - Counting_print.species=(fun a -> a.species); - Counting_print.to_visit=(fun a -> a.to_visit); - Counting_print.error=(fun a -> a.error_handler)} + type induction_state = { + error_handler: Exception.method_handler; + dependence_graph: dependence_graph; + to_visit: + (E.puzzle_hole + * E.abstract_species_set + * Puzzle_hole_map_and_set.Set.t + * hole_multiset) + list; + species: + (E.abstract_species_set * Puzzle_hole_map_and_set.Set.t) + Interfaces.Map.t; + } + let print_handler error_handler kappa_handler hole_handler = + { + Counting_print.iter_map1 = Puzzle_hole_map_and_set.Map.iter; + Counting_print.iter_map2 = Interfaces.Map.iter; + Counting_print.iter_map3 = Puzzle_hole_map_and_set.Map.iter; + Counting_print.iter_set = Puzzle_hole_map_and_set.Set.iter; + Counting_print.iter_set2 = Interfaces.Set.iter; + Counting_print.dependences = (fun a -> a.dependences); + Counting_print.dependence_graph = (fun a -> a.dependence_graph); + Counting_print.print_hole = hole_handler.print_hole; + Counting_print.print_short = + (fun stdout -> + E.print_short error_handler kappa_handler stdout + hole_handler.print_hole); + Counting_print.interfaces = (fun a -> a.interfaces); + Counting_print.species = (fun a -> a.species); + Counting_print.to_visit = (fun a -> a.to_visit); + Counting_print.error = (fun a -> a.error_handler); + } + let trace_state title prefix hole_handler state = + if verbose_mode then ( + let _ = Printf.fprintf stdout "%s" title in + let _ = Counting_print.dump_state stdout prefix hole_handler state in + () + ) - let trace_state title prefix hole_handler state = - if verbose_mode then - let _ = Printf.fprintf stdout "%s" title in - let _ = Counting_print.dump_state stdout prefix hole_handler state - in () + let find_dependence parameters error hole graph = + Puzzle_hole_map_and_set.Map.find_default parameters error [] hole graph - let find_dependence parameters error hole graph = - Puzzle_hole_map_and_set.Map.find_default parameters error [] hole graph + let add_dependence parameters error_handler hole interface graph = + let error_handler, old_interface_list = + find_dependence parameters error_handler hole graph + in + Puzzle_hole_map_and_set.Map.add parameters error_handler hole + (interface :: old_interface_list) + graph - let add_dependence parameters error_handler hole interface graph = - let error_handler,old_interface_list = - find_dependence parameters error_handler hole graph - in - Puzzle_hole_map_and_set.Map.add parameters error_handler hole (interface::old_interface_list) graph + let add_species parameters error_handler _hole_handler species holeset + interface interface_map = + let error_handler, (old, old_holeset) = + Interfaces.Map.find_default_without_logs parameters error_handler + (E.nil, Puzzle_hole_map_and_set.Set.empty) + interface interface_map + in + let new_species = E.sum old species in + let error_handler, new_hole_set = + Puzzle_hole_map_and_set.Set.union parameters error_handler old_holeset + holeset + in + Interfaces.Map.add parameters error_handler interface + (new_species, new_hole_set) + interface_map - let add_species parameters error_handler _hole_handler species holeset interface interface_map = - let error_handler,(old,old_holeset) = - Interfaces.Map.find_default_without_logs parameters error_handler (E.nil,Puzzle_hole_map_and_set.Set.empty) interface interface_map - in - let new_species = E.sum old species in - let error_handler,new_hole_set = Puzzle_hole_map_and_set.Set.union parameters error_handler old_holeset holeset in - Interfaces.Map.add parameters error_handler interface (new_species,new_hole_set) interface_map + let remove_species parameters hole self state = + let species = state.species in + let error_handler = state.error_handler in + let error_handler, interface_other = + Puzzle_hole_map_and_set.Map.add parameters error_handler hole 1 + Puzzle_hole_map_and_set.Map.empty + in + let error_handler, k = + Interfaces.Map.find_option parameters error_handler + (interface_other, self) species + in + match k with + | None -> + let error_handler, state = + Exception.warn parameters state.error_handler __POS__ + ~message:"unknown interface in remove_species" Exit state + in + { state with error_handler }, (E.nil, Puzzle_hole_map_and_set.Set.empty) + | Some k -> + let error_handler, species = + Interfaces.Map.remove parameters error_handler (interface_other, self) + species + in + { state with species; error_handler }, k - let remove_species parameters hole self state = - let species = state.species in - let error_handler = state.error_handler in - let error_handler,interface_other = Puzzle_hole_map_and_set.Map.add parameters error_handler hole 1 Puzzle_hole_map_and_set.Map.empty in - let error_handler,k = Interfaces.Map.find_option parameters error_handler (interface_other,self) species in - match k with - | None -> - let error_handler,state = - Exception.warn - parameters state.error_handler __POS__ - ~message:"unknown interface in remove_species" - Exit state - in - {state with error_handler}, - (E.nil,Puzzle_hole_map_and_set.Set.empty) - | Some k -> - let error_handler,species = - Interfaces.Map.remove parameters error_handler (interface_other,self) species - in - {state with species=species; error_handler},k + let add_interface parameters hole_handler interface species holeset state = + let error_handler = state.error_handler in + let interface_other, interface_self = interface in + let empty_interface_other = + Puzzle_hole_map_and_set.Map.for_all (fun _ x -> x = 0) interface_other + in + let is_singleton_interface_other = + let min_elt = + Puzzle_hole_map_and_set.Map.filter_one + (fun _ i -> i <> 0) + interface_other + in + match min_elt with + | None -> false + | Some (hole, _) -> + Puzzle_hole_map_and_set.Map.for_all + (fun x y -> (y = 1 && x = hole) || y = 0) + interface_other + in + (*1*) + if empty_interface_other then ( + let error_handler, species = + add_species parameters state.error_handler hole_handler species + holeset + (interface_other, interface_self) + state.species + in + { state with error_handler; species } + ) else ( + (*2*) + let state = + if is_singleton_interface_other then ( + let hole = + Puzzle_hole_map_and_set.Map.filter_one + (fun _ i -> i <> 0) + interface_other + in + match hole with + | None -> + let error_handler, state = + Exception.warn parameters state.error_handler __POS__ Exit state + in + { state with error_handler } + | Some (hole, _) -> + { + state with + to_visit = + (hole, species, holeset, interface_self) :: state.to_visit; + } + ) else + state + in + (*3*) + if Interfaces.Set.mem interface state.dependence_graph.interfaces then ( + (*4*) + let error_handler, species = + add_species parameters error_handler hole_handler species holeset + interface state.species + in + { state with species; error_handler } + ) else ( + (*4*) - let add_interface parameters hole_handler interface species holeset state = - let error_handler = state.error_handler in - let interface_other,interface_self = interface in - let empty_interface_other = - Puzzle_hole_map_and_set.Map.for_all - (fun _ x -> x=0) - interface_other - in - let is_singleton_interface_other = - let min_elt = Puzzle_hole_map_and_set.Map.filter_one - (fun _ i -> i<>0) interface_other in - match min_elt with - | None -> false - | Some (hole,_) -> - Puzzle_hole_map_and_set.Map.for_all - (fun x y -> (y=1 && x=hole) || y=0) - interface_other - in - begin (*1*) - if empty_interface_other - then - let error_handler,species = add_species parameters state.error_handler hole_handler species holeset (interface_other,interface_self) state.species in - { - state with - error_handler = error_handler ; - species = species - } - else - begin (*2*) - let state = - if is_singleton_interface_other - then - let hole = Puzzle_hole_map_and_set.Map.filter_one - (fun _ i -> i<>0) interface_other in - match hole with - | None -> - let error_handler,state = - Exception.warn - parameters state.error_handler __POS__ - Exit state - in - {state with error_handler = error_handler } - | Some (hole,_) -> - { - state with - to_visit = (hole,species,holeset,interface_self)::state.to_visit - } - else - state - in - begin (*3*) - if Interfaces.Set.mem interface state.dependence_graph.interfaces - then - begin (*4*) - let error_handler,species = add_species parameters error_handler hole_handler species holeset interface state.species in - {state with - species = species; - error_handler = error_handler - } - end (*4*) - else - begin (*4*) - let error_handler,dependences = - Puzzle_hole_map_and_set.Map.fold - (fun hole n (error_handler,graph) -> - if n=0 - then error_handler,graph - else add_dependence parameters error_handler hole interface graph) - interface_other - (error_handler,state.dependence_graph.dependences) - in - let error_handler,interfaces = - Interfaces.Set.add parameters error_handler interface state.dependence_graph.interfaces - in - let error_handler,species = add_species parameters error_handler hole_handler species holeset interface state.species in - {state with - error_handler = error_handler; - species = species; - dependence_graph = - { - dependences = dependences; - interfaces = interfaces - };} - end (*4*) - end (*3*) - end (*2*) - end (*1*) + (*4*) + let error_handler, dependences = + Puzzle_hole_map_and_set.Map.fold + (fun hole n (error_handler, graph) -> + if n = 0 then + error_handler, graph + else + add_dependence parameters error_handler hole interface graph) + interface_other + (error_handler, state.dependence_graph.dependences) + in + let error_handler, interfaces = + Interfaces.Set.add parameters error_handler interface + state.dependence_graph.interfaces + in + let error_handler, species = + add_species parameters error_handler hole_handler species holeset + interface state.species + in + { + state with + error_handler; + species; + dependence_graph = { dependences; interfaces }; + } + (*4*) + (*3*) + (*2*) + ) + ) + (*1*) - let empty_state error_handler = - { - error_handler=error_handler; - dependence_graph= - { - dependences = Puzzle_hole_map_and_set.Map.empty; - interfaces = Interfaces.Set.empty - }; - to_visit=[]; - species=Interfaces.Map.empty; - } + let empty_state error_handler = + { + error_handler; + dependence_graph = + { + dependences = Puzzle_hole_map_and_set.Map.empty; + interfaces = Interfaces.Set.empty; + }; + to_visit = []; + species = Interfaces.Map.empty; + } - let infinite_state parameters error_handler = - let empty_state = empty_state error_handler in - let error_handler,species = Interfaces.Map.add parameters error_handler (Puzzle_hole_map_and_set.Map.empty,Puzzle_hole_map_and_set.Map.empty) (E.infinity,Puzzle_hole_map_and_set.Set.empty) Interfaces.Map.empty in - {empty_state with species = species ; error_handler} + let infinite_state parameters error_handler = + let empty_state = empty_state error_handler in + let error_handler, species = + Interfaces.Map.add parameters error_handler + (Puzzle_hole_map_and_set.Map.empty, Puzzle_hole_map_and_set.Map.empty) + (E.infinity, Puzzle_hole_map_and_set.Set.empty) + Interfaces.Map.empty + in + { empty_state with species; error_handler } - let inc parameters error_handler x delta map = - let error_handler,old = Puzzle_hole_map_and_set.Map.find_default_without_logs parameters error_handler 0 x map in - let output = old + delta in - if output = 0 - then Puzzle_hole_map_and_set.Map.remove parameters error_handler x map - else Puzzle_hole_map_and_set.Map.add parameters error_handler x output map + let inc parameters error_handler x delta map = + let error_handler, old = + Puzzle_hole_map_and_set.Map.find_default_without_logs parameters + error_handler 0 x map + in + let output = old + delta in + if output = 0 then + Puzzle_hole_map_and_set.Map.remove parameters error_handler x map + else + Puzzle_hole_map_and_set.Map.add parameters error_handler x output map - let init parameters hole_handler _print_handler empty_state linear_combination = - let error_handler = empty_state.error_handler in - List.fold_left - (fun state (n,i) -> - let error_handler,interface = hole_handler.interface_of_brick error_handler i in - let error_handler,partition = - let rec aux list error_handler other self_other self = - match list with - | [] -> error_handler,Some (other,self_other,self) - | (elt:E.puzzle_hole)::tail -> - let error_handler,dual_other,can_self = hole_handler.dual_and_self error_handler elt in - let can_other = dual_other <> [] in - match can_other,can_self with - | false,false -> - error_handler,None - | true,false -> - let error_handler,other = inc parameters error_handler elt 1 other in - aux tail error_handler other self_other self - | false,true -> - let error_handler,self = inc parameters error_handler elt 1 self in - aux tail error_handler other self_other self - | true,true -> - aux tail error_handler other (elt::self_other) self - in aux interface error_handler Puzzle_hole_map_and_set.Map.empty [] Puzzle_hole_map_and_set.Map.empty + let init parameters hole_handler _print_handler empty_state + linear_combination = + let error_handler = empty_state.error_handler in + List.fold_left + (fun state (n, i) -> + let error_handler, interface = + hole_handler.interface_of_brick error_handler i + in + let error_handler, partition = + let rec aux list error_handler other self_other self = + match list with + | [] -> error_handler, Some (other, self_other, self) + | (elt : E.puzzle_hole) :: tail -> + let error_handler, dual_other, can_self = + hole_handler.dual_and_self error_handler elt + in + let can_other = dual_other <> [] in + (match can_other, can_self with + | false, false -> error_handler, None + | true, false -> + let error_handler, other = + inc parameters error_handler elt 1 other + in + aux tail error_handler other self_other self + | false, true -> + let error_handler, self = + inc parameters error_handler elt 1 self + in + aux tail error_handler other self_other self + | true, true -> + aux tail error_handler other (elt :: self_other) self) in - match partition with - | None -> {state with error_handler = error_handler} - | Some (other,self_other,self) -> - let error_handler,interface_list = - List.fold_left - (fun (error_handler,interface_list) elt -> - List.fold_left - (fun (error_handler,list) (prefix1,prefix2) -> - let error_handler,sol1 = inc parameters error_handler elt 1 prefix1 in - let error_handler,sol2 = inc parameters error_handler elt 1 prefix2 in - error_handler,(sol1,prefix2)::(prefix1,sol2)::list) - (error_handler,[]) - interface_list) - (error_handler,[other,self]) - self_other - in + aux interface error_handler Puzzle_hole_map_and_set.Map.empty [] + Puzzle_hole_map_and_set.Map.empty + in + match partition with + | None -> { state with error_handler } + | Some (other, self_other, self) -> + let error_handler, interface_list = List.fold_left - (fun state interface -> - add_interface parameters hole_handler interface (E.promote [n,i]) Puzzle_hole_map_and_set.Set.empty state) - {state with error_handler = error_handler} - interface_list) - empty_state - linear_combination - - - let conclude state = - Interfaces.Map.fold - (fun (other,x) (new_abstract_species,_) abstract_species -> - if Puzzle_hole_map_and_set.Map.for_all (fun _ x -> x=0) other - then - let nhole = - Puzzle_hole_map_and_set.Map.fold - (fun _ x y -> x+y) - x - 0 - in - match nhole with - | 0 -> E.sum abstract_species new_abstract_species - | 1 -> E.sum - abstract_species - (E.square new_abstract_species) - | _ -> E.infinity - else - abstract_species) - state.species - E.nil + (fun (error_handler, interface_list) elt -> + List.fold_left + (fun (error_handler, list) (prefix1, prefix2) -> + let error_handler, sol1 = + inc parameters error_handler elt 1 prefix1 + in + let error_handler, sol2 = + inc parameters error_handler elt 1 prefix2 + in + error_handler, (sol1, prefix2) :: (prefix1, sol2) :: list) + (error_handler, []) interface_list) + (error_handler, [ other, self ]) + self_other + in + List.fold_left + (fun state interface -> + add_interface parameters hole_handler interface + (E.promote [ n, i ]) + Puzzle_hole_map_and_set.Set.empty state) + { state with error_handler } + interface_list) + empty_state linear_combination + let conclude state = + Interfaces.Map.fold + (fun (other, x) (new_abstract_species, _) abstract_species -> + if Puzzle_hole_map_and_set.Map.for_all (fun _ x -> x = 0) other then ( + let nhole = + Puzzle_hole_map_and_set.Map.fold (fun _ x y -> x + y) x 0 + in + match nhole with + | 0 -> E.sum abstract_species new_abstract_species + | 1 -> E.sum abstract_species (E.square new_abstract_species) + | _ -> E.infinity + ) else + abstract_species) + state.species E.nil - let induction parameters error_handler hole_handler print_handler state = - let rec aux state = - let _ = trace_state "Induction\n" " " print_handler state in - match state.to_visit with - | [] -> state - | (hole,formula,forbidden,self)::q -> - let error_handler,dual_list = hole_handler.dual error_handler hole in - let state = {state with error_handler = error_handler} in - let state,_ = - remove_species parameters hole self state in - let state = {state with to_visit = q} in - let state = - begin - let rec aux2 dual_list state = - match dual_list with - | [] -> state - | dual::dual_tail -> - let error_handler,partner_set = find_dependence parameters error_handler dual state.dependence_graph.dependences in - let state = {state with error_handler = error_handler} in - let state = - let rec aux3 list state = - match list with - | [] -> state - | interface::tail -> - begin - match - Interfaces.Map.find_option_without_logs parameters error_handler interface state.species - with - | error_handler,None -> aux3 tail {state with error_handler = error_handler} - | error_handler,Some (abstract_species_set,hole_set) -> - begin - if Puzzle_hole_map_and_set.Set.mem hole hole_set - || Puzzle_hole_map_and_set.Set.mem dual forbidden - then - infinite_state parameters error_handler - else - let new_abstract_species = E.combine formula hole dual abstract_species_set in - let error_handler,new_interface = - let error_handler,new_other = inc parameters error_handler dual (-1) (fst interface) in - let error_handler,new_self = - Puzzle_hole_map_and_set.Map.map2z - parameters - error_handler - (fun _paramters error_handler x y -> error_handler,x+y) - (snd interface) - self - in - error_handler,(new_other,new_self) - in - let error_handler,new_hole_set = Puzzle_hole_map_and_set.Set.add parameters error_handler dual hole_set in - let state = - add_interface - parameters hole_handler new_interface new_abstract_species new_hole_set - {state with error_handler} - in - aux3 tail state - end end - in aux3 partner_set state - in aux2 dual_tail state - in aux2 dual_list state - end - in aux state - in aux state + let induction parameters error_handler hole_handler print_handler state = + let rec aux state = + let _ = trace_state "Induction\n" " " print_handler state in + match state.to_visit with + | [] -> state + | (hole, formula, forbidden, self) :: q -> + let error_handler, dual_list = hole_handler.dual error_handler hole in + let state = { state with error_handler } in + let state, _ = remove_species parameters hole self state in + let state = { state with to_visit = q } in + let state = + let rec aux2 dual_list state = + match dual_list with + | [] -> state + | dual :: dual_tail -> + let error_handler, partner_set = + find_dependence parameters error_handler dual + state.dependence_graph.dependences + in + let state = { state with error_handler } in + let state = + let rec aux3 list state = + match list with + | [] -> state + | interface :: tail -> + (match + Interfaces.Map.find_option_without_logs parameters + error_handler interface state.species + with + | error_handler, None -> + aux3 tail { state with error_handler } + | error_handler, Some (abstract_species_set, hole_set) -> + if + Puzzle_hole_map_and_set.Set.mem hole hole_set + || Puzzle_hole_map_and_set.Set.mem dual forbidden + then + infinite_state parameters error_handler + else ( + let new_abstract_species = + E.combine formula hole dual abstract_species_set + in + let error_handler, new_interface = + let error_handler, new_other = + inc parameters error_handler dual (-1) + (fst interface) + in + let error_handler, new_self = + Puzzle_hole_map_and_set.Map.map2z parameters + error_handler + (fun _paramters error_handler x y -> + error_handler, x + y) + (snd interface) self + in + error_handler, (new_other, new_self) + in + let error_handler, new_hole_set = + Puzzle_hole_map_and_set.Set.add parameters + error_handler dual hole_set + in + let state = + add_interface parameters hole_handler new_interface + new_abstract_species new_hole_set + { state with error_handler } + in + aux3 tail state + )) + in + aux3 partner_set state + in + aux2 dual_tail state + in + aux2 dual_list state + in + aux state + in + aux state - let count parameters error_handler kappa_handler hole_handler print_handler linear_combination = - let empty_state = empty_state error_handler in - let print_handler = print_handler error_handler kappa_handler hole_handler in - let _ = trace_state "Empty state\n" " " print_handler empty_state in - let init_state = init parameters hole_handler print_handler empty_state linear_combination in - let _ = trace_state "\nInitial state\n" " " print_handler init_state in - let final_state = (induction parameters error_handler hole_handler print_handler init_state) in - let _ = trace_state "\nFinal state\n" " " print_handler final_state in - let sol = conclude final_state in - let _ = E.print error_handler kappa_handler stdout hole_handler.print_hole sol in - sol - end) + let count parameters error_handler kappa_handler hole_handler print_handler + linear_combination = + let empty_state = empty_state error_handler in + let print_handler = + print_handler error_handler kappa_handler hole_handler + in + let _ = trace_state "Empty state\n" " " print_handler empty_state in + let init_state = + init parameters hole_handler print_handler empty_state + linear_combination + in + let _ = trace_state "\nInitial state\n" " " print_handler init_state in + let final_state = + induction parameters error_handler hole_handler print_handler init_state + in + let _ = trace_state "\nFinal state\n" " " print_handler final_state in + let sol = conclude final_state in + let _ = + E.print error_handler kappa_handler stdout hole_handler.print_hole sol + in + sol + end diff --git a/core/KaSa_rep/counting_enumerating_species/counting_print.ml b/core/KaSa_rep/counting_enumerating_species/counting_print.ml index 5b1812a088..4c0db61cdc 100644 --- a/core/KaSa_rep/counting_enumerating_species/counting_print.ml +++ b/core/KaSa_rep/counting_enumerating_species/counting_print.ml @@ -12,100 +12,143 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - - -type ('error,'species,'state,'dependence_graph,'dependence,'hole,'holeset,'hole_multiset,'species_interface_map,'hole_map_interface_list,'interface,'interfaceset) print_handler = - {iter_map1:('hole -> int -> unit) -> 'hole_multiset -> unit; - iter_map2:('interface -> ('species*'holeset) ->unit) -> 'species_interface_map -> unit; - iter_map3:('hole -> 'interface list -> unit) -> 'hole_map_interface_list -> unit; - iter_set:('hole -> unit) -> 'holeset -> unit; - iter_set2:('interface -> unit) -> 'interfaceset -> unit; - dependences:'dependence_graph -> 'dependence; - dependence_graph:'state -> 'dependence_graph; - print_hole:out_channel -> 'hole -> unit; - print_short:out_channel -> 'species -> unit; - interfaces:'dependence_graph -> 'interfaceset; - species:'state -> 'species_interface_map; - to_visit:'state -> ('hole * 'species * 'holeset * 'hole_multiset) list ; - error:'state -> 'error} +type ('error, + 'species, + 'state, + 'dependence_graph, + 'dependence, + 'hole, + 'holeset, + 'hole_multiset, + 'species_interface_map, + 'hole_map_interface_list, + 'interface, + 'interfaceset) + print_handler = { + iter_map1: ('hole -> int -> unit) -> 'hole_multiset -> unit; + iter_map2: + ('interface -> 'species * 'holeset -> unit) -> + 'species_interface_map -> + unit; + iter_map3: + ('hole -> 'interface list -> unit) -> 'hole_map_interface_list -> unit; + iter_set: ('hole -> unit) -> 'holeset -> unit; + iter_set2: ('interface -> unit) -> 'interfaceset -> unit; + dependences: 'dependence_graph -> 'dependence; + dependence_graph: 'state -> 'dependence_graph; + print_hole: out_channel -> 'hole -> unit; + print_short: out_channel -> 'species -> unit; + interfaces: 'dependence_graph -> 'interfaceset; + species: 'state -> 'species_interface_map; + to_visit: 'state -> ('hole * 'species * 'holeset * 'hole_multiset) list; + error: 'state -> 'error; +} let dump_hole_set log print_handler hole_set = print_handler.iter_map1 (fun x i -> match i with - | 0 -> () - | 1 -> - let _ = print_handler.print_hole log x in - let _ = Printf.fprintf log ";" in - () - | _ -> - let _ = Printf.fprintf log "%i*" i in - let _ = print_handler.print_hole log x in - let _ = Printf.fprintf log ";" in - ()) + | 0 -> () + | 1 -> + let _ = print_handler.print_hole log x in + let _ = Printf.fprintf log ";" in + () + | _ -> + let _ = Printf.fprintf log "%i*" i in + let _ = print_handler.print_hole log x in + let _ = Printf.fprintf log ";" in + ()) hole_set -let dump_interface log prefix print_handler (other,self) = - let _ = Printf.fprintf log "%s * Hole connected to other kind of pieces: " prefix in +let dump_interface log prefix print_handler (other, self) = + let _ = + Printf.fprintf log "%s * Hole connected to other kind of pieces: " prefix + in let _ = dump_hole_set log print_handler other in - let _ = Printf.fprintf log "\n%s * Hole connected to identical kind of pieces: " prefix in + let _ = + Printf.fprintf log "\n%s * Hole connected to identical kind of pieces: " + prefix + in let _ = dump_hole_set log print_handler self in let _ = Printf.fprintf log "\n" in () let dump_dependence_graph log prefix print_handler graph = - let _ = Printf.fprintf log "%sDependence_graph:\n%s * Known interfaces:\n" prefix prefix in + let _ = + Printf.fprintf log "%sDependence_graph:\n%s * Known interfaces:\n" prefix + prefix + in let _ = print_handler.iter_set2 (dump_interface log prefix print_handler) (print_handler.interfaces graph) in - let _ = Printf.fprintf log "%s * Dependences:\n" prefix in + let _ = Printf.fprintf log "%s * Dependences:\n" prefix in let _ = print_handler.iter_map3 - (fun hole list -> - let _ = Printf.fprintf log "%s * Hole :" prefix in - let _ = print_handler.print_hole log hole in - let _ = Printf.fprintf log "\n" in - let _ = - List.iter - (dump_interface log (" "^prefix) print_handler) - list - in ()) - (print_handler.dependences graph) - in () - - - + (fun hole list -> + let _ = Printf.fprintf log "%s * Hole :" prefix in + let _ = print_handler.print_hole log hole in + let _ = Printf.fprintf log "\n" in + let _ = + List.iter (dump_interface log (" " ^ prefix) print_handler) list + in + ()) + (print_handler.dependences graph) + in + () let dump_state log prefix print_handler state = let _ = Printf.fprintf log "%sState:\n" prefix in - let _ = dump_dependence_graph log (prefix^" ") print_handler (print_handler.dependence_graph state) in + let _ = + dump_dependence_graph log (prefix ^ " ") print_handler + (print_handler.dependence_graph state) + in let _ = Printf.fprintf log "%s Available pieces:\n" prefix in let _ = print_handler.iter_map2 - (fun interface (species,forbidden) -> + (fun interface (species, forbidden) -> let _ = Printf.fprintf log "%s * species\n" prefix in - let _ = dump_interface log (prefix^" ") print_handler interface in - let _ = Printf.fprintf log "%s * regular formula\n%s " prefix prefix in + let _ = dump_interface log (prefix ^ " ") print_handler interface in + let _ = + Printf.fprintf log "%s * regular formula\n%s " prefix prefix + in let _ = print_handler.print_short log species in - let _ = Printf.fprintf log "%s * forbidden holes\n%s " prefix prefix in - let _ = print_handler.iter_set (fun x -> print_handler.print_hole log x;Printf.fprintf log ";") forbidden in - let _ = Printf.fprintf log "\n" in ()) - (print_handler.species state) in + let _ = + Printf.fprintf log "%s * forbidden holes\n%s " prefix prefix + in + let _ = + print_handler.iter_set + (fun x -> + print_handler.print_hole log x; + Printf.fprintf log ";") + forbidden + in + let _ = Printf.fprintf log "\n" in + ()) + (print_handler.species state) + in let _ = Printf.fprintf log "\n" in - let _ = Printf.fprintf log "%s To be visited:\n" prefix in + let _ = Printf.fprintf log "%s To be visited:\n" prefix in let _ = List.iter - (fun (hole,species,holeset,_hole_multiset) -> - let _ = Printf.fprintf log "%s * element\n" prefix in - let _ = Printf.fprintf log "%s - hole " prefix in - let _ = print_handler.print_hole log hole in - let _ = Printf.fprintf log "," in - let _ = Printf.fprintf log "regular formula " in - let _ = print_handler.print_short log species in - let _ = Printf.fprintf log "forbidden holes " in - let _ = print_handler.iter_set (fun x -> print_handler.print_hole log x;Printf.fprintf log ";") holeset in - let _ = Printf.fprintf log "\n" in ()) - (print_handler.to_visit state) - in () + (fun (hole, species, holeset, _hole_multiset) -> + let _ = Printf.fprintf log "%s * element\n" prefix in + let _ = Printf.fprintf log "%s - hole " prefix in + let _ = print_handler.print_hole log hole in + let _ = Printf.fprintf log "," in + let _ = Printf.fprintf log "regular formula " in + let _ = print_handler.print_short log species in + let _ = Printf.fprintf log "forbidden holes " in + let _ = + print_handler.iter_set + (fun x -> + print_handler.print_hole log x; + Printf.fprintf log ";") + holeset + in + let _ = Printf.fprintf log "\n" in + ()) + (print_handler.to_visit state) + in + () diff --git a/core/KaSa_rep/counting_enumerating_species/counting_test.ml b/core/KaSa_rep/counting_enumerating_species/counting_test.ml index 6df20a3603..dc3cf05be8 100644 --- a/core/KaSa_rep/counting_enumerating_species/counting_test.ml +++ b/core/KaSa_rep/counting_enumerating_species/counting_test.ml @@ -1,4 +1,4 @@ - (** +(** * counting_test.ml * openkappa * Jérôme Feret, projet Abstraction, INRIA Paris-Rocquencourt @@ -12,92 +12,105 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module C = Counting_engine.Count(Counting_algebrae.Explicit_enumeration) -module D = Counting_engine.Count(Counting_algebrae.Counting) - +module C = Counting_engine.Count (Counting_algebrae.Explicit_enumeration) +module D = Counting_engine.Count (Counting_algebrae.Counting) let f parameters dual dual_and_self interface_of_brick init = - let _error_handler,kappa_handler = - List_tokens.empty_handler parameters Exception.empty_error_handler in + let _error_handler, kappa_handler = + List_tokens.empty_handler parameters Exception.empty_error_handler + in let i = - C.count - parameters - Exception.empty_error_handler - kappa_handler - {Counting_engine.print_hole=(fun log -> Printf.fprintf log "%d"); - Counting_engine.dual = dual ; - Counting_engine.dual_and_self = dual_and_self ; - Counting_engine.interface_of_brick = interface_of_brick} - C.print_handler - init + C.count parameters Exception.empty_error_handler kappa_handler + { + Counting_engine.print_hole = (fun log -> Printf.fprintf log "%d"); + Counting_engine.dual; + Counting_engine.dual_and_self; + Counting_engine.interface_of_brick; + } + C.print_handler init in let j = - D.count - parameters - Exception.empty_error_handler - kappa_handler - {Counting_engine.print_hole=(fun log -> Printf.fprintf log "%d"); - Counting_engine.dual = dual ; - Counting_engine.dual_and_self = dual_and_self ; - Counting_engine.interface_of_brick = interface_of_brick} - D.print_handler - init - in Counting_algebrae.Explicit_enumeration.size_of_abstract_species_set i, - Counting_algebrae.Counting.size_of_abstract_species_set j + D.count parameters Exception.empty_error_handler kappa_handler + { + Counting_engine.print_hole = (fun log -> Printf.fprintf log "%d"); + Counting_engine.dual; + Counting_engine.dual_and_self; + Counting_engine.interface_of_brick; + } + D.print_handler init + in + ( Counting_algebrae.Explicit_enumeration.size_of_abstract_species_set i, + Counting_algebrae.Counting.size_of_abstract_species_set j ) let test_counting_procedure parameters = let dual error x = - error, - match x with - | 1 -> [2;3] - | 2 -> [1] - | 3 -> [1] - | 4 -> [5] - | 5 -> [4] - | _ -> [] + ( error, + match x with + | 1 -> [ 2; 3 ] + | 2 -> [ 1 ] + | 3 -> [ 1 ] + | 4 -> [ 5 ] + | 5 -> [ 4 ] + | _ -> [] ) in let dual_and_self error x = - error, - (match x with - | 1 -> [2;3] - | 2 -> [1] - | 3 -> [1] - | 4 -> [5] - | 5 -> [4] - | _ -> []), - match x with - | 6 -> true - | _ -> false + ( error, + (match x with + | 1 -> [ 2; 3 ] + | 2 -> [ 1 ] + | 3 -> [ 1 ] + | 4 -> [ 5 ] + | 5 -> [ 4 ] + | _ -> []), + match x with + | 6 -> true + | _ -> false ) in let interface_of_brick error x = - error, - match x with - | 0 -> [1] - | 1 -> [2;3] - | 2 -> [] - | 3 -> [4] - | 4 -> [5;6] - | _ -> [] + ( error, + match x with + | 0 -> [ 1 ] + | 1 -> [ 2; 3 ] + | 2 -> [] + | 3 -> [ 4 ] + | 4 -> [ 5; 6 ] + | _ -> [] ) in - let init = [2,0;4,1;5,2;2,3;2,4] in + let init = [ 2, 0; 4, 1; 5, 2; 2, 3; 2, 4 ] in let _ = Printf.fprintf stdout "\n\nFirst test\n\n" in let n = f parameters dual dual_and_self interface_of_brick init in let dual error x = - error,if x =1 then [2] else if x =2 then [1] else [] + ( error, + if x = 1 then + [ 2 ] + else if x = 2 then + [ 1 ] + else + [] ) in let dual_and_self error x = - let error,y = dual error x in - error,y,false + let error, y = dual error x in + error, y, false in let interface_of_brick error x = - error,if x = 1 then [2] else if x = 2 then [1;2] else [] + ( error, + if x = 1 then + [ 2 ] + else if x = 2 then + [ 1; 2 ] + else + [] ) in - let init = [1,1;1,2] in + let init = [ 1, 1; 1, 2 ] in let _ = Printf.fprintf stdout "\n\nSecond test\n\n" in let m = f parameters dual dual_and_self interface_of_brick init in - ["Counting0",(fun x -> x, Int_inf.equal (fst n) (snd n), None) ; - "Counting1",(fun x -> x, Int_inf.equal (fst n) (Int_inf.Int (Big_int.big_int_of_int 41)), None); - "Counting2",(fun x -> x, Int_inf.equal (fst m) (snd m), None); - "Counting3",(fun x -> x, Int_inf.equal (fst m) (Int_inf.Infinity), None) + [ + ("Counting0", fun x -> x, Int_inf.equal (fst n) (snd n), None); + ( "Counting1", + fun x -> + x, Int_inf.equal (fst n) (Int_inf.Int (Big_int.big_int_of_int 41)), None + ); + ("Counting2", fun x -> x, Int_inf.equal (fst m) (snd m), None); + ("Counting3", fun x -> x, Int_inf.equal (fst m) Int_inf.Infinity, None); ] diff --git a/core/KaSa_rep/counting_enumerating_species/dune b/core/KaSa_rep/counting_enumerating_species/dune index 1537000c19..3d2268303b 100644 --- a/core/KaSa_rep/counting_enumerating_species/dune +++ b/core/KaSa_rep/counting_enumerating_species/dune @@ -1,12 +1,19 @@ (library - (name kappa_species_count_enumeration) - (libraries num kappa_kasa_remanent_state kappa-library.generic) - (flags (:standard) - -open Kappa_parameters - -open Kappa_errors - -open Kappa_kasa_remanent_state - -open Kappa_kasa_frontend - -open Kappa_logging - -open Kappa_generic_toolset - -open Kappa_kasa_kastor_toolset -)) + (name kappa_species_count_enumeration) + (libraries num kappa_kasa_remanent_state kappa-library.generic) + (flags + (:standard) + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_kasa_remanent_state + -open + Kappa_kasa_frontend + -open + Kappa_logging + -open + Kappa_generic_toolset + -open + Kappa_kasa_kastor_toolset)) diff --git a/core/KaSa_rep/counting_enumerating_species/int_inf.ml b/core/KaSa_rep/counting_enumerating_species/int_inf.ml index b27726556c..b217a96268 100644 --- a/core/KaSa_rep/counting_enumerating_species/int_inf.ml +++ b/core/KaSa_rep/counting_enumerating_species/int_inf.ml @@ -12,76 +12,55 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type 'a intinf = Int of 'a | Infinity let equal a b = - match - a,b - with - | Infinity,Infinity -> true - | Infinity,_ | _,Infinity -> false - | Int a,Int b -> Big_int.eq_big_int a b + match a, b with + | Infinity, Infinity -> true + | Infinity, _ | _, Infinity -> false + | Int a, Int b -> Big_int.eq_big_int a b -let f_gen_zeroary f = - Int (f ()) +let f_gen_zeroary f = Int (f ()) let f_gen_unary f x = - match x - with - Infinity -> Infinity - | Int (x) -> Int(f x) + match x with + | Infinity -> Infinity + | Int x -> Int (f x) let f_gen_binary f x y = - match x,y - with - Infinity,_ | _,Infinity -> Infinity - | Int i,Int j -> Int (f i j) + match x, y with + | Infinity, _ | _, Infinity -> Infinity + | Int i, Int j -> Int (f i j) type bi_intinf = Big_int.big_int intinf let bi_add = f_gen_binary Big_int.add_big_int let bi_mult = f_gen_binary Big_int.mult_big_int - let big_zero = Big_int.zero_big_int let big_two = Big_int.unit_big_int - let infty = Infinity let bi_one = Int (Big_int.big_int_of_int 1) -let bi_zero = Int(Big_int.big_int_of_int 0) - - -let bi_of_int i = Int(Big_int.big_int_of_int i) - +let bi_zero = Int (Big_int.big_int_of_int 0) +let bi_of_int i = Int (Big_int.big_int_of_int i) let bi_print_int stdout i = - match i - with - Int i -> Printf.fprintf stdout "%s" (Big_int.string_of_big_int i) - | Infinity -> Printf.fprintf stdout "+oo" - + match i with + | Int i -> Printf.fprintf stdout "%s" (Big_int.string_of_big_int i) + | Infinity -> Printf.fprintf stdout "+oo" let bi_string_of i = - match i - with - Int i -> Big_int.string_of_big_int i - | Infinity -> "+oo" - - - let bi_n_n_plus_1_divided_by_2 n = - match n - with - Int i when Big_int.eq_big_int (Big_int.mod_big_int i big_two) big_zero-> - Int - (Big_int.mult_big_int - (Big_int.div_big_int - i - big_two) - (Big_int.succ_big_int i)) - | Int i -> - let succ = Big_int.succ_big_int i in - Int ( - Big_int.mult_big_int - i - (Big_int.div_big_int succ big_two)) - | Infinity -> Infinity + match i with + | Int i -> Big_int.string_of_big_int i + | Infinity -> "+oo" + +let bi_n_n_plus_1_divided_by_2 n = + match n with + | Int i when Big_int.eq_big_int (Big_int.mod_big_int i big_two) big_zero -> + Int + (Big_int.mult_big_int + (Big_int.div_big_int i big_two) + (Big_int.succ_big_int i)) + | Int i -> + let succ = Big_int.succ_big_int i in + Int (Big_int.mult_big_int i (Big_int.div_big_int succ big_two)) + | Infinity -> Infinity diff --git a/core/KaSa_rep/counting_enumerating_species/linear_combination.ml b/core/KaSa_rep/counting_enumerating_species/linear_combination.ml index aa03362b68..87cdf8425e 100644 --- a/core/KaSa_rep/counting_enumerating_species/linear_combination.ml +++ b/core/KaSa_rep/counting_enumerating_species/linear_combination.ml @@ -1 +1 @@ -type 'a linear_combination = (int * 'a) list +type 'a linear_combination = (int * 'a) list diff --git a/core/KaSa_rep/export/dune b/core/KaSa_rep/export/dune index eb0c8be693..06dd1eeb83 100644 --- a/core/KaSa_rep/export/dune +++ b/core/KaSa_rep/export/dune @@ -1,25 +1,50 @@ (library - (name kappa_kasa_export) - (libraries kappa_flow_analysis kappa_reachability kappa_influence_map kappa_polymers_analysis kappa_symmetries) - (flags (:standard) - -open Kappa_kasa_frontend - -open Kappa_kasa_remanent_state - -open Kappa_grammar - -open Kappa_terms - -open Kappa_logging - -open Kappa_generic_toolset - -open Kappa_errors - -open Kappa_reachability - -open Kappa_flow_analysis - -open Kappa_parameters - -open Kappa_kasa_kastor_toolset - -open Kappa_cli - -open Kappa_profiling - -open Kappa_mixtures - -open Kappa_influence_map - -open Kappa_polymers_analysis - -open Kappa_kasa_site_graphs - -open Kappa_kasa_backend - -open Kappa_symmetries - -open Kappa_kasa_type_interface -)) + (name kappa_kasa_export) + (libraries + kappa_flow_analysis + kappa_reachability + kappa_influence_map + kappa_polymers_analysis + kappa_symmetries) + (flags + (:standard) + -open + Kappa_kasa_frontend + -open + Kappa_kasa_remanent_state + -open + Kappa_grammar + -open + Kappa_terms + -open + Kappa_logging + -open + Kappa_generic_toolset + -open + Kappa_errors + -open + Kappa_reachability + -open + Kappa_flow_analysis + -open + Kappa_parameters + -open + Kappa_kasa_kastor_toolset + -open + Kappa_cli + -open + Kappa_profiling + -open + Kappa_mixtures + -open + Kappa_influence_map + -open + Kappa_polymers_analysis + -open + Kappa_kasa_site_graphs + -open + Kappa_kasa_backend + -open + Kappa_symmetries + -open + Kappa_kasa_type_interface)) diff --git a/core/KaSa_rep/export/export.ml b/core/KaSa_rep/export/export.ml index 6f4302ae4f..6f1369e1bc 100644 --- a/core/KaSa_rep/export/export.ml +++ b/core/KaSa_rep/export/export.ml @@ -11,7 +11,6 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - let warn parameters mh pos exn default = Exception.warn parameters mh pos exn default @@ -19,2189 +18,1942 @@ let warn parameters mh pos exn default = (*module signatures*) module Export = - functor (Reachability:Analyzer.Analyzer) -> struct - -type state = - (Reachability.static_information, - Reachability.dynamic_information) - Remanent_state.state - -type contact_map = Public_data.contact_map +functor + (Reachability : Analyzer.Analyzer) + -> + struct + type state = + ( Reachability.static_information, + Reachability.dynamic_information ) + Remanent_state.state + + type contact_map = Public_data.contact_map + type ctmc_flow = Remanent_state.flow + type ode_flow = Ode_fragmentation_type.ode_frag + type c_compilation = Cckappa_sig.compil + + type reachability_analysis = + ( Reachability.static_information, + Reachability.dynamic_information ) + Remanent_state.reachability_result + + type parameters = Remanent_parameters_sig.parameters + type errors = Exception.method_handler + type internal_contact_map = Remanent_state.internal_contact_map + type internal_scc_decomposition = Remanent_state.internal_scc_decomposition + type internal_influence_map = Remanent_state.internal_influence_map + + type bidirectional_influence_map = + Remanent_state.bidirectional_influence_map + + type handler = Cckappa_sig.kappa_handler + type internal_constraints_list = Remanent_state.internal_constraints_list + + module AgentProj = + Map_wrapper.Proj + (Ckappa_sig.Agent_map_and_set) + (Map_wrapper.Make (Mods.StringSetMap)) + + module SiteProj = + Map_wrapper.Proj + (Ckappa_sig.Site_map_and_set) + (Map_wrapper.Make (Mods.StringSetMap)) + + module StateProj = + Map_wrapper.Proj + (Ckappa_sig.State_map_and_set) + (Map_wrapper.Make (Mods.StringSetMap)) + + (******************************************************************) + (*operations of module signatures*) + + let init ?compil ~called_from () = + match compil with + | Some compil -> + let parameters = Remanent_parameters.get_parameters ~called_from () in + let state = + Remanent_state.create_state parameters (Remanent_state.Compil compil) + in + state + | None -> + (match called_from with + | Remanent_parameters_sig.Internalised | Remanent_parameters_sig.Server + | Remanent_parameters_sig.KaSim | Remanent_parameters_sig.KaSa -> + let errors = Exception.empty_error_handler in + let errors, parameters, files = Get_option.get_option errors in + let log = Remanent_parameters.get_logger parameters in + let _ = + Loggers.fprintf log "%s" + (Remanent_parameters.get_full_version parameters) + in + let () = Loggers.print_newline log in + let _ = + Loggers.fprintf log "%s" + (Remanent_parameters.get_launched_when_and_where parameters) + in + let () = Loggers.print_newline log in + Remanent_state.create_state ~errors parameters + (Remanent_state.Files files)) + + let get_parameters = Remanent_state.get_parameters + let set_parameters = Remanent_state.set_parameters + let set_errors = Remanent_state.set_errors + let get_errors = Remanent_state.get_errors + + let title_only_in_kasa parameters = + match Remanent_parameters.get_called_from parameters with + | Remanent_parameters_sig.Server | Remanent_parameters_sig.Internalised + | Remanent_parameters_sig.KaSim -> + false + | Remanent_parameters_sig.KaSa -> true + + let compute_show_title do_we_show_title log_title state = + let parameters = Remanent_state.get_parameters state in + if do_we_show_title parameters then ( + match log_title with + | None -> () + | Some title -> + let title = + if title_only_in_kasa parameters then + title ^ "..." + else + "+ " ^ title + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" title + in + Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) else + () + + let get_gen ?debug_mode ?dump_result ?stack_title ?do_we_show_title + ?log_title ?log_main_title ?log_prefix ?phase ?int ?dump get compute + state = + let debug_mode = + match debug_mode with + | None | Some false -> false + | Some true -> true + in + let dump_result = + match dump_result with + | None | Some false -> false + | Some true -> true + in + let dump = + match dump with + | None -> fun state _output -> state + | Some f -> f + in + let do_we_show_title = + match do_we_show_title with + | None -> fun _ -> true + | Some f -> f + in + (*------------------------------------------------------*) + match get state with + | None -> + let parameters = Remanent_state.get_parameters state in + let parameters' = + Remanent_parameters.update_call_stack parameters debug_mode + stack_title + in + let parameters' = + match log_prefix with + | None -> parameters' + | Some prefix -> Remanent_parameters.set_prefix parameters' prefix + in + let state = Remanent_state.set_parameters parameters' state in + let () = + match log_main_title with + | None -> () + | Some title -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" title + in + Loggers.print_newline (Remanent_parameters.get_logger parameters') + in + let show_title = compute_show_title do_we_show_title log_title in + (*------------------------------------------------------*) + let state = + match phase with + | None -> state + | Some phase -> Remanent_state.add_event phase int state + in + let state, output = compute show_title state in + (*------------------------------------------------------*) + let state = + match phase with + | None -> state + | Some phase -> Remanent_state.close_event phase int state + in + (*------------------------------------------------------*) + let state = + if Remanent_parameters.get_trace parameters' || dump_result then + dump state output + else + state + in + Remanent_state.set_parameters parameters state, output + | Some a -> state, a + + let lift_wo_handler f parameter error _handler x = f parameter error x + + let flush_errors state = + Remanent_state.set_errors Exception.empty_error_handler state + + let compute_env_init show_title + (state : + ( Reachability.static_information, + Reachability.dynamic_information ) + Remanent_state.state) = + match Remanent_state.get_init state with + | Remanent_state.Compil _ -> state, None, None, None + | Remanent_state.Files files -> + let () = show_title state in + let cli = Run_cli_args.default in + let syntax_version = + Remanent_parameters.get_syntax_version + (Remanent_state.get_parameters state) + in + let () = cli.Run_cli_args.syntaxVersion <- syntax_version in + let () = cli.Run_cli_args.inputKappaFileNames <- files in + let compilation_result : Cli_init.compilation_result = + Cli_init.get_compilation + ~warning:(fun ~pos:_ _msg -> ()) + ~debug_mode:false cli + in + let state = + Remanent_state.set_init_state compilation_result.init_l + (Remanent_state.set_env (Some compilation_result.env) + (Remanent_state.set_contact_map_int + (Some compilation_result.contact_map) state)) + in + ( state, + Some (compilation_result.env : Model.t), + Some compilation_result.init_l, + Some compilation_result.contact_map ) -type ctmc_flow = Remanent_state.flow + let compute_env show_title state = + let state, env, _, _ = compute_env_init show_title state in + state, env -type ode_flow = Ode_fragmentation_type.ode_frag + let get_env = + get_gen ~phase:StoryProfiling.LKappa_signature Remanent_state.get_env + compute_env -type c_compilation = Cckappa_sig.compil + let compute_init show_title state = + let state, _, init, _ = compute_env_init show_title state in + state, init -type reachability_analysis = - (Reachability.static_information, - Reachability.dynamic_information) - Remanent_state.reachability_result + let get_init = + get_gen ~phase:StoryProfiling.LKappa_signature + (fun x -> Some (Remanent_state.get_init_state x)) + compute_init -type parameters = Remanent_parameters_sig.parameters + (******************************************************************) + (*compilation*) -type errors = Exception.method_handler + let compute_compilation show_title state = + let parameters = get_parameters state in + let syntax_version = Remanent_parameters.get_syntax_version parameters in + let compil = + match Remanent_state.get_init state with + | Remanent_state.Compil compil -> compil + | Remanent_state.Files files -> + let () = show_title state in + Cli_init.get_ast_from_list_of_files syntax_version files + in + let state = Remanent_state.set_compilation compil state in + state, compil -type internal_contact_map = Remanent_state.internal_contact_map -type internal_scc_decomposition = Remanent_state.internal_scc_decomposition -type internal_influence_map = Remanent_state.internal_influence_map -type bidirectional_influence_map = Remanent_state.bidirectional_influence_map -type handler = Cckappa_sig.kappa_handler + let get_compilation = + get_gen ~phase:StoryProfiling.KaSa_lexing Remanent_state.get_compilation + compute_compilation -type internal_constraints_list = Remanent_state.internal_constraints_list + (******************************************************************) -module AgentProj = - Map_wrapper.Proj - (Ckappa_sig.Agent_map_and_set) - (Map_wrapper.Make(Mods.StringSetMap)) + let compute_refined_compil show_title state = + let state, compil = get_compilation state in + let errors = Remanent_state.get_errors state in + let parameters = Remanent_state.get_parameters state in + let () = show_title state in + let errors, refined_compil = + Prepreprocess.translate_compil parameters errors compil + in + let state = Remanent_state.set_errors errors state in + let state = Remanent_state.set_refined_compil refined_compil state in + state, refined_compil + + let get_refined_compil = + get_gen ~debug_mode:Preprocess.local_trace + ~stack_title:"Prepreprocess.translate_compil" + ~phase:StoryProfiling.KaSim_compilation + Remanent_state.get_refined_compil compute_refined_compil + + let compute_prehandler show_title state = + let state, refined_compil = get_refined_compil state in + let parameters = Remanent_state.get_parameters state in + let errors = Remanent_state.get_errors state in + let () = show_title state in + let errors, handler = + List_tokens.scan_compil parameters errors refined_compil + in + let state = Remanent_state.set_errors errors state in + let state = Remanent_state.set_handler handler state in + state, handler + + let lift_dump_parameter_error dump state output = + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let error = dump parameters error output in + Remanent_state.set_errors error state + + let get_prehandler = + get_gen ~debug_mode:List_tokens.local_trace + ~dump_result:Print_handler.trace ~stack_title:"List_tokens.scan_compil" + ~log_prefix:"Signature:" ~phase:StoryProfiling.KaSa_lexing + Remanent_state.get_handler compute_prehandler + ~dump:(lift_dump_parameter_error Print_handler.print_handler) + + let compute_c_compilation_handler show_title state = + let parameters = Remanent_state.get_parameters state in + let state, refined_compil = get_refined_compil state in + let state, handler = get_prehandler state in + let error = Remanent_state.get_errors state in + let () = show_title state in + let error, handler, c_compil = + Preprocess.translate_c_compil parameters error handler refined_compil + in + ( Remanent_state.set_errors error + (Remanent_state.set_handler handler + (Remanent_state.set_c_compil c_compil state)), + (c_compil, handler) ) + + (******************************************************************) + + let choose f show_title state = + let state, pair = compute_c_compilation_handler show_title state in + state, f pair + + let get_c_compilation = + get_gen ~debug_mode:List_tokens.local_trace + ~stack_title:"Preprocess.translate_c_compil" ~log_prefix:"Compilation:" + ~do_we_show_title:title_only_in_kasa ~log_title:"Compiling" + ~phase:StoryProfiling.KaSa_linking Remanent_state.get_c_compil + (choose fst) + + let get_handler = + get_gen ~debug_mode:List_tokens.local_trace + ~stack_title:"Preprocess.translate_c_compil" + ~do_we_show_title:title_only_in_kasa ~log_title:"Compiling" + ~phase:StoryProfiling.KaSa_linking Remanent_state.get_handler + (choose snd) + + let simplify_site site = + match site with + | Ckappa_sig.Counter site_name + | Ckappa_sig.Binding site_name + | Ckappa_sig.Internal site_name -> + site_name + + let translate_agent ~message ~ml_pos state agent = + let state, handler = get_handler state in + let error = get_errors state in + let parameters = get_parameters state in + let error, ag = + Handler.translate_agent ~message ~ml_pos parameters error handler agent + in + let state = set_errors error state in + state, ag -module SiteProj = - Map_wrapper.Proj - (Ckappa_sig.Site_map_and_set) - (Map_wrapper.Make(Mods.StringSetMap)) + let translate_site ~message ~ml_pos state agent site = + let state, handler = get_handler state in + let error = get_errors state in + let parameters = get_parameters state in + let error, site = + Handler.translate_site ~message ~ml_pos parameters error handler agent + site + in + let state = set_errors error state in + state, site -module StateProj = - Map_wrapper.Proj - (Ckappa_sig.State_map_and_set) - (Map_wrapper.Make(Mods.StringSetMap)) + let translate_state ~message ~ml_pos state agent site prop = + let state, handler = get_handler state in + let error = get_errors state in + let parameters = get_parameters state in + let error, site = + Handler.translate_state ~message ~ml_pos parameters error handler agent + site prop + in + let state = set_errors error state in + state, site + + let translate_and_simplify_site ~message ~ml_pos state agent site = + let state, site = translate_site ~message ~ml_pos state agent site in + state, simplify_site site + + let dump_c_compil state c_compil = + let state, handler = get_handler state in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let error = + Print_cckappa.print_compil parameters error handler c_compil + in + let state = Remanent_state.set_errors error state in + state -(******************************************************************) -(*operations of module signatures*) + (******************************************************************) -let init ?compil ~called_from () = - match compil with - | Some compil -> - let parameters = Remanent_parameters.get_parameters ~called_from () in - let state = - Remanent_state.create_state parameters - (Remanent_state.Compil compil) - in - state - | None -> - begin - match - called_from - with - | Remanent_parameters_sig.Internalised - | Remanent_parameters_sig.Server - | Remanent_parameters_sig.KaSim - | Remanent_parameters_sig.KaSa -> - begin - let errors = Exception.empty_error_handler in - let errors, parameters, files = Get_option.get_option errors in - let log = (Remanent_parameters.get_logger parameters) in - let _ = - Loggers.fprintf log "%s" - (Remanent_parameters.get_full_version parameters) + let rename_link parameters handler error map ((_, i), j) = + let error, agent = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler + (Ckappa_sig.agent_name_of_int i) + in + let error, site = + Handler.translate_site ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler + (Ckappa_sig.agent_name_of_int i) + (Ckappa_sig.site_name_of_int j) + in + match Mods.String2Map.find_option (agent, simplify_site site) map with + | None -> Exception.warn parameters error __POS__ Exit ((0, 0), 0) + | Some (i, j) -> error, ((0, i), j) + + let rename_links parameter handler error map = function + | User_graph.LINKS l -> + let error', l' = + List.fold_left + (fun (error, l) link -> + let error, link = rename_link parameter handler error map link in + error, link :: l) + (error, []) (List.rev l) + in + error', User_graph.LINKS l' + | (WHATEVER | SOME | TYPE _) as x -> error, x + + let reindex parameters error handler list = + let map, _ = + Array.fold_left + (fun (map, counter_ag) site_node -> + let ag = site_node.User_graph.node_type in + let interface = site_node.User_graph.node_sites in + let map, _ = + Array.fold_left + (fun (map, counter_site) site -> + let site_name = site.User_graph.site_name in + ( Mods.String2Map.add (ag, site_name) + (counter_ag, counter_site) map, + counter_site + 1 )) + (map, 0) interface + in + map, counter_ag + 1) + (Mods.String2Map.empty, 0) list + in + Array.fold_right + (fun site_node (error, agent_list) -> + let error, interface = + Array.fold_right + (fun site (error, interface) -> + let error, site = + match site.User_graph.site_type with + | User_graph.Counter _ -> error, site + | User_graph.Port p -> + let error, new_links = + rename_links parameters handler error map + p.User_graph.port_links + in + ( error, + { + site with + User_graph.site_type = + User_graph.Port + { p with User_graph.port_links = new_links }; + } ) + in + error, site :: interface) + site_node.User_graph.node_sites (error, []) in - let () = Loggers.print_newline log in - let _ = - Loggers.fprintf log "%s" - (Remanent_parameters.get_launched_when_and_where parameters) + let agent = + { site_node with User_graph.node_sites = Array.of_list interface } in - let () = Loggers.print_newline log in - Remanent_state.create_state ~errors parameters - (Remanent_state.Files files) - end - end - -let get_parameters = Remanent_state.get_parameters -let set_parameters = Remanent_state.set_parameters -let set_errors = Remanent_state.set_errors -let get_errors = Remanent_state.get_errors - -let title_only_in_kasa parameters = - match - Remanent_parameters.get_called_from parameters - with - | Remanent_parameters_sig.Server - | Remanent_parameters_sig.Internalised - | Remanent_parameters_sig.KaSim -> false - | Remanent_parameters_sig.KaSa -> true - -let compute_show_title do_we_show_title log_title = - (fun state -> - let parameters = Remanent_state.get_parameters state in - if do_we_show_title parameters - then - match log_title with - | None -> () - | Some title -> - let title = - if title_only_in_kasa parameters - then title ^ "..." - else - "+ " ^ title - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) "%s" title - in - Loggers.print_newline (Remanent_parameters.get_logger parameters) - else - ()) - -let get_gen - ?debug_mode - ?dump_result - ?stack_title - ?do_we_show_title - ?log_title - ?log_main_title - ?log_prefix - ?phase - ?int - ?dump - get compute state = - let debug_mode = - match debug_mode with - | None | Some false -> false - | Some true -> true - in - let dump_result = - match dump_result with - | None | Some false -> false - | Some true -> true - in - let dump = - match dump with - | None -> (fun state _output -> state) - | Some f -> f - in - let do_we_show_title = - match do_we_show_title with - | None -> (fun _ -> true) - | Some f -> f - in - (*------------------------------------------------------*) - match get state with - | None -> - let parameters = Remanent_state.get_parameters state in - let parameters' = - Remanent_parameters.update_call_stack - parameters debug_mode stack_title - in - let parameters' = - match log_prefix with - | None -> parameters' - | Some prefix -> Remanent_parameters.set_prefix parameters' prefix - in - let state = Remanent_state.set_parameters parameters' state in - let () = - match log_main_title with - | None -> () - | Some title -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) "%s" title - in - Loggers.print_newline (Remanent_parameters.get_logger parameters') - in - let show_title = compute_show_title do_we_show_title log_title in - (*------------------------------------------------------*) - let state = - match phase with - | None -> state - | Some phase -> Remanent_state.add_event phase int state - in - let state, output = compute show_title state in - (*------------------------------------------------------*) - let state = - match phase with - | None -> state - | Some phase -> Remanent_state.close_event phase int state - in - (*------------------------------------------------------*) - let state = - if - Remanent_parameters.get_trace parameters' || dump_result - then - dump state output + error, Some agent :: agent_list) + list (error, []) + + (******************************************************************) + + let convert_label a = + if a < 0 then + Public_data.Side_effect (-(a + 1)) else - state - in - Remanent_state.set_parameters parameters state, output - | Some a -> - state, a - -let lift_wo_handler f = (fun parameter error _handler x -> f parameter error x) - -let flush_errors state = - Remanent_state.set_errors Exception.empty_error_handler state - -let compute_env_init - show_title - (state: - (Reachability.static_information, - Reachability.dynamic_information) - Remanent_state.state) - = - match Remanent_state.get_init state with - | Remanent_state.Compil _ -> - state, None, None, None - | Remanent_state.Files files -> - let () = show_title state in - let cli = Run_cli_args.default in - let syntax_version = - Remanent_parameters.get_syntax_version - (Remanent_state.get_parameters state) in - let () = cli.Run_cli_args.syntaxVersion <- syntax_version in - let () = cli.Run_cli_args.inputKappaFileNames <- files in - let (_,env, contactmap, _, _, _, _, init), _ = - Cli_init.get_compilation - ~warning:(fun ~pos:_ _msg -> ()) ~debugMode:false cli in - let state = - Remanent_state.set_init_state - init - (Remanent_state.set_env (Some env) - (Remanent_state.set_contact_map_int - (Some contactmap) state)) - in - state, Some (env:Model.t), Some init, Some (contactmap) - -let compute_env show_title state = - let state, env, _, _ = compute_env_init show_title state in - state, env - -let get_env = - get_gen - ~phase:StoryProfiling.LKappa_signature - Remanent_state.get_env - compute_env - -let compute_init show_title state = - let state, _, init, _ = compute_env_init show_title state in - state, init - -let get_init = - get_gen - ~phase:StoryProfiling.LKappa_signature - (fun x -> Some (Remanent_state.get_init_state x)) - compute_init - -(******************************************************************) -(*compilation*) - -let compute_compilation show_title state = - let parameters = get_parameters state in - let syntax_version = Remanent_parameters.get_syntax_version parameters in - let compil = - match Remanent_state.get_init state with - | Remanent_state.Compil compil -> compil - | Remanent_state.Files files -> + Public_data.Direct a + + let convert_id_short parameters error handler compiled id = + Handler.convert_id_short parameters error handler compiled id + + let convert_id_refined parameters error handler compiled id = + Handler.convert_id_refined parameters error handler compiled id + + (******************************************************************) + (*quark map *) + (******************************************************************) + + let compute_quark_map show_title state = + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let state, c_compil = get_c_compilation state in + let state, handler = get_handler state in let () = show_title state in - Cli_init.get_ast_from_list_of_files syntax_version files - in - let state = Remanent_state.set_compilation compil state in - state, compil - -let get_compilation = - get_gen - ~phase:StoryProfiling.KaSa_lexing - Remanent_state.get_compilation - compute_compilation - -(******************************************************************) - -let compute_refined_compil show_title state = - let state,compil = get_compilation state in - let errors = Remanent_state.get_errors state in - let parameters = Remanent_state.get_parameters state in - let () = show_title state in - let errors,refined_compil = - Prepreprocess.translate_compil parameters errors compil - in - let state = Remanent_state.set_errors errors state in - let state = Remanent_state.set_refined_compil refined_compil state in - state, refined_compil - -let get_refined_compil = - get_gen - ~debug_mode:Preprocess.local_trace - ~stack_title:"Prepreprocess.translate_compil" - ~phase:StoryProfiling.KaSim_compilation - Remanent_state.get_refined_compil - compute_refined_compil - -let compute_prehandler show_title state = - let state, refined_compil = get_refined_compil state in - let parameters = Remanent_state.get_parameters state in - let errors = Remanent_state.get_errors state in - let () = show_title state in - let errors, handler = - List_tokens.scan_compil parameters errors refined_compil - in - let state = Remanent_state.set_errors errors state in - let state = Remanent_state.set_handler handler state in - state, handler - -let lift_dump_parameter_error dump state output = - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let error = dump parameters error output in - Remanent_state.set_errors error state - -let get_prehandler = - get_gen - ~debug_mode:List_tokens.local_trace - ~dump_result:Print_handler.trace - ~stack_title:"List_tokens.scan_compil" - ~log_prefix:"Signature:" - ~phase:StoryProfiling.KaSa_lexing - Remanent_state.get_handler - compute_prehandler - ~dump:(lift_dump_parameter_error Print_handler.print_handler) - -let compute_c_compilation_handler show_title state = - let parameters = Remanent_state.get_parameters state in - let state, refined_compil = get_refined_compil state in - let state, handler = get_prehandler state in - let error = Remanent_state.get_errors state in - let () = show_title state in - let error, handler, c_compil = - Preprocess.translate_c_compil - parameters error handler refined_compil - in - Remanent_state.set_errors - error - (Remanent_state.set_handler handler - (Remanent_state.set_c_compil c_compil state)), - (c_compil,handler) - -(******************************************************************) - -let choose f show_title state = - let state,pair = compute_c_compilation_handler show_title state in - state,f pair - -let get_c_compilation = - get_gen - ~debug_mode:List_tokens.local_trace - ~stack_title:"Preprocess.translate_c_compil" - ~log_prefix:"Compilation:" - ~do_we_show_title:title_only_in_kasa - ~log_title:"Compiling" - ~phase:StoryProfiling.KaSa_linking - Remanent_state.get_c_compil (choose fst) - -let get_handler = - get_gen - ~debug_mode:List_tokens.local_trace - ~stack_title:"Preprocess.translate_c_compil" - ~do_we_show_title:title_only_in_kasa - ~log_title:"Compiling" - ~phase:StoryProfiling.KaSa_linking - Remanent_state.get_handler (choose snd) - -let simplify_site site = - match site with - | Ckappa_sig.Counter site_name - | Ckappa_sig.Binding site_name - | Ckappa_sig.Internal site_name -> site_name - -let translate_agent ~message ~ml_pos state agent = - let state,handler = get_handler state in - let error = get_errors state in - let parameters = get_parameters state in - let error,ag = - Handler.translate_agent - ~message ~ml_pos - parameters error handler agent - in - let state = set_errors error state in - state, ag - -let translate_site ~message ~ml_pos state agent site = - let state,handler = get_handler state in - let error = get_errors state in - let parameters = get_parameters state in - let error,site = - Handler.translate_site ~message ~ml_pos parameters error handler agent site - in - let state = set_errors error state in - state, site - -let translate_state ~message ~ml_pos state agent site prop = - let state,handler = get_handler state in - let error = get_errors state in - let parameters = get_parameters state in - let error,site = - Handler.translate_state ~message ~ml_pos parameters error handler agent site prop - in - let state = set_errors error state in - state, site - -let translate_and_simplify_site ~message ~ml_pos state agent site = - let state, site = translate_site ~message ~ml_pos state agent site in - state, simplify_site site - -let dump_c_compil state c_compil = - let state, handler = get_handler state in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let error = Print_cckappa.print_compil parameters error handler c_compil in - let state = Remanent_state.set_errors error state in - state - -(******************************************************************) - -let rename_link parameters handler error map ((_,i),j) = - let error, agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler (Ckappa_sig.agent_name_of_int i) - in - let error, site = - Handler.translate_site - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler (Ckappa_sig.agent_name_of_int i) (Ckappa_sig.site_name_of_int j) in - match - Mods.String2Map.find_option (agent,simplify_site site) map - with - | None -> - Exception.warn parameters error __POS__ Exit ((0,0),0) - | Some (i,j) -> error, ((0,i),j) - -let rename_links parameter handler error map = function - | User_graph.LINKS l -> - let error',l' = - List.fold_left - (fun (error, l) link -> - let error, link = rename_link parameter handler error map link in - error, link::l) - (error,[]) (List.rev l) in - (error', User_graph.LINKS l') - | WHATEVER | SOME | TYPE _ as x -> (error,x) - -let reindex parameters error handler list = - let map,_ = - Array.fold_left - (fun (map,counter_ag) site_node -> - let ag = site_node.User_graph.node_type in - let interface = site_node.User_graph.node_sites in - let map,_ = - Array.fold_left - (fun (map,counter_site) site -> - let site_name = site.User_graph.site_name in - Mods.String2Map.add (ag,site_name) (counter_ag,counter_site) - map, - counter_site+1) - (map,0) interface - in - map, counter_ag+1 - ) - (Mods.String2Map.empty, 0) - list - in - Array.fold_right - (fun site_node (error,agent_list) -> - let error, interface = - Array.fold_right - (fun site (error,interface) -> - let error,site = - match site.User_graph.site_type with - | User_graph.Counter _ -> error,site - | User_graph.Port p -> - let error, new_links = - rename_links - parameters handler error map - p.User_graph.port_links - in - error,{site with User_graph.site_type = - User_graph.Port {p with User_graph.port_links = - new_links}} in - error, (site::interface)) - site_node.User_graph.node_sites (error,[]) - in - let agent = {site_node with User_graph.node_sites = Array.of_list interface} - in - error, Some agent::agent_list) - list (error,[]) - - -(******************************************************************) - -let convert_label a = - if a<0 then Public_data.Side_effect (-(a+1)) - else Public_data.Direct a - -let convert_id_short parameters error handler compiled id = - Handler.convert_id_short parameters error handler compiled id - - -let convert_id_refined parameters error handler compiled id = - Handler.convert_id_refined parameters error handler compiled id - - -(******************************************************************) -(*quark map *) -(******************************************************************) - -let compute_quark_map show_title state = - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let state, c_compil = get_c_compilation state in - let state, handler = get_handler state in - let () = show_title state in - let error,quark_map = - Quark.quarkify parameters error handler c_compil - in - let error = - if - (Remanent_parameters.get_trace parameters) - || Print_quarks.trace - then - Print_quarks.print_quarks parameters error handler quark_map - else - error - in - Remanent_state.set_errors error - (Remanent_state.set_quark_map quark_map state), - quark_map - -let get_quark_map = - get_gen - ~debug_mode:Quark.local_trace - ~stack_title:"Quark.quarkify" - ~log_prefix:"Quarks:" - Remanent_state.get_quark_map - compute_quark_map - -(******************************************************************) -(*Reachability*) -(******************************************************************) - -let compute_reachability_result show_title state = - let state, c_compil = get_c_compilation state in - let state, handler = get_handler state in - let () = show_title state in - let bdu_handler = Remanent_state.get_bdu_handler state in - let log_info = Remanent_state.get_log_info state in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let error, log_info, static, dynamic = - Reachability.main - parameters log_info error bdu_handler c_compil handler - in - let error, dynamic, state = - Reachability.export static dynamic - error state - in - let state = Remanent_state.set_errors error state in - let state = Remanent_state.set_log_info log_info state in - let state = Remanent_state.set_bdu_handler bdu_handler state in - let state = Remanent_state.set_reachability_result (static, dynamic) state in - state, (static, dynamic) - -let get_reachability_analysis = - get_gen - ~log_title:"Reachability analysis" - (Remanent_state.get_reachability_result) - compute_reachability_result - -(******************************************************************) -(*ODE flows*) -(******************************************************************) - -let compute_ctmc_flow show_title state = - let state, c_compil = get_c_compilation state in - let state, handler = get_handler state in - let () = show_title state in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let error, output = - Stochastic_classes.stochastic_classes parameters error - handler c_compil - in - Remanent_state.set_errors - error - (Remanent_state.set_ctmc_flow output state), - output - -let get_ctmc_flow = - get_gen - ~log_prefix:"Flow of information in the CTMC semantics:" - ~log_title:"Flow of information in the CTMC semantcs:" - Remanent_state.get_ctmc_flow - compute_ctmc_flow - -let compute_ode_flow show_title state = - let state, c_compil = get_c_compilation state in - let state, handler = get_handler state in - let () = show_title state in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let error, output = - Ode_fragmentation.scan_rule_set - parameters error handler c_compil - in - Remanent_state.set_errors - error - (Remanent_state.set_ode_flow output state), - output - -let get_ode_flow = - get_gen - ~log_prefix:"Flow of information in the ODE semantics:" - ~log_title:"Flow of information in the ODE semantcs:" - Remanent_state.get_ode_flow - compute_ode_flow - -(******************************************************************) -(*influence_map*) -(******************************************************************) - -let compute_pos_of_rules_and_vars show_title state = - let parameters = get_parameters state in - let state, compil = get_c_compilation state in - let state, handler = get_handler state in - let error = get_errors state in - let nrules = Handler.nrules parameters error handler in - let nvars = Handler.nvars parameters error handler in - let () = show_title state in - let rec aux inc pos of_int lift n (error,l) = - if n<0 then (error, l) - else - let error, p = pos parameters error handler compil ((of_int (n+inc))) in - aux inc pos of_int lift (n-1) (error, (lift n,p)::l) - in - let error, l = - aux 0 Handler.pos_of_rule - Ckappa_sig.rule_id_of_int (fun x -> Public_data.Rule x) - (nrules-1) - (aux nrules Handler.pos_of_var Ckappa_sig.rule_id_of_int - (fun x -> Public_data.Var x) - (nvars-1) (error,[])) - in - let json = Public_data.pos_of_rules_and_vars_to_json l in - let _ = Public_data.pos_of_rules_and_vars_of_json json in - Remanent_state.set_errors error - (Remanent_state.set_pos_of_rules_and_vars l state), l - -let get_pos_of_rules_and_vars = - get_gen - ~log_prefix:"Summarize the position of rules and variables" + let error, quark_map = Quark.quarkify parameters error handler c_compil in + let error = + if Remanent_parameters.get_trace parameters || Print_quarks.trace then + Print_quarks.print_quarks parameters error handler quark_map + else + error + in + ( Remanent_state.set_errors error + (Remanent_state.set_quark_map quark_map state), + quark_map ) + + let get_quark_map = + get_gen ~debug_mode:Quark.local_trace ~stack_title:"Quark.quarkify" + ~log_prefix:"Quarks:" Remanent_state.get_quark_map compute_quark_map + + (******************************************************************) + (*Reachability*) + (******************************************************************) + + let compute_reachability_result show_title state = + let state, c_compil = get_c_compilation state in + let state, handler = get_handler state in + let () = show_title state in + let bdu_handler = Remanent_state.get_bdu_handler state in + let log_info = Remanent_state.get_log_info state in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let error, log_info, static, dynamic = + Reachability.main parameters log_info error bdu_handler c_compil handler + in + let error, dynamic, state = + Reachability.export static dynamic error state + in + let state = Remanent_state.set_errors error state in + let state = Remanent_state.set_log_info log_info state in + let state = Remanent_state.set_bdu_handler bdu_handler state in + let state = + Remanent_state.set_reachability_result (static, dynamic) state + in + state, (static, dynamic) + + let get_reachability_analysis = + get_gen ~log_title:"Reachability analysis" + Remanent_state.get_reachability_result compute_reachability_result + + (******************************************************************) + (*ODE flows*) + (******************************************************************) + + let compute_ctmc_flow show_title state = + let state, c_compil = get_c_compilation state in + let state, handler = get_handler state in + let () = show_title state in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let error, output = + Stochastic_classes.stochastic_classes parameters error handler c_compil + in + ( Remanent_state.set_errors error + (Remanent_state.set_ctmc_flow output state), + output ) + + let get_ctmc_flow = + get_gen ~log_prefix:"Flow of information in the CTMC semantics:" + ~log_title:"Flow of information in the CTMC semantcs:" + Remanent_state.get_ctmc_flow compute_ctmc_flow + + let compute_ode_flow show_title state = + let state, c_compil = get_c_compilation state in + let state, handler = get_handler state in + let () = show_title state in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let error, output = + Ode_fragmentation.scan_rule_set parameters error handler c_compil + in + ( Remanent_state.set_errors error + (Remanent_state.set_ode_flow output state), + output ) + + let get_ode_flow = + get_gen ~log_prefix:"Flow of information in the ODE semantics:" + ~log_title:"Flow of information in the ODE semantcs:" + Remanent_state.get_ode_flow compute_ode_flow + + (******************************************************************) + (*influence_map*) + (******************************************************************) + + let compute_pos_of_rules_and_vars show_title state = + let parameters = get_parameters state in + let state, compil = get_c_compilation state in + let state, handler = get_handler state in + let error = get_errors state in + let nrules = Handler.nrules parameters error handler in + let nvars = Handler.nvars parameters error handler in + let () = show_title state in + let rec aux inc pos of_int lift n (error, l) = + if n < 0 then + error, l + else ( + let error, p = + pos parameters error handler compil (of_int (n + inc)) + in + aux inc pos of_int lift (n - 1) (error, (lift n, p) :: l) + ) + in + let error, l = + aux 0 Handler.pos_of_rule Ckappa_sig.rule_id_of_int + (fun x -> Public_data.Rule x) + (nrules - 1) + (aux nrules Handler.pos_of_var Ckappa_sig.rule_id_of_int + (fun x -> Public_data.Var x) + (nvars - 1) (error, [])) + in + let json = Public_data.pos_of_rules_and_vars_to_json l in + let _ = Public_data.pos_of_rules_and_vars_of_json json in + ( Remanent_state.set_errors error + (Remanent_state.set_pos_of_rules_and_vars l state), + l ) + + let get_pos_of_rules_and_vars = + get_gen ~log_prefix:"Summarize the position of rules and variables" ~log_title:"Summarize the position of rules and variables" - Remanent_state.get_pos_of_rules_and_vars - compute_pos_of_rules_and_vars - -let compute_raw_internal_influence_map show_title state = - let parameters = Remanent_state.get_parameters state in - let state, compil = get_c_compilation state in - let state, quark_map = get_quark_map state in - let state, handler = get_handler state in - let error = Remanent_state.get_errors state in - let nrules = Handler.nrules parameters error handler in - let nvars = Handler.nvars parameters error handler in - let nodes = Misc_sa.list_0_n (nrules+nvars-1) in - let nodes = - List.rev_map Ckappa_sig.rule_id_of_int (List.rev nodes) - in - let () = show_title state in - let error,wake_up_map,inhibition_map = - Influence_map.compute_influence_map parameters - error handler quark_map nrules - in - let error = - if - (Remanent_parameters.get_trace parameters || Print_quarks.trace) - && Remanent_parameters.get_influence_map_accuracy_level parameters = Remanent_parameters_sig.Low - then - Print_quarks.print_wake_up_map - parameters - error - handler - compil - Handler.print_rule_txt - Handler.print_var_txt - Handler.get_label_of_rule_txt - Handler.get_label_of_var_txt - Handler.print_labels "\n" - wake_up_map - else error - in - let error = - if - (Remanent_parameters.get_trace parameters - || Print_quarks.trace) - && Remanent_parameters.get_influence_map_accuracy_level parameters = - Remanent_parameters_sig.Low - then - Print_quarks.print_inhibition_map - parameters error handler - compil - Handler.print_rule_txt - Handler.print_var_txt - Handler.get_label_of_rule_txt - Handler.get_label_of_var_txt - Handler.print_labels - "\n" - inhibition_map - else error - in - let state = - Remanent_state.set_internal_influence_map Public_data.Low - (nodes,wake_up_map,inhibition_map) - state - in - Remanent_state.set_errors error state, - (nodes, wake_up_map, inhibition_map) - -let get_raw_internal_influence_map = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_prefix:"Influence_map:" - ~log_main_title:"Generating the raw influence map..." - ~phase:(StoryProfiling.Internal_influence_map "raw") - (Remanent_state.get_internal_influence_map Public_data.Low) - compute_raw_internal_influence_map - -let convert_half_influence_map parameters error handler compiled influence = - Ckappa_sig.PairRule_setmap.Map.fold - (fun (x,y) list (error,map) -> - let error,x = - Handler.convert_id_short parameters error handler compiled - (Ckappa_sig.rule_id_of_int - (int_of_string (Ckappa_sig.string_of_rule_id x))) - in - let error,y = - Handler.convert_id_short parameters error handler compiled - (Ckappa_sig.rule_id_of_int - (int_of_string (Ckappa_sig.string_of_rule_id y))) - in - let old = - match - Public_data.InfluenceNodeMap.find_option x map - with - | None -> Public_data.InfluenceNodeMap.empty - | Some x -> x - in - let list = - Quark_type.Labels.convert_label_set_couple list - in - let list = - List.rev_map - (fun (a,b) -> convert_label a,convert_label b) - (List.rev list) - in - error, - Public_data.InfluenceNodeMap.add x - (Public_data.InfluenceNodeMap.add y list old) - map - ) - influence - (error, Public_data.InfluenceNodeMap.empty) - - -let extract_all_nodes_of_influence_map state (nodes,_,_) = - let parameters = Remanent_state.get_parameters state in - let state, handler = get_handler state in - let state, compiled = get_c_compilation state in - let error = Remanent_state.get_errors state in - let _error, nodes = - List.fold_left - (fun (error, list) id -> - let error, head = - Handler.convert_id_refined parameters error - handler compiled id - in - error, head::list) - (error, []) - (List.rev nodes) - in - state, nodes - -let convert_influence_map - state (nodes, wake_up_map, inhibition_map) - = - let state, nodes = - extract_all_nodes_of_influence_map state (nodes,wake_up_map,inhibition_map) - in - let parameters = Remanent_state.get_parameters state in - let state, handler = get_handler state in - let state, compiled = get_c_compilation state in - let error = Remanent_state.get_errors state in - let error, pos = convert_half_influence_map parameters error handler compiled wake_up_map in - let error, neg = convert_half_influence_map parameters error handler compiled inhibition_map in - let state = Remanent_state.set_errors error state in - let output = - { - Public_data.nodes = nodes ; - Public_data.positive = pos ; - Public_data.negative = neg - } - in - state, output - -let compute_intermediary_internal_influence_map show_title state = - let state, handler = get_handler state in - let state, compil = get_c_compilation state in - let state,(nodes,wake_up_map,inhibition_map) = - get_raw_internal_influence_map state - in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let state, _ = compute_pos_of_rules_and_vars (fun _ -> ()) state in - let () = show_title state in - let error,wake_up_map = - Algebraic_construction.filter_influence - parameters error handler compil wake_up_map true - in - let error,inhibition_map = - Algebraic_construction.filter_influence - parameters error handler compil inhibition_map false - in - let state = - Remanent_state.set_internal_influence_map Public_data.Medium - (nodes,wake_up_map,inhibition_map) - state - in - let state, output = - convert_influence_map - state - (nodes, wake_up_map, inhibition_map) - in - let state = - Remanent_state.set_influence_map Public_data.Medium - output - state - in - let error = - if Remanent_parameters.get_trace parameters || Print_quarks.trace - then - Print_quarks.print_wake_up_map - parameters - error - handler - compil - Handler.print_rule_txt - Handler.print_var_txt - Handler.get_label_of_rule_txt - Handler.get_label_of_var_txt - Handler.print_labels "\n" - wake_up_map - else error - in - let error = - if - Remanent_parameters.get_trace parameters - || Print_quarks.trace - then - Print_quarks.print_inhibition_map - parameters error handler - compil - Handler.print_rule_txt - Handler.print_var_txt - Handler.get_label_of_rule_txt - Handler.get_label_of_var_txt - Handler.print_labels - "\n" - inhibition_map - else error - in - Remanent_state.set_errors error state, (nodes, wake_up_map, inhibition_map) - -let get_intermediary_internal_influence_map = - get_gen - ~log_prefix:"Influence_map:" - ~log_title:"Refining the influence map" - ~phase:(StoryProfiling.Internal_influence_map "medium") - (Remanent_state.get_internal_influence_map Public_data.Medium) - compute_intermediary_internal_influence_map - -let string_of_influence_node rule var x = - match x with - | Public_data.Rule i -> "Rule "^(rule i) (*(string_of_int i.Public_data.rule_id)*) - | Public_data.Var i -> "Var "^(var i) (*string_of_int i.Public_data.var_id) + Remanent_state.get_pos_of_rules_and_vars compute_pos_of_rules_and_vars + + let compute_raw_internal_influence_map show_title state = + let parameters = Remanent_state.get_parameters state in + let state, compil = get_c_compilation state in + let state, quark_map = get_quark_map state in + let state, handler = get_handler state in + let error = Remanent_state.get_errors state in + let nrules = Handler.nrules parameters error handler in + let nvars = Handler.nvars parameters error handler in + let nodes = Misc_sa.list_0_n (nrules + nvars - 1) in + let nodes = List.rev_map Ckappa_sig.rule_id_of_int (List.rev nodes) in + let () = show_title state in + let error, wake_up_map, inhibition_map = + Influence_map.compute_influence_map parameters error handler quark_map + nrules + in + let error = + if + (Remanent_parameters.get_trace parameters || Print_quarks.trace) + && Remanent_parameters.get_influence_map_accuracy_level parameters + = Remanent_parameters_sig.Low + then + Print_quarks.print_wake_up_map parameters error handler compil + Handler.print_rule_txt Handler.print_var_txt + Handler.get_label_of_rule_txt Handler.get_label_of_var_txt + Handler.print_labels "\n" wake_up_map + else + error + in + let error = + if + (Remanent_parameters.get_trace parameters || Print_quarks.trace) + && Remanent_parameters.get_influence_map_accuracy_level parameters + = Remanent_parameters_sig.Low + then + Print_quarks.print_inhibition_map parameters error handler compil + Handler.print_rule_txt Handler.print_var_txt + Handler.get_label_of_rule_txt Handler.get_label_of_var_txt + Handler.print_labels "\n" inhibition_map + else + error + in + let state = + Remanent_state.set_internal_influence_map Public_data.Low + (nodes, wake_up_map, inhibition_map) + state + in + Remanent_state.set_errors error state, (nodes, wake_up_map, inhibition_map) + + let get_raw_internal_influence_map = + get_gen ~do_we_show_title:title_only_in_kasa ~log_prefix:"Influence_map:" + ~log_main_title:"Generating the raw influence map..." + ~phase:(StoryProfiling.Internal_influence_map "raw") + (Remanent_state.get_internal_influence_map Public_data.Low) + compute_raw_internal_influence_map + + let convert_half_influence_map parameters error handler compiled influence = + Ckappa_sig.PairRule_setmap.Map.fold + (fun (x, y) list (error, map) -> + let error, x = + Handler.convert_id_short parameters error handler compiled + (Ckappa_sig.rule_id_of_int + (int_of_string (Ckappa_sig.string_of_rule_id x))) + in + let error, y = + Handler.convert_id_short parameters error handler compiled + (Ckappa_sig.rule_id_of_int + (int_of_string (Ckappa_sig.string_of_rule_id y))) + in + let old = + match Public_data.InfluenceNodeMap.find_option x map with + | None -> Public_data.InfluenceNodeMap.empty + | Some x -> x + in + let list = Quark_type.Labels.convert_label_set_couple list in + let list = + List.rev_map + (fun (a, b) -> convert_label a, convert_label b) + (List.rev list) + in + ( error, + Public_data.InfluenceNodeMap.add x + (Public_data.InfluenceNodeMap.add y list old) + map )) + influence + (error, Public_data.InfluenceNodeMap.empty) + + let extract_all_nodes_of_influence_map state (nodes, _, _) = + let parameters = Remanent_state.get_parameters state in + let state, handler = get_handler state in + let state, compiled = get_c_compilation state in + let error = Remanent_state.get_errors state in + let _error, nodes = + List.fold_left + (fun (error, list) id -> + let error, head = + Handler.convert_id_refined parameters error handler compiled id + in + error, head :: list) + (error, []) (List.rev nodes) + in + state, nodes + + let convert_influence_map state (nodes, wake_up_map, inhibition_map) = + let state, nodes = + extract_all_nodes_of_influence_map state + (nodes, wake_up_map, inhibition_map) + in + let parameters = Remanent_state.get_parameters state in + let state, handler = get_handler state in + let state, compiled = get_c_compilation state in + let error = Remanent_state.get_errors state in + let error, pos = + convert_half_influence_map parameters error handler compiled wake_up_map + in + let error, neg = + convert_half_influence_map parameters error handler compiled + inhibition_map + in + let state = Remanent_state.set_errors error state in + let output = + { + Public_data.nodes; + Public_data.positive = pos; + Public_data.negative = neg; + } + in + state, output + + let compute_intermediary_internal_influence_map show_title state = + let state, handler = get_handler state in + let state, compil = get_c_compilation state in + let state, (nodes, wake_up_map, inhibition_map) = + get_raw_internal_influence_map state + in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let state, _ = compute_pos_of_rules_and_vars (fun _ -> ()) state in + let () = show_title state in + let error, wake_up_map = + Algebraic_construction.filter_influence parameters error handler compil + wake_up_map true + in + let error, inhibition_map = + Algebraic_construction.filter_influence parameters error handler compil + inhibition_map false + in + let state = + Remanent_state.set_internal_influence_map Public_data.Medium + (nodes, wake_up_map, inhibition_map) + state + in + let state, output = + convert_influence_map state (nodes, wake_up_map, inhibition_map) + in + let state = + Remanent_state.set_influence_map Public_data.Medium output state + in + let error = + if Remanent_parameters.get_trace parameters || Print_quarks.trace then + Print_quarks.print_wake_up_map parameters error handler compil + Handler.print_rule_txt Handler.print_var_txt + Handler.get_label_of_rule_txt Handler.get_label_of_var_txt + Handler.print_labels "\n" wake_up_map + else + error + in + let error = + if Remanent_parameters.get_trace parameters || Print_quarks.trace then + Print_quarks.print_inhibition_map parameters error handler compil + Handler.print_rule_txt Handler.print_var_txt + Handler.get_label_of_rule_txt Handler.get_label_of_var_txt + Handler.print_labels "\n" inhibition_map + else + error + in + Remanent_state.set_errors error state, (nodes, wake_up_map, inhibition_map) + + let get_intermediary_internal_influence_map = + get_gen ~log_prefix:"Influence_map:" + ~log_title:"Refining the influence map" + ~phase:(StoryProfiling.Internal_influence_map "medium") + (Remanent_state.get_internal_influence_map Public_data.Medium) + compute_intermediary_internal_influence_map + + let string_of_influence_node rule var x = + match x with + | Public_data.Rule i -> + "Rule " ^ rule i (*(string_of_int i.Public_data.rule_id)*) + | Public_data.Var i -> "Var " ^ var i + (*string_of_int i.Public_data.var_id) *) -let string_of_short_influence_node = - string_of_influence_node - string_of_int string_of_int - -let string_of_refined_influence_node = - string_of_influence_node - (fun i -> string_of_int i.Public_data.rule_id) - (fun i -> string_of_int i.Public_data.var_id) - -let print_influence_map parameters influence_map = - let log = (Remanent_parameters.get_logger parameters) in - Loggers.fprintf log "Influence map:" ; - Loggers.print_newline log; - Public_data.InfluenceNodeMap.iter - (fun x y -> - Public_data.InfluenceNodeMap.iter - (fun y _labellist -> - let () = - Loggers.fprintf log - " %s->%s" - (string_of_short_influence_node x) - (string_of_short_influence_node y) - in - let () = - Loggers.print_newline log in - ()) - y) - influence_map.Public_data.positive; - Public_data.InfluenceNodeMap.iter - (fun x y -> - Public_data.InfluenceNodeMap.iter - (fun y _labellist -> - let () = - Loggers.fprintf log - " %s-|%s" - (string_of_short_influence_node x) - (string_of_short_influence_node y) in - let () = Loggers.print_newline log in - ()) - y) - influence_map.Public_data.negative; - Loggers.print_newline log - -let query_inhibition_map influence_map r1 r2 = - match - Public_data.InfluenceNodeMap.find_option - (Public_data.Rule r1) influence_map.Public_data.negative - with - | None -> [] - | Some map -> - begin + let string_of_short_influence_node = + string_of_influence_node string_of_int string_of_int + + let string_of_refined_influence_node = + string_of_influence_node + (fun i -> string_of_int i.Public_data.rule_id) + (fun i -> string_of_int i.Public_data.var_id) + + let print_influence_map parameters influence_map = + let log = Remanent_parameters.get_logger parameters in + Loggers.fprintf log "Influence map:"; + Loggers.print_newline log; + Public_data.InfluenceNodeMap.iter + (fun x y -> + Public_data.InfluenceNodeMap.iter + (fun y _labellist -> + let () = + Loggers.fprintf log " %s->%s" + (string_of_short_influence_node x) + (string_of_short_influence_node y) + in + let () = Loggers.print_newline log in + ()) + y) + influence_map.Public_data.positive; + Public_data.InfluenceNodeMap.iter + (fun x y -> + Public_data.InfluenceNodeMap.iter + (fun y _labellist -> + let () = + Loggers.fprintf log " %s-|%s" + (string_of_short_influence_node x) + (string_of_short_influence_node y) + in + let () = Loggers.print_newline log in + ()) + y) + influence_map.Public_data.negative; + Loggers.print_newline log + + let query_inhibition_map influence_map r1 r2 = match - Public_data.InfluenceNodeMap.find_option - (Public_data.Rule r2) - map + Public_data.InfluenceNodeMap.find_option (Public_data.Rule r1) + influence_map.Public_data.negative with | None -> [] - | Some l -> l - end - -let find_most_precise map = - match - Public_data.AccuracyMap.max_key map - with - | None -> None - | Some key -> - Public_data.AccuracyMap.find_option key map - -let compute_high_res_internal_influence_map show_title state = - let state, handler = get_handler state in - let state, compil = get_c_compilation state in - let state,(nodes,wake_up_map,inhibition_map) = - get_intermediary_internal_influence_map state - in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let state, (static, dynamic) = get_reachability_analysis state in - let () = show_title state in - let maybe_reachable static dynamic error = - Reachability.maybe_reachable static dynamic error Analyzer_headers.Morphisms - in - let (error,dynamic), wake_up_map = - Algebraic_construction.filter_influence_high - maybe_reachable - parameters handler error compil - static dynamic wake_up_map true - in - let (error,dynamic), inhibition_map = - Algebraic_construction.filter_influence_high - maybe_reachable - parameters handler error compil - static dynamic inhibition_map false - in - let state = Remanent_state.set_errors error state in - let state = Remanent_state.set_reachability_result (static, dynamic) state in - let state = - Remanent_state.set_internal_influence_map Public_data.High - (nodes, wake_up_map,inhibition_map) - state - in - let state, handler = get_handler state in - let state, output = - convert_influence_map - state - (nodes, wake_up_map, inhibition_map) - in - let state = - Remanent_state.set_influence_map Public_data.High - output - state - in - let error = get_errors state in - let error = - if Remanent_parameters.get_trace parameters || Print_quarks.trace - then - Print_quarks.print_wake_up_map - parameters - error - handler - compil - Handler.print_rule_txt - Handler.print_var_txt - Handler.get_label_of_rule_txt - Handler.get_label_of_var_txt - Handler.print_labels "\n" - wake_up_map - else error - in - let error = - if - Remanent_parameters.get_trace parameters - || Print_quarks.trace - then - Print_quarks.print_inhibition_map - parameters error handler - compil - Handler.print_rule_txt - Handler.print_var_txt - Handler.get_label_of_rule_txt - Handler.get_label_of_var_txt - Handler.print_labels - "\n" - inhibition_map - else error - in - Remanent_state.set_errors error state, (nodes, wake_up_map, inhibition_map) - - -let get_high_res_internal_influence_map = - get_gen - ~log_prefix:"Influence_map:" - ~log_title:"Refining further the influence map" - ~phase:(StoryProfiling.Internal_influence_map "high") - (Remanent_state.get_internal_influence_map Public_data.High) - compute_high_res_internal_influence_map - -let get_internal_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - state = - match accuracy_level with - | Public_data.Low -> - get_raw_internal_influence_map state - | Public_data.Medium -> get_intermediary_internal_influence_map state - | Public_data.High | Public_data.Full -> - get_high_res_internal_influence_map state - -let compute_map_gen - (get: ?accuracy_level:Public_data.accuracy_level -> - (Reachability.static_information, - Reachability.dynamic_information) - Remanent_state.state -> - (Reachability.static_information, - Reachability.dynamic_information) - Remanent_state.state * 'a ) - store convert ?(accuracy_level=Public_data.Low) - ?do_we_show_title:(do_we_show_title=(fun _ -> true)) - ?log_title state = - let show_title = - match log_title with - | None -> (fun _ -> ()) - | Some log_title -> - compute_show_title do_we_show_title (log_title accuracy_level) - in - let () = show_title state in - let state, internal = - get ~accuracy_level state - in - let state, rep = convert (fun _ -> ()) state internal in - store accuracy_level rep state, rep - - -let compute_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) _show_title = - compute_map_gen - get_internal_influence_map - Remanent_state.set_influence_map - (fun _ -> convert_influence_map) - ~accuracy_level - -let get_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - ?do_we_show_title:(do_we_show_title=(fun _ -> true)) - ?log_title:(log_title= - (fun x -> - match x with - | Public_data.Low -> - Some "Compute the influence map" - | Public_data.Medium - | Public_data.High | Public_data.Full -> - Some "Refine the influence map")) = - get_gen - (Remanent_state.get_influence_map accuracy_level) - (compute_influence_map ~accuracy_level ~do_we_show_title ~log_title) - -let nrules state = - let parameters = Remanent_state.get_parameters state in - let state, handler = get_handler state in - let error = get_errors state in - state, Handler.nrules parameters error handler - -let nvars state = - let parameters = Remanent_state.get_parameters state in - let state, handler = get_handler state in - let error = get_errors state in - state, Handler.nvars parameters error handler - -let convert_to_birectional_influence_map - show_title state influence_map = - let () = show_title state in - let state, nrules = nrules state in - let state, nvars = nvars state in - let output = - Bidirectional_influence_map.convert ~nrules ~nvars influence_map - in - state, output - -let compute_bidirectional_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) _show_title = - compute_map_gen - get_internal_influence_map - Remanent_state.set_bidirectional_influence_map - convert_to_birectional_influence_map - ~accuracy_level - -let get_bidirectional_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - ?do_we_show_title:(do_we_show_title=(fun _ -> true)) - ?log_title:(log_title= - (fun x -> - match x with - | Public_data.Low -> - Some "Compute the bidirectional influence map" - | Public_data.Medium - | Public_data.High | Public_data.Full -> - Some "Refine the bidirectional influence map")) = - get_gen - (Remanent_state.get_bidirectional_influence_map accuracy_level) - (compute_bidirectional_influence_map ~accuracy_level ~do_we_show_title ~log_title) - -let compute_influence_map_blackboard show_title state = - let () = show_title state in - let state, nrules = nrules state in - let state, nvars = nvars state in - let blackboard = Local_influence_map.init_blackboard nrules nvars in - state, blackboard - -let get_influence_map_blackboard - = - get_gen - ~log_title:"Preparing data-structures for local influence map" - (Remanent_state.get_local_influence_map_blackboard) - compute_influence_map_blackboard - -let get_local_internal_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - ?fwd ?bwd ~total - origin - state = - let parameters = get_parameters state in - let error = get_errors state in - let state,bidirectional_influence_map = - get_bidirectional_influence_map ~accuracy_level state - in - let state, blackboard = - get_influence_map_blackboard state - in - let error, local_influence_map, _blackboard = - Local_influence_map.explore_influence_map - parameters error - ?fwd ?bwd ~total - blackboard origin bidirectional_influence_map - in - let state = set_errors error state in - state, local_influence_map - -let get_local_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - ?fwd ?bwd ~total - origin - state = - let state, internal_influence_map = - get_local_internal_influence_map - ~accuracy_level ?fwd ?bwd ~total - origin - state - in - convert_influence_map state internal_influence_map - -let get_all_nodes_of_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - state = - let state, internal_influence_map = - get_internal_influence_map - ~accuracy_level - state - in - extract_all_nodes_of_influence_map state internal_influence_map - - -let query_inhibition_map ?accuracy_level state r1 r2 = - let state,inf_map = get_influence_map ?accuracy_level state in - let output = query_inhibition_map inf_map r1 r2 in - state, output - -let get_most_accurate_influence_map state = - let map = Remanent_state.get_influence_map_map state in - find_most_precise map - -let output_internal_influence_map ?logger - ?accuracy_level:(accuracy_level=Public_data.Low) state = - let parameters = get_parameters state in - let state, influence_map = get_internal_influence_map ~accuracy_level state in - let state, c_compil = get_c_compilation state in - let state, handler = get_handler state in - let error = get_errors state in - let error = - Print_quarks.dot_of_influence_map ?logger parameters error handler c_compil - influence_map - in - set_errors error state - -let output_local_internal_influence_map ?logger - ?accuracy_level:(accuracy_level=Public_data.Low) - ?fwd ?bwd ~total origin state = - let parameters = get_parameters state in - let state, influence_map = get_local_internal_influence_map ~accuracy_level ?fwd ?bwd ~total origin state in - let state, c_compil = get_c_compilation state in - let state, handler = get_handler state in - let error = get_errors state in - let error = - Print_quarks.dot_of_influence_map ?logger parameters error handler c_compil - influence_map - in - set_errors error state - -let output_best_internal_influence_map state = - let map = Remanent_state.get_internal_influence_map_map state in - match - Public_data.AccuracyMap.max_key map - with - | None -> state - | Some accuracy_level -> - output_internal_influence_map ~accuracy_level state - -let dump_influence_map ?accuracy_level:(accuracy_level=Public_data.Low) state = - match - Remanent_state.get_influence_map accuracy_level state - with - | None -> () - | Some influence_map -> - print_influence_map (Remanent_state.get_parameters state) influence_map - -(******************************************************************) -(*contact map*) -(******************************************************************) - -let get_most_accurate_contact_map state = - let map = Remanent_state.get_contact_map_map state in - find_most_precise map - -let compute_raw_internal_contact_map show_title state = - let state, _ = get_compilation state in - let state, handler = get_handler state in - let () = show_title state in - let state, c_compil = get_c_compilation state in - let parameters = Remanent_state.get_parameters state in - let parameters = Remanent_parameters.update_prefix - parameters "Compilation:" in - let error = Remanent_state.get_errors state in - let error = - if Remanent_parameters.get_trace parameters || Print_cckappa.trace - then Print_cckappa.print_compil parameters error handler c_compil - else error - in - let error, contact_map = - Preprocess.export_contact_map parameters error handler - in - let state = Remanent_state.set_errors error state in - Remanent_state.set_internal_contact_map Public_data.Low contact_map state, - contact_map - -let dump_raw_internal_contact_map state handler = - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let error = - match Remanent_parameters.get_cm_format parameters with - | DOT -> Print_handler.dot_of_contact_map parameters error handler - | GEPHI -> Print_handler.gexf_of_contact_map parameters error handler - | _ -> let error, () = warn parameters error __POS__ Exit () in error - in - Remanent_state.set_errors error state - -let get_raw_internal_contact_map = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"Generating the raw contact map" - (* ~dump:dump_raw_internal_contact_map *) - (Remanent_state.get_internal_contact_map Public_data.Low) - compute_raw_internal_contact_map - -let compute_intermediary_internal_contact_map _show_title state = - let state,_ = get_reachability_analysis state in - match - Remanent_state.get_internal_contact_map Public_data.Medium state - with - | Some map -> state, map - | None -> assert false - -let get_intermediary_internal_contact_map = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"Generating the intermediary contact map" - (* ~dump:dump_raw_internal_contact_map *) - (Remanent_state.get_internal_contact_map Public_data.Medium) - compute_intermediary_internal_contact_map - -let get_internal_contact_map - ?accuracy_level:(accuracy_level=Public_data.Low) state = - match - accuracy_level - with - | Public_data.Low -> get_raw_internal_contact_map state - | Public_data.Medium - | Public_data.High - | Public_data.Full -> get_intermediary_internal_contact_map state - -let convert_contact_map_map_to_list sol = - Tools.array_rev_of_list - (Mods.StringSetMap.Map.fold - (fun a data l -> - { User_graph.node_type = a; - User_graph.node_id = None; - User_graph.node_sites= - Tools.array_rev_of_list - (Mods.StringSetMap.Map.fold - (fun a (props,links) l -> - let links = - List.rev_map (fun (i,j) -> ((0,i),j)) (List.rev links) in - { - User_graph.site_name=a; - User_graph.site_type = User_graph.Port { - User_graph.port_links=User_graph.LINKS links; - User_graph.port_states=Some props; - } - }::l) data [])}::l) - sol []) - -let convert_contact_map show_title state contact_map = - let parameters = Remanent_state.get_parameters state in - let state, handler = get_handler state in - let error = Remanent_state.get_errors state in - let () = show_title state in - let error, contact_map = - AgentProj.monadic_proj_map_i - (fun parameters error ag -> - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler ag) - parameters error - Mods.StringSetMap.Map.empty - (fun parameters error _ ag sitemap-> - SiteProj.monadic_proj_map_i - (fun parameters errors site -> - let error, site = Handler.translate_site parameters errors - handler ag (site:Ckappa_sig.c_site_name) in - error, Handler.print_site_contact_map site) - parameters error - ([],[]) - (fun parameters error (list_a,list_b) site (list_a',list_b') -> - let error, list_a'' = - List.fold_left - (fun (error, list) state -> - let error, state = Handler.translate_state parameters - error handler ag site state in - match state with - | Ckappa_sig.Internal state -> error, state::list - | Ckappa_sig.Counter _ - | Ckappa_sig.Binding _ -> - - warn parameters error __POS__ Exit list) - (error, list_a) (List.rev list_a') - in - let error, list_b'' = - List.fold_left - (fun (error, list) (agent,site) -> - error, (Ckappa_sig.int_of_agent_name agent, - Ckappa_sig.int_of_site_name site)::list) - (error, list_b) (List.rev list_b') - in - error, (list_a'', list_b'')) - sitemap) - contact_map - in - let contact_map = - convert_contact_map_map_to_list contact_map - in - let error, contact_map = - reindex parameters error handler contact_map - in - Remanent_state.set_errors error state, - [|Array.of_list contact_map|] - -let compute_contact_map - ?(accuracy_level=Public_data.Low) _show_title = - compute_map_gen - get_internal_contact_map - Remanent_state.set_contact_map - convert_contact_map - ~accuracy_level - -let get_contact_map - ?accuracy_level:(accuracy_level=Public_data.Low) - = - get_gen - (Remanent_state.get_contact_map accuracy_level) - (compute_contact_map - ~accuracy_level - ~do_we_show_title:(fun _ -> true) - ~log_title:(fun x -> - match x with - | Public_data.Low -> - Some "Compute the contact map" - | Public_data.Medium - | Public_data.High | Public_data.Full -> - Some "Refine the contact map")) - -let dump_contact_map accuracy state = - match - Remanent_state.get_contact_map accuracy state - with - | None -> () - | Some contact_map -> - let logger = - Remanent_parameters.get_logger - (Remanent_state.get_parameters state) in - Loggers.fprintf logger "Contact map:@ %a" User_graph.print_cc contact_map - - -let compute_internal_scc_decomposition - ?accuracy_level_cm:(accuracy_level_cm=Public_data.Low) - ?accuracy_level_scc:(accuracy_level_scc=Public_data.Low) - ?do_we_show_title:(_do_we_show_title=(fun _ -> false)) - ?log_title:(_log_title="") - _show_title state = - let parameters = Remanent_state.get_parameters state in - let accuracy_level = accuracy_level_cm in - let state, contact_map = get_internal_contact_map ~accuracy_level state in - let errors = get_errors state in - let errors, cm_graph = - Contact_map_scc.convert_contact_map - parameters errors contact_map - in - let state, (static, dynamic) = - get_reachability_analysis state - in - let state, handler = get_handler state in - let errors, dynamic, cm_graph = - match - accuracy_level_scc - with - | Public_data.Low -> errors, dynamic, cm_graph - | Public_data.Medium - | Public_data.High - | Public_data.Full -> - let maybe_reachable _parameters error static dynamic = - Reachability.maybe_reachable static dynamic error Analyzer_headers.Embeddings - in - Contact_map_scc.filter_edges_in_converted_contact_map - parameters errors handler static dynamic maybe_reachable cm_graph - in - let state = Remanent_state.set_reachability_result (static, dynamic) state in - let errors, graph_scc = - Contact_map_scc.compute_graph_scc - parameters errors cm_graph - in - let state = Remanent_state.set_internal_scc_decomposition - accuracy_level_cm accuracy_level_scc graph_scc state - in - let state = Remanent_state.set_errors errors state in - state, graph_scc - -let get_internal_scc_decomposition - ?accuracy_level_cm:(accuracy_level_cm=Public_data.Low) - ?accuracy_level_scc:(accuracy_level_scc=Public_data.Low) - = - get_gen - (Remanent_state.get_internal_scc_decomposition - accuracy_level_cm accuracy_level_scc) - (compute_internal_scc_decomposition - ~accuracy_level_cm - ~accuracy_level_scc - ~do_we_show_title:(fun _ -> true) - ~log_title:("Decompose the contact map in strongly connected components") - ) - -let get_internal_scc_decomposition_map state = - Remanent_state.get_internal_scc_decomposition_map state - -(*internal contact map*) - -(*((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)* - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)) list list*) - -(*scc = ((string * string) * (string * string)) list list*) - -let translate_scc_decomposition state - (internal_scc:internal_scc_decomposition) = - let error = Remanent_state.get_errors state in - let parameters = get_parameters state in - let state, handler = get_handler state in - let error, scc = - List.fold_left (fun (error, store_result) list -> - let error, store_list = - List.fold_left (fun (error, store_result) ((ag,st),(ag',st')) -> - let error,agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler ag - in - let error,site = - Handler.translate_site parameters error handler ag st - in - let site = simplify_site site in - let error,agent' = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler ag' - in - let error,site' = - Handler.translate_site parameters error handler ag' st' - in - let site' = simplify_site site' in - let pair = ((agent, site), (agent', site')) in - error, pair :: store_result - ) (error, []) list - in - error, store_list :: store_result - ) (error, [[]]) internal_scc - in - let state = set_errors error state in - state, scc - -let compute_map2_gen - get - store convert ?(accuracy_level_cm=Public_data.Low) - ?(accuracy_level_scc=Public_data.Low) - ?do_we_show_title:(do_we_show_title=(fun _ -> true)) - ?log_title state = - let show_title = - match log_title with - | None -> (fun _ -> ()) - | Some log_title -> - compute_show_title do_we_show_title (log_title accuracy_level_cm accuracy_level_scc) - in - let () = show_title state in - let state, internal = - get - ?accuracy_level_cm:(Some accuracy_level_cm) - ?accuracy_level_scc:(Some accuracy_level_scc) - state - in - let state, rep = convert state internal in - store accuracy_level_cm accuracy_level_scc rep state, rep - -let compute_scc_map - ?accuracy_level_cm:(accuracy_level_cm=Public_data.Low) - ?accuracy_level_scc:(accuracy_level_scc=Public_data.Low) - _show_title = - compute_map2_gen - get_internal_scc_decomposition - Remanent_state.set_scc_decomposition - translate_scc_decomposition - ~accuracy_level_cm ~accuracy_level_scc - -let get_scc_decomposition - ?accuracy_level_cm:(accuracy_level_cm=Public_data.Low) - ?accuracy_level_scc:(accuracy_level_scc=Public_data.Low) - ?do_we_show_title:(do_we_show_title=(fun _ -> true)) - ?log_title:(log_title= - (fun _ _ ->Some "Detect potential polymers")) = - get_gen - (Remanent_state.get_scc_decomposition accuracy_level_cm accuracy_level_scc) - (compute_scc_map - ~accuracy_level_cm ~accuracy_level_scc ~do_we_show_title ~log_title) - -let dump_internal_scc_decomposition - ?accuracy_level_cm:(accuracy_level_cm=Public_data.Low) - ?accuracy_level_scc:(accuracy_level_scc=Public_data.Low) - state = - let parameters = Remanent_state.get_parameters state in - let state, handler = get_handler state in - let logger = Remanent_parameters.get_logger parameters in - let state, graph_scc = get_internal_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc state in - let error = get_errors state in - let () = - Loggers.fprintf - logger - "Potential polymerization:" - in - let () = - Loggers.print_newline - logger - in - let error = - List.fold_left - (fun error list -> - let error = - List.fold_left - (fun error ((ag,st),(ag',st')) -> - let error, agent_name = - Handler.string_of_agent parameters error handler ag - in - let error, site_name = - Handler.string_of_site parameters error handler ag st - in - let error, agent_name' = - Handler.string_of_agent parameters error handler ag' - in - let error, site_name' = - Handler.string_of_site parameters error handler ag' st' - in - let () = - Loggers.fprintf - logger - " (%s,%s)--(%s,%s); " - agent_name site_name agent_name' site_name' + | Some map -> + (match + Public_data.InfluenceNodeMap.find_option (Public_data.Rule r2) map + with + | None -> [] + | Some l -> l) + + let find_most_precise map = + match Public_data.AccuracyMap.max_key map with + | None -> None + | Some key -> Public_data.AccuracyMap.find_option key map + + let compute_high_res_internal_influence_map show_title state = + let state, handler = get_handler state in + let state, compil = get_c_compilation state in + let state, (nodes, wake_up_map, inhibition_map) = + get_intermediary_internal_influence_map state + in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let state, (static, dynamic) = get_reachability_analysis state in + let () = show_title state in + let maybe_reachable static dynamic error = + Reachability.maybe_reachable static dynamic error + Analyzer_headers.Morphisms + in + let (error, dynamic), wake_up_map = + Algebraic_construction.filter_influence_high maybe_reachable parameters + handler error compil static dynamic wake_up_map true + in + let (error, dynamic), inhibition_map = + Algebraic_construction.filter_influence_high maybe_reachable parameters + handler error compil static dynamic inhibition_map false + in + let state = Remanent_state.set_errors error state in + let state = + Remanent_state.set_reachability_result (static, dynamic) state + in + let state = + Remanent_state.set_internal_influence_map Public_data.High + (nodes, wake_up_map, inhibition_map) + state + in + let state, handler = get_handler state in + let state, output = + convert_influence_map state (nodes, wake_up_map, inhibition_map) + in + let state = + Remanent_state.set_influence_map Public_data.High output state + in + let error = get_errors state in + let error = + if Remanent_parameters.get_trace parameters || Print_quarks.trace then + Print_quarks.print_wake_up_map parameters error handler compil + Handler.print_rule_txt Handler.print_var_txt + Handler.get_label_of_rule_txt Handler.get_label_of_var_txt + Handler.print_labels "\n" wake_up_map + else + error + in + let error = + if Remanent_parameters.get_trace parameters || Print_quarks.trace then + Print_quarks.print_inhibition_map parameters error handler compil + Handler.print_rule_txt Handler.print_var_txt + Handler.get_label_of_rule_txt Handler.get_label_of_var_txt + Handler.print_labels "\n" inhibition_map + else + error + in + Remanent_state.set_errors error state, (nodes, wake_up_map, inhibition_map) + + let get_high_res_internal_influence_map = + get_gen ~log_prefix:"Influence_map:" + ~log_title:"Refining further the influence map" + ~phase:(StoryProfiling.Internal_influence_map "high") + (Remanent_state.get_internal_influence_map Public_data.High) + compute_high_res_internal_influence_map + + let get_internal_influence_map ?(accuracy_level = Public_data.Low) state = + match accuracy_level with + | Public_data.Low -> get_raw_internal_influence_map state + | Public_data.Medium -> get_intermediary_internal_influence_map state + | Public_data.High | Public_data.Full -> + get_high_res_internal_influence_map state + + let compute_map_gen + (get : + ?accuracy_level:Public_data.accuracy_level -> + ( Reachability.static_information, + Reachability.dynamic_information ) + Remanent_state.state -> + ( Reachability.static_information, + Reachability.dynamic_information ) + Remanent_state.state + * 'a) store convert ?(accuracy_level = Public_data.Low) + ?(do_we_show_title = fun _ -> true) ?log_title state = + let show_title = + match log_title with + | None -> fun _ -> () + | Some log_title -> + compute_show_title do_we_show_title (log_title accuracy_level) + in + let () = show_title state in + let state, internal = get ~accuracy_level state in + let state, rep = convert (fun _ -> ()) state internal in + store accuracy_level rep state, rep + + let compute_influence_map ?(accuracy_level = Public_data.Low) _show_title = + compute_map_gen get_internal_influence_map + Remanent_state.set_influence_map + (fun _ -> convert_influence_map) + ~accuracy_level + + let get_influence_map ?(accuracy_level = Public_data.Low) + ?(do_we_show_title = fun _ -> true) + ?(log_title = + fun x -> + match x with + | Public_data.Low -> Some "Compute the influence map" + | Public_data.Medium | Public_data.High | Public_data.Full -> + Some "Refine the influence map") = + get_gen + (Remanent_state.get_influence_map accuracy_level) + (compute_influence_map ~accuracy_level ~do_we_show_title ~log_title) + + let nrules state = + let parameters = Remanent_state.get_parameters state in + let state, handler = get_handler state in + let error = get_errors state in + state, Handler.nrules parameters error handler + + let nvars state = + let parameters = Remanent_state.get_parameters state in + let state, handler = get_handler state in + let error = get_errors state in + state, Handler.nvars parameters error handler + + let convert_to_birectional_influence_map show_title state influence_map = + let () = show_title state in + let state, nrules = nrules state in + let state, nvars = nvars state in + let output = + Bidirectional_influence_map.convert ~nrules ~nvars influence_map + in + state, output + + let compute_bidirectional_influence_map ?(accuracy_level = Public_data.Low) + _show_title = + compute_map_gen get_internal_influence_map + Remanent_state.set_bidirectional_influence_map + convert_to_birectional_influence_map ~accuracy_level + + let get_bidirectional_influence_map ?(accuracy_level = Public_data.Low) + ?(do_we_show_title = fun _ -> true) + ?(log_title = + fun x -> + match x with + | Public_data.Low -> Some "Compute the bidirectional influence map" + | Public_data.Medium | Public_data.High | Public_data.Full -> + Some "Refine the bidirectional influence map") = + get_gen + (Remanent_state.get_bidirectional_influence_map accuracy_level) + (compute_bidirectional_influence_map ~accuracy_level ~do_we_show_title + ~log_title) + + let compute_influence_map_blackboard show_title state = + let () = show_title state in + let state, nrules = nrules state in + let state, nvars = nvars state in + let blackboard = Local_influence_map.init_blackboard nrules nvars in + state, blackboard + + let get_influence_map_blackboard = + get_gen ~log_title:"Preparing data-structures for local influence map" + Remanent_state.get_local_influence_map_blackboard + compute_influence_map_blackboard + + let get_local_internal_influence_map ?(accuracy_level = Public_data.Low) + ?fwd ?bwd ~total origin state = + let parameters = get_parameters state in + let error = get_errors state in + let state, bidirectional_influence_map = + get_bidirectional_influence_map ~accuracy_level state + in + let state, blackboard = get_influence_map_blackboard state in + let error, local_influence_map, _blackboard = + Local_influence_map.explore_influence_map parameters error ?fwd ?bwd + ~total blackboard origin bidirectional_influence_map + in + let state = set_errors error state in + state, local_influence_map + + let get_local_influence_map ?(accuracy_level = Public_data.Low) ?fwd ?bwd + ~total origin state = + let state, internal_influence_map = + get_local_internal_influence_map ~accuracy_level ?fwd ?bwd ~total origin + state + in + convert_influence_map state internal_influence_map + + let get_all_nodes_of_influence_map ?(accuracy_level = Public_data.Low) state + = + let state, internal_influence_map = + get_internal_influence_map ~accuracy_level state + in + extract_all_nodes_of_influence_map state internal_influence_map + + let query_inhibition_map ?accuracy_level state r1 r2 = + let state, inf_map = get_influence_map ?accuracy_level state in + let output = query_inhibition_map inf_map r1 r2 in + state, output + + let get_most_accurate_influence_map state = + let map = Remanent_state.get_influence_map_map state in + find_most_precise map + + let output_internal_influence_map ?logger + ?(accuracy_level = Public_data.Low) state = + let parameters = get_parameters state in + let state, influence_map = + get_internal_influence_map ~accuracy_level state + in + let state, c_compil = get_c_compilation state in + let state, handler = get_handler state in + let error = get_errors state in + let error = + Print_quarks.dot_of_influence_map ?logger parameters error handler + c_compil influence_map + in + set_errors error state + + let output_local_internal_influence_map ?logger + ?(accuracy_level = Public_data.Low) ?fwd ?bwd ~total origin state = + let parameters = get_parameters state in + let state, influence_map = + get_local_internal_influence_map ~accuracy_level ?fwd ?bwd ~total origin + state + in + let state, c_compil = get_c_compilation state in + let state, handler = get_handler state in + let error = get_errors state in + let error = + Print_quarks.dot_of_influence_map ?logger parameters error handler + c_compil influence_map + in + set_errors error state + + let output_best_internal_influence_map state = + let map = Remanent_state.get_internal_influence_map_map state in + match Public_data.AccuracyMap.max_key map with + | None -> state + | Some accuracy_level -> + output_internal_influence_map ~accuracy_level state + + let dump_influence_map ?(accuracy_level = Public_data.Low) state = + match Remanent_state.get_influence_map accuracy_level state with + | None -> () + | Some influence_map -> + print_influence_map (Remanent_state.get_parameters state) influence_map + + (******************************************************************) + (*contact map*) + (******************************************************************) + + let get_most_accurate_contact_map state = + let map = Remanent_state.get_contact_map_map state in + find_most_precise map + + let compute_raw_internal_contact_map show_title state = + let state, _ = get_compilation state in + let state, handler = get_handler state in + let () = show_title state in + let state, c_compil = get_c_compilation state in + let parameters = Remanent_state.get_parameters state in + let parameters = + Remanent_parameters.update_prefix parameters "Compilation:" + in + let error = Remanent_state.get_errors state in + let error = + if Remanent_parameters.get_trace parameters || Print_cckappa.trace then + Print_cckappa.print_compil parameters error handler c_compil + else + error + in + let error, contact_map = + Preprocess.export_contact_map parameters error handler + in + let state = Remanent_state.set_errors error state in + ( Remanent_state.set_internal_contact_map Public_data.Low contact_map state, + contact_map ) + + let dump_raw_internal_contact_map state handler = + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let error = + match Remanent_parameters.get_cm_format parameters with + | DOT -> Print_handler.dot_of_contact_map parameters error handler + | GEPHI -> Print_handler.gexf_of_contact_map parameters error handler + | _ -> + let error, () = warn parameters error __POS__ Exit () in + error + in + Remanent_state.set_errors error state + + let get_raw_internal_contact_map = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"Generating the raw contact map" + (* ~dump:dump_raw_internal_contact_map *) + (Remanent_state.get_internal_contact_map Public_data.Low) + compute_raw_internal_contact_map + + let compute_intermediary_internal_contact_map _show_title state = + let state, _ = get_reachability_analysis state in + match + Remanent_state.get_internal_contact_map Public_data.Medium state + with + | Some map -> state, map + | None -> assert false + + let get_intermediary_internal_contact_map = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"Generating the intermediary contact map" + (* ~dump:dump_raw_internal_contact_map *) + (Remanent_state.get_internal_contact_map Public_data.Medium) + compute_intermediary_internal_contact_map + + let get_internal_contact_map ?(accuracy_level = Public_data.Low) state = + match accuracy_level with + | Public_data.Low -> get_raw_internal_contact_map state + | Public_data.Medium | Public_data.High | Public_data.Full -> + get_intermediary_internal_contact_map state + + let convert_contact_map_map_to_list sol = + Tools.array_rev_of_list + (Mods.StringSetMap.Map.fold + (fun a data l -> + { + User_graph.node_type = a; + User_graph.node_id = None; + User_graph.node_sites = + Tools.array_rev_of_list + (Mods.StringSetMap.Map.fold + (fun a (props, links) l -> + let links = + List.rev_map + (fun (i, j) -> (0, i), j) + (List.rev links) + in + { + User_graph.site_name = a; + User_graph.site_type = + User_graph.Port + { + User_graph.port_links = User_graph.LINKS links; + User_graph.port_states = Some props; + }; + } + :: l) + data []); + } + :: l) + sol []) + + let convert_contact_map show_title state contact_map = + let parameters = Remanent_state.get_parameters state in + let state, handler = get_handler state in + let error = Remanent_state.get_errors state in + let () = show_title state in + let error, contact_map = + AgentProj.monadic_proj_map_i + (fun parameters error ag -> + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler ag) + parameters error Mods.StringSetMap.Map.empty + (fun parameters error _ ag sitemap -> + SiteProj.monadic_proj_map_i + (fun parameters errors site -> + let error, site = + Handler.translate_site parameters errors handler ag + (site : Ckappa_sig.c_site_name) in - let () = - Loggers.print_newline logger + error, Handler.print_site_contact_map site) + parameters error ([], []) + (fun parameters error (list_a, list_b) site (list_a', list_b') -> + let error, list_a'' = + List.fold_left + (fun (error, list) state -> + let error, state = + Handler.translate_state parameters error handler ag site + state + in + match state with + | Ckappa_sig.Internal state -> error, state :: list + | Ckappa_sig.Counter _ | Ckappa_sig.Binding _ -> + warn parameters error __POS__ Exit list) + (error, list_a) (List.rev list_a') in - error - ) - error - list - in - let () = - Loggers.print_newline - logger - in error - ) - error - graph_scc - in - let state = set_errors error state in - state - -let dump_scc_decomposition ?accuracy_level_cm:(accuracy_level_cm=Public_data.Low) - ?accuracy_level_scc:(accuracy_level_scc=Public_data.Low) - state = -let parameters = Remanent_state.get_parameters state in -let logger = Remanent_parameters.get_logger parameters in -let state, graph_scc = get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc state in -let error = get_errors state in -let () = - Loggers.fprintf - logger - "Potential polymerization:" -in -let () = - Loggers.print_newline - logger -in -let error = - List.fold_left - (fun error list -> - let error = - List.fold_left - (fun error ((agent_name,site_name),(agent_name',site_name')) -> - let () = - Loggers.fprintf - logger - "(%s,%s)--(%s,%s); " - agent_name site_name agent_name' site_name' - in error - ) - error - list - in - let () = - Loggers.print_newline - logger - in error - ) - error - graph_scc -in -let state = set_errors error state in -state - -let get_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - ?do_we_show_title:(do_we_show_title=(fun _ -> true)) - ?log_title:(log_title= - (fun x -> - match x with - | Public_data.Low -> - Some "Compute the influence map" - | Public_data.Medium - | Public_data.High | Public_data.Full -> - Some "Refine the influence map")) = - get_gen - (Remanent_state.get_influence_map accuracy_level) - (compute_influence_map ~accuracy_level ~do_we_show_title ~log_title) - - -let output_internal_contact_map ?logger - ?accuracy_level:(accuracy_level=Public_data.Low) state = - let parameters = Remanent_state.get_parameters state in - let state, contact_map = - get_internal_contact_map ~accuracy_level state in - let state, handler = get_handler state in - let error = get_errors state in - let scc_contact_map = - Remanent_state.get_internal_scc_decomposition_map state in - let error = - match Remanent_parameters.get_cm_format parameters with - | DOT -> Preprocess.dot_of_contact_map - ?logger parameters error handler scc_contact_map contact_map - | GEPHI -> Preprocess.gexf_of_contact_map - ?logger parameters error handler scc_contact_map contact_map - - | _ -> let error, () = warn parameters error __POS__ Exit () in error - in - set_errors error state - -(*contact map interge *) - -let compute_contact_map_int show_title state = - let state, _, _, contactmap = - compute_env_init show_title state in - state, contactmap - -let get_contact_map_int = - get_gen - ~phase:StoryProfiling.LKappa_signature - Remanent_state.get_contact_map_int - compute_contact_map_int - -(*Raw contact map*) - -let compute_raw_contact_map show_title state = - let sol = ref Mods.StringSetMap.Map.empty in - let state, handler = get_prehandler state in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let add_link (a,b) (c_id,d_id) sol = - let sol_a = Mods.StringSetMap.Map.find_default - Mods.StringSetMap.Map.empty a sol in - let l,old = - Mods.StringSetMap.Map.find_default ([],[]) b sol_a - in - Mods.StringSetMap.Map.add a - (Mods.StringSetMap.Map.add b - (l,((Ckappa_sig.int_of_agent_name c_id, - Ckappa_sig.int_of_site_name d_id)::old)) sol_a) sol - in - let add_link (a,b) (a_id,b_id) (c,d) (c_id,d_id) sol = - add_link (a,b) (c_id,d_id) (add_link (c,d) (a_id,b_id) sol) - in - (*----------------------------------------------------------------*) - let add_internal_state (a,b) c sol = - match c with - | Ckappa_sig.Counter _ - | Ckappa_sig.Binding _ -> sol - | Ckappa_sig.Internal state -> - let sol_a = Mods.StringSetMap.Map.find_default - Mods.StringSetMap.Map.empty a sol in - let old,l = Mods.StringSetMap.Map.find_default ([],[]) b sol_a in - Mods.StringSetMap.Map.add a - (Mods.StringSetMap.Map.add b (state::old,l) sol_a) sol - in - (*----------------------------------------------------------------*) - let () = show_title state in - let error = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.iter - parameters error - (fun parameters error (i,j) s -> - let error,ag = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler i - in - let error,site = - Handler.translate_site parameters error handler i j - in - let site = simplify_site site in - let error = - Ckappa_sig.Dictionary_of_States.iter - parameters error - (fun _parameters error _s state () () -> - let () = - sol := add_internal_state (ag,site) state (!sol) + let error, list_b'' = + List.fold_left + (fun (error, list) (agent, site) -> + ( error, + ( Ckappa_sig.int_of_agent_name agent, + Ckappa_sig.int_of_site_name site ) + :: list )) + (error, list_b) (List.rev list_b') in - error) - s - in - error) - handler.Cckappa_sig.states_dic - in - (*----------------------------------------------------------------*) - let sol = !sol in - let error, sol = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.fold - parameters error - (fun _parameters error (i, (j , _k)) (i', j', _k') sol -> - let error, ag_i = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler i - in - let error, site_j = - Handler.translate_site parameters error handler i j - in - let site_j = simplify_site site_j in - let error, ag_i' = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters error handler i' - in - let error, site_j' = - Handler.translate_site parameters error handler i' j' - in - let site_j' = simplify_site site_j' in - let sol = add_link (ag_i,site_j) (i,j) (ag_i',site_j') (i',j') sol in - error, sol) - handler.Cckappa_sig.dual sol - in - let sol = - Mods.StringSetMap.Map.map - (Mods.StringSetMap.Map.map (fun (l,x) -> List.rev l,x)) sol - in - let sol = - convert_contact_map_map_to_list sol - in - let error, sol = - reindex parameters error handler sol - in - let sol = [|Array.of_list sol|] in - Remanent_state.set_errors error - (Remanent_state.set_contact_map Public_data.Low sol state), - sol - -let get_raw_contact_map = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"Compute the contact map" - (Remanent_state.get_contact_map Public_data.Low) - compute_raw_contact_map - -(******************************************************************) -(*signature*) -(******************************************************************) - -let compute_signature show_title state = - let state,l = get_contact_map state in - let () = show_title state in - let state, l = - Array.fold_left - (fun (state,list) -> function - | None -> (state,list) - | Some site_node -> - let a = site_node.User_graph.node_type in - let interface = site_node.User_graph.node_sites in - let state,acc = - Array.fold_left - (fun (state,acc) site -> - let x = site.User_graph.site_name in - let states,rev_binding = - match site.User_graph.site_type with - | User_graph.Counter _ -> - failwith "KaSa does not deal with counters yet" - | User_graph.Port p -> - Option_util.unsome [] p.User_graph.port_states, - match p.User_graph.port_links with - | User_graph.LINKS l -> List.rev_map (fun ((_,i),j) -> (i,j)) l - | SOME | WHATEVER | TYPE _ -> assert false in - let state, binding' = - List.fold_left - (fun (state,list) (x,y) -> - let state,sx = - translate_agent state - ~message:"unknown agent name id" ~ml_pos:(Some __POS__) - (Ckappa_sig.agent_name_of_int x) - in - let state,sy = - translate_and_simplify_site - ~message:"unknown site name id" ~ml_pos:(Some __POS__) - state - (Ckappa_sig.agent_name_of_int x) - (Ckappa_sig.site_name_of_int y) - in - state,(Locality.dummy_annot sx, Locality.dummy_annot sy)::list) - (state,[]) rev_binding + error, (list_a'', list_b'')) + sitemap) + contact_map + in + let contact_map = convert_contact_map_map_to_list contact_map in + let error, contact_map = reindex parameters error handler contact_map in + Remanent_state.set_errors error state, [| Array.of_list contact_map |] + + let compute_contact_map ?(accuracy_level = Public_data.Low) _show_title = + compute_map_gen get_internal_contact_map Remanent_state.set_contact_map + convert_contact_map ~accuracy_level + + let get_contact_map ?(accuracy_level = Public_data.Low) = + get_gen + (Remanent_state.get_contact_map accuracy_level) + (compute_contact_map ~accuracy_level + ~do_we_show_title:(fun _ -> true) + ~log_title:(fun x -> + match x with + | Public_data.Low -> Some "Compute the contact map" + | Public_data.Medium | Public_data.High | Public_data.Full -> + Some "Refine the contact map")) + + let dump_contact_map accuracy state = + match Remanent_state.get_contact_map accuracy state with + | None -> () + | Some contact_map -> + let logger = + Remanent_parameters.get_logger (Remanent_state.get_parameters state) + in + Loggers.fprintf logger "Contact map:@ %a" User_graph.print_cc + contact_map + + let compute_internal_scc_decomposition + ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) + ?do_we_show_title:(_do_we_show_title = fun _ -> false) + ?log_title:(_log_title = "") _show_title state = + let parameters = Remanent_state.get_parameters state in + let accuracy_level = accuracy_level_cm in + let state, contact_map = get_internal_contact_map ~accuracy_level state in + let errors = get_errors state in + let errors, cm_graph = + Contact_map_scc.convert_contact_map parameters errors contact_map + in + let state, (static, dynamic) = get_reachability_analysis state in + let state, handler = get_handler state in + let errors, dynamic, cm_graph = + match accuracy_level_scc with + | Public_data.Low -> errors, dynamic, cm_graph + | Public_data.Medium | Public_data.High | Public_data.Full -> + let maybe_reachable _parameters error static dynamic = + Reachability.maybe_reachable static dynamic error + Analyzer_headers.Embeddings + in + Contact_map_scc.filter_edges_in_converted_contact_map parameters + errors handler static dynamic maybe_reachable cm_graph + in + let state = + Remanent_state.set_reachability_result (static, dynamic) state + in + let errors, graph_scc = + Contact_map_scc.compute_graph_scc parameters errors cm_graph + in + let state = + Remanent_state.set_internal_scc_decomposition accuracy_level_cm + accuracy_level_scc graph_scc state + in + let state = Remanent_state.set_errors errors state in + state, graph_scc + + let get_internal_scc_decomposition ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) = + get_gen + (Remanent_state.get_internal_scc_decomposition accuracy_level_cm + accuracy_level_scc) + (compute_internal_scc_decomposition ~accuracy_level_cm + ~accuracy_level_scc + ~do_we_show_title:(fun _ -> true) + ~log_title: + "Decompose the contact map in strongly connected components") + + let get_internal_scc_decomposition_map state = + Remanent_state.get_internal_scc_decomposition_map state + + (*internal contact map*) + + (*((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)* + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)) list list*) + + (*scc = ((string * string) * (string * string)) list list*) + + let translate_scc_decomposition state + (internal_scc : internal_scc_decomposition) = + let error = Remanent_state.get_errors state in + let parameters = get_parameters state in + let state, handler = get_handler state in + let error, scc = + List.fold_left + (fun (error, store_result) list -> + let error, store_list = + List.fold_left + (fun (error, store_result) ((ag, st), (ag', st')) -> + let error, agent = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler ag + in + let error, site = + Handler.translate_site parameters error handler ag st in - let states' = - NamedDecls.create - (Tools.array_map_of_list - (fun i -> (Locality.dummy_annot i,())) states) + let site = simplify_site site in + let error, agent' = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler ag' in - state, - (Locality.dummy_annot x, - (states', - binding',None))::acc) - (state,[]) interface - in - state, - ((Locality.dummy_annot a, - NamedDecls.create - (Array.of_list acc) - ))::list) - (state,[]) l.(0) - in - let signature = Signature.create ~counters:[] true l in - Remanent_state.set_signature signature state, - signature - -let get_signature = - get_gen - Remanent_state.get_signature - compute_signature - -(******************************************************************) -(*Dump*) -(******************************************************************) - -let dump_signature state = - match Remanent_state.get_signature state with - | None -> () - | Some _signature -> () - -let dump_errors state = - Exception.print (Remanent_state.get_parameters state) - (Remanent_state.get_errors state) - -let dump_errors_light state = - Exception.print_errors_light_for_kasim - (Remanent_state.get_parameters state) - (Remanent_state.get_errors state) - -(******************************************************************) -(*Dead rules*) -(******************************************************************) - -let compute_dead_rules _show_title state = - let state, _ = get_reachability_analysis state in - match - Remanent_state.get_dead_rules state - with - | Some l -> state, l - | None -> assert false - -let get_dead_rules = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"Detecting which rules may be triggered during simulations" - (* ~dump:dump_raw_internal_contact_map *) - Remanent_state.get_dead_rules - compute_dead_rules - -let compute_separating_transitions _show_title state = - let parameters = get_parameters state in - let parameters' = - Remanent_parameters.set_compute_separating_transitions parameters true in - let state' = set_parameters parameters' state in - let state', _ = compute_reachability_result _show_title state' in - let state', _ = get_reachability_analysis state' in - let state = set_parameters parameters state' in - match - Remanent_state.get_separating_transitions state - with - | Some l -> state, l - | None -> assert false - -let get_separating_transitions = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"Detecting separating transitions" - Remanent_state.get_separating_transitions - compute_separating_transitions - -(******************************************************************) -(*Dead agents*) -(******************************************************************) - -let compute_dead_agents _show_title state = - let state,_ = get_reachability_analysis state in - match - Remanent_state.get_dead_agents state - with - | Some map -> state, map - | None -> assert false - -let get_dead_agents = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"Detecting which agents may occur during simulations" - (* ~dump:dump_raw_internal_contact_map *) - Remanent_state.get_dead_agents - compute_dead_agents + let error, site' = + Handler.translate_site parameters error handler ag' st' + in + let site' = simplify_site site' in + let pair = (agent, site), (agent', site') in + error, pair :: store_result) + (error, []) list + in + error, store_list :: store_result) + (error, [ [] ]) internal_scc + in + let state = set_errors error state in + state, scc + + let compute_map2_gen get store convert + ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) + ?(do_we_show_title = fun _ -> true) ?log_title state = + let show_title = + match log_title with + | None -> fun _ -> () + | Some log_title -> + compute_show_title do_we_show_title + (log_title accuracy_level_cm accuracy_level_scc) + in + let () = show_title state in + let state, internal = + get ?accuracy_level_cm:(Some accuracy_level_cm) + ?accuracy_level_scc:(Some accuracy_level_scc) state + in + let state, rep = convert state internal in + store accuracy_level_cm accuracy_level_scc rep state, rep + + let compute_scc_map ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) _show_title = + compute_map2_gen get_internal_scc_decomposition + Remanent_state.set_scc_decomposition translate_scc_decomposition + ~accuracy_level_cm ~accuracy_level_scc + + let get_scc_decomposition ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) + ?(do_we_show_title = fun _ -> true) + ?(log_title = fun _ _ -> Some "Detect potential polymers") = + get_gen + (Remanent_state.get_scc_decomposition accuracy_level_cm + accuracy_level_scc) + (compute_scc_map ~accuracy_level_cm ~accuracy_level_scc + ~do_we_show_title ~log_title) + + let dump_internal_scc_decomposition ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) state = + let parameters = Remanent_state.get_parameters state in + let state, handler = get_handler state in + let logger = Remanent_parameters.get_logger parameters in + let state, graph_scc = + get_internal_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc + state + in + let error = get_errors state in + let () = Loggers.fprintf logger "Potential polymerization:" in + let () = Loggers.print_newline logger in + let error = + List.fold_left + (fun error list -> + let error = + List.fold_left + (fun error ((ag, st), (ag', st')) -> + let error, agent_name = + Handler.string_of_agent parameters error handler ag + in + let error, site_name = + Handler.string_of_site parameters error handler ag st + in + let error, agent_name' = + Handler.string_of_agent parameters error handler ag' + in + let error, site_name' = + Handler.string_of_site parameters error handler ag' st' + in + let () = + Loggers.fprintf logger " (%s,%s)--(%s,%s); " agent_name + site_name agent_name' site_name' + in + let () = Loggers.print_newline logger in + error) + error list + in + let () = Loggers.print_newline logger in + error) + error graph_scc + in + let state = set_errors error state in + state -(****************************************************************) -(*constraints_list*) -(****************************************************************) + let dump_scc_decomposition ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) state = + let parameters = Remanent_state.get_parameters state in + let logger = Remanent_parameters.get_logger parameters in + let state, graph_scc = + get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc state + in + let error = get_errors state in + let () = Loggers.fprintf logger "Potential polymerization:" in + let () = Loggers.print_newline logger in + let error = + List.fold_left + (fun error list -> + let error = + List.fold_left + (fun error ((agent_name, site_name), (agent_name', site_name')) -> + let () = + Loggers.fprintf logger "(%s,%s)--(%s,%s); " agent_name + site_name agent_name' site_name' + in + error) + error list + in + let () = Loggers.print_newline logger in + error) + error graph_scc + in + let state = set_errors error state in + state -let compute_internal_constraints_list _show_title state = - let state,_ = get_reachability_analysis state in - match - Remanent_state.get_internal_constraints_list state - with - | None -> - let error = Remanent_state.get_errors state in - let parameters = Remanent_state.get_parameters state in - let error, output = warn parameters error __POS__ Exit [] in - let state = Remanent_state.set_errors error state in - state, output - | Some output -> state, output - -let get_internal_constraints_list = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"Extract refinement lemmas" - Remanent_state.get_internal_constraints_list - compute_internal_constraints_list - -let compute_constraints_list _show_title state = - let error = Remanent_state.get_errors state in - let state, internal_constraints_list = - get_internal_constraints_list state - in - let error, constraints_list = - List.fold_left - (fun (error, constraints_list) (domain_name, lemma_list) -> - let error, current_list = - List.fold_left (fun (error, current_list) lem -> - let hyp = Public_data.get_hyp lem in - let refine = Public_data.get_refinement lem in - let string_version = - Site_graphs.KaSa_site_graph.get_string_version - hyp - in - let error, site_graph = - Ckappa_site_graph.site_graph_to_list error - string_version - in - let error, refinement = - Ckappa_site_graph.site_graph_list_to_list error - refine - in - let lemma = - { - Public_data.hyp = site_graph; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in - error, current_list - ) (error, []) lemma_list - in - (*------------------------------------------------------*) - let pair_list = - (domain_name, List.rev current_list) :: constraints_list + let get_influence_map ?(accuracy_level = Public_data.Low) + ?(do_we_show_title = fun _ -> true) + ?(log_title = + fun x -> + match x with + | Public_data.Low -> Some "Compute the influence map" + | Public_data.Medium | Public_data.High | Public_data.Full -> + Some "Refine the influence map") = + get_gen + (Remanent_state.get_influence_map accuracy_level) + (compute_influence_map ~accuracy_level ~do_we_show_title ~log_title) + + let output_internal_contact_map ?logger ?(accuracy_level = Public_data.Low) + state = + let parameters = Remanent_state.get_parameters state in + let state, contact_map = get_internal_contact_map ~accuracy_level state in + let state, handler = get_handler state in + let error = get_errors state in + let scc_contact_map = + Remanent_state.get_internal_scc_decomposition_map state + in + let error = + match Remanent_parameters.get_cm_format parameters with + | DOT -> + Preprocess.dot_of_contact_map ?logger parameters error handler + scc_contact_map contact_map + | GEPHI -> + Preprocess.gexf_of_contact_map ?logger parameters error handler + scc_contact_map contact_map + | _ -> + let error, () = warn parameters error __POS__ Exit () in + error + in + set_errors error state + + (*contact map interge *) + + let compute_contact_map_int show_title state = + let state, _, _, contactmap = compute_env_init show_title state in + state, contactmap + + let get_contact_map_int = + get_gen ~phase:StoryProfiling.LKappa_signature + Remanent_state.get_contact_map_int compute_contact_map_int + + (*Raw contact map*) + + let compute_raw_contact_map show_title state = + let sol = ref Mods.StringSetMap.Map.empty in + let state, handler = get_prehandler state in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let add_link (a, b) (c_id, d_id) sol = + let sol_a = + Mods.StringSetMap.Map.find_default Mods.StringSetMap.Map.empty a sol in - error, pair_list - ) (error, []) internal_constraints_list - in - let state = - Remanent_state.set_constraints_list constraints_list state in - let state = Remanent_state.set_errors error state in - state, constraints_list - - let get_constraints_list = - get_gen - ~do_we_show_title:title_only_in_kasa - ~log_title:"translate refinement lemmas" - Remanent_state.get_constraints_list - compute_constraints_list - - let output_internal_constraints_list ?logger state = - let state, constraints_list = get_internal_constraints_list state in - let parameters = Remanent_state.get_parameters state in - let error = Remanent_state.get_errors state in - let state, kappa_handler = get_handler state in - (*PRINT*) - let error = - Ckappa_site_graph.print_internal_pattern - ?logger parameters error - kappa_handler - constraints_list - in - let state = Remanent_state.set_errors error state in - state - -let get_constraints_list_to_json state = - let state, constraints_list = - get_constraints_list state - in - state, - Remanent_state.lemmas_list_to_json constraints_list - -(*********************************************************) -(*Symmetries*) -(*********************************************************) - -let compute_symmetries - ?accuracy_level:(accuracy_level=Public_data.Low) - _show_title state = - let state, env = get_env state in - let state, init = get_init state in - let state, contact_map_int = get_contact_map_int state in - match env, init, contact_map_int with - | None, _, _ | _, None, _ | _, _, None -> state, None - | Some env, Some init, Some contact_map_int -> - begin - let rules = - Model.fold_rules (fun _ acc r -> r :: acc) [] env + let l, old = Mods.StringSetMap.Map.find_default ([], []) b sol_a in + Mods.StringSetMap.Map.add a + (Mods.StringSetMap.Map.add b + ( l, + ( Ckappa_sig.int_of_agent_name c_id, + Ckappa_sig.int_of_site_name d_id ) + :: old ) + sol_a) + sol + in + let add_link (a, b) (a_id, b_id) (c, d) (c_id, d_id) sol = + add_link (a, b) (c_id, d_id) (add_link (c, d) (a_id, b_id) sol) in + (*----------------------------------------------------------------*) + let add_internal_state (a, b) c sol = + match c with + | Ckappa_sig.Counter _ | Ckappa_sig.Binding _ -> sol + | Ckappa_sig.Internal state -> + let sol_a = + Mods.StringSetMap.Map.find_default Mods.StringSetMap.Map.empty a sol + in + let old, l = Mods.StringSetMap.Map.find_default ([], []) b sol_a in + Mods.StringSetMap.Map.add a + (Mods.StringSetMap.Map.add b (state :: old, l) sol_a) + sol + in + (*----------------------------------------------------------------*) + let () = show_title state in + let error = + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .iter parameters error + (fun parameters error (i, j) s -> + let error, ag = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler i + in + let error, site = + Handler.translate_site parameters error handler i j + in + let site = simplify_site site in + let error = + Ckappa_sig.Dictionary_of_States.iter parameters error + (fun _parameters error _s state () () -> + let () = sol := add_internal_state (ag, site) state !sol in + error) + s + in + error) + handler.Cckappa_sig.states_dic + in + (*----------------------------------------------------------------*) + let sol = !sol in + let error, sol = + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .fold parameters error + (fun _parameters error (i, (j, _k)) (i', j', _k') sol -> + let error, ag_i = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler i + in + let error, site_j = + Handler.translate_site parameters error handler i j + in + let site_j = simplify_site site_j in + let error, ag_i' = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters error handler i' + in + let error, site_j' = + Handler.translate_site parameters error handler i' j' + in + let site_j' = simplify_site site_j' in + let sol = + add_link (ag_i, site_j) (i, j) (ag_i', site_j') (i', j') sol + in + error, sol) + handler.Cckappa_sig.dual sol + in + let sol = + Mods.StringSetMap.Map.map + (Mods.StringSetMap.Map.map (fun (l, x) -> List.rev l, x)) + sol + in + let sol = convert_contact_map_map_to_list sol in + let error, sol = reindex parameters error handler sol in + let sol = [| Array.of_list sol |] in + ( Remanent_state.set_errors error + (Remanent_state.set_contact_map Public_data.Low sol state), + sol ) + + let get_raw_contact_map = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"Compute the contact map" + (Remanent_state.get_contact_map Public_data.Low) + compute_raw_contact_map + + (******************************************************************) + (*signature*) + (******************************************************************) + + let compute_signature show_title state = + let state, l = get_contact_map state in + let () = show_title state in + let state, l = + Array.fold_left + (fun (state, list) -> function + | None -> state, list + | Some site_node -> + let a = site_node.User_graph.node_type in + let interface = site_node.User_graph.node_sites in + let state, acc = + Array.fold_left + (fun (state, acc) site -> + let x = site.User_graph.site_name in + let states, rev_binding = + match site.User_graph.site_type with + | User_graph.Counter _ -> + failwith "KaSa does not deal with counters yet" + | User_graph.Port p -> + ( Option_util.unsome [] p.User_graph.port_states, + (match p.User_graph.port_links with + | User_graph.LINKS l -> + List.rev_map (fun ((_, i), j) -> i, j) l + | SOME | WHATEVER | TYPE _ -> assert false) ) + in + let state, binding' = + List.fold_left + (fun (state, list) (x, y) -> + let state, sx = + translate_agent state + ~message:"unknown agent name id" + ~ml_pos:(Some __POS__) + (Ckappa_sig.agent_name_of_int x) + in + let state, sy = + translate_and_simplify_site + ~message:"unknown site name id" + ~ml_pos:(Some __POS__) state + (Ckappa_sig.agent_name_of_int x) + (Ckappa_sig.site_name_of_int y) + in + ( state, + (Loc.annot_with_dummy sx, Loc.annot_with_dummy sy) + :: list )) + (state, []) rev_binding + in + let states' = + NamedDecls.create + (Tools.array_map_of_list + (fun i -> Loc.annot_with_dummy i, ()) + states) + in + ( state, + ( Loc.annot_with_dummy x, + { + Signature.internal_state = states'; + links = Some binding'; + counters_info = None; + } ) + :: acc )) + (state, []) interface + in + ( state, + (Loc.annot_with_dummy a, NamedDecls.create_from_list acc) + :: list )) + (state, []) l.(0) + in + + let agent_sigs = + LKappa_compiler.agent_sigs_of_agent_sigs_with_links_as_lists + ~build_contact_map:true + (NamedDecls.create_from_list l) + in + let signature = Signature.create ~counters_per_agent:[] agent_sigs in + Remanent_state.set_signature signature state, signature + + let get_signature = get_gen Remanent_state.get_signature compute_signature + + (******************************************************************) + (*Dump*) + (******************************************************************) + + let dump_signature state = + match Remanent_state.get_signature state with + | None -> () + | Some _signature -> () + + let dump_errors state = + Exception.print + (Remanent_state.get_parameters state) + (Remanent_state.get_errors state) + + let dump_errors_light state = + Exception.print_errors_light_for_kasim + (Remanent_state.get_parameters state) + (Remanent_state.get_errors state) + + (******************************************************************) + (*Dead rules*) + (******************************************************************) + + let compute_dead_rules _show_title state = + let state, _ = get_reachability_analysis state in + match Remanent_state.get_dead_rules state with + | Some l -> state, l + | None -> assert false + + let get_dead_rules = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"Detecting which rules may be triggered during simulations" + (* ~dump:dump_raw_internal_contact_map *) + Remanent_state.get_dead_rules compute_dead_rules + + let compute_separating_transitions _show_title state = let parameters = get_parameters state in - let cache = LKappa_auto.init_cache () in - let cc_cache = Pattern.PreEnv.of_env (Model.domain env) in - let _cc_cache, chemical_species = - Symmetry_interface.species_of_initial_state_env - ~debugMode:false env contact_map_int - cc_cache init in - let state, contact_map = - get_contact_map ~accuracy_level state - in - let rate_convention = - Remanent_parameters.get_rate_convention parameters - in - let _cache, symmetries = - Symmetries.detect_symmetries - parameters - env - cache - rate_convention - chemical_species - rules - contact_map + let parameters' = + Remanent_parameters.set_compute_separating_transitions parameters true + in + let state' = set_parameters parameters' state in + let state', _ = compute_reachability_result _show_title state' in + let state', _ = get_reachability_analysis state' in + let state = set_parameters parameters state' in + match Remanent_state.get_separating_transitions state with + | Some l -> state, l + | None -> assert false + + let get_separating_transitions = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"Detecting separating transitions" + Remanent_state.get_separating_transitions compute_separating_transitions + + (******************************************************************) + (*Dead agents*) + (******************************************************************) + + let compute_dead_agents _show_title state = + let state, _ = get_reachability_analysis state in + match Remanent_state.get_dead_agents state with + | Some map -> state, map + | None -> assert false + + let get_dead_agents = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"Detecting which agents may occur during simulations" + (* ~dump:dump_raw_internal_contact_map *) + Remanent_state.get_dead_agents compute_dead_agents + + (****************************************************************) + (*constraints_list*) + (****************************************************************) + + let compute_internal_constraints_list _show_title state = + let state, _ = get_reachability_analysis state in + match Remanent_state.get_internal_constraints_list state with + | None -> + let error = Remanent_state.get_errors state in + let parameters = Remanent_state.get_parameters state in + let error, output = warn parameters error __POS__ Exit [] in + let state = Remanent_state.set_errors error state in + state, output + | Some output -> state, output + + let get_internal_constraints_list = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"Extract refinement lemmas" + Remanent_state.get_internal_constraints_list + compute_internal_constraints_list + + let compute_constraints_list _show_title state = + let error = Remanent_state.get_errors state in + let state, internal_constraints_list = + get_internal_constraints_list state + in + let error, constraints_list = + List.fold_left + (fun (error, constraints_list) (domain_name, lemma_list) -> + let error, current_list = + List.fold_left + (fun (error, current_list) lem -> + let hyp = Public_data.get_hyp lem in + let refine = Public_data.get_refinement lem in + let string_version = + Site_graphs.KaSa_site_graph.get_string_version hyp + in + let error, site_graph = + Ckappa_site_graph.site_graph_to_list error string_version + in + let error, refinement = + Ckappa_site_graph.site_graph_list_to_list error refine + in + let lemma = + { Public_data.hyp = site_graph; Public_data.refinement } + in + let current_list = lemma :: current_list in + error, current_list) + (error, []) lemma_list + in + (*------------------------------------------------------*) + let pair_list = + (domain_name, List.rev current_list) :: constraints_list + in + error, pair_list) + (error, []) internal_constraints_list + in + let state = Remanent_state.set_constraints_list constraints_list state in + let state = Remanent_state.set_errors error state in + state, constraints_list + + let get_constraints_list = + get_gen ~do_we_show_title:title_only_in_kasa + ~log_title:"translate refinement lemmas" + Remanent_state.get_constraints_list compute_constraints_list + + let output_internal_constraints_list ?logger state = + let state, constraints_list = get_internal_constraints_list state in + let parameters = Remanent_state.get_parameters state in + let error = Remanent_state.get_errors state in + let state, kappa_handler = get_handler state in + (*PRINT*) + let error = + Ckappa_site_graph.print_internal_pattern ?logger parameters error + kappa_handler constraints_list in + let state = Remanent_state.set_errors error state in + state + + let get_constraints_list_to_json state = + let state, constraints_list = get_constraints_list state in + state, Remanent_state.lemmas_list_to_json constraints_list + + (*********************************************************) + (*Symmetries*) + (*********************************************************) + + let compute_symmetries ?(accuracy_level = Public_data.Low) _show_title state + = + let state, env = get_env state in + let state, init = get_init state in + let state, contact_map_int = get_contact_map_int state in + match env, init, contact_map_int with + | None, _, _ | _, None, _ | _, _, None -> state, None + | Some env, Some init, Some contact_map_int -> + let rules = Model.fold_rules (fun _ acc r -> r :: acc) [] env in + let parameters = get_parameters state in + let cache = LKappa_auto.init_cache () in + let cc_cache = Pattern.PreEnv.of_env (Model.domain env) in + let _cc_cache, chemical_species = + Symmetry_interface.species_of_initial_state_env ~debug_mode:false env + contact_map_int cc_cache init + in + let state, contact_map = get_contact_map ~accuracy_level state in + let rate_convention = + Remanent_parameters.get_rate_convention parameters + in + let _cache, symmetries = + Symmetries.detect_symmetries parameters env cache rate_convention + chemical_species rules contact_map + in state, Some symmetries - end - -let get_symmetric_sites - ?accuracy_level:(accuracy_level=Public_data.Low) = - get_gen - (Remanent_state.get_symmetries accuracy_level) - (compute_symmetries ~accuracy_level ) - -let output_symmetries - ?logger - ?accuracy_level:(accuracy_level=Public_data.Low) - state = - let parameters = Remanent_state.get_parameters state in - let parameters = - match logger with - | None -> parameters - | Some logger -> Remanent_parameters.set_logger parameters logger - in - let state, sym = get_symmetric_sites ~accuracy_level state in - let state, env = get_env state in - match sym, env with - | None, _ | _, None -> state - | Some sym, Some env -> - let () = Symmetries.print_symmetries parameters env sym in - state - -let get_data = Remanent_state.get_data - -end + + let get_symmetric_sites ?(accuracy_level = Public_data.Low) = + get_gen + (Remanent_state.get_symmetries accuracy_level) + (compute_symmetries ~accuracy_level) + + let output_symmetries ?logger ?(accuracy_level = Public_data.Low) state = + let parameters = Remanent_state.get_parameters state in + let parameters = + match logger with + | None -> parameters + | Some logger -> Remanent_parameters.set_logger parameters logger + in + let state, sym = get_symmetric_sites ~accuracy_level state in + let state, env = get_env state in + match sym, env with + | None, _ | _, None -> state + | Some sym, Some env -> + let () = Symmetries.print_symmetries parameters env sym in + state + + let get_data = Remanent_state.get_data + end diff --git a/core/KaSa_rep/export/export_to_KaDE.ml b/core/KaSa_rep/export/export_to_KaDE.ml index 7fc2f4eca8..9f7e6a928a 100644 --- a/core/KaSa_rep/export/export_to_KaDE.ml +++ b/core/KaSa_rep/export/export_to_KaDE.ml @@ -11,34 +11,31 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = -sig +module type Type = sig type state type parameters = Remanent_parameters_sig.parameters type errors = Exception.method_handler type handler = Cckappa_sig.kappa_handler - val init: ?compil:Ast.parsing_compil -> unit -> state + val init : ?compil:Ast.parsing_compil -> unit -> state + val get_parameters : state -> parameters + val set_parameters : parameters -> state -> state + val get_handler : state -> state * handler + val get_errors : state -> errors - val get_parameters: state -> parameters - val set_parameters: parameters -> state -> state - - val get_handler: state -> state * handler - - val get_errors: state -> errors - - val get_contact_map: + val get_contact_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * Public_data.contact_map + state -> + state * Public_data.contact_map end module Export = -functor (A:Analyzer.Analyzer) -> +functor + (A : Analyzer.Analyzer) + -> struct - - include Export.Export(A) + include Export.Export (A) let init ?compil () = init ?compil ~called_from:Remanent_parameters_sig.Server () - end diff --git a/core/KaSa_rep/export/export_to_KaDE.mli b/core/KaSa_rep/export/export_to_KaDE.mli index dd24f46d4e..f3fdda6a40 100644 --- a/core/KaSa_rep/export/export_to_KaDE.mli +++ b/core/KaSa_rep/export/export_to_KaDE.mli @@ -11,28 +11,22 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = - sig - type state - type parameters = Remanent_parameters_sig.parameters - type errors = Exception.method_handler - type handler = Cckappa_sig.kappa_handler - - val init: ?compil:Ast.parsing_compil -> unit -> state - - val get_parameters: state -> parameters - val set_parameters: parameters -> state -> state - - val get_handler: state -> state * handler - - val get_errors: state -> errors - - val get_contact_map: - ?accuracy_level:Public_data.accuracy_level -> state -> - state * Public_data.contact_map - - end - -module Export: - functor (Reachability : Analyzer.Analyzer) -> - Type +module type Type = sig + type state + type parameters = Remanent_parameters_sig.parameters + type errors = Exception.method_handler + type handler = Cckappa_sig.kappa_handler + + val init : ?compil:Ast.parsing_compil -> unit -> state + val get_parameters : state -> parameters + val set_parameters : parameters -> state -> state + val get_handler : state -> state * handler + val get_errors : state -> errors + + val get_contact_map : + ?accuracy_level:Public_data.accuracy_level -> + state -> + state * Public_data.contact_map +end + +module Export : functor (Reachability : Analyzer.Analyzer) -> Type diff --git a/core/KaSa_rep/export/export_to_KaSa.ml b/core/KaSa_rep/export/export_to_KaSa.ml index 61a41fe3a6..8f53a24a11 100644 --- a/core/KaSa_rep/export/export_to_KaSa.ml +++ b/core/KaSa_rep/export/export_to_KaSa.ml @@ -11,146 +11,144 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = -sig +module type Type = sig type state type parameters = Remanent_parameters_sig.parameters type errors = Exception.method_handler type internal_contact_map type internal_scc_decomposition = Remanent_state.internal_scc_decomposition type contact_map = Public_data.contact_map - type internal_influence_map = Remanent_state.internal_influence_map - type bidirectional_influence_map - type internal_constraints_list = Remanent_state.internal_constraints_list val empty_constraints_list : internal_constraints_list type handler = Cckappa_sig.kappa_handler - type c_compilation = Cckappa_sig.compil - type reachability_analysis - type ode_flow - type ctmc_flow - val init: - unit -> state - - val set_errors: errors -> state -> state - - val set_parameters: parameters -> state -> state + val init : unit -> state + val set_errors : errors -> state -> state + val set_parameters : parameters -> state -> state + val get_parameters : state -> parameters + val get_handler : state -> state * handler + val get_errors : state -> errors + val get_env : state -> state * Model.t option + val get_c_compilation : state -> state * c_compilation - val get_parameters: state -> parameters + (**************************************************) + (*work in process*) - val get_handler: state -> state * handler + val get_contact_map : + ?accuracy_level:Public_data.accuracy_level -> state -> state * contact_map - val get_errors: state -> errors + val dump_contact_map : Public_data.accuracy_level -> state -> unit - val get_env: state -> state * Model.t option - - val get_c_compilation: state -> state * c_compilation - - -(**************************************************) -(*work in process*) - -val get_contact_map : -?accuracy_level:Public_data.accuracy_level -> -state -> state * contact_map - -val dump_contact_map : -Public_data.accuracy_level -> -state -> unit - -val get_scc_decomposition : - ?accuracy_level_cm:Public_data.accuracy_level -> - ?accuracy_level_scc:Public_data.accuracy_level -> - state -> state * - internal_scc_decomposition + val get_scc_decomposition : + ?accuracy_level_cm:Public_data.accuracy_level -> + ?accuracy_level_scc:Public_data.accuracy_level -> + state -> + state * internal_scc_decomposition -val output_scc_decomposition : - ?accuracy_level_cm:Public_data.accuracy_level -> - ?accuracy_level_scc:Public_data.accuracy_level -> - state -> state + val output_scc_decomposition : + ?accuracy_level_cm:Public_data.accuracy_level -> + ?accuracy_level_scc:Public_data.accuracy_level -> + state -> + state -(**************************************************) + (**************************************************) - val get_internal_contact_map: + val get_internal_contact_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * internal_contact_map + state -> + state * internal_contact_map - val get_influence_map: + val get_influence_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * internal_influence_map + state -> + state * internal_influence_map - val get_local_influence_map: + val get_local_influence_map : ?accuracy_level:Public_data.accuracy_level -> - ?fwd:int -> ?bwd:int -> total:int -> Ckappa_sig.c_rule_id -> - state -> state * internal_influence_map - - val get_reachability_analysis: state -> state * reachability_analysis + ?fwd:int -> + ?bwd:int -> + total:int -> + Ckappa_sig.c_rule_id -> + state -> + state * internal_influence_map + val get_reachability_analysis : state -> state * reachability_analysis val get_constraints_list : state -> state * internal_constraints_list + val get_ctmc_flow : state -> state * ctmc_flow + val get_ode_flow : state -> state * ode_flow - val get_ctmc_flow: state -> state * ctmc_flow - - val get_ode_flow: state -> state * ode_flow - - val get_symmetric_sites: + val get_symmetric_sites : ?accuracy_level:Public_data.accuracy_level -> - state -> state * Remanent_state.symmetric_sites + state -> + state * Remanent_state.symmetric_sites - val dump_c_compil: state -> c_compilation -> state + val dump_c_compil : state -> c_compilation -> state - val output_internal_contact_map: ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> state -> state + val output_internal_contact_map : + ?logger:Loggers.t -> + ?accuracy_level:Public_data.accuracy_level -> + state -> + state - val output_influence_map: ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> state -> state + val output_influence_map : + ?logger:Loggers.t -> + ?accuracy_level:Public_data.accuracy_level -> + state -> + state - val output_local_influence_map: ?logger:Loggers.t -> + val output_local_influence_map : + ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> - ?fwd:int -> ?bwd:int -> total:int -> Ckappa_sig.c_rule_id -> - state -> state + ?fwd:int -> + ?bwd:int -> + total:int -> + Ckappa_sig.c_rule_id -> + state -> + state - val output_constraints_list: ?logger:Loggers.t -> - state -> state + val output_constraints_list : ?logger:Loggers.t -> state -> state - val output_symmetries: + val output_symmetries : ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> - state -> state + state -> + state - val get_data: + val get_data : state -> - Cckappa_sig.kappa_handler option * Public_data.dead_rules - option * Remanent_state.separating_transitions option * int list option + Cckappa_sig.kappa_handler option + * Public_data.dead_rules option + * Remanent_state.separating_transitions option + * int list option end module Export = - functor (A:Analyzer.Analyzer) -> - struct - include Export.Export(A) - let init () = - init ~called_from:Remanent_parameters_sig.KaSa () - - let get_contact_map = get_contact_map - let dump_contact_map = dump_contact_map - - let get_internal_contact_map = get_internal_contact_map - let get_influence_map = get_internal_influence_map - let get_local_influence_map = get_local_internal_influence_map - let get_scc_decomposition = get_internal_scc_decomposition - - let get_constraints_list = get_internal_constraints_list - let output_internal_contact_map = output_internal_contact_map - let output_influence_map = output_internal_influence_map - let output_local_influence_map = output_local_internal_influence_map - let output_constraints_list = output_internal_constraints_list - let output_scc_decomposition = dump_internal_scc_decomposition - - let empty_constraints_list = [] - end +functor + (A : Analyzer.Analyzer) + -> + struct + include Export.Export (A) + + let init () = init ~called_from:Remanent_parameters_sig.KaSa () + let get_contact_map = get_contact_map + let dump_contact_map = dump_contact_map + let get_internal_contact_map = get_internal_contact_map + let get_influence_map = get_internal_influence_map + let get_local_influence_map = get_local_internal_influence_map + let get_scc_decomposition = get_internal_scc_decomposition + let get_constraints_list = get_internal_constraints_list + let output_internal_contact_map = output_internal_contact_map + let output_influence_map = output_internal_influence_map + let output_local_influence_map = output_local_internal_influence_map + let output_constraints_list = output_internal_constraints_list + let output_scc_decomposition = dump_internal_scc_decomposition + let empty_constraints_list = [] + end diff --git a/core/KaSa_rep/export/export_to_KaSa.mli b/core/KaSa_rep/export/export_to_KaSa.mli index f0a2bd0a1b..748a740f08 100644 --- a/core/KaSa_rep/export/export_to_KaSa.mli +++ b/core/KaSa_rep/export/export_to_KaSa.mli @@ -11,119 +11,120 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = -sig +module type Type = sig type state type parameters = Remanent_parameters_sig.parameters type errors = Exception.method_handler type internal_contact_map type internal_scc_decomposition = Remanent_state.internal_scc_decomposition type contact_map = Public_data.contact_map - - type internal_influence_map = - Remanent_state.internal_influence_map - + type internal_influence_map = Remanent_state.internal_influence_map type internal_constraints_list = Remanent_state.internal_constraints_list - type bidirectional_influence_map val empty_constraints_list : internal_constraints_list type handler = Cckappa_sig.kappa_handler - type c_compilation = Cckappa_sig.compil - type reachability_analysis - type ode_flow - type ctmc_flow - val init: unit -> state - - val set_errors: errors -> state -> state - - val set_parameters: parameters -> state -> state - - val get_parameters: state -> parameters - - val get_handler: state -> state * handler - - val get_errors: state -> errors - - val get_env: state -> state * Model.t option - - val get_c_compilation: state -> state * c_compilation + val init : unit -> state + val set_errors : errors -> state -> state + val set_parameters : parameters -> state -> state + val get_parameters : state -> parameters + val get_handler : state -> state * handler + val get_errors : state -> errors + val get_env : state -> state * Model.t option + val get_c_compilation : state -> state * c_compilation val get_contact_map : - ?accuracy_level:Public_data.accuracy_level -> - state -> state * contact_map + ?accuracy_level:Public_data.accuracy_level -> state -> state * contact_map - val dump_contact_map : - Public_data.accuracy_level -> - state -> unit + val dump_contact_map : Public_data.accuracy_level -> state -> unit val get_scc_decomposition : ?accuracy_level_cm:Public_data.accuracy_level -> ?accuracy_level_scc:Public_data.accuracy_level -> - state -> state * internal_scc_decomposition + state -> + state * internal_scc_decomposition val output_scc_decomposition : ?accuracy_level_cm:Public_data.accuracy_level -> ?accuracy_level_scc:Public_data.accuracy_level -> - state -> state + state -> + state -(**************************************************) + (**************************************************) - val get_internal_contact_map: + val get_internal_contact_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * internal_contact_map + state -> + state * internal_contact_map - val get_influence_map: + val get_influence_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * internal_influence_map + state -> + state * internal_influence_map - val get_local_influence_map: + val get_local_influence_map : ?accuracy_level:Public_data.accuracy_level -> - ?fwd:int -> ?bwd:int -> total:int -> Ckappa_sig.c_rule_id -> - state -> state * internal_influence_map - - val get_reachability_analysis: state -> state * reachability_analysis + ?fwd:int -> + ?bwd:int -> + total:int -> + Ckappa_sig.c_rule_id -> + state -> + state * internal_influence_map + val get_reachability_analysis : state -> state * reachability_analysis val get_constraints_list : state -> state * internal_constraints_list + val get_ctmc_flow : state -> state * ctmc_flow + val get_ode_flow : state -> state * ode_flow - val get_ctmc_flow: state -> state * ctmc_flow - - val get_ode_flow: state -> state * ode_flow - - val get_symmetric_sites: + val get_symmetric_sites : ?accuracy_level:Public_data.accuracy_level -> - state -> state * Remanent_state.symmetric_sites + state -> + state * Remanent_state.symmetric_sites - val dump_c_compil: state -> c_compilation -> state + val dump_c_compil : state -> c_compilation -> state - val output_internal_contact_map: - ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> state -> state + val output_internal_contact_map : + ?logger:Loggers.t -> + ?accuracy_level:Public_data.accuracy_level -> + state -> + state - val output_influence_map: - ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> state -> state + val output_influence_map : + ?logger:Loggers.t -> + ?accuracy_level:Public_data.accuracy_level -> + state -> + state - val output_local_influence_map: ?logger:Loggers.t -> + val output_local_influence_map : + ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> - ?fwd:int -> ?bwd:int -> total:int -> Ckappa_sig.c_rule_id -> - state -> state + ?fwd:int -> + ?bwd:int -> + total:int -> + Ckappa_sig.c_rule_id -> + state -> + state - val output_constraints_list: ?logger:Loggers.t -> - state -> state + val output_constraints_list : ?logger:Loggers.t -> state -> state - val output_symmetries: - ?logger:Loggers.t -> ?accuracy_level:Public_data.accuracy_level -> state -> state + val output_symmetries : + ?logger:Loggers.t -> + ?accuracy_level:Public_data.accuracy_level -> + state -> + state - val get_data: + val get_data : state -> - Cckappa_sig.kappa_handler option * Public_data.dead_rules option * Remanent_state.separating_transitions option * int list option + Cckappa_sig.kappa_handler option + * Public_data.dead_rules option + * Remanent_state.separating_transitions option + * int list option end -module Export: - functor (Reachability : Analyzer.Analyzer) -> - Type +module Export : functor (Reachability : Analyzer.Analyzer) -> Type diff --git a/core/KaSa_rep/export/export_to_KaSim.ml b/core/KaSa_rep/export/export_to_KaSim.ml index 2bb8a36a45..89b47ce403 100644 --- a/core/KaSa_rep/export/export_to_KaSim.ml +++ b/core/KaSa_rep/export/export_to_KaSim.ml @@ -11,27 +11,22 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = -sig +module type Type = sig type state + type contact_map = Public_data.contact_map - type contact_map = - Public_data.contact_map - - val init: + val init : ?compil:Ast.parsing_compil -> called_from:Remanent_parameters_sig.called_from -> - unit -> state - - val get_contact_map: - ?accuracy_level: Public_data.accuracy_level -> state -> state * contact_map - - val get_dead_rules: - state -> state * Public_data.dead_rules + unit -> + state - val dump_errors_light: state -> unit + val get_contact_map : + ?accuracy_level:Public_data.accuracy_level -> state -> state * contact_map - val flush_errors: state -> state + val get_dead_rules : state -> state * Public_data.dead_rules + val dump_errors_light : state -> unit + val flush_errors : state -> state end include Export diff --git a/core/KaSa_rep/export/export_to_KaSim.mli b/core/KaSa_rep/export/export_to_KaSim.mli index 6df0ece9fe..79973ef8d7 100644 --- a/core/KaSa_rep/export/export_to_KaSim.mli +++ b/core/KaSa_rep/export/export_to_KaSim.mli @@ -11,31 +11,22 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = - sig - type state +module type Type = sig + type state + type contact_map = Public_data.contact_map + val init : + ?compil:Ast.parsing_compil -> + called_from:Remanent_parameters_sig.called_from -> + unit -> + state - type contact_map = - Public_data.contact_map + val get_contact_map : + ?accuracy_level:Public_data.accuracy_level -> state -> state * contact_map + val get_dead_rules : state -> state * Public_data.dead_rules + val dump_errors_light : state -> unit + val flush_errors : state -> state +end - val init: - ?compil:Ast.parsing_compil -> - called_from:Remanent_parameters_sig.called_from -> - unit -> state - - val get_contact_map: - ?accuracy_level: Public_data.accuracy_level -> state -> state * contact_map - - val get_dead_rules: - state -> state * Public_data.dead_rules - - val dump_errors_light: state -> unit - - val flush_errors: state -> state - end - -module Export: - functor (Reachability : Analyzer.Analyzer) -> - Type +module Export : functor (Reachability : Analyzer.Analyzer) -> Type diff --git a/core/KaSa_rep/export/export_to_Trace_Checker.ml b/core/KaSa_rep/export/export_to_Trace_Checker.ml index c0c9c94ded..1b789fbe12 100644 --- a/core/KaSa_rep/export/export_to_Trace_Checker.ml +++ b/core/KaSa_rep/export/export_to_Trace_Checker.ml @@ -13,15 +13,18 @@ module A = (val Domain_selection.select_domain - ~reachability_parameters:{ - Remanent_parameters_sig.views = true; - Remanent_parameters_sig.site_across_bonds = true; - Remanent_parameters_sig.parallel_bonds = true; - Remanent_parameters_sig.dynamic_contact_map = true; - Remanent_parameters_sig.counters = true; - Remanent_parameters_sig.counter_domain = Remanent_parameters_sig.Mi; - } ()) -include Export.Export(A) + ~reachability_parameters: + { + Remanent_parameters_sig.views = true; + Remanent_parameters_sig.site_across_bonds = true; + Remanent_parameters_sig.parallel_bonds = true; + Remanent_parameters_sig.dynamic_contact_map = true; + Remanent_parameters_sig.counters = true; + Remanent_parameters_sig.counter_domain = Remanent_parameters_sig.Mi; + } + ()) + +include Export.Export (A) let init ?compil () = init ?compil ~called_from:Remanent_parameters_sig.Server () diff --git a/core/KaSa_rep/export/export_to_Trace_Checker.mli b/core/KaSa_rep/export/export_to_Trace_Checker.mli index 08cb14c361..b1445efd85 100644 --- a/core/KaSa_rep/export/export_to_Trace_Checker.mli +++ b/core/KaSa_rep/export/export_to_Trace_Checker.mli @@ -12,20 +12,16 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type state -val init: - ?compil:Ast.parsing_compil -> unit -> state +val init : ?compil:Ast.parsing_compil -> unit -> state -val query_inhibition_map: +val query_inhibition_map : ?accuracy_level:Public_data.accuracy_level -> state -> Remanent_state.rule_id -> Remanent_state.rule_id -> state * (Public_data.location * Public_data.location) list -val dump_errors_light: state -> unit - - -val flush_errors: state -> state +val dump_errors_light : state -> unit +val flush_errors : state -> state diff --git a/core/KaSa_rep/export/export_to_json.ml b/core/KaSa_rep/export/export_to_json.ml index e948a53517..9e39aba04d 100644 --- a/core/KaSa_rep/export/export_to_json.ml +++ b/core/KaSa_rep/export/export_to_json.ml @@ -11,104 +11,106 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = -sig +module type Type = sig type state - val init: ?compil:Ast.parsing_compil -> unit -> state + val init : ?compil:Ast.parsing_compil -> unit -> state - val get_contact_map: + val get_contact_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t + state -> + state * Yojson.Basic.t - val get_scc_decomposition: - ?accuracy_level_cm:Public_data.accuracy_level -> - ?accuracy_level_scc:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t + val get_scc_decomposition : + ?accuracy_level_cm:Public_data.accuracy_level -> + ?accuracy_level_scc:Public_data.accuracy_level -> + state -> + state * Yojson.Basic.t - val get_influence_map_nodes_location: - state -> state * Yojson.Basic.t + val get_influence_map_nodes_location : state -> state * Yojson.Basic.t - val get_influence_map: + val get_influence_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t + state -> + state * Yojson.Basic.t - val get_all_nodes_of_influence_map: + val get_all_nodes_of_influence_map : ?accuracy_level:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t + state -> + state * Yojson.Basic.t - val get_local_influence_map: + val get_local_influence_map : ?accuracy_level:Public_data.accuracy_level -> - ?bwd:int -> ?fwd:int -> total:int -> - ?origin:(int,int) Public_data.influence_node -> - state -> state * Yojson.Basic.t - - val origin_of_influence_map: state -> state * Yojson.Basic.t - val next_node_in_influence_map: - state -> (int,int) Public_data.influence_node option -> state * Yojson.Basic.t - val previous_node_in_influence_map: - state -> (int,int) Public_data.influence_node option -> state * Yojson.Basic.t - - val get_dead_rules: state -> state * Yojson.Basic.t - - val get_dead_agents: state -> state * Yojson.Basic.t - - val get_separating_transitions: state -> state * Yojson.Basic.t - - val get_constraints_list: state -> state * Yojson.Basic.t - - val get_errors: state -> Exception_without_parameter.method_handler - val get_errors_json: state -> Yojson.Basic.t - - val to_json: state -> Yojson.Basic.t - - val of_json: + ?bwd:int -> + ?fwd:int -> + total:int -> + ?origin:(int, int) Public_data.influence_node -> + state -> + state * Yojson.Basic.t + + val origin_of_influence_map : state -> state * Yojson.Basic.t + + val next_node_in_influence_map : + state -> + (int, int) Public_data.influence_node option -> + state * Yojson.Basic.t + + val previous_node_in_influence_map : + state -> + (int, int) Public_data.influence_node option -> + state * Yojson.Basic.t + + val get_dead_rules : state -> state * Yojson.Basic.t + val get_dead_agents : state -> state * Yojson.Basic.t + val get_separating_transitions : state -> state * Yojson.Basic.t + val get_constraints_list : state -> state * Yojson.Basic.t + val get_errors : state -> Exception_without_parameter.method_handler + val get_errors_json : state -> Yojson.Basic.t + val to_json : state -> Yojson.Basic.t + + val of_json : Yojson.Basic.t -> - Exception_without_parameter.method_handler * - Public_data.contact_map Public_data.AccuracyMap.t * - Public_data.influence_map Public_data.AccuracyMap.t * - Public_data.dead_rules option * Remanent_state.constraints_list option * - Public_data.separating_transitions option + Exception_without_parameter.method_handler + * Public_data.contact_map Public_data.AccuracyMap.t + * Public_data.influence_map Public_data.AccuracyMap.t + * Public_data.dead_rules option + * Remanent_state.constraints_list option + * Public_data.separating_transitions option end module Export = -functor (A:Analyzer.Analyzer) -> +functor + (A : Analyzer.Analyzer) + -> struct - - include Export.Export(A) + include Export.Export (A) let init ?compil () = init ?compil ~called_from:Remanent_parameters_sig.Server () - let get_contact_map - ?accuracy_level:(accuracy_level=Public_data.Low) state = + let get_contact_map ?(accuracy_level = Public_data.Low) state = let state, cm = get_contact_map ~accuracy_level state in - state, Public_data.contact_map_to_json (accuracy_level,cm) + state, Public_data.contact_map_to_json (accuracy_level, cm) - let get_scc_decomposition - ?accuracy_level_cm:(accuracy_level_cm=Public_data.Low) - ?accuracy_level_scc:(accuracy_level_scc=Public_data.Low) - state = + let get_scc_decomposition ?(accuracy_level_cm = Public_data.Low) + ?(accuracy_level_scc = Public_data.Low) state = let state, scc = - get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc state in - state, - Public_data.scc_to_json (accuracy_level_cm, accuracy_level_scc, scc) + get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc state + in + state, Public_data.scc_to_json (accuracy_level_cm, accuracy_level_scc, scc) let get_influence_map_nodes_location state = - let state, list = - get_pos_of_rules_and_vars state - in + let state, list = get_pos_of_rules_and_vars state in state, Public_data.pos_of_rules_and_vars_to_json list - let get_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) state = + let get_influence_map ?(accuracy_level = Public_data.Low) state = let state, influence_map = get_influence_map ~accuracy_level state in - state, Public_data.influence_map_to_json (accuracy_level,influence_map) + state, Public_data.influence_map_to_json (accuracy_level, influence_map) - let get_all_nodes_of_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) state = + let get_all_nodes_of_influence_map ?(accuracy_level = Public_data.Low) state + = let state, nodes = get_all_nodes_of_influence_map ~accuracy_level state in - state, Public_data.nodes_of_influence_map_to_json (accuracy_level,nodes) + state, Public_data.nodes_of_influence_map_to_json (accuracy_level, nodes) let convert_id_refined state i = let parameters = get_parameters state in @@ -118,53 +120,38 @@ functor (A:Analyzer.Analyzer) -> let state, nrules = nrules state in let state, nvars = nvars state in let error, refined_id_opt = - if i < nrules+nvars - then + if i < nrules + nvars then ( let error, refined_id = - convert_id_refined - parameters - error handler compil (Ckappa_sig.rule_id_of_int i) + convert_id_refined parameters error handler compil + (Ckappa_sig.rule_id_of_int i) in error, Some refined_id - else - Exception.warn parameters error __POS__ Exit None + ) else + Exception.warn parameters error __POS__ Exit None in let state = set_errors error state in state, refined_id_opt - - - let origin_of_influence_map state = - convert_id_refined state 0 - - let get_local_influence_map - ?accuracy_level:(accuracy_level=Public_data.Low) - ?bwd ?fwd ~total - ?origin - state = - let state, rule_id_int = - match origin - with - | Some (Public_data.Rule a) -> - state, a - | Some (Public_data.Var a) -> - let state, n = nrules state in - state, a+n - | None -> - state, 0 - in - let rule_id = Ckappa_sig.rule_id_of_int rule_id_int in - let state, influence_map = - get_local_influence_map - ~accuracy_level ?fwd ?bwd ~total - rule_id state - in - let state, origin = - convert_id_refined state rule_id_int - in - state, + let origin_of_influence_map state = convert_id_refined state 0 + + let get_local_influence_map ?(accuracy_level = Public_data.Low) ?bwd ?fwd + ~total ?origin state = + let state, rule_id_int = + match origin with + | Some (Public_data.Rule a) -> state, a + | Some (Public_data.Var a) -> + let state, n = nrules state in + state, a + n + | None -> state, 0 + in + let rule_id = Ckappa_sig.rule_id_of_int rule_id_int in + let state, influence_map = + get_local_influence_map ~accuracy_level ?fwd ?bwd ~total rule_id state + in + let state, origin = convert_id_refined state rule_id_int in + ( state, Public_data.local_influence_map_to_json - (accuracy_level,total,bwd,fwd,origin,influence_map) + (accuracy_level, total, bwd, fwd, origin, influence_map) ) let short_origin_of_influence_map state = let state, origin_opt = origin_of_influence_map state in @@ -175,44 +162,42 @@ functor (A:Analyzer.Analyzer) -> let state, nvars = nvars state in let n = nrules + nvars - 1 in let state, next_opt = - if n = -1 - then + if n = -1 then state, None - else + else ( let state, short_id_opt = match short_id_opt with | None -> short_origin_of_influence_map state - | Some _ -> state, short_id_opt in + | Some _ -> state, short_id_opt + in let parameters = get_parameters state in let error = get_errors state in let error, id_int = match short_id_opt with | Some (Public_data.Rule a) -> error, a - | Some (Public_data.Var a) -> error, a+nrules - | None -> - Exception.warn parameters error __POS__ Exit 0 + | Some (Public_data.Var a) -> error, a + nrules + | None -> Exception.warn parameters error __POS__ Exit 0 in let state = set_errors error state in if id_int = 0 then convert_id_refined state (max 0 n) else - convert_id_refined state (id_int-1) + convert_id_refined state (id_int - 1) + ) in let json = - JsonUtil.of_option Public_data.refined_influence_node_to_json - next_opt + JsonUtil.of_option Public_data.refined_influence_node_to_json next_opt in state, json - let next_node_in_influence_map state short_id_opt = + let next_node_in_influence_map state short_id_opt = let state, nrules = nrules state in let state, nvars = nvars state in let n = nrules + nvars - 1 in let state, node_opt = - if n = -1 - then + if n = -1 then state, None - else + else ( let state, short_id_opt = match short_id_opt with | None -> short_origin_of_influence_map state @@ -223,21 +208,20 @@ functor (A:Analyzer.Analyzer) -> let error, id_int = match short_id_opt with | Some (Public_data.Rule a) -> error, a - | Some (Public_data.Var a) -> error, a+nrules - | None -> - Exception.warn parameters error __POS__ Exit 0 + | Some (Public_data.Var a) -> error, a + nrules + | None -> Exception.warn parameters error __POS__ Exit 0 in let state = set_errors error state in - if id_int = n - then + if id_int = n then origin_of_influence_map state else - convert_id_refined state (id_int+1) + convert_id_refined state (id_int + 1) + ) in let json = JsonUtil.of_option Public_data.refined_influence_node_to_json node_opt in - state, json + state, json let origin_of_influence_map state = let state, node = origin_of_influence_map state in @@ -255,14 +239,12 @@ functor (A:Analyzer.Analyzer) -> let state, separating_transitions = get_separating_transitions state in state, Public_data.separating_transitions_to_json separating_transitions - let get_constraints_list state = - get_constraints_list_to_json state + let get_constraints_list state = get_constraints_list_to_json state let get_errors_json state = let error = get_errors state in Exception_without_parameter.to_json error let to_json = Remanent_state.to_json - let of_json = Remanent_state.of_json end diff --git a/core/KaSa_rep/export/export_to_json.mli b/core/KaSa_rep/export/export_to_json.mli index 6ca4a0a378..88cc67f56c 100644 --- a/core/KaSa_rep/export/export_to_json.mli +++ b/core/KaSa_rep/export/export_to_json.mli @@ -11,68 +11,73 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Type = - sig - type state - - val init: ?compil:Ast.parsing_compil -> unit -> state - - val get_contact_map: - ?accuracy_level:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t - - val get_scc_decomposition: - ?accuracy_level_cm:Public_data.accuracy_level -> - ?accuracy_level_scc:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t - - val get_influence_map_nodes_location: - state -> state * Yojson.Basic.t - - val get_influence_map: - ?accuracy_level:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t - - val get_all_nodes_of_influence_map: - ?accuracy_level:Public_data.accuracy_level -> - state -> state * Yojson.Basic.t - - val get_local_influence_map: - ?accuracy_level:Public_data.accuracy_level -> - ?bwd:int -> ?fwd:int -> total:int -> - ?origin:(int,int) Public_data.influence_node -> - state -> state * Yojson.Basic.t - - val origin_of_influence_map: state -> state * Yojson.Basic.t - val next_node_in_influence_map: - state -> (int,int) Public_data.influence_node option -> state * Yojson.Basic.t - val previous_node_in_influence_map: - state -> (int,int) Public_data.influence_node option -> state * Yojson.Basic.t - - val get_dead_rules: state -> state * Yojson.Basic.t - val get_dead_agents: state -> state * Yojson.Basic.t - - val get_separating_transitions: state -> state * Yojson.Basic.t - - val get_constraints_list: state -> state * Yojson.Basic.t - val get_errors: state -> Exception_without_parameter.method_handler - val get_errors_json: state -> Yojson.Basic.t - - val to_json: state -> Yojson.Basic.t - - val of_json: - Yojson.Basic.t -> - Exception_without_parameter.method_handler * - Public_data.contact_map Public_data.AccuracyMap.t * - Public_data.influence_map Public_data.AccuracyMap.t * - Public_data.dead_rules option * Remanent_state.constraints_list option * - Public_data.separating_transitions option - - - end - -module Export: - functor (Reachability : Analyzer.Analyzer) -> - Type +module type Type = sig + type state + + val init : ?compil:Ast.parsing_compil -> unit -> state + + val get_contact_map : + ?accuracy_level:Public_data.accuracy_level -> + state -> + state * Yojson.Basic.t + + val get_scc_decomposition : + ?accuracy_level_cm:Public_data.accuracy_level -> + ?accuracy_level_scc:Public_data.accuracy_level -> + state -> + state * Yojson.Basic.t + + val get_influence_map_nodes_location : state -> state * Yojson.Basic.t + + val get_influence_map : + ?accuracy_level:Public_data.accuracy_level -> + state -> + state * Yojson.Basic.t + + val get_all_nodes_of_influence_map : + ?accuracy_level:Public_data.accuracy_level -> + state -> + state * Yojson.Basic.t + + val get_local_influence_map : + ?accuracy_level:Public_data.accuracy_level -> + ?bwd:int -> + ?fwd:int -> + total:int -> + ?origin:(int, int) Public_data.influence_node -> + state -> + state * Yojson.Basic.t + + val origin_of_influence_map : state -> state * Yojson.Basic.t + + val next_node_in_influence_map : + state -> + (int, int) Public_data.influence_node option -> + state * Yojson.Basic.t + + val previous_node_in_influence_map : + state -> + (int, int) Public_data.influence_node option -> + state * Yojson.Basic.t + + val get_dead_rules : state -> state * Yojson.Basic.t + val get_dead_agents : state -> state * Yojson.Basic.t + val get_separating_transitions : state -> state * Yojson.Basic.t + val get_constraints_list : state -> state * Yojson.Basic.t + val get_errors : state -> Exception_without_parameter.method_handler + val get_errors_json : state -> Yojson.Basic.t + val to_json : state -> Yojson.Basic.t + + val of_json : + Yojson.Basic.t -> + Exception_without_parameter.method_handler + * Public_data.contact_map Public_data.AccuracyMap.t + * Public_data.influence_map Public_data.AccuracyMap.t + * Public_data.dead_rules option + * Remanent_state.constraints_list option + * Public_data.separating_transitions option +end + +module Export : functor (Reachability : Analyzer.Analyzer) -> Type (*val get_internal_constraints_list: state -> state * Yojson.Basic.t*) diff --git a/core/KaSa_rep/export/kasa_mpi.ml b/core/KaSa_rep/export/kasa_mpi.ml index 9da62512f6..e84a48ae4e 100644 --- a/core/KaSa_rep/export/kasa_mpi.ml +++ b/core/KaSa_rep/export/kasa_mpi.ml @@ -8,73 +8,88 @@ module A = (val Domain_selection.select_domain - ~reachability_parameters:{ - Remanent_parameters_sig.views = true; - Remanent_parameters_sig.site_across_bonds = true; - Remanent_parameters_sig.parallel_bonds = true; - Remanent_parameters_sig.dynamic_contact_map = true; - Remanent_parameters_sig.counter_domain = Remanent_parameters_sig.Mi ; - Remanent_parameters_sig.counters = true ; - } ()) + ~reachability_parameters: + { + Remanent_parameters_sig.views = true; + Remanent_parameters_sig.site_across_bonds = true; + Remanent_parameters_sig.parallel_bonds = true; + Remanent_parameters_sig.dynamic_contact_map = true; + Remanent_parameters_sig.counter_domain = Remanent_parameters_sig.Mi; + Remanent_parameters_sig.counters = true; + } + ()) -include Export_to_json.Export(A) +include Export_to_json.Export (A) let gState = let compil = Ast.empty_compil in ref (init ~compil ()) let send_exception post ?id e = - let head = match id with None ->[] | Some id -> ["id", `Int id] in + let head = + match id with + | None -> [] + | Some id -> [ "id", `Int id ] + in let reply = - `Assoc (head @ [ - "code", `String "ERROR"; - "data", Exception_without_parameter.to_json - (Exception_without_parameter.add_uncaught_error - (Exception_without_parameter.build_uncaught_exception - ~file_name:"kasa_mpi" e) - Exception_without_parameter.empty_error_handler); - ]) in + `Assoc + (head + @ [ + "code", `String "ERROR"; + ( "data", + Exception_without_parameter.to_json + (Exception_without_parameter.add_uncaught_error + (Exception_without_parameter.build_uncaught_exception + ~file_name:"kasa_mpi" e) + Exception_without_parameter.empty_error_handler) ); + ]) + in post (Yojson.Basic.to_string reply) let send_response post id x = let reply = if Exception_without_parameter.is_empty_error_handler (get_errors !gState) - then `Assoc [ "id", `Int id; "code", `String "SUCCESS"; "data", x ] - else `Assoc [ - "id", `Int id; - "code", `String "ERROR"; - "data", Exception_without_parameter.to_json (get_errors !gState) - ] in + then + `Assoc [ "id", `Int id; "code", `String "SUCCESS"; "data", x ] + else + `Assoc + [ + "id", `Int id; + "code", `String "ERROR"; + "data", Exception_without_parameter.to_json (get_errors !gState); + ] + in post (Yojson.Basic.to_string reply) let unpack_request text = - try match Yojson.Basic.from_string text with - | `Assoc [ "id", `Int id; "data", data ] - | `Assoc [ "data", data; "id", `Int id ] -> - Some (id,data) + try + match Yojson.Basic.from_string text with + | `Assoc [ ("id", `Int id); ("data", data) ] + | `Assoc [ ("data", data); ("id", `Int id) ] -> + Some (id, data) | _ -> None with _ -> None let on_message post text = match unpack_request text with - | Some(id, `List [ `String "INIT"; compil ]) -> + | Some (id, `List [ `String "INIT"; compil ]) -> (try let compil = Ast.compil_of_json compil in - let () = gState := - init ~compil () in + let () = gState := init ~compil () in send_response post id `Null with e -> send_exception post ~id e) - | Some(id,`List [ `String "CONTACT_MAP"; acc ]) -> + | Some (id, `List [ `String "CONTACT_MAP"; acc ]) -> let accuracy_level = Public_data.accuracy_of_json acc in let state, cm = get_contact_map ~accuracy_level !gState in let () = gState := state in send_response post id cm - | Some(id, (`List [ `String "CONTACT_MAP" ] | `String "CONTACT_MAP")) -> + | Some (id, (`List [ `String "CONTACT_MAP" ] | `String "CONTACT_MAP")) -> let accuracy_level = Public_data.Low in let state, cm = get_contact_map ~accuracy_level !gState in let () = gState := state in send_response post id cm - | Some(id, `List [ `String "INFLUENCE_MAP"; acc ; fwd; bwd; total; origin]) -> + | Some (id, `List [ `String "INFLUENCE_MAP"; acc; fwd; bwd; total; origin ]) + -> let accuracy_level = Public_data.accuracy_of_json acc in let error_msg = "bad int" in let fwd = JsonUtil.to_option (JsonUtil.to_int ~error_msg) fwd in @@ -88,121 +103,130 @@ let on_message post text = in let () = gState := state in send_response post id im - | Some(id, `List [ `String "INFLUENCE_MAP"; fwd; bwd; total; origin]) -> - let accuracy_level = Public_data.Low in - let error_msg = "bad int" in - let fwd = JsonUtil.to_option (JsonUtil.to_int ~error_msg) fwd in - let bwd = JsonUtil.to_option (JsonUtil.to_int ~error_msg) bwd in - let total = JsonUtil.to_int ~error_msg total in - let origin = - JsonUtil.to_option Public_data.short_influence_node_of_json origin - in - let state, im = - get_local_influence_map ~accuracy_level ?fwd ?bwd ~total ?origin !gState - in - let () = gState := state in - send_response post id im - | Some(id, `List [ `String "INFLUENCE_MAP"; acc ]) -> + | Some (id, `List [ `String "INFLUENCE_MAP"; fwd; bwd; total; origin ]) -> + let accuracy_level = Public_data.Low in + let error_msg = "bad int" in + let fwd = JsonUtil.to_option (JsonUtil.to_int ~error_msg) fwd in + let bwd = JsonUtil.to_option (JsonUtil.to_int ~error_msg) bwd in + let total = JsonUtil.to_int ~error_msg total in + let origin = + JsonUtil.to_option Public_data.short_influence_node_of_json origin + in + let state, im = + get_local_influence_map ~accuracy_level ?fwd ?bwd ~total ?origin !gState + in + let () = gState := state in + send_response post id im + | Some (id, `List [ `String "INFLUENCE_MAP"; acc ]) -> let accuracy_level = Public_data.accuracy_of_json acc in let state, im = get_influence_map ~accuracy_level !gState in let () = gState := state in send_response post id im - | Some(id, (`List [ `String "INFLUENCE_MAP" ] | `String "INFLUENCE_MAP")) -> + | Some (id, (`List [ `String "INFLUENCE_MAP" ] | `String "INFLUENCE_MAP")) -> let accuracy_level = Public_data.Low in let state, im = get_influence_map ~accuracy_level !gState in let () = gState := state in send_response post id im - | Some(id, (`List [ `String "INFLUENCE_MAP_ORIGINAL_NODE" ] - | `String "INFLUENCE_MAP_ORIGINAL_NODE")) -> + | Some + ( id, + ( `List [ `String "INFLUENCE_MAP_ORIGINAL_NODE" ] + | `String "INFLUENCE_MAP_ORIGINAL_NODE" ) ) -> let state, im = origin_of_influence_map !gState in let () = gState := state in send_response post id im - | Some(id, `List [ `String "INFLUENCE_MAP_NEXT_NODE";origin]) -> + | Some (id, `List [ `String "INFLUENCE_MAP_NEXT_NODE"; origin ]) -> let origin = JsonUtil.to_option Public_data.short_influence_node_of_json origin in let state, im = next_node_in_influence_map !gState origin in let () = gState := state in send_response post id im - | Some(id, `List [ `String "INFLUENCE_MAP_PREVIOUS_NODE";origin ]) -> + | Some (id, `List [ `String "INFLUENCE_MAP_PREVIOUS_NODE"; origin ]) -> let origin = JsonUtil.to_option Public_data.short_influence_node_of_json origin in let state, im = previous_node_in_influence_map !gState origin in let () = gState := state in send_response post id im - | Some(id, `List [ `String "INFLUENCE_MAP_ALL_NODES" ; acc ]) -> + | Some (id, `List [ `String "INFLUENCE_MAP_ALL_NODES"; acc ]) -> let accuracy_level = Public_data.accuracy_of_json acc in let state, rules = get_all_nodes_of_influence_map ~accuracy_level !gState in let () = gState := state in send_response post id rules - | Some(id, - (`List [ - `String "INFLUENCE_MAP_ALL_NODES"] - | `String "INFLUENCE_MAP_ALL_NODES")) - -> + | Some + ( id, + ( `List [ `String "INFLUENCE_MAP_ALL_NODES" ] + | `String "INFLUENCE_MAP_ALL_NODES" ) ) -> let accuracy_level = Public_data.Low in let state, rules = get_all_nodes_of_influence_map ~accuracy_level !gState in let () = gState := state in send_response post id rules - - | Some(id, (`List [ `String "INFLUENCE_MAP_NODES_LOCATION" ] | `String "INFLUENCE_MAP_NODES_LOCATION")) -> + | Some + ( id, + ( `List [ `String "INFLUENCE_MAP_NODES_LOCATION" ] + | `String "INFLUENCE_MAP_NODES_LOCATION" ) ) -> let state, list = get_influence_map_nodes_location !gState in let () = gState := state in send_response post id list - - | Some(id, (`List [ `String "DEAD_RULES" ] | `String "DEAD_RULES")) -> + | Some (id, (`List [ `String "DEAD_RULES" ] | `String "DEAD_RULES")) -> let state, rules = get_dead_rules !gState in let () = gState := state in send_response post id rules - | Some(id, (`List [ `String "DEAD_AGENTS" ] | `String "DEAD_AGENTS")) -> + | Some (id, (`List [ `String "DEAD_AGENTS" ] | `String "DEAD_AGENTS")) -> let state, agents = get_dead_agents !gState in let () = gState := state in send_response post id agents - | Some(id, (`List [ `String "NON_WEAKLY_REVERSIBLE_TRANSITIONS"] - | `String "NON_WEAKLY_REVERSIBLE_TRANSITIONS")) -> + | Some + ( id, + ( `List [ `String "NON_WEAKLY_REVERSIBLE_TRANSITIONS" ] + | `String "NON_WEAKLY_REVERSIBLE_TRANSITIONS" ) ) -> let state, transitions = get_separating_transitions !gState in let () = gState := state in send_response post id transitions - | Some(id, (`List [ `String "CONSTRAINTS" ] | `String "CONSTRAINTS")) -> + | Some (id, (`List [ `String "CONSTRAINTS" ] | `String "CONSTRAINTS")) -> let state, out = get_constraints_list !gState in let () = gState := state in send_response post id out - | Some(id, (`List [ `String "POLYMERS" ; acc_cm] )) -> + | Some (id, `List [ `String "POLYMERS"; acc_cm ]) -> + let accuracy_level_cm = Public_data.accuracy_of_json acc_cm in + let state, out = + get_scc_decomposition ~accuracy_level_cm + ~accuracy_level_scc:Public_data.Low !gState + in + let () = gState := state in + send_response post id out + | Some (id, `List [ `String "POLYMERS"; acc_cm; acc_scc ]) -> let accuracy_level_cm = Public_data.accuracy_of_json acc_cm in + let accuracy_level_scc = Public_data.accuracy_of_json acc_scc in let state, out = - get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc:Public_data.Low !gState + get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc !gState in let () = gState := state in send_response post id out - | Some(id, (`List [ `String "POLYMERS" ; acc_cm ; acc_scc ] )) -> - let accuracy_level_cm = Public_data.accuracy_of_json acc_cm in - let accuracy_level_scc = Public_data.accuracy_of_json acc_scc in - let state, out = - get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc !gState - in - let () = gState := state in - send_response post id out - | Some(id, (`List [ `String "POLYMERS" ; ] | `String "POLYMERS")) -> - let state, out = - get_scc_decomposition ~accuracy_level_cm:Public_data.Low ~accuracy_level_scc:Public_data.Low !gState - in - let () = gState := state in - send_response post id out - | Some(id, x) -> - send_exception - post ~id (Yojson.Basic.Util.Type_error("Invalid KaSa request",x)) + | Some (id, (`List [ `String "POLYMERS" ] | `String "POLYMERS")) -> + let state, out = + get_scc_decomposition ~accuracy_level_cm:Public_data.Low + ~accuracy_level_scc:Public_data.Low !gState + in + let () = gState := state in + send_response post id out + | Some (id, x) -> + send_exception post ~id + (Yojson.Basic.Util.Type_error ("Invalid KaSa request", x)) | None -> let message = - "Not a valid { id : _int_, data : ... } JSON message: "^text in + "Not a valid { id : _int_, data : ... } JSON message: " ^ text + in let reply = - `Assoc [ - "code", `String "ERROR"; - "data", - Exception_without_parameter.to_json - (Exception_without_parameter.add_uncaught_error - (Exception_without_parameter.build_uncaught_exception - ~file_name:"kasa_mpi" ~message Exit) - Exception_without_parameter.empty_error_handler); - ] in + `Assoc + [ + "code", `String "ERROR"; + ( "data", + Exception_without_parameter.to_json + (Exception_without_parameter.add_uncaught_error + (Exception_without_parameter.build_uncaught_exception + ~file_name:"kasa_mpi" ~message Exit) + Exception_without_parameter.empty_error_handler) ); + ] + in post (Yojson.Basic.to_string reply) diff --git a/core/KaSa_rep/flow/dune b/core/KaSa_rep/flow/dune index d29ed6c19f..e4644deea5 100644 --- a/core/KaSa_rep/flow/dune +++ b/core/KaSa_rep/flow/dune @@ -1,11 +1,15 @@ (library - (name kappa_flow_analysis) - (libraries kappa_kasa_frontend) - (flags (:standard) - -open Kappa_kasa_frontend - -open Kappa_generic_toolset - -open Kappa_parameters - -open Kappa_logging - -open Kappa_errors - -)) + (name kappa_flow_analysis) + (libraries kappa_kasa_frontend) + (flags + (:standard) + -open + Kappa_kasa_frontend + -open + Kappa_generic_toolset + -open + Kappa_parameters + -open + Kappa_logging + -open + Kappa_errors)) diff --git a/core/KaSa_rep/flow/ode_fragmentation.ml b/core/KaSa_rep/flow/ode_fragmentation.ml index 54d9dbfa52..1ff302cbc9 100644 --- a/core/KaSa_rep/flow/ode_fragmentation.ml +++ b/core/KaSa_rep/flow/ode_fragmentation.ml @@ -18,118 +18,122 @@ let trace = false (************************************************************************************) (*collect modified set*) -let collect_sites_modified_set parameters error rule handler_kappa store_result = +let collect_sites_modified_set parameters error rule handler_kappa store_result + = let error, store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id site_modif store_result -> - if Ckappa_sig.Site_map_and_set.Map.is_empty site_modif.Cckappa_sig.agent_interface - then - error, store_result - else - let agent_type = site_modif.Cckappa_sig.agent_name in - (*----------------------------------------------------------------------*) - (*collect a set of site that modified*) - let error, site_set = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ (error, current_set) -> - let error, set = - Ckappa_sig.Site_map_and_set.Set.add parameters error site current_set - in - error, set - ) - site_modif.Cckappa_sig.agent_interface - (error, Ckappa_sig.Site_map_and_set.Set.empty) - in - (*----------------------------------------------------------------------*) - (*PRINT at each rule*) - let error = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:modified sites:" - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let _ = - Printf.fprintf stdout "\tagent_type:%s:%s\n" - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - in - Ckappa_sig.Site_map_and_set.Set.fold - (fun site_type error -> - let error, site_string = - try - Handler.string_of_site parameters error handler_kappa agent_type - site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "\t\tsite_type:%s:%s" + if + Ckappa_sig.Site_map_and_set.Map.is_empty + site_modif.Cckappa_sig.agent_interface + then + error, store_result + else ( + let agent_type = site_modif.Cckappa_sig.agent_name in + (*----------------------------------------------------------------------*) + (*collect a set of site that modified*) + let error, site_set = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _ (error, current_set) -> + let error, set = + Ckappa_sig.Site_map_and_set.Set.add parameters error site + current_set + in + error, set) + site_modif.Cckappa_sig.agent_interface + (error, Ckappa_sig.Site_map_and_set.Set.empty) + in + (*----------------------------------------------------------------------*) + (*PRINT at each rule*) + let error = + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:modified sites:" + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + let error, agent_string = + try + Handler.string_of_agent parameters error handler_kappa + agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let _ = + Printf.fprintf stdout "\tagent_type:%s:%s\n" + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + in + Ckappa_sig.Site_map_and_set.Set.fold + (fun site_type error -> + let error, site_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type site_type + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_site_name site_type) - site_string - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - error) - site_set error - else - error - in - (*----------------------------------------------------------------------*) - (*get old?*) - let error, old_set = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_result - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - (*new*) - let error, new_set = - Ckappa_sig.Site_map_and_set.Set.union parameters error site_set old_set - in - (*----------------------------------------------------------------------*) - (*store*) - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_set - store_result - in - error, store_result - ) - rule.Cckappa_sig.diff_reverse - store_result + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "\t\tsite_type:%s:%s" + (Ckappa_sig.string_of_site_name site_type) + site_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + site_set error + ) else + error + in + (*----------------------------------------------------------------------*) + (*get old?*) + let error, old_set = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + (*new*) + let error, new_set = + Ckappa_sig.Site_map_and_set.Set.union parameters error site_set + old_set + in + (*----------------------------------------------------------------------*) + (*store*) + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type new_set store_result + in + error, store_result + )) + rule.Cckappa_sig.diff_reverse store_result in error, store_result (************************************************************************************) (*collect sites that are released*) -let collect_sites_bond_pair_set parameters error handler_kappa rule store_result = +let collect_sites_bond_pair_set parameters error handler_kappa rule store_result + = let bond_lhs = rule.Cckappa_sig.rule_lhs.Cckappa_sig.bonds in - List.fold_left (fun (error, store_result) (site_add1, site_add2) -> + List.fold_left + (fun (error, store_result) (site_add1, site_add2) -> let store_result1, store_result2 = store_result in let agent_id1 = site_add1.Cckappa_sig.agent_index in let agent_type1 = site_add1.Cckappa_sig.agent_type in @@ -146,25 +150,26 @@ let collect_sites_bond_pair_set parameters error handler_kappa rule store_result let error, sites_bond_set1 = Ckappa_sig.Site_map_and_set.Map.fold (fun site _ (error, current_set) -> - let error, set = - Ckappa_sig.Site_map_and_set.Set.add - parameters - error - site - current_set - in - error, set - ) site_add_map1 (error, Ckappa_sig.Site_map_and_set.Set.empty) + let error, set = + Ckappa_sig.Site_map_and_set.Set.add parameters error site + current_set + in + error, set) + site_add_map1 + (error, Ckappa_sig.Site_map_and_set.Set.empty) in (*----------------------------------------------------------------------*) (*PRINT*) let error = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:bond sites (first agent):" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:bond sites (first \ + agent):" in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) @@ -172,16 +177,15 @@ let collect_sites_bond_pair_set parameters error handler_kappa rule store_result let error, agent_string1 = try Handler.string_of_agent parameters error handler_kappa agent_type1 - with - _ -> - Exception.warn - parameters error __POS__ Exit - ((Ckappa_sig.string_of_agent_name agent_type1)) + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type1) in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "\tagent_type:%s:%s" - (Ckappa_sig.string_of_agent_name agent_type1 ) + (Ckappa_sig.string_of_agent_name agent_type1) agent_string1 in let () = @@ -189,36 +193,35 @@ let collect_sites_bond_pair_set parameters error handler_kappa rule store_result in Ckappa_sig.Site_map_and_set.Set.fold (fun site_type error -> - let error, site_string = - try - Handler.string_of_site parameters error handler_kappa agent_type1 - site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "\t\tsite_type:%s:%s" - (Ckappa_sig.string_of_site_name site_type) - site_string - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error - ) sites_bond_set1 error - else error + let error, site_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type1 site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_type) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "\t\tsite_type:%s:%s" + (Ckappa_sig.string_of_site_name site_type) + site_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + sites_bond_set1 error + ) else + error in (*----------------------------------------------------------------------*) (*compute first pair*) let error, store_result1 = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type1 - sites_bond_set1 - store_result1 + parameters error agent_type1 sites_bond_set1 store_result1 in (*----------------------------------------------------------------------*) (*compute second pair*) @@ -236,25 +239,26 @@ let collect_sites_bond_pair_set parameters error handler_kappa rule store_result let error, sites_bond_set2 = Ckappa_sig.Site_map_and_set.Map.fold (fun site _ (error, current_set) -> - let error, set = - Ckappa_sig.Site_map_and_set.Set.add - parameters - error - site - current_set - in - error, set - ) site_add_map2 (error, Ckappa_sig.Site_map_and_set.Set.empty) + let error, set = + Ckappa_sig.Site_map_and_set.Set.add parameters error site + current_set + in + error, set) + site_add_map2 + (error, Ckappa_sig.Site_map_and_set.Set.empty) in (*----------------------------------------------------------------------*) (*PRINT*) let error = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:bond sites (second agent):" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:bond sites (second \ + agent):" in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) @@ -262,81 +266,81 @@ let collect_sites_bond_pair_set parameters error handler_kappa rule store_result let error, agent_string2 = try Handler.string_of_agent parameters error handler_kappa agent_type2 - with - | _ -> - Exception.warn - parameters error __POS__ Exit - ((Ckappa_sig.string_of_agent_name agent_type2)) + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type2) in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "\tagent_type:%s:%s" - (Ckappa_sig.string_of_agent_name agent_type2 ) + (Ckappa_sig.string_of_agent_name agent_type2) agent_string2 in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - Ckappa_sig.Site_map_and_set.Set.fold (fun site_type error -> + Ckappa_sig.Site_map_and_set.Set.fold + (fun site_type error -> let error, site_string = try - Handler.string_of_site parameters error handler_kappa agent_type2 - site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit + Handler.string_of_site parameters error handler_kappa + agent_type2 site_type + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_site_name site_type) in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "\t\tsite_type:%s:%s" (Ckappa_sig.string_of_site_name site_type) site_string in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error - ) sites_bond_set2 error - else error + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + sites_bond_set2 error + ) else + error in (*----------------------------------------------------------------------*) (*get old*) let error, old_set2 = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type2 store_result2 + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type2 store_result2 with | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty | error, Some s -> error, s in (*new set*) let error, new_set2 = - Ckappa_sig.Site_map_and_set.Set.union parameters error sites_bond_set2 old_set2 + Ckappa_sig.Site_map_and_set.Set.union parameters error sites_bond_set2 + old_set2 in (*store*) let error, store_result2 = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type2 - new_set2 - store_result2 + parameters error agent_type2 new_set2 store_result2 in (*----------------------------------------------------------------------*) (*result*) (*return a pair, first pair is a first binding agent of each rule. Second pair is a second binding agent, it is a result of anchor*) - let error, store_result = - error, (store_result1, store_result2) - in - error, store_result - ) (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.release + let error, store_result = error, (store_result1, store_result2) in + error, store_result) + (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.release (************************************************************************************) (*collect sites that are external*) let collect_sites_bond_pair_set_external parameters error rule store_result = let bond_lhs = rule.Cckappa_sig.rule_lhs.Cckappa_sig.bonds in - List.fold_left (fun (error, store_result) (site_add1, site_add2) -> + List.fold_left + (fun (error, store_result) (site_add1, site_add2) -> let store_result1, store_result2 = store_result in let agent_id1 = site_add1.Cckappa_sig.agent_index in let agent_type1 = site_add1.Cckappa_sig.agent_type in @@ -351,24 +355,18 @@ let collect_sites_bond_pair_set_external parameters error rule store_result = let error, sites_bond_set1 = Ckappa_sig.Site_map_and_set.Map.fold (fun site _ (error, current_set) -> - let error, set = - Ckappa_sig.Site_map_and_set.Set.add - parameters - error - site - current_set - in - error, set - ) site_add_map1 (error, Ckappa_sig.Site_map_and_set.Set.empty) + let error, set = + Ckappa_sig.Site_map_and_set.Set.add parameters error site + current_set + in + error, set) + site_add_map1 + (error, Ckappa_sig.Site_map_and_set.Set.empty) in (*store*) let error, store_result1 = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type1 - sites_bond_set1 - store_result1 + parameters error agent_type1 sites_bond_set1 store_result1 in (*----------------------------------------------------------------------*) (*compute second pair*) @@ -385,72 +383,59 @@ let collect_sites_bond_pair_set_external parameters error rule store_result = let error, sites_bond_set2 = Ckappa_sig.Site_map_and_set.Map.fold (fun site _ (error, current_set) -> - let error, set = - Ckappa_sig.Site_map_and_set.Set.add - parameters - error - site - current_set - in - error, set - ) site_add_map2 (error, Ckappa_sig.Site_map_and_set.Set.empty) + let error, set = + Ckappa_sig.Site_map_and_set.Set.add parameters error site + current_set + in + error, set) + site_add_map2 + (error, Ckappa_sig.Site_map_and_set.Set.empty) in let error, store_result2 = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type2 - sites_bond_set2 - store_result2 + parameters error agent_type2 sites_bond_set2 store_result2 in (*----------------------------------------------------------------------*) - let error, store_result = - error, (store_result1, store_result2) - in - error, store_result - ) (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.release + let error, store_result = error, (store_result1, store_result2) in + error, store_result) + (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.release (************************************************************************************) (*collect sites from lhs rule*) let collect_sites_lhs parameters error rule store_result = let error, store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id agent store_result -> - match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ -> error, store_result - | Cckappa_sig.Dead_agent (agent, _, _, _) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, site_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ (error, current_list) -> - let site_list = site :: current_list in - error, site_list - ) agent.Cckappa_sig.agent_interface (error, []) - in - (*get old?*) - let error, old_list = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_result - with - | error, None -> error, [] - | error, Some l -> error, l - in - let new_list = List.concat [site_list; old_list] in - (*store*) - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_list - store_result - in - error, store_result - ) rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result + match agent with + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ -> error, store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, site_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _ (error, current_list) -> + let site_list = site :: current_list in + error, site_list) + agent.Cckappa_sig.agent_interface (error, []) + in + (*get old?*) + let error, old_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result + with + | error, None -> error, [] + | error, Some l -> error, l + in + let new_list = List.concat [ site_list; old_list ] in + (*store*) + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type new_list store_result + in + error, store_result) + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result in error, store_result @@ -458,197 +443,192 @@ let collect_sites_lhs parameters error rule store_result = (*collect sites anchor set*) let collect_sites_anchor_set parameters error handler_kappa rule - store_sites_modified_set - store_sites_bond_pair_set - store_sites_lhs + store_sites_modified_set store_sites_bond_pair_set store_sites_lhs store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id agent store_result -> - let store_result1, store_result2 = store_result in - match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ -> error, store_result - | Cckappa_sig.Dead_agent (agent, _, _, _) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - (*----------------------------------------------------------------------*) - (*get sites that is modified*) - let error, modified_set = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - store_sites_modified_set - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - (*----------------------------------------------------------------------*) - (*get a set of sites in the lhs that are bond*) - let error, site_lhs_bond_fst_set = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - (fst store_sites_bond_pair_set) - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - (*----------------------------------------------------------------------*) - (*get a list of sites in the lsh*) - let error, sites_lhs_list = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - store_sites_lhs - with - | error, None -> error, [] - | error, Some l -> error, l - in - (*----------------------------------------------------------------------*) - (*first case: a site connected to a modified site*) - let error, store_result1 = - List.fold_left (fun (error, store_result) x -> - begin - if Ckappa_sig.Site_map_and_set.Set.mem x modified_set && - Ckappa_sig.Site_map_and_set.Set.mem x site_lhs_bond_fst_set - then - let store_result = - snd store_sites_bond_pair_set - in - error, store_result - else - error, store_result - end - ) (error, store_result1) (List.rev sites_lhs_list) - in - (*----------------------------------------------------------------------*) - (*second result*) - (*get a set of anchor sites*) - let error, anchor_set1 = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - (fst store_sites_bond_pair_set) - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - let error, anchor_set2 = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - (snd store_sites_bond_pair_set) - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - let error, anchor_set = - Ckappa_sig.Site_map_and_set.Set.union parameters error anchor_set1 anchor_set2 - in - (*----------------------------------------------------------------------*) - let error, store_result2 = - List.fold_left (fun (error, store_result) x -> - List.fold_left (fun (error, store_result) y -> - begin - if Ckappa_sig.Site_map_and_set.Set.mem x anchor_set || - Ckappa_sig.Site_map_and_set.Set.mem x modified_set && - Ckappa_sig.Site_map_and_set.Set.mem y site_lhs_bond_fst_set - then - let store_result = - snd store_sites_bond_pair_set - in - error, store_result - else - error, store_result - end - ) (error, store_result) (List.tl sites_lhs_list) - ) (error, store_result2) (List.rev sites_lhs_list) - in - (*----------------------------------------------------------------------*) - (*get union both result*) - let error, get_set1 = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_result1 - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - let error, get_set2 = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_result2 - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - let error, union_set = - Ckappa_sig.Site_map_and_set.Set.union parameters error get_set1 get_set2 - in - (*----------------------------------------------------------------------*) - (*PRINT*) - let error = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:anchor sites:" - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "\tagent_type:%s:%s" - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - Ckappa_sig.Site_map_and_set.Set.fold - (fun site_type error -> - let error, site_string = - try - Handler.string_of_site parameters error handler_kappa agent_type - site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "\t\tsite_type:%s:%s" + let store_result1, store_result2 = store_result in + match agent with + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ -> error, store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + (*----------------------------------------------------------------------*) + (*get sites that is modified*) + let error, modified_set = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_sites_modified_set + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + (*----------------------------------------------------------------------*) + (*get a set of sites in the lhs that are bond*) + let error, site_lhs_bond_fst_set = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type + (fst store_sites_bond_pair_set) + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + (*----------------------------------------------------------------------*) + (*get a list of sites in the lsh*) + let error, sites_lhs_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_sites_lhs + with + | error, None -> error, [] + | error, Some l -> error, l + in + (*----------------------------------------------------------------------*) + (*first case: a site connected to a modified site*) + let error, store_result1 = + List.fold_left + (fun (error, store_result) x -> + if + Ckappa_sig.Site_map_and_set.Set.mem x modified_set + && Ckappa_sig.Site_map_and_set.Set.mem x site_lhs_bond_fst_set + then ( + let store_result = snd store_sites_bond_pair_set in + error, store_result + ) else + error, store_result) + (error, store_result1) (List.rev sites_lhs_list) + in + (*----------------------------------------------------------------------*) + (*second result*) + (*get a set of anchor sites*) + let error, anchor_set1 = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type + (fst store_sites_bond_pair_set) + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + let error, anchor_set2 = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type + (snd store_sites_bond_pair_set) + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + let error, anchor_set = + Ckappa_sig.Site_map_and_set.Set.union parameters error anchor_set1 + anchor_set2 + in + (*----------------------------------------------------------------------*) + let error, store_result2 = + List.fold_left + (fun (error, store_result) x -> + List.fold_left + (fun (error, store_result) y -> + if + Ckappa_sig.Site_map_and_set.Set.mem x anchor_set + || Ckappa_sig.Site_map_and_set.Set.mem x modified_set + && Ckappa_sig.Site_map_and_set.Set.mem y + site_lhs_bond_fst_set + then ( + let store_result = snd store_sites_bond_pair_set in + error, store_result + ) else + error, store_result) + (error, store_result) (List.tl sites_lhs_list)) + (error, store_result2) (List.rev sites_lhs_list) + in + (*----------------------------------------------------------------------*) + (*get union both result*) + let error, get_set1 = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result1 + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + let error, get_set2 = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result2 + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + let error, union_set = + Ckappa_sig.Site_map_and_set.Set.union parameters error get_set1 + get_set2 + in + (*----------------------------------------------------------------------*) + (*PRINT*) + let error = + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:anchor sites:" + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let error, agent_string = + try + Handler.string_of_agent parameters error handler_kappa + agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "\tagent_type:%s:%s" + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + Ckappa_sig.Site_map_and_set.Set.fold + (fun site_type error -> + let error, site_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type site_type + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_site_name site_type) - site_string - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error - ) union_set error - else error - in - (*----------------------------------------------------------------------*) - (*result*) - let error, store_result = - error, (store_result1, store_result2) - in - error, store_result - ) rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "\t\tsite_type:%s:%s" + (Ckappa_sig.string_of_site_name site_type) + site_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + union_set error + ) else + error + in + (*----------------------------------------------------------------------*) + (*result*) + let error, store_result = error, (store_result1, store_result2) in + error, store_result) + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result (************************************************************************************) (*collect internal flow*) @@ -658,218 +638,237 @@ let cartesian_prod_eq i a b = match a with | [] -> List.rev acc | x :: xs -> - loop xs (List.rev_append (List.rev (List.fold_left (fun acc y -> - if x <> y - then (i, x, y) :: acc - else acc - ) [] b)) acc) + loop xs + (List.rev_append + (List.rev + (List.fold_left + (fun acc y -> + if x <> y then + (i, x, y) :: acc + else + acc) + [] b)) + acc) in loop a [] -let collect_internal_flow parameters error handler_kappa rule - store_sites_lhs - store_sites_modified_set - store_sites_anchor_set - store_result = +let collect_internal_flow parameters error handler_kappa rule store_sites_lhs + store_sites_modified_set store_sites_anchor_set store_result = (*----------------------------------------------------------------------*) let add_link error agent_type (site_list, set) store_result = let result = - Ode_fragmentation_type.Internal_flow_map.Map.add - agent_type (site_list, set) store_result + Ode_fragmentation_type.Internal_flow_map.Map.add agent_type + (site_list, set) store_result in error, result in (*----------------------------------------------------------------------*) - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id agent store_result -> - let store_result1, store_result2 = store_result in - match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ -> error, store_result - | Cckappa_sig.Dead_agent (agent, _, _, _) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - (*let agent_type_modif = agent_modif.agent_name in*) - (*get modified set*) - let error, modified_set = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type - store_sites_modified_set - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - (*get anchor set*) - let error, anchor_set1 = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type - (fst store_sites_anchor_set) - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - let error, anchor_set2 = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type - (snd store_sites_anchor_set) - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty - | error, Some s -> error, s - in - let error, anchor_set = - Ckappa_sig.Site_map_and_set.Set.union parameters error anchor_set1 anchor_set2 - in - (*----------------------------------------------------------------------*) - (*first result: site -> modified site*) - let error, site_list = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_sites_lhs with - | error, None -> error, [] - | error, Some l -> error, l - in - (*------------------------------------------------------------------------------*) - (*PRINT*) - let error = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then - let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:internal flow (first case):\n" - in - let modified_list = - Ckappa_sig.Site_map_and_set.Set.elements modified_set - in - let cartesian_output = - cartesian_prod_eq agent_type site_list modified_list - in - let error = - List.fold_left (fun error (agent_type, site_type, site_modif) -> - let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let error, site_string = - try - Handler.string_of_site parameters error handler_kappa agent_type - site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let error, site_modif_string = - Handler.string_of_site parameters error handler_kappa agent_type - site_modif - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:Internal flow\n-agent_type:%s:%s:site_type:%s:%s -> agent_type:%s:%s:site_type_modified:%s:%s" - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - (Ckappa_sig.string_of_site_name site_type) - site_string - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - (Ckappa_sig.string_of_site_name site_modif) - site_modif_string - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - error - ) error cartesian_output - in - error - else - error - in - (*------------------------------------------------------------------------------*) - (*PRINT second internal flow*) - let error = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:internal flow (second case):" - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let anchor_list = - Ckappa_sig.Site_map_and_set.Set.elements anchor_set - in - let cartesian_output = - cartesian_prod_eq agent_type site_list anchor_list - in - let error = - List.fold_left (fun error (agent_type, site_type, site_anchor) -> - let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let error, site_string = - try - Handler.string_of_site parameters error handler_kappa agent_type - site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let error, site_anchor_string = - try - Handler.string_of_site parameters error handler_kappa agent_type - site_anchor - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_anchor) - in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "Flow of information in the ODE semantics:Internal flow\n-agent_type:%s:%s:site_type:%s:%s -> agent_type:%s:%s:site_type_anchor:%s:%s" - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - (Ckappa_sig.string_of_site_name site_type) - site_string - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - (Ckappa_sig.string_of_site_name site_anchor) - site_anchor_string - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error - ) error cartesian_output - in - error - else - error - in - (*------------------------------------------------------------------------------*) - let error, store_result1 = - add_link error agent_type (site_list, modified_set) store_result1 - in - (*------------------------------------------------------------------------------*) - let error, store_result2 = - add_link error agent_type (site_list, anchor_set) store_result2 - in - (*------------------------------------------------------------------------------*) - let error, store_result = - error, (store_result1, store_result2) - in - error, store_result - ) rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - store_result + let store_result1, store_result2 = store_result in + match agent with + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ -> error, store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + (*let agent_type_modif = agent_modif.agent_name in*) + (*get modified set*) + let error, modified_set = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_sites_modified_set + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + (*get anchor set*) + let error, anchor_set1 = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type + (fst store_sites_anchor_set) + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + let error, anchor_set2 = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type + (snd store_sites_anchor_set) + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty + | error, Some s -> error, s + in + let error, anchor_set = + Ckappa_sig.Site_map_and_set.Set.union parameters error anchor_set1 + anchor_set2 + in + (*----------------------------------------------------------------------*) + (*first result: site -> modified site*) + let error, site_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_sites_lhs + with + | error, None -> error, [] + | error, Some l -> error, l + in + (*------------------------------------------------------------------------------*) + (*PRINT*) + let error = + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:internal flow (first \ + case):\n" + in + let modified_list = + Ckappa_sig.Site_map_and_set.Set.elements modified_set + in + let cartesian_output = + cartesian_prod_eq agent_type site_list modified_list + in + let error = + List.fold_left + (fun error (agent_type, site_type, site_modif) -> + let error, agent_string = + try + Handler.string_of_agent parameters error handler_kappa + agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let error, site_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_type) + in + let error, site_modif_string = + Handler.string_of_site parameters error handler_kappa + agent_type site_modif + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:Internal flow\n\ + -agent_type:%s:%s:site_type:%s:%s -> \ + agent_type:%s:%s:site_type_modified:%s:%s" + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + (Ckappa_sig.string_of_site_name site_type) + site_string + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + (Ckappa_sig.string_of_site_name site_modif) + site_modif_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + error cartesian_output + in + error + ) else + error + in + (*------------------------------------------------------------------------------*) + (*PRINT second internal flow*) + let error = + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:internal flow \ + (second case):" + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let anchor_list = + Ckappa_sig.Site_map_and_set.Set.elements anchor_set + in + let cartesian_output = + cartesian_prod_eq agent_type site_list anchor_list + in + let error = + List.fold_left + (fun error (agent_type, site_type, site_anchor) -> + let error, agent_string = + try + Handler.string_of_agent parameters error handler_kappa + agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let error, site_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_type) + in + let error, site_anchor_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type site_anchor + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_anchor) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:Internal flow\n\ + -agent_type:%s:%s:site_type:%s:%s -> \ + agent_type:%s:%s:site_type_anchor:%s:%s" + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + (Ckappa_sig.string_of_site_name site_type) + site_string + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + (Ckappa_sig.string_of_site_name site_anchor) + site_anchor_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + error cartesian_output + in + error + ) else + error + in + (*------------------------------------------------------------------------------*) + let error, store_result1 = + add_link error agent_type (site_list, modified_set) store_result1 + in + (*------------------------------------------------------------------------------*) + let error, store_result2 = + add_link error agent_type (site_list, anchor_set) store_result2 + in + (*------------------------------------------------------------------------------*) + let error, store_result = error, (store_result1, store_result2) in + error, store_result) + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result (************************************************************************************) (*collect external flow*) @@ -880,47 +879,57 @@ let cartesian_prod_external i anchor_set i' bond_fst_list bond_snd_set = match anchor_list with | [] -> List.rev acc | x :: xs -> - loop xs (List.rev_append (List.rev (List.fold_left (fun acc y -> - if Ckappa_sig.Site_map_and_set.Set.mem x anchor_set && - Ckappa_sig.Site_map_and_set.Set.mem x bond_snd_set - then (i, x, i', y) :: acc - else acc - ) [] bond_fst_list)) acc) + loop xs + (List.rev_append + (List.rev + (List.fold_left + (fun acc y -> + if + Ckappa_sig.Site_map_and_set.Set.mem x anchor_set + && Ckappa_sig.Site_map_and_set.Set.mem x bond_snd_set + then + (i, x, i', y) :: acc + else + acc) + [] bond_fst_list)) + acc) in loop anchor_list [] let collect_external_flow parameters error handler_kappa rule - store_sites_bond_pair_set_external - store_sites_anchor_set - store_result = + store_sites_bond_pair_set_external store_sites_anchor_set store_result = (*------------------------------------------------------------------------------*) - let add_link error (agent_type1, agent_type2) (anchor_set, bond_fst_set, bond_snd_set) - store_result = + let add_link error (agent_type1, agent_type2) + (anchor_set, bond_fst_set, bond_snd_set) store_result = let result = Ode_fragmentation_type.External_flow_map.Map.add (agent_type1, agent_type2) - (anchor_set, bond_fst_set, bond_snd_set) store_result + (anchor_set, bond_fst_set, bond_snd_set) + store_result in error, result in (*------------------------------------------------------------------------------*) - List.fold_left (fun (error, store_result) (site_add1, site_add2) -> + List.fold_left + (fun (error, store_result) (site_add1, site_add2) -> let agent_type1 = site_add1.Cckappa_sig.agent_type in let agent_type2 = site_add2.Cckappa_sig.agent_type in (*------------------------------------------------------------------------------*) (*get sites that are bond on the lhs*) let error, bond_fst_set = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type1 - (fst store_sites_bond_pair_set_external) + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type1 + (fst store_sites_bond_pair_set_external) with | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty | error, Some s -> error, s in (*------------------------------------------------------------------------------*) let error, bond_snd_set = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type2 - (snd store_sites_bond_pair_set_external) + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type2 + (snd store_sites_bond_pair_set_external) with | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty | error, Some s -> error, s @@ -928,121 +937,121 @@ let collect_external_flow parameters error handler_kappa rule (*------------------------------------------------------------------------------*) (*get anchor set*) let error, anchor_set1 = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold + parameters error (fun parameters error _agent_type site_set old_set -> - let error, set = - Ckappa_sig.Site_map_and_set.Set.union - parameters - error - site_set - old_set - in - error, set - ) (fst store_sites_anchor_set) Ckappa_sig.Site_map_and_set.Set.empty + let error, set = + Ckappa_sig.Site_map_and_set.Set.union parameters error site_set + old_set + in + error, set) + (fst store_sites_anchor_set) + Ckappa_sig.Site_map_and_set.Set.empty in let error, anchor_set2 = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold + parameters error (fun parameters error _agent_type site_set old_set -> - let error, set = - Ckappa_sig.Site_map_and_set.Set.union - parameters - error - site_set - old_set - in - error, set - )(snd store_sites_anchor_set) Ckappa_sig.Site_map_and_set.Set.empty + let error, set = + Ckappa_sig.Site_map_and_set.Set.union parameters error site_set + old_set + in + error, set) + (snd store_sites_anchor_set) + Ckappa_sig.Site_map_and_set.Set.empty in let error, anchor_set = - Ckappa_sig.Site_map_and_set.Set.union - parameters - error - anchor_set1 + Ckappa_sig.Site_map_and_set.Set.union parameters error anchor_set1 anchor_set2 in (*------------------------------------------------------------------------------*) (*PRINT External flow*) - let bond_fst_list = Ckappa_sig.Site_map_and_set.Set.elements bond_fst_set in + let bond_fst_list = + Ckappa_sig.Site_map_and_set.Set.elements bond_fst_set + in let cartesian_output = - cartesian_prod_external - agent_type2 - anchor_set - agent_type1 - bond_fst_list + cartesian_prod_external agent_type2 anchor_set agent_type1 bond_fst_list bond_snd_set in let error = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "Flow of information in the ODE semantics:external flow:" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in List.fold_left (fun error (agent_type, anchor_site_type, agent_type', site_modif) -> - let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let error, agent_string' = - try - Handler.string_of_agent parameters error handler_kappa agent_type' - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type') - in - let error, anchor_site_type_string = - try - Handler.string_of_site parameters error handler_kappa agent_type - anchor_site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name anchor_site_type) - in - let error, site_modif_string = - try - Handler.string_of_site parameters error handler_kappa agent_type' - site_modif - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_modif) - in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "Flow of information in the ODE semantics:External flow:\n-agent-type:%s:%s:site_type_anchor:%s:%s -> agent_type:%s:%s:site_type_modified:%s:%s" - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - (Ckappa_sig.string_of_site_name anchor_site_type) - anchor_site_type_string - (Ckappa_sig.string_of_agent_name agent_type') - agent_string' - (Ckappa_sig.string_of_site_name site_modif) - site_modif_string - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error - ) error cartesian_output - else error + let error, agent_string = + try + Handler.string_of_agent parameters error handler_kappa + agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let error, agent_string' = + try + Handler.string_of_agent parameters error handler_kappa + agent_type' + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type') + in + let error, anchor_site_type_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type anchor_site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name anchor_site_type) + in + let error, site_modif_string = + try + Handler.string_of_site parameters error handler_kappa + agent_type' site_modif + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_modif) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:External flow:\n\ + -agent-type:%s:%s:site_type_anchor:%s:%s -> \ + agent_type:%s:%s:site_type_modified:%s:%s" + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + (Ckappa_sig.string_of_site_name anchor_site_type) + anchor_site_type_string + (Ckappa_sig.string_of_agent_name agent_type') + agent_string' + (Ckappa_sig.string_of_site_name site_modif) + site_modif_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + error cartesian_output + ) else + error in (*------------------------------------------------------------------------------*) let error, store_result = - add_link error (agent_type1, agent_type2) (anchor_set, bond_fst_set, bond_snd_set) + add_link error (agent_type1, agent_type2) + (anchor_set, bond_fst_set, bond_snd_set) store_result in - error, store_result - ) (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.release + error, store_result) + (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.release (************************************************************************************) (*RULE*) @@ -1051,159 +1060,128 @@ let scan_rule parameters error handler_kappa rule store_result = (*----------------------------------------------------------------------*) (*modified set*) let error, store_sites_modified_set = - collect_sites_modified_set - parameters - error - rule - handler_kappa + collect_sites_modified_set parameters error rule handler_kappa store_result.Ode_fragmentation_type.store_sites_modified_set in (*----------------------------------------------------------------------*) (*collect sites that are release*) let error, store_sites_bond_pair_set = - collect_sites_bond_pair_set - parameters - error - handler_kappa - rule + collect_sites_bond_pair_set parameters error handler_kappa rule store_result.Ode_fragmentation_type.store_sites_bond_pair_set in (*----------------------------------------------------------------------*) (*collects sites that are external*) let error, store_sites_bond_pair_set_external = - collect_sites_bond_pair_set_external - parameters - error - rule + collect_sites_bond_pair_set_external parameters error rule store_result.Ode_fragmentation_type.store_sites_bond_pair_set_external in (*----------------------------------------------------------------------*) (*collect sites from lhs rule*) let error, store_sites_lhs = - collect_sites_lhs - parameters - error - rule + collect_sites_lhs parameters error rule store_result.Ode_fragmentation_type.store_sites_lhs in (*----------------------------------------------------------------------*) (*collect anchor sites*) let error, store_sites_anchor_set = - collect_sites_anchor_set - parameters - error - handler_kappa - rule - store_sites_modified_set - store_sites_bond_pair_set - store_sites_lhs + collect_sites_anchor_set parameters error handler_kappa rule + store_sites_modified_set store_sites_bond_pair_set store_sites_lhs store_result.Ode_fragmentation_type.store_sites_anchor_set in (*----------------------------------------------------------------------*) (*collect internal flow: site -> modified/anchor site*) let error, store_internal_flow = - collect_internal_flow - parameters - error - handler_kappa - rule - store_sites_lhs - store_sites_modified_set - store_sites_anchor_set + collect_internal_flow parameters error handler_kappa rule store_sites_lhs + store_sites_modified_set store_sites_anchor_set store_result.Ode_fragmentation_type.store_internal_flow in (*----------------------------------------------------------------------*) (*collect external flow : a -> b , if 'a' is an anchor site or 'b' is a modified site*) let error, store_external_flow = - collect_external_flow - parameters - error - handler_kappa - rule - store_sites_bond_pair_set_external - store_sites_anchor_set + collect_external_flow parameters error handler_kappa rule + store_sites_bond_pair_set_external store_sites_anchor_set store_result.Ode_fragmentation_type.store_external_flow in (*----------------------------------------------------------------------*) - error, - { - Ode_fragmentation_type.store_sites_modified_set = store_sites_modified_set; - Ode_fragmentation_type.store_sites_bond_pair_set = store_sites_bond_pair_set; - Ode_fragmentation_type.store_sites_bond_pair_set_external = store_sites_bond_pair_set_external; - Ode_fragmentation_type.store_sites_lhs = store_sites_lhs; - Ode_fragmentation_type.store_sites_anchor_set = store_sites_anchor_set; - Ode_fragmentation_type.store_internal_flow = store_internal_flow; - Ode_fragmentation_type.store_external_flow = store_external_flow; - } + ( error, + { + Ode_fragmentation_type.store_sites_modified_set; + Ode_fragmentation_type.store_sites_bond_pair_set; + Ode_fragmentation_type.store_sites_bond_pair_set_external; + Ode_fragmentation_type.store_sites_lhs; + Ode_fragmentation_type.store_sites_anchor_set; + Ode_fragmentation_type.store_internal_flow; + Ode_fragmentation_type.store_external_flow; + } ) (************************************************************************************) (*RULES*) let scan_rule_set parameters error handler_kappa compiled = - let error, init_store_sites_modified_set = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - let error, init = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - let init_store_sites_bond_pair_set = (init, init) in - let init_store_sites_bond_pair_set_external = (init, init) in + let error, init_store_sites_modified_set = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + let error, init = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + let init_store_sites_bond_pair_set = init, init in + let init_store_sites_bond_pair_set_external = init, init in let error, init_store_sites_lhs = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - let init_store_sites_anchor = (init, init) in + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + let init_store_sites_anchor = init, init in let init_internal1 = Ode_fragmentation_type.Internal_flow_map.Map.empty in let init_internal2 = Ode_fragmentation_type.Internal_flow_map.Map.empty in let init_external = Ode_fragmentation_type.External_flow_map.Map.empty in let init_ode = { - Ode_fragmentation_type.store_sites_modified_set = init_store_sites_modified_set; - Ode_fragmentation_type.store_sites_bond_pair_set = init_store_sites_bond_pair_set; - Ode_fragmentation_type.store_sites_bond_pair_set_external = init_store_sites_bond_pair_set_external; - Ode_fragmentation_type.store_sites_lhs = init_store_sites_lhs; + Ode_fragmentation_type.store_sites_modified_set = + init_store_sites_modified_set; + Ode_fragmentation_type.store_sites_bond_pair_set = + init_store_sites_bond_pair_set; + Ode_fragmentation_type.store_sites_bond_pair_set_external = + init_store_sites_bond_pair_set_external; + Ode_fragmentation_type.store_sites_lhs = init_store_sites_lhs; Ode_fragmentation_type.store_sites_anchor_set = init_store_sites_anchor; - Ode_fragmentation_type.store_internal_flow = init_internal1, init_internal2; - Ode_fragmentation_type.store_external_flow = init_external; + Ode_fragmentation_type.store_internal_flow = + init_internal1, init_internal2; + Ode_fragmentation_type.store_external_flow = init_external; } in (*----------------------------------------------------------------------*) let error, store_result = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error rule_id rule store_result -> - (*----------------------------------------------------------------------*) - (*PRINT*) - let _ = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - && Remanent_parameters.get_trace parameters - then - let parameters = - Remanent_parameters.update_prefix parameters "" - in - (*Print at each rule:*) - let error, rule_string = - try - Handler.string_of_rule parameters error compiled rule_id - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_rule_id rule_id) - in - let () = Printf.fprintf stdout "%s\n" rule_string in - error - else error - in - (*----------------------------------------------------------------------*) - let error, store_result = - scan_rule - parameters - error - handler_kappa - rule.Cckappa_sig.e_rule_c_rule - store_result - in - error, store_result - ) - compiled.Cckappa_sig.rules - init_ode + (*----------------------------------------------------------------------*) + (*PRINT*) + let _ = + if + Remanent_parameters.get_do_ODE_flow_of_information parameters + && Remanent_parameters.get_trace parameters + then ( + let parameters = Remanent_parameters.update_prefix parameters "" in + (*Print at each rule:*) + let error, rule_string = + try Handler.string_of_rule parameters error compiled rule_id + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_rule_id rule_id) + in + let () = Printf.fprintf stdout "%s\n" rule_string in + error + ) else + error + in + (*----------------------------------------------------------------------*) + let error, store_result = + scan_rule parameters error handler_kappa + rule.Cckappa_sig.e_rule_c_rule store_result + in + error, store_result) + compiled.Cckappa_sig.rules init_ode in error, store_result diff --git a/core/KaSa_rep/flow/ode_fragmentation_type.ml b/core/KaSa_rep/flow/ode_fragmentation_type.ml index fb397bbdab..83e36c0e01 100644 --- a/core/KaSa_rep/flow/ode_fragmentation_type.ml +++ b/core/KaSa_rep/flow/ode_fragmentation_type.ml @@ -18,47 +18,50 @@ let trace = false (************************************************************************************) (*TYPE*) -module Internal_flow_map = - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_name - let compare = compare - let print _ _ = () - end) +module Internal_flow_map = SetMap.Make (struct + type t = Ckappa_sig.c_agent_name -module External_flow_map = - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_agent_name - let compare = compare - let print _ _ = () - end) + let compare = compare + let print _ _ = () +end) -type ode_frag = - { - store_sites_modified_set: - Ckappa_sig.Site_map_and_set.Set.t Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_sites_bond_pair_set: - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t * - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_sites_bond_pair_set_external : - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t * - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_sites_lhs : Ckappa_sig.c_site_name list - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_sites_anchor_set : - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t * - Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_internal_flow : - (Ckappa_sig.c_site_name list * Ckappa_sig.Site_map_and_set.Set.t) Internal_flow_map.Map.t * - (Ckappa_sig.c_site_name list * Ckappa_sig.Site_map_and_set.Set.t) Internal_flow_map.Map.t; - store_external_flow : - (Ckappa_sig.Site_map_and_set.Set.t * Ckappa_sig.Site_map_and_set.Set.t * Ckappa_sig.Site_map_and_set.Set.t) - External_flow_map.Map.t; - } +module External_flow_map = SetMap.Make (struct + type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_agent_name + + let compare = compare + let print _ _ = () +end) + +type ode_frag = { + store_sites_modified_set: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_sites_bond_pair_set: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t + * Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_sites_bond_pair_set_external: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t + * Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_sites_lhs: + Ckappa_sig.c_site_name list + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_sites_anchor_set: + Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t + * Ckappa_sig.Site_map_and_set.Set.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_internal_flow: + (Ckappa_sig.c_site_name list * Ckappa_sig.Site_map_and_set.Set.t) + Internal_flow_map.Map.t + * (Ckappa_sig.c_site_name list * Ckappa_sig.Site_map_and_set.Set.t) + Internal_flow_map.Map.t; + store_external_flow: + (Ckappa_sig.Site_map_and_set.Set.t + * Ckappa_sig.Site_map_and_set.Set.t + * Ckappa_sig.Site_map_and_set.Set.t) + External_flow_map.Map.t; +} diff --git a/core/KaSa_rep/flow/print_ode_fragmentation.ml b/core/KaSa_rep/flow/print_ode_fragmentation.ml index 89bd7c9588..47a6a0b99f 100644 --- a/core/KaSa_rep/flow/print_ode_fragmentation.ml +++ b/core/KaSa_rep/flow/print_ode_fragmentation.ml @@ -19,48 +19,52 @@ let trace = false (*Print sites that modified*) let print_sites_modified_set parameters error handler_kappa result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter parameters error + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error (fun parameters error agent_type site_set -> - let error, agent_name = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "agent_type:%s:%s" - (Ckappa_sig.string_of_agent_name agent_type) agent_name - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - (*convert site of type int to string*) - let error = - Ckappa_sig.Site_map_and_set.Set.fold (fun site_type error -> - let error, site_string = - try - Handler.string_of_site parameters error handler_kappa agent_type site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameters) "site_type:%s:%s" - (Ckappa_sig.string_of_site_name site_type) - site_string - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error - ) site_set error - in - error - ) result + let error, agent_name = + try Handler.string_of_agent parameters error handler_kappa agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "agent_type:%s:%s" + (Ckappa_sig.string_of_agent_name agent_type) + agent_name + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + (*convert site of type int to string*) + let error = + Ckappa_sig.Site_map_and_set.Set.fold + (fun site_type error -> + let error, site_string = + try + Handler.string_of_site parameters error handler_kappa agent_type + site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_type) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "site_type:%s:%s" + (Ckappa_sig.string_of_site_name site_type) + site_string + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) + site_set error + in + error) + result (**************************************************************************) @@ -69,22 +73,27 @@ let cartesian_prod_eq i a b = match a with | [] -> List.rev acc | x :: xs -> - loop xs (List.rev_append (List.rev (List.fold_left (fun acc y -> - if x <> y - then (i, x, y) :: acc - else acc - ) [] b)) acc) + loop xs + (List.rev_append + (List.rev + (List.fold_left + (fun acc y -> + if x <> y then + (i, x, y) :: acc + else + acc) + [] b)) + acc) in loop a [] let print_internal_flow parameters _error _handler_kappa result = let store_result1, _store_result2 = result in - if Remanent_parameters.get_do_ODE_flow_of_information parameters - then - if Remanent_parameters.get_trace parameters - then + if Remanent_parameters.get_do_ODE_flow_of_information parameters then + if Remanent_parameters.get_trace parameters then ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "Flow of information in the ODE semantics:internal flow (first case):" in let () = @@ -92,39 +101,44 @@ let print_internal_flow parameters _error _handler_kappa result = in Ode_fragmentation_type.Internal_flow_map.Map.iter (fun agent_type (site_list, modified_set) -> - let modified_list = - Ckappa_sig.Site_map_and_set.Set.elements modified_set - in - let cartesian_output = - cartesian_prod_eq agent_type site_list modified_list - in - let _ = - List.iter (fun (agent_type, site_type, site_modif) -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Flow of information in the ODE semantics:Internal flow\n-agent_type:%s:site_type:%s -> agent_type:%s:site_type_modified:%s" - (Ckappa_sig.string_of_agent_name agent_type) - (Ckappa_sig.string_of_site_name site_type) - (Ckappa_sig.string_of_agent_name agent_type) - (Ckappa_sig.string_of_site_name site_modif) - in - Loggers.print_newline (Remanent_parameters.get_logger parameters) - ) cartesian_output - in - () - ) store_result1 + let modified_list = + Ckappa_sig.Site_map_and_set.Set.elements modified_set + in + let cartesian_output = + cartesian_prod_eq agent_type site_list modified_list + in + let _ = + List.iter + (fun (agent_type, site_type, site_modif) -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Flow of information in the ODE semantics:Internal flow\n\ + -agent_type:%s:site_type:%s -> \ + agent_type:%s:site_type_modified:%s" + (Ckappa_sig.string_of_agent_name agent_type) + (Ckappa_sig.string_of_site_name site_type) + (Ckappa_sig.string_of_agent_name agent_type) + (Ckappa_sig.string_of_site_name site_modif) + in + Loggers.print_newline + (Remanent_parameters.get_logger parameters)) + cartesian_output + in + ()) + store_result1 + ) (**************************************************************************) (*MAIN*) let print_result parameters error handler_kappa result = let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "Flow of information in the ODE semantics:Internal flow\n"; let error = - print_internal_flow - parameters - error - handler_kappa + print_internal_flow parameters error handler_kappa result.Ode_fragmentation_type.store_internal_flow in error diff --git a/core/KaSa_rep/frontend/build_graph.ml b/core/KaSa_rep/frontend/build_graph.ml index 42290349a0..00f47cb622 100644 --- a/core/KaSa_rep/frontend/build_graph.ml +++ b/core/KaSa_rep/frontend/build_graph.ml @@ -12,8 +12,8 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - -let add_agent parameters error handler cckappa_only agent_id agent_type mixture = +let add_agent parameters error handler cckappa_only agent_id agent_type mixture + = let error, agent_string = Handler.string_of_agent parameters error handler agent_type in @@ -26,45 +26,38 @@ let add_agent parameters error handler cckappa_only agent_id agent_type mixture in let agent = { - Cckappa_sig.agent_kasim_id = agent_id ; - Cckappa_sig.agent_name = agent_type ; + Cckappa_sig.agent_kasim_id = agent_id; + Cckappa_sig.agent_name = agent_type; Cckappa_sig.agent_interface = Ckappa_sig.Site_map_and_set.Map.empty; - Cckappa_sig.agent_position = Locality.dummy ; - Cckappa_sig.is_created = false ; + Cckappa_sig.agent_position = Loc.dummy; + Cckappa_sig.is_created = false; } in let error', views = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - agent_id (Cckappa_sig.Agent agent) mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_id (Cckappa_sig.Agent agent) mixture.Cckappa_sig.views in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit in - error, - { mixture - with - Cckappa_sig.c_mixture = c_mixture ; - Cckappa_sig.views = views - } + error, { mixture with Cckappa_sig.c_mixture; Cckappa_sig.views } let empty_port = { - Cckappa_sig.site_name = Ckappa_sig.dummy_site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_free = None ; + Cckappa_sig.site_name = Ckappa_sig.dummy_site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = None; Cckappa_sig.site_state = { - Cckappa_sig.min= Some Ckappa_sig.dummy_state_index ; - Cckappa_sig.max = Some Ckappa_sig.dummy_state_index - }} + Cckappa_sig.min = Some Ckappa_sig.dummy_state_index; + Cckappa_sig.max = Some Ckappa_sig.dummy_state_index; + }; + } let add_site parameters error handler cckappa_only agent_id site_name mixture = let error', agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_id - mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_id mixture.Cckappa_sig.views in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit @@ -83,57 +76,47 @@ let add_site parameters error handler cckappa_only agent_id site_name mixture = mixture.Cckappa_sig.c_mixture in let error, max_state_index = - Handler.last_state_of_site - parameters error handler agent_name site_name + Handler.last_state_of_site parameters error handler agent_name site_name in let site = { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_free = None ; + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = None; Cckappa_sig.site_state = { - Cckappa_sig.min= Some Ckappa_sig.dummy_state_index ; - Cckappa_sig.max = Some max_state_index - }} + Cckappa_sig.min = Some Ckappa_sig.dummy_state_index; + Cckappa_sig.max = Some max_state_index; + }; + } in let error', interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters error - site_name - site + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name site ag.Cckappa_sig.agent_interface in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit in - let ag = - {ag with Cckappa_sig.agent_interface = interface} - in + let ag = { ag with Cckappa_sig.agent_interface = interface } in let agent = Cckappa_sig.Agent ag in let error', views = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - agent_id agent mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_id agent mixture.Cckappa_sig.views in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit in - error, - { mixture - with - Cckappa_sig.c_mixture = c_mixture ; - Cckappa_sig.views = views - } - | Some (Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _ ) | None -> + error, { mixture with Cckappa_sig.c_mixture; Cckappa_sig.views } + | Some + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) + | None -> Exception.warn parameters error __POS__ Exit mixture let add_state parameters error agent_id site_name state mixture = let error', agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_id - mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_id mixture.Cckappa_sig.views in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit @@ -141,95 +124,83 @@ let add_state parameters error agent_id site_name state mixture = match agent with | Some (Cckappa_sig.Agent ag) -> let error, site = - Ckappa_sig.Site_map_and_set.Map.find_default_without_logs - parameters error - empty_port - site_name - ag.Cckappa_sig.agent_interface + Ckappa_sig.Site_map_and_set.Map.find_default_without_logs parameters error + empty_port site_name ag.Cckappa_sig.agent_interface in let error, () = - if Ckappa_sig.compare_state_index_option_min - (Some state) - site.Cckappa_sig.site_state.Cckappa_sig.min < 0 - || - Ckappa_sig.compare_state_index_option_max - site.Cckappa_sig.site_state.Cckappa_sig.max - (Some state) < 0 + if + Ckappa_sig.compare_state_index_option_min (Some state) + site.Cckappa_sig.site_state.Cckappa_sig.min + < 0 + || Ckappa_sig.compare_state_index_option_max + site.Cckappa_sig.site_state.Cckappa_sig.max (Some state) + < 0 then Exception.warn parameters error __POS__ Exit () else error, () in - let site = {site with Cckappa_sig.site_state = {Cckappa_sig.min=Some state; Cckappa_sig.max=Some state}} + let site = + { + site with + Cckappa_sig.site_state = + { Cckappa_sig.min = Some state; Cckappa_sig.max = Some state }; + } in let error', agent_interface = - Ckappa_sig.Site_map_and_set.Map.overwrite - parameters error - site_name site + Ckappa_sig.Site_map_and_set.Map.overwrite parameters error site_name site ag.Cckappa_sig.agent_interface in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit in - let ag = - {ag with Cckappa_sig.agent_interface = agent_interface} - in + let ag = { ag with Cckappa_sig.agent_interface } in let agent = Cckappa_sig.Agent ag in let error', views = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - agent_id agent mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_id agent mixture.Cckappa_sig.views in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit in - error, - { mixture - with - Cckappa_sig.views = views; - } - | Some (Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _ ) | None -> + error, { mixture with Cckappa_sig.views } + | Some + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) + | None -> Exception.warn parameters error __POS__ Exit mixture - - - -let add_pointer - parameter error - agent_id site_name address mixture = +let add_pointer parameter error agent_id site_name address mixture = let error, old = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameter error agent_id mixture.Cckappa_sig.bonds in + parameter error agent_id mixture.Cckappa_sig.bonds + in let old = match old with | None -> Ckappa_sig.Site_map_and_set.Map.empty | Some old -> old in let error', old' = - Ckappa_sig.Site_map_and_set.Map.add parameter error - site_name address old + Ckappa_sig.Site_map_and_set.Map.add parameter error site_name address old in let error = Exception.check_point Exception.warn parameter error error' __POS__ Exit in let error, bonds = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameter error agent_id old' mixture.Cckappa_sig.bonds + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set parameter + error agent_id old' mixture.Cckappa_sig.bonds in - error, {mixture with Cckappa_sig.bonds = bonds} + error, { mixture with Cckappa_sig.bonds } -let add_link parameters error handler cckappa_only agent_id site_name agent_id' site_name' lnk_value mixture = +let add_link parameters error handler cckappa_only agent_id site_name agent_id' + site_name' lnk_value mixture = let error, agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_id - mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_id mixture.Cckappa_sig.views in let error, agent' = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_id' - mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_id' mixture.Cckappa_sig.views in match agent, agent' with | Some (Cckappa_sig.Agent ag), Some (Cckappa_sig.Agent ag') -> @@ -252,21 +223,19 @@ let add_link parameters error handler cckappa_only agent_id site_name agent_id' error, mixture.Cckappa_sig.c_mixture else Ckappa_sig.add_link parameters error agent_id ~agent_name site_string - agent_id' ~agent_name' site_string' lnk_value - mixture.Cckappa_sig.c_mixture + agent_id' ~agent_name' site_string' lnk_value + mixture.Cckappa_sig.c_mixture in let error, state = - Handler.id_of_binding_type - parameters error handler - agent_type site_name agent_type' site_name' + Handler.id_of_binding_type parameters error handler agent_type site_name + agent_type' site_name' in let error, mixture = add_state parameters error agent_id site_name state mixture in let error, state' = - Handler.id_of_binding_type - parameters error handler - agent_type' site_name' agent_type site_name + Handler.id_of_binding_type parameters error handler agent_type' site_name' + agent_type site_name in let error, mixture = add_state parameters error agent_id' site_name' state' mixture @@ -274,103 +243,98 @@ let add_link parameters error handler cckappa_only agent_id site_name agent_id' let site_address = { Cckappa_sig.agent_index = agent_id'; - Cckappa_sig.site = site_name' ; - Cckappa_sig.agent_type = agent_type' } + Cckappa_sig.site = site_name'; + Cckappa_sig.agent_type = agent_type'; + } in let error, mixture = - add_pointer - parameters error - agent_id site_name site_address mixture + add_pointer parameters error agent_id site_name site_address mixture in let site_address' = { Cckappa_sig.agent_index = agent_id; - Cckappa_sig.site = site_name ; - Cckappa_sig.agent_type = agent_type } + Cckappa_sig.site = site_name; + Cckappa_sig.agent_type; + } in let error, mixture = - add_pointer - parameters error - agent_id' site_name' site_address' mixture + add_pointer parameters error agent_id' site_name' site_address' mixture in - error, - { mixture - with - Cckappa_sig.c_mixture = c_mixture ; - } - | (Some (Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _ ) | None), _ - | _, (Some (Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _ ) | None) -> + error, { mixture with Cckappa_sig.c_mixture } + | ( ( Some + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) + | None ), + _ ) + | ( _, + ( Some + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) + | None ) ) -> Exception.warn parameters error __POS__ Exit mixture -type in_progress = - { - fresh_agent_id: Ckappa_sig.c_agent_id ; - fresh_bond_id: Ckappa_sig.c_link_value ; - cckappa_only: bool; - mixture: Cckappa_sig.mixture; - kappa_handler: Cckappa_sig.kappa_handler ; - } +type in_progress = { + fresh_agent_id: Ckappa_sig.c_agent_id; + fresh_bond_id: Ckappa_sig.c_link_value; + cckappa_only: bool; + mixture: Cckappa_sig.mixture; + kappa_handler: Cckappa_sig.kappa_handler; +} let init ?cckappa_only parameters error kappa_handler = let error, mixture = Preprocess.empty_mixture parameters error in - error, - let cckappa_only = - match cckappa_only with - | None | Some false -> false - | Some true -> true - in - { - fresh_agent_id = Ckappa_sig.dummy_agent_id ; - fresh_bond_id = Ckappa_sig.dummy_link_value ; - mixture = mixture ; - cckappa_only = cckappa_only ; - kappa_handler = kappa_handler - } + ( error, + let cckappa_only = + match cckappa_only with + | None | Some false -> false + | Some true -> true + in + { + fresh_agent_id = Ckappa_sig.dummy_agent_id; + fresh_bond_id = Ckappa_sig.dummy_link_value; + mixture; + cckappa_only; + kappa_handler; + } ) let add_agent parameters error agent_type in_progress = let handler = in_progress.kappa_handler in let agent_id = in_progress.fresh_agent_id in let fresh_agent_id = Ckappa_sig.next_agent_id in_progress.fresh_agent_id in let error, mixture = - add_agent - parameters error handler in_progress.cckappa_only - agent_id agent_type in_progress.mixture + add_agent parameters error handler in_progress.cckappa_only agent_id + agent_type in_progress.mixture in - error, agent_id, {in_progress with fresh_agent_id ; mixture} + error, agent_id, { in_progress with fresh_agent_id; mixture } let add_site parameters error agent_id site_name in_progress = let handler = in_progress.kappa_handler in let error, mixture = - add_site - parameters error handler in_progress.cckappa_only - agent_id site_name in_progress.mixture + add_site parameters error handler in_progress.cckappa_only agent_id + site_name in_progress.mixture in - error, {in_progress with mixture} + error, { in_progress with mixture } let add_internal_state parameters error agent_id site_name state in_progress = - let error',mixture = - add_state - parameters error agent_id site_name state in_progress.mixture + let error', mixture = + add_state parameters error agent_id site_name state in_progress.mixture in - Exception.check_point Exception.warn parameters error error' __POS__ Exit, {in_progress with mixture} + ( Exception.check_point Exception.warn parameters error error' __POS__ Exit, + { in_progress with mixture } ) let add_free parameters error agent_id site_name in_progress = - add_internal_state - parameters error agent_id site_name Ckappa_sig.dummy_state_index in_progress - - - + add_internal_state parameters error agent_id site_name + Ckappa_sig.dummy_state_index in_progress -let add_link parameters error agent_id site_name agent_id' site_name' in_progress = +let add_link parameters error agent_id site_name agent_id' site_name' + in_progress = let handler = in_progress.kappa_handler in let lnk_id = in_progress.fresh_bond_id in - let fresh_bond_id = Ckappa_sig.next_lnk_value in_progress.fresh_bond_id in + let fresh_bond_id = Ckappa_sig.next_link_value in_progress.fresh_bond_id in let error, mixture = - add_link - parameters error handler in_progress.cckappa_only - agent_id site_name agent_id' site_name' lnk_id - in_progress.mixture + add_link parameters error handler in_progress.cckappa_only agent_id + site_name agent_id' site_name' lnk_id in_progress.mixture in - error, {in_progress with fresh_bond_id ; mixture} + error, { in_progress with fresh_bond_id; mixture } let export in_progress = in_progress.mixture diff --git a/core/KaSa_rep/frontend/build_graph.mli b/core/KaSa_rep/frontend/build_graph.mli index d8343ae6d1..b775e3903c 100644 --- a/core/KaSa_rep/frontend/build_graph.mli +++ b/core/KaSa_rep/frontend/build_graph.mli @@ -14,38 +14,53 @@ type in_progress -val init: +val init : ?cckappa_only:bool -> Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> Exception.method_handler * in_progress -val add_agent: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - Ckappa_sig.c_agent_name -> in_progress -> +val add_agent : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_agent_name -> + in_progress -> Exception.method_handler * Ckappa_sig.c_agent_id * in_progress -val add_site: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - Ckappa_sig.c_agent_id -> Ckappa_sig.c_site_name -> in_progress -> +val add_site : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_agent_id -> + Ckappa_sig.c_site_name -> + in_progress -> Exception.method_handler * in_progress -val add_free: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - Ckappa_sig.c_agent_id -> Ckappa_sig.c_site_name -> in_progress -> - Exception.method_handler * in_progress +val add_free : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_agent_id -> + Ckappa_sig.c_site_name -> + in_progress -> + Exception.method_handler * in_progress -val add_internal_state: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - Ckappa_sig.c_agent_id -> Ckappa_sig.c_site_name -> Ckappa_sig.c_state -> in_progress -> +val add_internal_state : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_agent_id -> + Ckappa_sig.c_site_name -> + Ckappa_sig.c_state -> + in_progress -> Exception.method_handler * in_progress -val add_link: -Remanent_parameters_sig.parameters -> Exception.method_handler -> -Ckappa_sig.c_agent_id -> Ckappa_sig.c_site_name -> -Ckappa_sig.c_agent_id -> Ckappa_sig.c_site_name -> -in_progress -> -Exception.method_handler * in_progress +val add_link : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_agent_id -> + Ckappa_sig.c_site_name -> + Ckappa_sig.c_agent_id -> + Ckappa_sig.c_site_name -> + in_progress -> + Exception.method_handler * in_progress -val export: in_progress -> Cckappa_sig.mixture +val export : in_progress -> Cckappa_sig.mixture diff --git a/core/KaSa_rep/frontend/cckappa_sig.ml b/core/KaSa_rep/frontend/cckappa_sig.ml index a9fb8e7298..870de1196f 100644 --- a/core/KaSa_rep/frontend/cckappa_sig.ml +++ b/core/KaSa_rep/frontend/cckappa_sig.ml @@ -12,203 +12,202 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type site = - (Ckappa_sig.c_site_name, Ckappa_sig.c_site_name, Ckappa_sig.c_site_name) Ckappa_sig.site_type +type site = + ( Ckappa_sig.c_site_name, + Ckappa_sig.c_site_name, + Ckappa_sig.c_site_name ) + Ckappa_sig.site_type type state_dic = (unit, unit) Ckappa_sig.Dictionary_of_States.dictionary -type kappa_handler = - { - nrules : int; - nvars : int; - nagents : Ckappa_sig.c_agent_name; - agents_dic : Ckappa_sig.agent_dic; - agents_annotation : - (string * Locality.t list ) - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; - interface_constraints : Ckappa_sig.agent_specification - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; - sites : Ckappa_sig.site_dic - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; - states_dic : state_dic - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t; - dual : - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.t; - } - -type 'a interval = {min:'a option; max:'a option} - -type 'state port = - { - site_name : Ckappa_sig.c_site_name; - site_position : Ckappa_sig.position; - site_free : bool option; - site_state : 'state - } +type kappa_handler = { + nrules: int; + nvars: int; + nagents: Ckappa_sig.c_agent_name; + agents_dic: Ckappa_sig.agent_dic; + agents_annotation: + (string * Loc.t list) + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + interface_constraints: + Ckappa_sig.agent_specification + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + sites: + Ckappa_sig.site_dic Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + states_dic: + state_dic + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t; + dual: + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .t; +} + +type 'a interval = { min: 'a option; max: 'a option } + +type 'state port = { + site_name: Ckappa_sig.c_site_name; + site_position: Ckappa_sig.position; + site_free: bool option; + site_state: 'state; +} type 'state interface = 'state port Ckappa_sig.Site_map_and_set.Map.t -type 'interface proper_agent = - { - agent_kasim_id : Ckappa_sig.c_agent_id; - agent_name : Ckappa_sig.c_agent_name; - agent_interface : 'interface; - agent_position : Ckappa_sig.position; - is_created : bool; - } +type 'interface proper_agent = { + agent_kasim_id: Ckappa_sig.c_agent_id; + agent_name: Ckappa_sig.c_agent_name; + agent_interface: 'interface; + agent_position: Ckappa_sig.position; + is_created: bool; +} -type site_address = - { - agent_index : Ckappa_sig.c_agent_id; - site : Ckappa_sig.c_site_name; - agent_type : Ckappa_sig.c_agent_name - } +type site_address = { + agent_index: Ckappa_sig.c_agent_id; + site: Ckappa_sig.c_site_name; + agent_type: Ckappa_sig.c_agent_name; +} type delta = int -module Address_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = site_address - let compare = compare - let print _ _ = () - end)) +module Address_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = site_address + + let compare = compare + let print _ _ = () +end)) type bond = site_address * site_address -module KaSim_Site_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = (string, string, string) Ckappa_sig.site_type - let compare = compare - let print _ _ = () - end)) +module KaSim_Site_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = (string, string, string) Ckappa_sig.site_type + + let compare = compare + let print _ _ = () +end)) type agent = | Ghost | Agent of Ckappa_sig.c_state interval interface proper_agent | Dead_agent of - Ckappa_sig.c_state interval interface proper_agent * - KaSim_Site_map_and_set.Set.t * ((string option, unit, unit) Ckappa_sig.site_type) - Ckappa_sig.Site_map_and_set.Map.t * - Ckappa_sig.link Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.c_state interval interface proper_agent + * KaSim_Site_map_and_set.Set.t + * (string option, unit, unit) Ckappa_sig.site_type + Ckappa_sig.Site_map_and_set.Map.t + * Ckappa_sig.link Ckappa_sig.Site_map_and_set.Map.t (* agent with a site or state that never occur in the rhs or an initial state, set of the undefined sites, map of sites with undefined internal states, map of sites with undefined binding states*) | Unknown_agent of (string * Ckappa_sig.c_agent_id) - (* agent with a type that never occur in rhs or initial states *) +(* agent with a type that never occur in rhs or initial states *) type agent_sig = Ckappa_sig.c_state list interface proper_agent - type views = agent Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t type diff_views = - Ckappa_sig.c_state - interval - port - Ckappa_sig.Site_map_and_set.Map.t - proper_agent - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t - -type mixture = - { - c_mixture : Ckappa_sig.mixture; - views : views; - bonds : site_address Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t; - plus : (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list; - dot : (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list - } - -type enriched_variable = - { - e_id : string * Ckappa_sig.position ; - e_id_dot : string * Ckappa_sig.position ; - c_variable : (Ckappa_sig.mixture,string) Alg_expr.e; - e_variable : (mixture,string) Ast.variable_def - } - -type counter_action = - { - precondition:Ckappa_sig.c_state interval; - postcondition: Ckappa_sig.c_state interval; - increment: delta - } - -type actions = - { - creation : (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name) list; - remove : (Ckappa_sig.c_agent_id * unit interface proper_agent * Ckappa_sig.c_site_name list) list; - release : bond list; - bind : bond list; - half_break : (site_address * (Ckappa_sig.c_state interval option)) list ; - translate_counters : (site_address * counter_action) list ; - removed_counters: (site_address * Ckappa_sig.c_state interval) list ; - new_counters: (site_address * Ckappa_sig.c_state) list; - binder: (string * site_address) list; - } - -type rule = - { - prefix : int; - delta : int; - rule_lhs : mixture; - rule_rhs : mixture; - diff_direct : diff_views; - diff_reverse : diff_views; - actions : actions - } + Ckappa_sig.c_state interval port Ckappa_sig.Site_map_and_set.Map.t + proper_agent + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t + +type mixture = { + c_mixture: Ckappa_sig.mixture; + views: views; + bonds: + site_address Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t; + plus: (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list; + dot: (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list; +} + +type enriched_variable = { + e_id: string * Ckappa_sig.position; + e_id_dot: string * Ckappa_sig.position; + c_variable: (Ckappa_sig.mixture, string) Alg_expr.e; + e_variable: (mixture, string) Ast.variable_def; +} + +type counter_action = { + precondition: Ckappa_sig.c_state interval; + postcondition: Ckappa_sig.c_state interval; + increment: delta; +} + +type actions = { + creation: (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name) list; + remove: + (Ckappa_sig.c_agent_id + * unit interface proper_agent + * Ckappa_sig.c_site_name list) + list; + release: bond list; + bind: bond list; + half_break: (site_address * Ckappa_sig.c_state interval option) list; + translate_counters: (site_address * counter_action) list; + removed_counters: (site_address * Ckappa_sig.c_state interval) list; + new_counters: (site_address * Ckappa_sig.c_state) list; + binder: (string * site_address) list; +} + +type rule = { + prefix: int; + delta: int; + rule_lhs: mixture; + rule_rhs: mixture; + diff_direct: diff_views; + diff_reverse: diff_views; + actions: actions; +} type modif_expr = - | APPLY of ((mixture,string) Alg_expr.e * rule * Ckappa_sig.position) - | UPDATE of (string * Ckappa_sig.position * (mixture,string) Alg_expr.e * Ckappa_sig.position) + | APPLY of ((mixture, string) Alg_expr.e * rule * Ckappa_sig.position) + | UPDATE of + (string + * Ckappa_sig.position + * (mixture, string) Alg_expr.e + * Ckappa_sig.position) (*TODO: pause*) - | STOP of Ckappa_sig.position + | STOP of Ckappa_sig.position | SNAPSHOT of Ckappa_sig.position (*maybe later of mixture too*) type perturbation = - ((((mixture,string) Alg_expr.bool) * Ckappa_sig.position) * - (modif_expr list) * - (((mixture,string) Alg_expr.bool * Ckappa_sig.position) option)) * - Ckappa_sig.position - -type enriched_rule = - { - e_rule_label : (string * Ckappa_sig.position) option; - e_rule_label_dot : (string * Ckappa_sig.position) option; - e_rule_initial_direction : Ckappa_sig.direction; - e_rule_rule : Ckappa_sig.mixture Ckappa_sig.rule; - e_rule_c_rule : rule - } - -type enriched_init = - { - e_init_factor : (Ckappa_sig.mixture, string) Alg_expr.e; - e_init_c_factor : (mixture, string) Alg_expr.e; - e_init_mixture : Ckappa_sig.mixture; - e_init_c_mixture : mixture - } - -type compil = - { - variables : enriched_variable Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t ; - (*pattern declaration for reusing as variable in perturbations or kinetic rate*) - signatures : (agent_sig (*position*)) Int_storage.Nearly_inf_Imperatif.t; - (*agent signature declaration*) - counter_default: Ckappa_sig.c_state option Ckappa_sig.AgentSite_map_and_set.Map.t ; - rules : enriched_rule Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t; - (*rules (possibly named)*) - observables : - (mixture, string) Alg_expr.e Locality.annot Int_storage.Nearly_inf_Imperatif.t; - (*list of patterns to plot*) - init : enriched_init Int_storage.Nearly_inf_Imperatif.t ; - (*initial graph declaration*) - perturbations : - (mixture,rule) Ckappa_sig.perturbation Int_storage.Nearly_inf_Imperatif.t - } + (((mixture, string) Alg_expr.bool * Ckappa_sig.position) + * modif_expr list + * ((mixture, string) Alg_expr.bool * Ckappa_sig.position) option) + * Ckappa_sig.position + +type enriched_rule = { + e_rule_label: (string * Ckappa_sig.position) option; + e_rule_label_dot: (string * Ckappa_sig.position) option; + e_rule_initial_direction: Ckappa_sig.direction; + e_rule_rule: Ckappa_sig.mixture Ckappa_sig.rule; + e_rule_c_rule: rule; +} + +type enriched_init = { + e_init_factor: (Ckappa_sig.mixture, string) Alg_expr.e; + e_init_c_factor: (mixture, string) Alg_expr.e; + e_init_mixture: Ckappa_sig.mixture; + e_init_c_mixture: mixture; +} + +type compil = { + variables: + enriched_variable Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t; + (*pattern declaration for reusing as variable in perturbations or kinetic rate*) + signatures: agent_sig (*position*) Int_storage.Nearly_inf_Imperatif.t; + (*agent signature declaration*) + counter_default: + Ckappa_sig.c_state option Ckappa_sig.AgentSite_map_and_set.Map.t; + rules: enriched_rule Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t; + (*rules (possibly named)*) + observables: + (mixture, string) Alg_expr.e Loc.annoted Int_storage.Nearly_inf_Imperatif.t; + (*list of patterns to plot*) + init: enriched_init Int_storage.Nearly_inf_Imperatif.t; + (*initial graph declaration*) + perturbations: + (mixture, rule) Ckappa_sig.perturbation Int_storage.Nearly_inf_Imperatif.t; +} (*******************************************************) (*EMPTY*) @@ -216,10 +215,10 @@ type compil = let empty_actions = { - creation = []; - remove = []; - release = []; - bind = []; + creation = []; + remove = []; + release = []; + bind = []; half_break = []; translate_counters = []; removed_counters = []; @@ -228,25 +227,22 @@ let empty_actions = } let dummy_init parameters error = - let error,views = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - let error,bonds = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 + let error, views = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in - error, - { - e_init_factor = Alg_expr.CONST (Nbr.I 0); - e_init_c_factor = Alg_expr.CONST (Nbr.I 0); - e_init_mixture = Ckappa_sig.EMPTY_MIX; - e_init_c_mixture = - { - c_mixture = Ckappa_sig.EMPTY_MIX; - views = views; - bonds = bonds; - plus = []; - dot = [] - }; - } + let error, bonds = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 + in + ( error, + { + e_init_factor = Alg_expr.CONST (Nbr.I 0); + e_init_c_factor = Alg_expr.CONST (Nbr.I 0); + e_init_mixture = Ckappa_sig.EMPTY_MIX; + e_init_c_mixture = + { c_mixture = Ckappa_sig.EMPTY_MIX; views; bonds; plus = []; dot = [] }; + } ) (*******************************************************) (*JOIN*) @@ -260,44 +256,32 @@ let _port_equal port1 port2 = && state_equal port1.site_state port2.site_state let join_port parameters error a b = - if a.site_name == b.site_name - then + if a.site_name == b.site_name then ( let error, site_free = match a.site_free, b.site_free with - | None, x | x,None -> error, x - | Some b1, Some b2 when b1=b2 -> error, a.site_free - | Some _ , Some _ -> - Exception.warn parameters error __POS__ Exit None + | None, x | x, None -> error, x + | Some b1, Some b2 when b1 = b2 -> error, a.site_free + | Some _, Some _ -> Exception.warn parameters error __POS__ Exit None in let site_state = - {min = max a.site_state.min b.site_state.min ; - max = min a.site_state.max b.site_state.max + { + min = max a.site_state.min b.site_state.min; + max = min a.site_state.max b.site_state.max; } in - error, - { - a - with - site_free = site_free ; - site_state = site_state } - else + error, { a with site_free; site_state } + ) else Exception.warn parameters error __POS__ Exit a let _join_interface parameters error interface1 interface2 = - Ckappa_sig.Site_map_and_set.Map.fold2 - parameters error - Ckappa_sig.Site_map_and_set.Map.add - Ckappa_sig.Site_map_and_set.Map.add + Ckappa_sig.Site_map_and_set.Map.fold2 parameters error + Ckappa_sig.Site_map_and_set.Map.add Ckappa_sig.Site_map_and_set.Map.add (fun parameters error a b c map -> - if b=c then - Ckappa_sig.Site_map_and_set.Map.add - parameters error a b map - else - Exception.warn parameters error __POS__ Exit map - ) - interface1 - interface2 - Ckappa_sig.Site_map_and_set.Map.empty + if b = c then + Ckappa_sig.Site_map_and_set.Map.add parameters error a b map + else + Exception.warn parameters error __POS__ Exit map) + interface1 interface2 Ckappa_sig.Site_map_and_set.Map.empty let join_interface' = KaSim_Site_map_and_set.Set.union @@ -306,62 +290,43 @@ let join_interface' = KaSim_Site_map_and_set.Set.union let join_proper_agent parameters error agent1 agent2 = let bool = (*agent1.agent_kasim_id = agent2.agent_kasim_id - &&*) agent1.agent_name = agent2.agent_name + &&*) + agent1.agent_name = agent2.agent_name in - if bool then + if bool then ( let error, map = - Ckappa_sig.Site_map_and_set.Map.fold2 - parameters error - Ckappa_sig.Site_map_and_set.Map.add - Ckappa_sig.Site_map_and_set.Map.add + Ckappa_sig.Site_map_and_set.Map.fold2 parameters error + Ckappa_sig.Site_map_and_set.Map.add Ckappa_sig.Site_map_and_set.Map.add (fun parameters error key a b map -> - let error, c = join_port parameters error a b in - Ckappa_sig.Site_map_and_set.Map.add - parameters error key c map) - agent1.agent_interface - agent2.agent_interface + let error, c = join_port parameters error a b in + Ckappa_sig.Site_map_and_set.Map.add parameters error key c map) + agent1.agent_interface agent2.agent_interface Ckappa_sig.Site_map_and_set.Map.empty in - error, {agent1 with agent_interface = map} - else - Exception.warn parameters error __POS__ Exit agent1 + error, { agent1 with agent_interface = map } + ) else + Exception.warn parameters error __POS__ Exit agent1 let join_props parameters error map1 map2 = - Ckappa_sig.Site_map_and_set.Map.fold2 - parameters error - Ckappa_sig.Site_map_and_set.Map.add - Ckappa_sig.Site_map_and_set.Map.add + Ckappa_sig.Site_map_and_set.Map.fold2 parameters error + Ckappa_sig.Site_map_and_set.Map.add Ckappa_sig.Site_map_and_set.Map.add (fun parameters error key value1 value2 map -> - if value1=value2 - then - Ckappa_sig.Site_map_and_set.Map.add - parameters error key value1 map - else - Exception.warn parameters error __POS__ Exit map) - map1 - map2 - Ckappa_sig.Site_map_and_set.Map.empty + if value1 = value2 then + Ckappa_sig.Site_map_and_set.Map.add parameters error key value1 map + else + Exception.warn parameters error __POS__ Exit map) + map1 map2 Ckappa_sig.Site_map_and_set.Map.empty let join_bonds' parameters error map1 map2 = - Ckappa_sig.Site_map_and_set.Map.fold2 - parameters error - Ckappa_sig.Site_map_and_set.Map.add - Ckappa_sig.Site_map_and_set.Map.add + Ckappa_sig.Site_map_and_set.Map.fold2 parameters error + Ckappa_sig.Site_map_and_set.Map.add Ckappa_sig.Site_map_and_set.Map.add (fun parameters error key value1 value2 map -> - let error, value3 = - Ckappa_sig.join_link parameters error value1 value2 - in - Ckappa_sig.Site_map_and_set.Map.add - parameters error key value3 map - ) - map1 - map2 - Ckappa_sig.Site_map_and_set.Map.empty + let error, value3 = Ckappa_sig.join_link parameters error value1 value2 in + Ckappa_sig.Site_map_and_set.Map.add parameters error key value3 map) + map1 map2 Ckappa_sig.Site_map_and_set.Map.empty let join_agent parameters error agent1 agent2 = - match - agent1, agent2 - with + match agent1, agent2 with | Ghost, _ -> error, agent2 | _, Ghost -> error, agent1 | Agent proper_agent1, Agent proper_agent2 -> @@ -369,96 +334,98 @@ let join_agent parameters error agent1 agent2 = join_proper_agent parameters error proper_agent1 proper_agent2 in error, Agent proper_agent - | Dead_agent (proper_agent1, intf1, props1, bonds1), - Dead_agent (proper_agent2, intf2, props2, bonds2) -> - let error, proper_agent3 = join_proper_agent parameters error proper_agent1 proper_agent2 in + | ( Dead_agent (proper_agent1, intf1, props1, bonds1), + Dead_agent (proper_agent2, intf2, props2, bonds2) ) -> + let error, proper_agent3 = + join_proper_agent parameters error proper_agent1 proper_agent2 + in let error, intf3 = join_interface' parameters error intf1 intf2 in let error, props3 = join_props parameters error props1 props2 in let error, bonds3 = join_bonds' parameters error bonds1 bonds2 in error, Dead_agent (proper_agent3, intf3, props3, bonds3) - | Dead_agent (proper_agent1, intf1, props1, bonds1), - Agent (proper_agent) - | Agent (proper_agent), - Dead_agent(proper_agent1, intf1, props1, bonds1) -> - let error, proper_agent = join_proper_agent parameters error proper_agent proper_agent1 in + | Dead_agent (proper_agent1, intf1, props1, bonds1), Agent proper_agent + | Agent proper_agent, Dead_agent (proper_agent1, intf1, props1, bonds1) -> + let error, proper_agent = + join_proper_agent parameters error proper_agent proper_agent1 + in error, Dead_agent (proper_agent, intf1, props1, bonds1) - | Unknown_agent (string1, id1), Unknown_agent (string2, id2) when string1=string2 && id1=id2 -> error, agent1 - | (Agent _ | Dead_agent _ | Unknown_agent _), - (Agent _ | Dead_agent _ | Unknown_agent _) - -> Exception.warn parameters error __POS__ Exit agent1 + | Unknown_agent (string1, id1), Unknown_agent (string2, id2) + when string1 = string2 && id1 = id2 -> + error, agent1 + | ( (Agent _ | Dead_agent _ | Unknown_agent _), + (Agent _ | Dead_agent _ | Unknown_agent _) ) -> + Exception.warn parameters error __POS__ Exit agent1 let join_views parameters error views1 views2 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error id agent1 v -> - let error, agent2 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error id views2 - in - let error, agent3 = - match agent2 with - | None -> error, agent1 - | Some agent2 -> - join_agent parameters error agent1 agent2 - in - let error', v = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error id agent3 v - in - let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit - in - error, v) - views1 - views2 + let error, agent2 = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error id views2 + in + let error, agent3 = + match agent2 with + | None -> error, agent1 + | Some agent2 -> join_agent parameters error agent1 agent2 + in + let error', v = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error id agent3 v + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, v) + views1 views2 let join_bonds parameters error bond1 bond2 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error id bond1 b -> - let error, bond2 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error id bond2 in - let error, bond3 = - match bond2 with - | None -> error, bond1 - | Some bond2 -> - Ckappa_sig.Site_map_and_set.Map.fold2 - parameters - error - Ckappa_sig.Site_map_and_set.Map.add - Ckappa_sig.Site_map_and_set.Map.add - (fun parameters error key value1 value2 map -> - if value1=value2 then - Ckappa_sig.Site_map_and_set.Map.add parameters error key value1 map - else - Exception.warn parameters error __POS__ Exit map) - bond1 - bond2 - Ckappa_sig.Site_map_and_set.Map.empty - in - let error', b = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error id bond3 b in - let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit - in - error, b - ) - bond1 - bond2 + let error, bond2 = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error id bond2 + in + let error, bond3 = + match bond2 with + | None -> error, bond1 + | Some bond2 -> + Ckappa_sig.Site_map_and_set.Map.fold2 parameters error + Ckappa_sig.Site_map_and_set.Map.add + Ckappa_sig.Site_map_and_set.Map.add + (fun parameters error key value1 value2 map -> + if value1 = value2 then + Ckappa_sig.Site_map_and_set.Map.add parameters error key value1 + map + else + Exception.warn parameters error __POS__ Exit map) + bond1 bond2 Ckappa_sig.Site_map_and_set.Map.empty + in + let error', b = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error id bond3 b + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, b) + bond1 bond2 let join_rel error l1 l2 = let l = List.rev (List.append l1 l2) in let rec clean l current output = - match l with t::q when t = current -> clean q current output - | t::q -> clean q t (t::output) - | [] -> List.rev output + match l with + | t :: q when t = current -> clean q current output + | t :: q -> clean q t (t :: output) + | [] -> List.rev output in let clean l = - match l with [] -> l | t::q -> clean q t [t] + match l with + | [] -> l + | t :: q -> clean q t [ t ] in error, clean l @@ -466,30 +433,21 @@ let join_rel error l1 l2 = (* UPGRADE *) (*******************************************************) -let upgrade_interface ag agent_interface = - {ag with agent_interface} +let upgrade_interface ag agent_interface = { ag with agent_interface } let map_agent f ag = - upgrade_interface - ag - begin - Ckappa_sig.Site_map_and_set.Map.map - (fun port -> - { - site_free = port.site_free; - site_name = port.site_name; - site_position = port.site_position; - site_state = f port.site_state - }) - ag.agent_interface - end - -let build_address k agent site = - { - agent_index = k; - site = site; - agent_type = agent - } + upgrade_interface ag + (Ckappa_sig.Site_map_and_set.Map.map + (fun port -> + { + site_free = port.site_free; + site_name = port.site_name; + site_position = port.site_position; + site_state = f port.site_state; + }) + ag.agent_interface) + +let build_address k agent site = { agent_index = k; site; agent_type = agent } (*******************************************************) (* RENAME *) @@ -497,16 +455,11 @@ let build_address k agent site = let rename_proper_agent parameters error f agent = let error, id = f parameters error agent.agent_kasim_id in - error, - { - agent with agent_kasim_id = id - } + error, { agent with agent_kasim_id = id } let rename_site_address parameters error f site_address = - let error, agent_index = - f parameters error site_address.agent_index - in - error, {site_address with agent_index = agent_index} + let error, agent_index = f parameters error site_address.agent_index in + error, { site_address with agent_index } let rename_agent parameters error f agent = match agent with @@ -517,15 +470,14 @@ let rename_agent parameters error f agent = in error, Agent proper_agent | Dead_agent (proper_agent, intf, props, bonds) -> - let error, proper_agent = rename_proper_agent parameters error f proper_agent in + let error, proper_agent = + rename_proper_agent parameters error f proper_agent + in let error, bonds = Ckappa_sig.Site_map_and_set.Map.fold (fun key value (error, map) -> - let error, value = - Ckappa_sig.rename_link parameters error f value - in - Ckappa_sig.Site_map_and_set.Map.add - parameters error key value map) + let error, value = Ckappa_sig.rename_link parameters error f value in + Ckappa_sig.Site_map_and_set.Map.add parameters error key value map) bonds (error, Ckappa_sig.Site_map_and_set.Map.empty) in @@ -536,71 +488,63 @@ let rename_agent parameters error f agent = let rename_views parameters error f views = let error, v_empty = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error id agent v -> - let error, id = f parameters error id in - let error, agent = rename_agent parameters error f agent in - let error', v = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error id agent v - in - let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit - in - error, v) - views - v_empty + let error, id = f parameters error id in + let error, agent = rename_agent parameters error f agent in + let error', v = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error id agent v + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, v) + views v_empty let rename_bonds parameters error f bonds = let error, empty = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error key value map -> - let error, key = f parameters error key in - let error, value = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site site_address (error, value) -> - let error, site_address = - rename_site_address - parameters - error - f - site_address - in - Ckappa_sig.Site_map_and_set.Map.add - parameters error site site_address value) - value - (error, Ckappa_sig.Site_map_and_set.Map.empty) - in - let error', map = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - key value map in - let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit - in - error, map) - bonds - empty + let error, key = f parameters error key in + let error, value = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site site_address (error, value) -> + let error, site_address = + rename_site_address parameters error f site_address + in + Ckappa_sig.Site_map_and_set.Map.add parameters error site + site_address value) + value + (error, Ckappa_sig.Site_map_and_set.Map.empty) + in + let error', map = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error key value map + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, map) + bonds empty let rename_rel parameters error f l = List.fold_left - (fun (error, list) (a,b) -> - let error, a = f parameters error a in - let error, b = f parameters error b in - error, (a,b)::list - ) - (error, []) - (List.rev l) + (fun (error, list) (a, b) -> + let error, a = f parameters error a in + let error, b = f parameters error b in + error, (a, b) :: list) + (error, []) (List.rev l) let rename_mixture parameters error f mixture = let error, c_mixture = @@ -610,13 +554,7 @@ let rename_mixture parameters error f mixture = let error, bonds = rename_bonds parameters error f mixture.bonds in let error, plus = rename_rel parameters error f mixture.plus in let error, dot = rename_rel parameters error f mixture.dot in - error, - {c_mixture = c_mixture ; - views = views ; - bonds = bonds ; - plus = plus ; - dot = dot ; - } + error, { c_mixture; views; bonds; plus; dot } (*******************************************************) (* JOIN MIXTURE *) @@ -625,52 +563,40 @@ let rename_mixture parameters error f mixture = let join_mixture parameters error f g mixture1 mixture2 = let error', mixture1 = rename_mixture parameters error f mixture1 in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error', mixture2 = rename_mixture parameters error g mixture2 in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error', c_mixture = - Ckappa_sig.join_mixture parameters error mixture1.c_mixture mixture2.c_mixture + Ckappa_sig.join_mixture parameters error mixture1.c_mixture + mixture2.c_mixture in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error', views = join_views parameters error mixture1.views mixture2.views in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error', bonds = join_bonds parameters error mixture1.bonds mixture2.bonds in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error', plus = join_rel error mixture1.plus mixture2.plus in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error', dot = join_rel error mixture1.dot mixture2.dot in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in - error, - {c_mixture = c_mixture ; - views = views ; - bonds = bonds ; - plus = plus ; - dot = dot ; - } + error, { c_mixture; views; bonds; plus; dot } (*******************************************************) (* ADD *) @@ -680,7 +606,7 @@ let empty_port site = let empty_interval = { min = Some Ckappa_sig.dummy_state_index; - max = Some Ckappa_sig.dummy_state_index + max = Some Ckappa_sig.dummy_state_index; } in let empty_port = @@ -688,71 +614,62 @@ let empty_port site = site_name = site; site_free = None; site_state = empty_interval; - site_position = Locality.dummy + site_position = Loc.dummy; } - in empty_port + in + empty_port let get_state_port_interval parameters error site agent_interface = match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters - error - site - agent_interface + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters error + site agent_interface with | error, None -> - Exception.warn parameters error __POS__ Exit - (empty_port site) + Exception.warn parameters error __POS__ Exit (empty_port site) | error, Some value -> error, value let max_state_index_option_min a b = - if Ckappa_sig.compare_state_index_option_min a b <= 0 - then b else a + if Ckappa_sig.compare_state_index_option_min a b <= 0 then + b + else + a let min_state_index_option_max a b = - if Ckappa_sig.compare_state_index_option_max a b <= 0 - then a else b - + if Ckappa_sig.compare_state_index_option_max a b <= 0 then + a + else + b let add_port parameters error site state_min state_max port = let old_min = port.site_state.min in let old_max = port.site_state.max in - if Ckappa_sig.compare_state_index_option_min state_min old_min <= 0 - || - Ckappa_sig.compare_state_index_option_max old_max state_max <= 0 - then + if + Ckappa_sig.compare_state_index_option_min state_min old_min <= 0 + || Ckappa_sig.compare_state_index_option_max old_max state_max <= 0 + then ( let new_min = max_state_index_option_min state_min old_min in let new_max = min_state_index_option_max state_max old_max in - if new_min = old_min && new_max = old_max - then + if new_min = old_min && new_max = old_max then error, port - else - let site_state = - {min = new_min; - max = new_max} - in - let port = - {port with site_state = site_state} - in + else ( + let site_state = { min = new_min; max = new_max } in + let port = { port with site_state } in error, port - else - Exception.warn parameters error __POS__ - ~message:"incompatible states" Exit (empty_port site) + ) + ) else + Exception.warn parameters error __POS__ ~message:"incompatible states" Exit + (empty_port site) let add_state parameters error site state port = add_port parameters error site state state port let add_agent_interface parameters error site agent_interface = let error, state = - get_state_port_interval parameters error - site agent_interface + get_state_port_interval parameters error site agent_interface in (*TODO: add_state_interval?*) let error', agent_interface = - Ckappa_sig.Site_map_and_set.Map.add_or_overwrite - parameters error - site - state + Ckappa_sig.Site_map_and_set.Map.add_or_overwrite parameters error site state agent_interface in let error = diff --git a/core/KaSa_rep/frontend/cckappa_sig.mli b/core/KaSa_rep/frontend/cckappa_sig.mli index 344a3cfaaf..a051d0a371 100644 --- a/core/KaSa_rep/frontend/cckappa_sig.mli +++ b/core/KaSa_rep/frontend/cckappa_sig.mli @@ -12,196 +12,203 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type site = - (Ckappa_sig.c_site_name, Ckappa_sig.c_site_name, Ckappa_sig.c_site_name) Ckappa_sig.site_type +type site = + ( Ckappa_sig.c_site_name, + Ckappa_sig.c_site_name, + Ckappa_sig.c_site_name ) + Ckappa_sig.site_type type state_dic = (unit, unit) Ckappa_sig.Dictionary_of_States.dictionary -type kappa_handler = - { - nrules : int; - nvars : int; - nagents : Ckappa_sig.c_agent_name; - agents_dic : Ckappa_sig.agent_dic; - agents_annotation : - (string * Locality.t list ) - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; - interface_constraints : Ckappa_sig.agent_specification - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; - sites : Ckappa_sig.site_dic - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; - states_dic : state_dic - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t; - dual : - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.t; - } - -type 'a interval = {min:'a option; max:'a option} - -type 'state port = - { - site_name : Ckappa_sig.c_site_name; - site_position : Ckappa_sig.position; - site_free : bool option; - site_state : 'state - } +type kappa_handler = { + nrules: int; + nvars: int; + nagents: Ckappa_sig.c_agent_name; + agents_dic: Ckappa_sig.agent_dic; + agents_annotation: + (string * Loc.t list) + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + interface_constraints: + Ckappa_sig.agent_specification + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + sites: + Ckappa_sig.site_dic Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t; + states_dic: + state_dic + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t; + dual: + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .t; +} + +type 'a interval = { min: 'a option; max: 'a option } + +type 'state port = { + site_name: Ckappa_sig.c_site_name; + site_position: Ckappa_sig.position; + site_free: bool option; + site_state: 'state; +} type 'state interface = 'state port Ckappa_sig.Site_map_and_set.Map.t -type 'interface proper_agent = - { - agent_kasim_id : Ckappa_sig.c_agent_id; - agent_name : Ckappa_sig.c_agent_name; - agent_interface : 'interface; - agent_position : Ckappa_sig.position; - is_created : bool; - } - -type site_address = - { - agent_index : Ckappa_sig.c_agent_id; - site : Ckappa_sig.c_site_name; - agent_type : Ckappa_sig.c_agent_name - } +type 'interface proper_agent = { + agent_kasim_id: Ckappa_sig.c_agent_id; + agent_name: Ckappa_sig.c_agent_name; + agent_interface: 'interface; + agent_position: Ckappa_sig.position; + is_created: bool; +} + +type site_address = { + agent_index: Ckappa_sig.c_agent_id; + site: Ckappa_sig.c_site_name; + agent_type: Ckappa_sig.c_agent_name; +} type delta = int -module Address_map_and_set: Map_wrapper.S_with_logs with type elt = site_address +module Address_map_and_set : + Map_wrapper.S_with_logs with type elt = site_address type bond = site_address * site_address -module KaSim_Site_map_and_set: Map_wrapper.S_with_logs with type elt = (string, string, string) Ckappa_sig.site_type +module KaSim_Site_map_and_set : + Map_wrapper.S_with_logs + with type elt = (string, string, string) Ckappa_sig.site_type type agent = | Ghost | Agent of Ckappa_sig.c_state interval interface proper_agent | Dead_agent of - Ckappa_sig.c_state interval interface proper_agent * - KaSim_Site_map_and_set.Set.t * ((string option, unit, unit) Ckappa_sig.site_type) - Ckappa_sig.Site_map_and_set.Map.t * - Ckappa_sig.link Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.c_state interval interface proper_agent + * KaSim_Site_map_and_set.Set.t + * (string option, unit, unit) Ckappa_sig.site_type + Ckappa_sig.Site_map_and_set.Map.t + * Ckappa_sig.link Ckappa_sig.Site_map_and_set.Map.t (* agent with a site or state that never occur in the rhs or an initial state, set of the undefined sites, map of sites with undefined internal states, map of sites with undefined binding states*) | Unknown_agent of (string * Ckappa_sig.c_agent_id) - (* agent with a type that never occur in rhs or initial states *) +(* agent with a type that never occur in rhs or initial states *) type agent_sig = Ckappa_sig.c_state list interface proper_agent - type views = agent Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t type diff_views = - Ckappa_sig.c_state - interval - port - Ckappa_sig.Site_map_and_set.Map.t - proper_agent - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t - -type mixture = - { - c_mixture : Ckappa_sig.mixture; - views : views; - bonds : site_address Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t; - plus : (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list; - dot : (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list - } - -type enriched_variable = - { - e_id : string * Ckappa_sig.position ; - e_id_dot : string * Ckappa_sig.position ; - c_variable : (Ckappa_sig.mixture,string) Alg_expr.e; - e_variable : (mixture,string) Ast.variable_def - } - -type counter_action = - { - precondition:Ckappa_sig.c_state interval; - postcondition: Ckappa_sig.c_state interval; - increment: delta - } - -type actions = - { - creation : (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name) list; - remove : (Ckappa_sig.c_agent_id * unit interface proper_agent * Ckappa_sig.c_site_name list) list; - release : bond list; - bind : bond list; - half_break : (site_address * (Ckappa_sig.c_state interval option)) list ; - translate_counters : (site_address * counter_action) list ; - removed_counters: (site_address * Ckappa_sig.c_state interval) list ; - new_counters: (site_address * Ckappa_sig.c_state) list; - binder: (string * site_address) list; - } - -type rule = - { - prefix : int; - delta : int; - rule_lhs : mixture; - rule_rhs : mixture; - diff_direct : diff_views; - diff_reverse : diff_views; - actions : actions - } + Ckappa_sig.c_state interval port Ckappa_sig.Site_map_and_set.Map.t + proper_agent + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t + +type mixture = { + c_mixture: Ckappa_sig.mixture; + views: views; + bonds: + site_address Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.t; + plus: (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list; + dot: (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_id) list; +} + +type enriched_variable = { + e_id: string * Ckappa_sig.position; + e_id_dot: string * Ckappa_sig.position; + c_variable: (Ckappa_sig.mixture, string) Alg_expr.e; + e_variable: (mixture, string) Ast.variable_def; +} + +type counter_action = { + precondition: Ckappa_sig.c_state interval; + postcondition: Ckappa_sig.c_state interval; + increment: delta; +} + +type actions = { + creation: (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name) list; + remove: + (Ckappa_sig.c_agent_id + * unit interface proper_agent + * Ckappa_sig.c_site_name list) + list; + release: bond list; + bind: bond list; + half_break: (site_address * Ckappa_sig.c_state interval option) list; + translate_counters: (site_address * counter_action) list; + removed_counters: (site_address * Ckappa_sig.c_state interval) list; + new_counters: (site_address * Ckappa_sig.c_state) list; + binder: (string * site_address) list; +} + +type rule = { + prefix: int; + delta: int; + rule_lhs: mixture; + rule_rhs: mixture; + diff_direct: diff_views; + diff_reverse: diff_views; + actions: actions; +} type modif_expr = - | APPLY of ((mixture,string) Alg_expr.e * rule * Ckappa_sig.position) - | UPDATE of (string * Ckappa_sig.position * (mixture,string) Alg_expr.e * Ckappa_sig.position) + | APPLY of ((mixture, string) Alg_expr.e * rule * Ckappa_sig.position) + | UPDATE of + (string + * Ckappa_sig.position + * (mixture, string) Alg_expr.e + * Ckappa_sig.position) (*TODO: pause*) - | STOP of Ckappa_sig.position + | STOP of Ckappa_sig.position | SNAPSHOT of Ckappa_sig.position (*maybe later of mixture too*) type perturbation = - ((((mixture,string) Alg_expr.bool) * Ckappa_sig.position) * - (modif_expr list) * - (((mixture,string) Alg_expr.bool * Ckappa_sig.position) option)) * - Ckappa_sig.position - -type enriched_rule = - { - e_rule_label : (string * Ckappa_sig.position) option; - e_rule_label_dot : (string * Ckappa_sig.position) option; - e_rule_initial_direction : Ckappa_sig.direction; - e_rule_rule : Ckappa_sig.mixture Ckappa_sig.rule; - e_rule_c_rule : rule - } - -type enriched_init = - { - e_init_factor : (Ckappa_sig.mixture, string) Alg_expr.e; - e_init_c_factor : (mixture, string) Alg_expr.e; - e_init_mixture : Ckappa_sig.mixture; - e_init_c_mixture : mixture - } - -type compil = - { - variables : enriched_variable Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t ; - (*pattern declaration for reusing as variable in perturbations or kinetic rate*) - signatures : (agent_sig (*position*)) Int_storage.Nearly_inf_Imperatif.t; - (*agent signature declaration*) - counter_default: Ckappa_sig.c_state option Ckappa_sig.AgentSite_map_and_set.Map.t ; - rules : enriched_rule Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t; - (*rules (possibly named)*) - observables : - (mixture, string) Alg_expr.e Locality.annot Int_storage.Nearly_inf_Imperatif.t; - (*list of patterns to plot*) - init : enriched_init Int_storage.Nearly_inf_Imperatif.t ; - (*initial graph declaration*) - perturbations : - (mixture,rule) Ckappa_sig.perturbation Int_storage.Nearly_inf_Imperatif.t - } + (((mixture, string) Alg_expr.bool * Ckappa_sig.position) + * modif_expr list + * ((mixture, string) Alg_expr.bool * Ckappa_sig.position) option) + * Ckappa_sig.position + +type enriched_rule = { + e_rule_label: (string * Ckappa_sig.position) option; + e_rule_label_dot: (string * Ckappa_sig.position) option; + e_rule_initial_direction: Ckappa_sig.direction; + e_rule_rule: Ckappa_sig.mixture Ckappa_sig.rule; + e_rule_c_rule: rule; +} + +type enriched_init = { + e_init_factor: (Ckappa_sig.mixture, string) Alg_expr.e; + e_init_c_factor: (mixture, string) Alg_expr.e; + e_init_mixture: Ckappa_sig.mixture; + e_init_c_mixture: mixture; +} + +type compil = { + variables: + enriched_variable Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t; + (*pattern declaration for reusing as variable in perturbations or kinetic rate*) + signatures: agent_sig (*position*) Int_storage.Nearly_inf_Imperatif.t; + (*agent signature declaration*) + counter_default: + Ckappa_sig.c_state option Ckappa_sig.AgentSite_map_and_set.Map.t; + rules: enriched_rule Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t; + (*rules (possibly named)*) + observables: + (mixture, string) Alg_expr.e Loc.annoted Int_storage.Nearly_inf_Imperatif.t; + (*list of patterns to plot*) + init: enriched_init Int_storage.Nearly_inf_Imperatif.t; + (*initial graph declaration*) + perturbations: + (mixture, rule) Ckappa_sig.perturbation Int_storage.Nearly_inf_Imperatif.t; +} (*******************************************************) (*EMPTY*) (*******************************************************) -val empty_actions: actions -val dummy_init: +val empty_actions : actions + +val dummy_init : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Exception_without_parameter.method_handler * enriched_init @@ -210,14 +217,13 @@ val dummy_init: (*JOIN*) (*******************************************************) -val rename_mixture: +val rename_mixture : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - Ckappa_sig.c_agent_id -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_agent_id) -> + Exception_without_parameter.method_handler -> + Ckappa_sig.c_agent_id -> + Exception_without_parameter.method_handler * Ckappa_sig.c_agent_id) -> mixture -> Exception_without_parameter.method_handler * mixture @@ -225,65 +231,69 @@ val rename_mixture: (* JOIN MIXTURE *) (*******************************************************) -val join_mixture: +val join_mixture : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - Ckappa_sig.c_agent_id -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_agent_id) -> + Exception_without_parameter.method_handler -> + Ckappa_sig.c_agent_id -> + Exception_without_parameter.method_handler * Ckappa_sig.c_agent_id) -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - Ckappa_sig.c_agent_id -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_agent_id) -> + Exception_without_parameter.method_handler -> + Ckappa_sig.c_agent_id -> + Exception_without_parameter.method_handler * Ckappa_sig.c_agent_id) -> + mixture -> mixture -> - mixture -> Exception_without_parameter.method_handler * mixture + Exception_without_parameter.method_handler * mixture (*******************************************************) (* ADD *) (*******************************************************) - -val add_port: +val add_port : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.c_site_name -> Ckappa_sig.c_state option -> Ckappa_sig.c_state option -> Ckappa_sig.c_state interval port -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_state interval port - + Exception_without_parameter.method_handler * Ckappa_sig.c_state interval port -val add_state: +val add_state : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.c_site_name -> Ckappa_sig.c_state option -> Ckappa_sig.c_state interval port -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_state interval port + Exception_without_parameter.method_handler * Ckappa_sig.c_state interval port -val add_agent_interface: +val add_agent_interface : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.c_site_name -> Ckappa_sig.c_state interval port Ckappa_sig.Site_map_and_set.Map.t -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_state interval port Ckappa_sig.Site_map_and_set.Map.t + Exception_without_parameter.method_handler + * Ckappa_sig.c_state interval port Ckappa_sig.Site_map_and_set.Map.t + +val max_state_index_option_min : + Ckappa_sig.c_state option -> + Ckappa_sig.c_state option -> + Ckappa_sig.c_state option -val max_state_index_option_min: Ckappa_sig.c_state option -> Ckappa_sig.c_state option -> Ckappa_sig.c_state option -val min_state_index_option_max: Ckappa_sig.c_state option -> Ckappa_sig.c_state option -> Ckappa_sig.c_state option +val min_state_index_option_max : + Ckappa_sig.c_state option -> + Ckappa_sig.c_state option -> + Ckappa_sig.c_state option -val upgrade_interface: 'a proper_agent -> 'b -> 'b proper_agent +val upgrade_interface : 'a proper_agent -> 'b -> 'b proper_agent -val map_agent: +val map_agent : ('a -> 'b) -> 'a port Ckappa_sig.Site_map_and_set.Map.t proper_agent -> 'b port Ckappa_sig.Site_map_and_set.Map.t proper_agent -val build_address: +val build_address : Ckappa_sig.c_agent_id -> - Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> site_address + Ckappa_sig.c_agent_name -> + Ckappa_sig.c_site_name -> + site_address diff --git a/core/KaSa_rep/frontend/ckappa_sig.ml b/core/KaSa_rep/frontend/ckappa_sig.ml index 0d33d28b30..f17b89ebac 100644 --- a/core/KaSa_rep/frontend/ckappa_sig.ml +++ b/core/KaSa_rep/frontend/ckappa_sig.ml @@ -12,147 +12,124 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module Int_Set_and_Map = Map_wrapper.Make(Mods.IntSetMap) +module Int_Set_and_Map = Map_wrapper.Make (Mods.IntSetMap) let local_trace = true - let _ = local_trace -type position = Locality.t -type agent_name = string -type site_name = string +type position = Loc.t +type agent_name = string +type site_name = string type internal_state = string type counter_name = string type counter_state = int - type c_agent_name = int -type c_agent_id = int -type c_site_name = int -type c_state = int -type c_rule_id = int -type c_link_value = int +type c_agent_id = int +type c_site_name = int +type c_state = int +type c_rule_id = int +type c_link_value = int type c_counter_name = int - -type binding_state = - | Free - | Lnk_type of agent_name * site_name - +type binding_state = Free | Lnk_type of agent_name * site_name type mixture = - | SKIP of mixture + | SKIP of mixture | COMMA of agent * mixture - | DOT of c_agent_id * agent * mixture - | PLUS of c_agent_id * agent * mixture + | DOT of c_agent_id * agent * mixture + | PLUS of c_agent_id * agent * mixture | EMPTY_MIX -and agent = - { - ag_nme : string; - ag_intf : interface; - ag_nme_pos : position (*; ag_pos:position*) - } +and agent = { + agent_name: string; + ag_intf: interface; + agent_name_pos: position; (*; ag_pos:position*) +} and interface = | EMPTY_INTF | PORT_SEP of port * interface | COUNTER_SEP of counter * interface -and port = - { - port_nme : string; - port_int : internal; - port_lnk : link; - (*port_pos: position ;*) - port_free : bool option - } - -and counter = - { - count_nme : string; - count_test : counter_test option; - count_delta: int option - } - -and counter_test = - | CEQ of int | CGTE of int | CVAR of string | UNKNOWN - - +and port = { + port_name: string; + port_int: internal; + port_link: link; + (*port_pos: position ;*) + port_free: bool option; +} + +and counter = { + counter_name: string; + counter_test: counter_test option; + counter_delta: int option; +} + +and counter_test = CEQ of int | CGTE of int | CVAR of string | UNKNOWN and internal = string option list and link = | LNK_VALUE of (c_agent_id * agent_name * site_name * c_link_value * position) | FREE - | LNK_ANY of position - | LNK_SOME of position - | LNK_TYPE of (string Locality.annot * string Locality.annot) + | LNK_ANY of position + | LNK_SOME of position + | LNK_TYPE of (string Loc.annoted * string Loc.annoted) | LNK_MISSING let rec skip_only mix = match mix with - | EMPTY_MIX -> true - | SKIP mix -> skip_only mix - | COMMA _ | DOT _ | PLUS _ -> false + | EMPTY_MIX -> true + | SKIP mix -> skip_only mix + | COMMA _ | DOT _ | PLUS _ -> false type direction = Direct | Reverse -type 'pattern rule = - { - position: Locality.t; - prefix: int; - interprete_delta: direction ; - delta: int; - (* to go from Ckappa id to KaSim id: *) - (* in direct mode: - substract delta to agents with id >= prefix in the rhs *) - (* in reverse mode: - substract delta to agents with id >= prefix in the lhs *) - lhs : 'pattern; - rhs : 'pattern; - k_def : ('pattern,string) Alg_expr.e Locality.annot; - k_un : ('pattern,string) Alg_expr.e Locality.annot option; - ast: string ; - ast_no_rate: string ; - original_ast: string ; - original_ast_no_rate: string ; - from_a_biderectional_rule: bool; - } - -type ('pattern,'rule) perturbation = - ('pattern,'pattern,string,'rule) Ast.perturbation - -type ('pattern,'rule) modif_expr = - ('pattern,'pattern,string,'rule) Ast.modif_expr - -type 'pattern variable = ('pattern,string) Ast.variable_def - -type ('agent,'pattern,'mixture,'rule) compil = +type 'pattern rule = { + position: Loc.t; + prefix: int; + interprete_delta: direction; + delta: int; + (* to go from Ckappa id to KaSim id: *) + (* in direct mode: + substract delta to agents with id >= prefix in the rhs *) + (* in reverse mode: + substract delta to agents with id >= prefix in the lhs *) + lhs: 'pattern; + rhs: 'pattern; + k_def: ('pattern, string) Alg_expr.e Loc.annoted; + k_un: ('pattern, string) Alg_expr.e Loc.annoted option; + ast: string; + ast_no_rate: string; + original_ast: string; + original_ast_no_rate: string; + from_a_biderectional_rule: bool; +} + +type ('pattern, 'rule) perturbation = + ('pattern, 'pattern, string, 'rule) Ast.perturbation + +type ('pattern, 'rule) modif_expr = + ('pattern, 'pattern, string, 'rule) Ast.modif_expr + +type 'pattern variable = ('pattern, string) Ast.variable_def + +type ('agent, 'pattern, 'mixture, 'rule) compil = ('agent, 'pattern, 'mixture, string, 'rule) Ast.compil -type ('a, 'b, 'c) site_type = - | Internal of 'a - | Binding of 'b - | Counter of 'c - +type ('a, 'b, 'c) site_type = Internal of 'a | Binding of 'b | Counter of 'c type site = (site_name, site_name, site_name) site_type - type state = (internal_state, binding_state, counter_state) site_type (****************************************************************************) -let rule_id_to_json x = - `Assoc ["rule_id", `Int x] +let rule_id_to_json x = `Assoc [ "rule_id", `Int x ] let rule_id_of_json json = - match - json - with - | `Assoc [s,json] when s = "rule_id" - -> Yojson.Basic.Util.to_int json + match json with + | `Assoc [ (s, json) ] when s = "rule_id" -> Yojson.Basic.Util.to_int json | _ -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "rule id",json)) + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "rule id", json)) -let write_c_rule_id ob f = - Yojson.Basic.to_buffer ob (rule_id_to_json f) +let write_c_rule_id ob f = Yojson.Basic.to_buffer ob (rule_id_to_json f) let string_of_c_rule_id ?(len = 1024) x = let ob = Buffer.create len in @@ -173,61 +150,51 @@ let dummy_agent_id = 0 let dummy_site_name_1 = 1 let dummy_site_name_minus1 = -1 (*REMOVE:Use in views_domain*) let dummy_state_index_1 = 1 + let dummy_agent = - { - ag_nme = "" ; - ag_intf = EMPTY_INTF ; - ag_nme_pos = Locality.dummy - } -let dummy_link_value = 1 + { agent_name = ""; ag_intf = EMPTY_INTF; agent_name_pos = Loc.dummy } +let dummy_link_value = 1 let fst_site = 1 let snd_site = 2 - -let string_of_agent_name (a: c_agent_name) : string = string_of_int a -let int_of_agent_name (a: c_agent_name) : int = a -let agent_name_of_int (a: int) : c_agent_name = a - -let _int_of_lnk_value (a: c_link_value) : int = a -let lnk_value_of_int (a: int) : c_link_value = a -let next_lnk_value (i: c_link_value) : c_link_value = i+1 - -let site_name_of_int (a: int) : c_site_name = a +let string_of_agent_name (a : c_agent_name) : string = string_of_int a +let int_of_agent_name (a : c_agent_name) : int = a +let agent_name_of_int (a : int) : c_agent_name = a +let _int_of_link_value (a : c_link_value) : int = a +let lnk_value_of_int (a : int) : c_link_value = a +let next_link_value (i : c_link_value) : c_link_value = i + 1 +let site_name_of_int (a : int) : c_site_name = a let int_of_site_name (a : c_site_name) : int = a -let string_of_site_name (a: c_site_name) : string = string_of_int a +let string_of_site_name (a : c_site_name) : string = string_of_int a +let state_index_of_int (a : int) : c_state = a +let int_of_state_index (a : c_state) : int = a +let string_of_state_index (a : c_state) : string = string_of_int a -let state_index_of_int (a:int) : c_state = a -let int_of_state_index (a:c_state) : int = a -let string_of_state_index (a:c_state) : string = string_of_int a let string_of_state_index_option_min parameters a = match a with | Some a -> string_of_state_index a | None -> Remanent_parameters.get_minus_infinity_symbol parameters + let string_of_state_index_option_max parameters a = match a with | Some a -> string_of_state_index a | None -> Remanent_parameters.get_plus_infinity_symbol parameters - -let int_of_rule_id (a: c_rule_id) : int = a -let rule_id_of_int (a: int) : c_rule_id = a -let string_of_rule_id (a: c_rule_id) : string = string_of_int a - -let int_of_agent_id (a: c_agent_id) : int = a -let agent_id_of_int (a: int) : c_agent_id = a -let string_of_agent_id (a: c_agent_id) : string = string_of_int a - -let string_of_c_link_value (a: c_link_value) : string = string_of_int a +let int_of_rule_id (a : c_rule_id) : int = a +let rule_id_of_int (a : int) : c_rule_id = a +let string_of_rule_id (a : c_rule_id) : string = string_of_int a +let int_of_agent_id (a : c_agent_id) : int = a +let agent_id_of_int (a : int) : c_agent_id = a +let string_of_agent_id (a : c_agent_id) : string = string_of_int a +let string_of_c_link_value (a : c_link_value) : string = string_of_int a let get_agent_shape n_sites parameters = - Misc_sa.fetch_array - (int_of_site_name n_sites) + Misc_sa.fetch_array (int_of_site_name n_sites) (Remanent_parameters.get_agent_shape_array parameters) (Remanent_parameters.get_agent_shape_def parameters) let get_agent_color n_sites parameters = - Misc_sa.fetch_array - (int_of_site_name n_sites) + Misc_sa.fetch_array (int_of_site_name n_sites) (Remanent_parameters.get_agent_color_array parameters) (Remanent_parameters.get_agent_color_def parameters) @@ -236,32 +203,20 @@ let get_agent_color n_sites parameters = (***************************************************************) let rename_link parameters error f link = - match - link - with - | LNK_VALUE (ag,x,y,value,position) -> + match link with + | LNK_VALUE (ag, x, y, value, position) -> let error, ag = f parameters error ag in - error, LNK_VALUE (ag,x,y,value,position) - | LNK_MISSING - | FREE - | LNK_ANY _ - | LNK_SOME _ - | LNK_TYPE _ -> error, link + error, LNK_VALUE (ag, x, y, value, position) + | LNK_MISSING | FREE | LNK_ANY _ | LNK_SOME _ | LNK_TYPE _ -> error, link let rename_port parameters error f port = - let error, port_lnk = rename_link parameters error f port.port_lnk in - error, - { - port with - port_lnk = port_lnk - } + let error, port_link = rename_link parameters error f port.port_link in + error, { port with port_link } let rec rename_interface parameters error f interface = - match - interface - with + match interface with | EMPTY_INTF -> error, EMPTY_INTF - | COUNTER_SEP (counter, interface) -> + | COUNTER_SEP (counter, interface) -> let error, interface = rename_interface parameters error f interface in error, COUNTER_SEP (counter, interface) | PORT_SEP (port, interface) -> @@ -270,82 +225,78 @@ let rec rename_interface parameters error f interface = error, PORT_SEP (port, interface) let rename_agent parameters error f agent = - let error, interface = - rename_interface parameters error f agent.ag_intf - in - error, { agent with ag_intf = interface} + let error, interface = rename_interface parameters error f agent.ag_intf in + error, { agent with ag_intf = interface } let rename_mixture parameters error f mixture = let rec aux parameters error f pos mixture = - match - mixture - with + match mixture with | SKIP m -> - let error, map, dot, plus = aux parameters error f (pos+1) m in + let error, map, dot, plus = aux parameters error f (pos + 1) m in error, map, dot, plus - | COMMA (agent,m) -> + | COMMA (agent, m) -> let error, agent = rename_agent parameters error f agent in - let error, m, dot, plus = aux parameters error f (pos+1) m in + let error, m, dot, plus = aux parameters error f (pos + 1) m in let error, pos = f parameters error pos in error, Mods.IntMap.add pos agent m, dot, plus | DOT (id, agent, mixture) -> let error, id = f parameters error id in let error, agent = rename_agent parameters error f agent in - let error, m, dot, plus = aux parameters error f (pos+1) mixture in + let error, m, dot, plus = aux parameters error f (pos + 1) mixture in let error, pos = f parameters error pos in - let min,max = if compare id pos < 0 then (id,pos) else (pos,id) in + let min, max = + if compare id pos < 0 then + id, pos + else + pos, id + in error, Mods.IntMap.add pos agent m, Mods.IntMap.add min max dot, plus | PLUS (id, agent, mixture) -> let error, id = f parameters error id in let error, agent = rename_agent parameters error f agent in - let error, m, dot, plus = aux parameters error f (pos+1) mixture in + let error, m, dot, plus = aux parameters error f (pos + 1) mixture in let error, pos = f parameters error pos in - let min,max = if compare id pos < 0 then (id,pos) else (pos,id) in + let min, max = + if compare id pos < 0 then + id, pos + else + pos, id + in error, Mods.IntMap.add pos agent m, dot, Mods.IntMap.add min max plus - | EMPTY_MIX -> error, Mods.IntMap.empty, Mods.IntMap.empty, Mods.IntMap.empty + | EMPTY_MIX -> + error, Mods.IntMap.empty, Mods.IntMap.empty, Mods.IntMap.empty in - let error, m, dot, plus = aux parameters error f 0 mixture in (* first agent has id 0 ???*) + let error, m, dot, plus = aux parameters error f 0 mixture in + (* first agent has id 0 ???*) let list_m = Mods.IntMap.bindings m in let dot = Mods.IntMap.bindings dot in let plus = Mods.IntMap.bindings plus in let rec aux parameters error pos list_m dot plus = - match - list_m - with + match list_m with | [] -> error, EMPTY_MIX - | (pos',agent)::tail-> - if compare pos pos' >= 0 - then + | (pos', agent) :: tail -> + if compare pos pos' >= 0 then ( let opt1, dot = - match dot - with - | (pos',pos'')::q when pos=pos' -> Some pos'', q + match dot with + | (pos', pos'') :: q when pos = pos' -> Some pos'', q | _ -> None, dot in let opt2, plus = - match plus - with - | (pos',pos'')::q when pos=pos' -> Some pos'', q + match plus with + | (pos', pos'') :: q when pos = pos' -> Some pos'', q | _ -> None, plus in - let error, mixture = aux parameters error (pos+1) tail dot plus in - match - opt1, opt2 - with - | Some _ , Some _ - -> Exception.warn parameters error __POS__ Exit (SKIP(mixture)) - | Some pos'', None -> - error, - DOT (pos'', agent, mixture) - | None, Some pos'' -> - error, - PLUS (pos'',agent, mixture) - | None, None -> - error, - COMMA (agent,mixture) - else - let error, mixture = aux parameters error (pos+1) list_m dot plus in + let error, mixture = aux parameters error (pos + 1) tail dot plus in + match opt1, opt2 with + | Some _, Some _ -> + Exception.warn parameters error __POS__ Exit (SKIP mixture) + | Some pos'', None -> error, DOT (pos'', agent, mixture) + | None, Some pos'' -> error, PLUS (pos'', agent, mixture) + | None, None -> error, COMMA (agent, mixture) + ) else ( + let error, mixture = aux parameters error (pos + 1) list_m dot plus in error, SKIP mixture + ) in aux parameters error 0 list_m dot plus @@ -354,80 +305,86 @@ let rename_mixture parameters error f mixture = (***************************************************************) let join_link parameters error link1 link2 = - if link1 = link2 - then error, link1 - else + if link1 = link2 then + error, link1 + else ( match link1, link2 with | (LNK_ANY _ | LNK_MISSING), _ -> error, link2 | _, (LNK_ANY _ | LNK_MISSING) -> error, link1 | FREE, _ | _, FREE -> - Exception.warn parameters error __POS__ Exit (LNK_ANY Locality.dummy) + Exception.warn parameters error __POS__ Exit (LNK_ANY Loc.dummy) | LNK_SOME _, _ -> error, link2 | _, LNK_SOME _ -> error, link1 - | LNK_TYPE ((a,_),(b,_)), LNK_TYPE ((a',_),(b',_)) when a=a' && b=b' -> + | LNK_TYPE ((a, _), (b, _)), LNK_TYPE ((a', _), (b', _)) + when a = a' && b = b' -> + error, link1 + | LNK_TYPE _, LNK_TYPE _ -> + Exception.warn parameters error __POS__ Exit (LNK_ANY Loc.dummy) + | LNK_VALUE (_, x, y, _, _), LNK_TYPE ((a, _), (b, _)) when x = a && b = y + -> error, link1 - | LNK_TYPE _, LNK_TYPE _ -> Exception.warn parameters error __POS__ Exit (LNK_ANY Locality.dummy) - | LNK_VALUE(_,x,y,_,_), LNK_TYPE((a,_),(b,_)) when x=a && b=y -> error, link1 - | LNK_TYPE((a,_),(b,_)), LNK_VALUE(_,x,y,_,_) when x=a && b=y -> error, link2 - | LNK_VALUE(ag,x,y,_,_), LNK_VALUE(ag',x',y',_,_) when - ag=ag' && x=x' && y=y' - -> error, link1 - | (LNK_VALUE _ | LNK_TYPE _ ), (LNK_VALUE _ | LNK_TYPE _ ) -> - Exception.warn parameters error __POS__ Exit (LNK_ANY Locality.dummy) + | LNK_TYPE ((a, _), (b, _)), LNK_VALUE (_, x, y, _, _) when x = a && b = y + -> + error, link2 + | LNK_VALUE (ag, x, y, _, _), LNK_VALUE (ag', x', y', _, _) + when ag = ag' && x = x' && y = y' -> + error, link1 + | (LNK_VALUE _ | LNK_TYPE _), (LNK_VALUE _ | LNK_TYPE _) -> + Exception.warn parameters error __POS__ Exit (LNK_ANY Loc.dummy) + ) let join_port parameters error port1 port2 = - if port1.port_nme = port2.port_nme - && port1.port_int = port2.port_int - && port1.port_free = port2.port_free - then - let error, lnk = join_link parameters error port1.port_lnk port2.port_lnk in - error, - { - port1 - with - port_lnk = lnk - } - else + if + port1.port_name = port2.port_name + && port1.port_int = port2.port_int + && port1.port_free = port2.port_free + then ( + let error, lnk = + join_link parameters error port1.port_link port2.port_link + in + error, { port1 with port_link = lnk } + ) else Exception.warn parameters error __POS__ Exit port1 let join_counter_test parameters error test1 test2 = - match test1,test2 with + match test1, test2 with | None, None -> error, None | None, _ -> error, test2 - | _,None -> error, test1 - | Some a, Some b when a=b -> error, test1 - | Some _, Some _ -> - Exception.warn parameters error __POS__ Exit test1 + | _, None -> error, test1 + | Some a, Some b when a = b -> error, test1 + | Some _, Some _ -> Exception.warn parameters error __POS__ Exit test1 let join_counter parameters error counter1 counter2 = - if counter1.count_nme = counter2.count_nme - && counter1.count_delta = counter2.count_delta - then - let error, test = join_counter_test parameters error counter1.count_test counter2.count_test in - error, - { - counter1 - with - count_test=test - } - else + if + counter1.counter_name = counter2.counter_name + && counter1.counter_delta = counter2.counter_delta + then ( + let error, test = + join_counter_test parameters error counter1.counter_test + counter2.counter_test + in + error, { counter1 with counter_test = test } + ) else Exception.warn parameters error __POS__ Exit counter1 type interface_elt = Port of port | CounterP of counter + let rev_list_of_interface x = let rec aux x output = match x with - | PORT_SEP (port, interface) -> aux interface (Port port::output) - | COUNTER_SEP (counter, interface) -> aux interface (CounterP counter::output) + | PORT_SEP (port, interface) -> aux interface (Port port :: output) + | COUNTER_SEP (counter, interface) -> + aux interface (CounterP counter :: output) | EMPTY_INTF -> output in aux x [] let rev_interface_of_list x = let rec aux list x = - match list with [] -> x - | Port t::q -> aux q (PORT_SEP(t,x)) - | CounterP t::q -> aux q (COUNTER_SEP (t,x)) + match list with + | [] -> x + | Port t :: q -> aux q (PORT_SEP (t, x)) + | CounterP t :: q -> aux q (COUNTER_SEP (t, x)) in aux x EMPTY_INTF @@ -439,11 +396,11 @@ let join_interface parameters error interface1 interface2 = | EMPTY_INTF -> map_ports, map_counters | COUNTER_SEP (counter, interface) -> let map_counters = - Mods.StringMap.add counter.count_nme counter map_counters + Mods.StringMap.add counter.counter_name counter map_counters in collect interface map_ports map_counters | PORT_SEP (port, interface) -> - let map_ports = Mods.StringMap.add port.port_nme port map_ports in + let map_ports = Mods.StringMap.add port.port_name port map_ports in collect interface map_ports map_counters in let map_ports_1, map_counters_1 = @@ -453,129 +410,111 @@ let join_interface parameters error interface1 interface2 = collect interface2 Mods.StringMap.empty Mods.StringMap.empty in let error, map_ports_3 = - Mods.StringMap.monadic_fold2 - parameters error + Mods.StringMap.monadic_fold2 parameters error (fun parameters error key port1 port2 map -> - let error, port = join_port parameters error port1 port2 in - error, Mods.StringMap.add key port map) + let error, port = join_port parameters error port1 port2 in + error, Mods.StringMap.add key port map) (fun _parameters error key port map -> - error, Mods.StringMap.add key port map) + error, Mods.StringMap.add key port map) (fun _parameters error key port map -> - error, Mods.StringMap.add key port map) - map_ports_1 - map_ports_2 - Mods.StringMap.empty + error, Mods.StringMap.add key port map) + map_ports_1 map_ports_2 Mods.StringMap.empty in let error, map_counters_3 = - Mods.StringMap.monadic_fold2 - parameters error + Mods.StringMap.monadic_fold2 parameters error (fun parameters error key counter1 counter2 map -> - let error, counter = join_counter parameters error counter1 counter2 in - error, Mods.StringMap.add key counter map) + let error, counter = join_counter parameters error counter1 counter2 in + error, Mods.StringMap.add key counter map) (fun _parameters error key counter map -> - error, Mods.StringMap.add key counter map) + error, Mods.StringMap.add key counter map) (fun _parameters error key counter map -> - error, Mods.StringMap.add key counter map) - map_counters_1 - map_counters_2 - Mods.StringMap.empty + error, Mods.StringMap.add key counter map) + map_counters_1 map_counters_2 Mods.StringMap.empty in let list_ports = Mods.StringMap.bindings map_ports_3 in - let list_ports = - List.rev_map - (fun (_,a) -> Port a) - list_ports - in + let list_ports = List.rev_map (fun (_, a) -> Port a) list_ports in let list_counters = Mods.StringMap.bindings map_counters_3 in let list = - List.fold_left - (fun l (_,b) -> CounterP b::l) - list_ports list_counters + List.fold_left (fun l (_, b) -> CounterP b :: l) list_ports list_counters in error, rev_interface_of_list list let join_agent parameters error agent1 agent2 = - if agent1.ag_nme = agent2.ag_nme - then + if agent1.agent_name = agent2.agent_name then ( let error, interface = join_interface parameters error agent1.ag_intf agent2.ag_intf in - error, {agent1 with ag_intf = interface} - else + error, { agent1 with ag_intf = interface } + ) else Exception.warn parameters error __POS__ - ?message:(Some (agent1.ag_nme^ agent2.ag_nme)) + ?message:(Some (agent1.agent_name ^ agent2.agent_name)) Exit dummy_agent let rec join_mixture parameters error mixture1 mixture2 = - match - mixture1, mixture2 - with + match mixture1, mixture2 with | EMPTY_MIX, _ -> error, mixture2 | _, EMPTY_MIX -> error, mixture1 - | SKIP m, SKIP m'-> + | SKIP m, SKIP m' -> let error, m'' = join_mixture parameters error m m' in error, SKIP m'' - | SKIP m, COMMA (ag, m') | COMMA(ag,m), SKIP m'-> + | SKIP m, COMMA (ag, m') | COMMA (ag, m), SKIP m' -> let error, m'' = join_mixture parameters error m m' in error, COMMA (ag, m'') - | SKIP m, DOT(id, ag, m') | DOT(id,ag,m), SKIP m' -> + | SKIP m, DOT (id, ag, m') | DOT (id, ag, m), SKIP m' -> let error, m'' = join_mixture parameters error m m' in - error, DOT(id, ag, m'') - | SKIP m, PLUS(id, ag, m') | PLUS(id,ag,m), SKIP m' -> + error, DOT (id, ag, m'') + | SKIP m, PLUS (id, ag, m') | PLUS (id, ag, m), SKIP m' -> let error, m'' = join_mixture parameters error m m' in - error, PLUS(id, ag, m'') - | COMMA(ag,m), COMMA(ag',m') -> + error, PLUS (id, ag, m'') + | COMMA (ag, m), COMMA (ag', m') -> let error, ag = join_agent parameters error ag ag' in let error, m'' = join_mixture parameters error m m' in - error, COMMA(ag,m'') - | DOT(_), _ - | PLUS(_), _ - | _,DOT(_) - | _,PLUS(_)-> + error, COMMA (ag, m'') + | DOT _, _ | PLUS _, _ | _, DOT _ | _, PLUS _ -> Exception.warn parameters error __POS__ Exit EMPTY_MIX - let add_agent parameters error agent_id agent_name mixture = - let agent = - {dummy_agent with ag_nme = agent_name} - in + let agent = { dummy_agent with agent_name } in let k = int_of_agent_id agent_id in let rec aux k mixture = match mixture with | SKIP mixture' -> - let error, mixture'' = aux (k-1) mixture' in - if k=0 then - error, COMMA(agent,mixture'') + let error, mixture'' = aux (k - 1) mixture' in + if k = 0 then + error, COMMA (agent, mixture'') else error, SKIP mixture' - | COMMA(agent,mixture') -> - if k=0 then + | COMMA (agent, mixture') -> + if k = 0 then Exception.warn parameters error __POS__ Exit mixture - else - let error, mixture'' = aux (k-1) mixture' in - error, COMMA(agent, mixture'') - | DOT(id,agent,mixture') -> - if k=0 then + else ( + let error, mixture'' = aux (k - 1) mixture' in + error, COMMA (agent, mixture'') + ) + | DOT (id, agent, mixture') -> + if k = 0 then Exception.warn parameters error __POS__ Exit mixture - else - let error, mixture'' = aux (k-1) mixture' in - error, DOT(id,agent, mixture'') - | PLUS(id,agent,mixture') -> - if - k=0 - then + else ( + let error, mixture'' = aux (k - 1) mixture' in + error, DOT (id, agent, mixture'') + ) + | PLUS (id, agent, mixture') -> + if k = 0 then Exception.warn parameters error __POS__ Exit mixture - else - let error, mixture'' = aux (k-1) mixture' in - error, PLUS(id,agent, mixture'') + else ( + let error, mixture'' = aux (k - 1) mixture' in + error, PLUS (id, agent, mixture'') + ) | EMPTY_MIX -> - let rec aux2 k = - if k=0 then - COMMA(agent, EMPTY_MIX) - else - let mixture' = aux2 (k-1) in - SKIP(mixture') - in error, aux2 k + let rec aux2 k = + if k = 0 then + COMMA (agent, EMPTY_MIX) + else ( + let mixture' = aux2 (k - 1) in + SKIP mixture' + ) + in + error, aux2 k in aux k mixture @@ -584,178 +523,177 @@ let mod_agent_gen parameters error agent_id f mixture = let rec aux k mixture = match mixture with | SKIP mixture' -> - if k=0 - then + if k = 0 then Exception.warn parameters error __POS__ Exit mixture - else - let error, mixture'' = aux (k-1) mixture' in + else ( + let error, mixture'' = aux (k - 1) mixture' in error, SKIP mixture'' - | COMMA(agent,mixture') -> - if k=0 - then + ) + | COMMA (agent, mixture') -> + if k = 0 then ( let error, agent = f parameters error agent in - error, COMMA(agent, mixture') - else - let error, mixture'' = aux (k-1) mixture' in - error, COMMA(agent, mixture'') - | DOT(id,agent,mixture') -> - if k=0 - then - let error, agent = f parameters error agent in - error, DOT(id, agent, mixture') - else - let error, mixture'' = aux (k-1) mixture' in - error, DOT(id, agent, mixture'') - | PLUS(id,agent,mixture') -> - if k=0 - then + error, COMMA (agent, mixture') + ) else ( + let error, mixture'' = aux (k - 1) mixture' in + error, COMMA (agent, mixture'') + ) + | DOT (id, agent, mixture') -> + if k = 0 then ( let error, agent = f parameters error agent in - error, PLUS(id, agent, mixture') - else - let error, mixture'' = aux (k-1) mixture' in - error, PLUS(id, agent, mixture'') - | EMPTY_MIX -> - Exception.warn parameters error __POS__ Exit mixture + error, DOT (id, agent, mixture') + ) else ( + let error, mixture'' = aux (k - 1) mixture' in + error, DOT (id, agent, mixture'') + ) + | PLUS (id, agent, mixture') -> + if k = 0 then ( + let error, agent = f parameters error agent in + error, PLUS (id, agent, mixture') + ) else ( + let error, mixture'' = aux (k - 1) mixture' in + error, PLUS (id, agent, mixture'') + ) + | EMPTY_MIX -> Exception.warn parameters error __POS__ Exit mixture in aux k mixture let rec has_site x interface = match interface with | EMPTY_INTF -> false - | COUNTER_SEP (_,intf) -> has_site x intf - | PORT_SEP (p,intf) -> - if p.port_nme = x then true else has_site x intf + | COUNTER_SEP (_, intf) -> has_site x intf + | PORT_SEP (p, intf) -> + if p.port_name = x then + true + else + has_site x intf let rec has_counter x interface = match interface with | EMPTY_INTF -> false - | PORT_SEP(_,intf) -> has_site x intf - | COUNTER_SEP (c,intf) -> - if c.count_nme = x then true else has_counter x intf + | PORT_SEP (_, intf) -> has_site x intf + | COUNTER_SEP (c, intf) -> + if c.counter_name = x then + true + else + has_counter x intf let add_site parameters error agent_id site_name mixture = mod_agent_gen parameters error agent_id (fun _parameters error agent -> - if has_site site_name agent.ag_intf - then error, agent - else - let port = - { - port_nme = site_name; - port_lnk = LNK_ANY Locality.dummy ; - port_int = []; - port_free = None - } in - let interface = PORT_SEP (port,agent.ag_intf) in - error, {agent with ag_intf = interface}) + if has_site site_name agent.ag_intf then + error, agent + else ( + let port = + { + port_name = site_name; + port_link = LNK_ANY Loc.dummy; + port_int = []; + port_free = None; + } + in + let interface = PORT_SEP (port, agent.ag_intf) in + error, { agent with ag_intf = interface } + )) mixture - let add_counter parameters error agent_id counter_name mixture = - mod_agent_gen parameters error agent_id - (fun _parameters error agent -> - if has_counter counter_name agent.ag_intf - then error, agent - else - let counter = - { - count_nme = counter_name; - count_test = None; - count_delta = None; - } in - let interface = COUNTER_SEP (counter,agent.ag_intf) in - error, {agent with ag_intf = interface}) - mixture +let add_counter parameters error agent_id counter_name mixture = + mod_agent_gen parameters error agent_id + (fun _parameters error agent -> + if has_counter counter_name agent.ag_intf then + error, agent + else ( + let counter = + { counter_name; counter_test = None; counter_delta = None } + in + let interface = COUNTER_SEP (counter, agent.ag_intf) in + error, { agent with ag_intf = interface } + )) + mixture let mod_site_gen parameters error agent_id site_name f mixture = mod_agent_gen parameters error agent_id (fun parameters error agent -> - let rec aux interface = - match interface with - | EMPTY_INTF -> error, EMPTY_INTF - | COUNTER_SEP (counter,intf) -> - let error, intf = aux intf in - error, COUNTER_SEP (counter, intf) - | PORT_SEP (port, intf) -> - if port.port_nme = site_name - then - let error, port = f parameters error port in - error, PORT_SEP (port, intf) - else - let error, intf = aux intf in - error, PORT_SEP (port, intf) - in - let error, interface = aux agent.ag_intf in - error, {agent with ag_intf = interface}) + let rec aux interface = + match interface with + | EMPTY_INTF -> error, EMPTY_INTF + | COUNTER_SEP (counter, intf) -> + let error, intf = aux intf in + error, COUNTER_SEP (counter, intf) + | PORT_SEP (port, intf) -> + if port.port_name = site_name then ( + let error, port = f parameters error port in + error, PORT_SEP (port, intf) + ) else ( + let error, intf = aux intf in + error, PORT_SEP (port, intf) + ) + in + let error, interface = aux agent.ag_intf in + error, { agent with ag_intf = interface }) mixture - -let add_binding_state parameters error agent_id site_name p state bool_opt mixture = +let add_binding_state parameters error agent_id site_name p state bool_opt + mixture = mod_site_gen parameters error agent_id site_name (fun parameters error port -> - let error, b = p parameters error port.port_lnk in - if b - then - error, {port with port_lnk = state ; port_free = bool_opt} - else - Exception.warn parameters error __POS__ Exit port) + let error, b = p parameters error port.port_link in + if b then + error, { port with port_link = state; port_free = bool_opt } + else + Exception.warn parameters error __POS__ Exit port) mixture let add_free parameters error agent_id site_name mixture = add_binding_state parameters error agent_id site_name (fun _parameters error lnk -> - match lnk with - | LNK_MISSING | LNK_ANY _ -> error, true - | FREE | LNK_VALUE _ | LNK_SOME _ | LNK_TYPE _ -> error, false) - FREE - (Some true) - mixture + match lnk with + | LNK_MISSING | LNK_ANY _ -> error, true + | FREE | LNK_VALUE _ | LNK_SOME _ | LNK_TYPE _ -> error, false) + FREE (Some true) mixture -let add_binding_type parameters error agent_id site_name agent_name' site_name' mixture = +let add_binding_type parameters error agent_id site_name agent_name' site_name' + mixture = add_binding_state parameters error agent_id site_name - (fun _parameters error lnk -> - match lnk with - | LNK_MISSING | LNK_SOME _ | LNK_ANY _ -> error, true - | FREE | LNK_VALUE _ | LNK_TYPE _ -> error, false) - (LNK_TYPE (Locality.dummy_annot agent_name', Locality.dummy_annot site_name')) - (Some false) - mixture - + (fun _parameters error lnk -> + match lnk with + | LNK_MISSING | LNK_SOME _ | LNK_ANY _ -> error, true + | FREE | LNK_VALUE _ | LNK_TYPE _ -> error, false) + (LNK_TYPE (Loc.annot_with_dummy agent_name', Loc.annot_with_dummy site_name')) + (Some false) mixture let add_bound parameters error agent_id site_name mixture = add_binding_state parameters error agent_id site_name (fun _parameters error lnk -> - match lnk with - | LNK_MISSING | LNK_ANY _ -> error, true - | LNK_SOME _ | FREE | LNK_VALUE _ | LNK_TYPE _ -> error, false) - (LNK_SOME Locality.dummy) - (Some false) - mixture + match lnk with + | LNK_MISSING | LNK_ANY _ -> error, true + | LNK_SOME _ | FREE | LNK_VALUE _ | LNK_TYPE _ -> error, false) + (LNK_SOME Loc.dummy) (Some false) mixture -let add_pointer parameters error agent_id site_name agent_id' agent_name' site_name' lnk_value mixture = +let add_pointer parameters error agent_id site_name agent_id' agent_name' + site_name' lnk_value mixture = add_binding_state parameters error agent_id site_name (fun _parameters error lnk -> - match lnk with - | LNK_MISSING | LNK_SOME _ | LNK_ANY _ -> error, true - | LNK_TYPE ((agent_name'',_),(site_name'',_)) -> - error, agent_name'' = agent_name' && site_name'' = site_name' - | FREE | LNK_VALUE _ -> error, false) - (LNK_VALUE (agent_id',agent_name', site_name', lnk_value, Locality.dummy)) - (Some false) - mixture + match lnk with + | LNK_MISSING | LNK_SOME _ | LNK_ANY _ -> error, true + | LNK_TYPE ((agent_name'', _), (site_name'', _)) -> + error, agent_name'' = agent_name' && site_name'' = site_name' + | FREE | LNK_VALUE _ -> error, false) + (LNK_VALUE (agent_id', agent_name', site_name', lnk_value, Loc.dummy)) + (Some false) mixture let rec get_agent_name parameters error k mixture = match mixture with | SKIP mixture -> - if k=0 then + if k = 0 then Exception.warn parameters error __POS__ Exit "" else - get_agent_name parameters error (k-1) mixture - | COMMA (agent, mixture) - | DOT(_,agent,mixture) - | PLUS(_,agent,mixture) -> - if k=0 then error, agent.ag_nme + get_agent_name parameters error (k - 1) mixture + | COMMA (agent, mixture) | DOT (_, agent, mixture) | PLUS (_, agent, mixture) + -> + if k = 0 then + error, agent.agent_name else - get_agent_name parameters error (k-1) mixture + get_agent_name parameters error (k - 1) mixture | EMPTY_MIX -> Exception.warn parameters error __POS__ Exit "" let get_agent_name ?agent_name parameters error k mixture = @@ -763,224 +701,189 @@ let get_agent_name ?agent_name parameters error k mixture = | None -> get_agent_name parameters error k mixture | Some ag -> error, ag -let add_link parameters error agent_id ?agent_name site_name agent_id' ?agent_name' site_name' lnk_value mixture = - let error, agent_name = get_agent_name parameters error agent_id ?agent_name mixture in - let error, agent_name' = get_agent_name parameters error agent_id' ?agent_name:agent_name' mixture in +let add_link parameters error agent_id ?agent_name site_name agent_id' + ?agent_name' site_name' lnk_value mixture = + let error, agent_name = + get_agent_name parameters error agent_id ?agent_name mixture + in + let error, agent_name' = + get_agent_name parameters error agent_id' ?agent_name:agent_name' mixture + in let error, mixture = - add_pointer parameters error - agent_id site_name agent_id' agent_name' site_name' lnk_value mixture + add_pointer parameters error agent_id site_name agent_id' agent_name' + site_name' lnk_value mixture in - add_pointer parameters error - agent_id' site_name' agent_id agent_name site_name lnk_value mixture - + add_pointer parameters error agent_id' site_name' agent_id agent_name + site_name lnk_value mixture -let add_internal_state parameters error agent_id (site_name:site_name) (state:internal_state) mixture = +let add_internal_state parameters error agent_id (site_name : site_name) + (state : internal_state) mixture = mod_site_gen parameters error agent_id site_name (fun parameters error port -> - match port.port_int with - | [] -> - error, {port with port_int = [Some state]} - | _::_ -> - Exception.warn parameters error __POS__ Exit port) + match port.port_int with + | [] -> error, { port with port_int = [ Some state ] } + | _ :: _ -> Exception.warn parameters error __POS__ Exit port) mixture (**********************************************************) (*TYPE C*) (**********************************************************) -type c_binding_state = - | C_Free - | C_Lnk_type of c_agent_name * c_site_name - +type c_binding_state = C_Free | C_Lnk_type of c_agent_name * c_site_name type state' = (internal_state, c_binding_state, counter_state) site_type -module State = -struct +module State = struct type t = state' + let compare = compare let print _ _ = () end -module Dictionary_of_States = - ( - Dictionary.Dictionary_of_Ord (State) : Dictionary.Dictionary - with type key = c_state - and type value = state' - ) +module Dictionary_of_States : + Dictionary.Dictionary with type key = c_state and type value = state' = + Dictionary.Dictionary_of_Ord (State) -type internal_state_specification = - { - string : internal_state option; - } +type internal_state_specification = { string: internal_state option } -module Site = -struct +module Site = struct type t = site + let compare = compare let print _ _ = () end -module Kasim_agent_name = -struct +module Kasim_agent_name = struct type t = agent_name + let compare = compare let print = Format.pp_print_string end -module Dictionary_of_agents = - ( - Dictionary.Dictionary_of_Ord (Kasim_agent_name): Dictionary.Dictionary - with type key = c_agent_name - and type value = agent_name - ) - -module Dictionary_of_sites = - ( - Dictionary.Dictionary_of_Ord (Site): Dictionary.Dictionary - with type key = c_site_name - and type value = site - ) - -type site_list = - { - used : (site_name list * position) list; - declared : (site_name list * position) list; - creation : (site_name list * position) list - } +module Dictionary_of_agents : + Dictionary.Dictionary with type key = c_agent_name and type value = agent_name = + Dictionary.Dictionary_of_Ord (Kasim_agent_name) + +module Dictionary_of_sites : + Dictionary.Dictionary with type key = c_site_name and type value = site = + Dictionary.Dictionary_of_Ord (Site) + +type site_list = { + used: (site_name list * position) list; + declared: (site_name list * position) list; + creation: (site_name list * position) list; +} + +type agent_dic = (unit, unit) Dictionary_of_agents.dictionary +type site_dic = (unit, unit) Dictionary_of_sites.dictionary +type state_dic = (unit, unit) Dictionary_of_States.dictionary + +type agent_specification = { + binding_sites_usage: site_list; + marked_sites_usage: site_list; +} + +type kappa_handler = { + agents_dic: agent_dic; + interface_constraints: agent_specification Int_storage.Nearly_inf_Imperatif.t; + sites: site_dic Int_storage.Nearly_inf_Imperatif.t; + states_dic: + state_dic Int_storage.Nearly_inf_Imperatif.t + Int_storage.Nearly_inf_Imperatif.t; +} + +type 'a interval = { min: 'a option; max: 'a option } + +type c_port = { + c_site_name: c_site_name; + c_site_position: position; + c_site_interval: c_state interval; +} + +module Site_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_site_name -type agent_dic = (unit,unit) Dictionary_of_agents.dictionary -type site_dic = (unit,unit) Dictionary_of_sites.dictionary -type state_dic = (unit,unit) Dictionary_of_States.dictionary - -type agent_specification = - { - binding_sites_usage : site_list; - marked_sites_usage : site_list - } - -type kappa_handler = - { - agents_dic : agent_dic; - interface_constraints : agent_specification Int_storage.Nearly_inf_Imperatif.t; - sites : site_dic Int_storage.Nearly_inf_Imperatif.t; - states_dic : state_dic Int_storage.Nearly_inf_Imperatif.t - Int_storage.Nearly_inf_Imperatif.t - } - -type 'a interval = {min:'a option; max:'a option} - -type c_port = - { - c_site_name : c_site_name; - c_site_position : position; - c_site_interval : c_state interval - } - -module Site_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_site_name - let compare = compare - let print = Format.pp_print_int - end)) + let compare = compare + let print = Format.pp_print_int +end)) type c_interface = c_port Site_map_and_set.Map.t -type c_proper_agent = - { - c_agent_kasim_id : c_agent_id; - c_agent_name : c_agent_name; - c_agent_interface : c_interface; - c_agent_position : position - } - -type site_address = - { - agent_index : c_agent_id; - site : c_site_name - } +type c_proper_agent = { + c_agent_kasim_id: c_agent_id; + c_agent_name: c_agent_name; + c_agent_interface: c_interface; + c_agent_position: position; +} +type site_address = { agent_index: c_agent_id; site: c_site_name } type c_bond = site_address * site_address - -type c_agent = - | C_ghost - | C_agent of c_proper_agent - -type c_mixture = - { - c_views : c_agent Int_storage.Quick_Nearly_inf_Imperatif.t; - c_bonds : - site_address Site_map_and_set.Map.t Int_storage.Nearly_inf_Imperatif.t; - c_plus : (int * int) list; - c_dot : (int * int) list - } - -type c_variable = (c_mixture,string) Alg_expr.e - -type action = - | Release of c_bond - | Bind of c_bond - | Half_breaf of site_address - -type c_rule = - { - c_rule_lhs : c_mixture; - c_rule_bidirectional : bool; - c_rule_rhs : c_mixture; - c_diff_direct : c_mixture; - c_diff_reverse : c_mixture; - c_side_effects : action list - } +type c_agent = C_ghost | C_agent of c_proper_agent + +type c_mixture = { + c_views: c_agent Int_storage.Quick_Nearly_inf_Imperatif.t; + c_bonds: + site_address Site_map_and_set.Map.t Int_storage.Nearly_inf_Imperatif.t; + c_plus: (int * int) list; + c_dot: (int * int) list; +} + +type c_variable = (c_mixture, string) Alg_expr.e +type action = Release of c_bond | Bind of c_bond | Half_breaf of site_address + +type c_rule = { + c_rule_lhs: c_mixture; + c_rule_bidirectional: bool; + c_rule_rhs: c_mixture; + c_diff_direct: c_mixture; + c_diff_reverse: c_mixture; + c_side_effects: action list; +} type c_modif_expr = - | C_APPLY of ((c_mixture,string) Alg_expr.e * c_rule * position) - | C_UPDATE of - (string * (c_mixture,string) Alg_expr.e * position) (*TODO: pause*) - | C_STOP of position + | C_APPLY of ((c_mixture, string) Alg_expr.e * c_rule * position) + | C_UPDATE of (string * (c_mixture, string) Alg_expr.e * position) + (*TODO: pause*) + | C_STOP of position | C_SNAPSHOT of position (*maybe later of mixture too*) type c_perturbation = - ((((c_mixture,string) Alg_expr.bool) * position) - * (c_modif_expr list) - * ((c_mixture,string) Alg_expr.bool * position) option) + (((c_mixture, string) Alg_expr.bool * position) + * c_modif_expr list + * ((c_mixture, string) Alg_expr.bool * position) option) * position -type enriched_rule = - { - e_rule_label : (string * position) option; - e_rule_direct : bool; - e_rule_rule : c_mixture rule; - e_rule_c_rule : c_rule - } - -type enriched_init = - { - e_init_factor : int; - e_init_mixture : mixture; - e_init_c_mixture : c_mixture; - e_init_pos : position - } - -type c_compil = - { - c_variables : c_variable Int_storage.Nearly_inf_Imperatif.t; - (*pattern declaration for reusing as variable in perturbations or kinetic rate*) - c_signatures : (agent * position) Int_storage.Nearly_inf_Imperatif.t; - (*agent signature declaration*) - c_rules : enriched_rule Int_storage.Nearly_inf_Imperatif.t; - (*rules (possibly named)*) - c_observables : (c_mixture,string) Alg_expr.e Int_storage.Nearly_inf_Imperatif.t; - (*list of patterns to plot*) - c_init : enriched_init Int_storage.Nearly_inf_Imperatif.t ; - (*initial graph declaration*) - c_perturbations : - (c_mixture Locality.annot,enriched_rule) perturbation - Int_storage.Nearly_inf_Imperatif.t - } - -let lift to_int from_int p = - fun a i -> from_int (p (to_int a) i) +type enriched_rule = { + e_rule_label: (string * position) option; + e_rule_direct: bool; + e_rule_rule: c_mixture rule; + e_rule_c_rule: c_rule; +} + +type enriched_init = { + e_init_factor: int; + e_init_mixture: mixture; + e_init_c_mixture: c_mixture; + e_init_pos: position; +} + +type c_compil = { + c_variables: c_variable Int_storage.Nearly_inf_Imperatif.t; + (*pattern declaration for reusing as variable in perturbations or kinetic rate*) + c_signatures: (agent * position) Int_storage.Nearly_inf_Imperatif.t; + (*agent signature declaration*) + c_rules: enriched_rule Int_storage.Nearly_inf_Imperatif.t; + (*rules (possibly named)*) + c_observables: + (c_mixture, string) Alg_expr.e Int_storage.Nearly_inf_Imperatif.t; + (*list of patterns to plot*) + c_init: enriched_init Int_storage.Nearly_inf_Imperatif.t; + (*initial graph declaration*) + c_perturbations: + (c_mixture Loc.annoted, enriched_rule) perturbation + Int_storage.Nearly_inf_Imperatif.t; +} + +let lift to_int from_int p a i = from_int (p (to_int a) i) let pred_site_name = pred let pred_agent_name = pred let pred_state_index = pred @@ -1000,149 +903,110 @@ let compare_state_index = compare let compare_agent_name = compare let compare_state_index_option_min a b = - match a,b with + match a, b with | None, None -> 0 | None, _ -> -1 | _, None -> 1 | Some a, Some b -> compare_state_index a b let compare_state_index_option_max a b = - match a,b with + match a, b with | None, None -> 0 | None, _ -> 1 | _, None -> -1 | Some a, Some b -> compare_state_index a b - let compare_unit_agent_site _ _ = 0 - let compare_unit _ _ = 0 let compare_unit_agent_name _ _ = dummy_agent_name let compare_unit_site_name _ _ = dummy_site_name let compare_unit_state_index _ _ = dummy_state_index + let array_of_list_rule_id create set parameters error list = let n = List.length list in let a = create parameters error n in let rec aux l k a = match l with | [] -> a - | t::q -> - begin - aux q - (next_rule_id k) - (set parameters (fst a) k t (snd a)) - end - in aux list dummy_rule_id a + | t :: q -> aux q (next_rule_id k) (set parameters (fst a) k t (snd a)) + in + aux list dummy_rule_id a (***************************************************************************) (*MODULE*) (***************************************************************************) -module Agent_type_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Nearly_inf_Imperatif: Int_storage.Storage - with type key = c_agent_name - and type dimension = int - ) +module Agent_type_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_name and type dimension = int = + Int_storage.Nearly_inf_Imperatif -module Agent_type_quick_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Quick_key_list (Agent_type_nearly_Inf_Int_storage_Imperatif): Int_storage.Storage - with type key = c_agent_name - and type dimension = int - ) +module Agent_type_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_name and type dimension = int = + Int_storage.Quick_key_list (Agent_type_nearly_Inf_Int_storage_Imperatif) -module Rule_id_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Nearly_inf_Imperatif: Int_storage.Storage - with type key = c_rule_id - and type dimension = int - ) -module Rule_id_quick_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Quick_key_list (Rule_id_nearly_Inf_Int_storage_Imperatif): Int_storage.Storage - with type key = c_rule_id - and type dimension = int - ) +module Rule_id_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_rule_id and type dimension = int = + Int_storage.Nearly_inf_Imperatif -module Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif = - ( - Int_storage.Nearly_Inf_Int_Int_storage_Imperatif_Imperatif: Int_storage.Storage +module Rule_id_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_rule_id and type dimension = int = + Int_storage.Quick_key_list (Rule_id_nearly_Inf_Int_storage_Imperatif) + +module Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif : + Int_storage.Storage with type key = c_agent_name * c_site_name - and type dimension = int * int - ) + and type dimension = int * int = + Int_storage.Nearly_Inf_Int_Int_storage_Imperatif_Imperatif -module Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif = - ( - Int_storage.Quick_key_list - (Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif): - Int_storage.Storage +module Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif : + Int_storage.Storage with type key = c_agent_name * c_site_name + and type dimension = int * int = + Int_storage.Quick_key_list + (Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif) - and type dimension = int * int - ) - -module Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif = - ( - Int_storage.Nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif : Int_storage.Storage - with type key = (c_agent_name * (c_site_name * c_state)) - and type dimension = (int * (int * int)) - ) +module Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif : + Int_storage.Storage + with type key = c_agent_name * (c_site_name * c_state) + and type dimension = int * (int * int) = + Int_storage.Nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif (*site*) -module Site_type_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Nearly_inf_Imperatif: Int_storage.Storage - with type key = c_site_name - and type dimension = int - ) +module Site_type_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_site_name and type dimension = int = + Int_storage.Nearly_inf_Imperatif -module Site_type_quick_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Quick_key_list (Site_type_nearly_Inf_Int_storage_Imperatif): Int_storage.Storage - with type key = c_site_name - and type dimension = int - ) +module Site_type_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_site_name and type dimension = int = + Int_storage.Quick_key_list (Site_type_nearly_Inf_Int_storage_Imperatif) (*state*) -module State_index_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Nearly_inf_Imperatif: Int_storage.Storage - with type key = c_state - and type dimension = int - ) +module State_index_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_state and type dimension = int = + Int_storage.Nearly_inf_Imperatif -module State_index_quick_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Quick_key_list (State_index_nearly_Inf_Int_storage_Imperatif): Int_storage.Storage - with type key = c_state - and type dimension = int - ) +module State_index_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_state and type dimension = int = + Int_storage.Quick_key_list (State_index_nearly_Inf_Int_storage_Imperatif) (*rule_id*) -module Rule_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Nearly_inf_Imperatif: Int_storage.Storage - with type key = c_rule_id - and type dimension = int - ) +module Rule_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_rule_id and type dimension = int = + Int_storage.Nearly_inf_Imperatif -module Rule_quick_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Quick_key_list (Rule_nearly_Inf_Int_storage_Imperatif) : Int_storage.Storage - with type key = c_rule_id - and type dimension = int - ) +module Rule_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_rule_id and type dimension = int = + Int_storage.Quick_key_list (Rule_nearly_Inf_Int_storage_Imperatif) module Site_union_find = - Union_find.Make(Site_type_nearly_Inf_Int_storage_Imperatif) + Union_find.Make (Site_type_nearly_Inf_Int_storage_Imperatif) (****************************************************************************) (*Define module fifo take rule_id*) -module Rule = -struct +module Rule = struct type t = c_rule_id + let compare = compare let print = Format.pp_print_int end @@ -1151,181 +1015,141 @@ module Rule_FIFO = Working_list.WlMake (Rule) (****************************************************************************) -module Agent_id_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Nearly_inf_Imperatif : Int_storage.Storage - with type key = c_agent_id - and type dimension = int - ) +module Agent_id_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_id and type dimension = int = + Int_storage.Nearly_inf_Imperatif -module Agent_id_quick_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Quick_key_list (Agent_id_nearly_Inf_Int_storage_Imperatif) : Int_storage.Storage - with type key = c_agent_id - and type dimension = int - ) +module Agent_id_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_id and type dimension = int = + Int_storage.Quick_key_list (Agent_id_nearly_Inf_Int_storage_Imperatif) (***************************************************************************) -module Agent_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_name - let compare = compare - let print = Format.pp_print_int - end - )) +module Agent_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_name -module Agent_id_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_id - let compare = compare - let print = Format.pp_print_int - end - )) + let compare = compare + let print = Format.pp_print_int +end)) -module Lnk_id_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_link_value - let compare = compare - let print = Format.pp_print_int - end - )) +module Agent_id_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_id + let compare = compare + let print = Format.pp_print_int +end)) -module Rule_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_rule_id - let compare = compare - let print = Format.pp_print_int - end)) +module Lnk_id_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_link_value -module State_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_state - let compare = compare - let print = Format.pp_print_int - end)) + let compare = compare + let print = Format.pp_print_int +end)) -module AgentRule_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_name * c_rule_id - let compare = compare - let print = Pp.pair Format.pp_print_int Format.pp_print_int - end)) +module Rule_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_rule_id -module RuleAgent_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_rule_id * c_agent_id - let compare = compare - let print = Pp.pair Format.pp_print_int Format.pp_print_int - end)) + let compare = compare + let print = Format.pp_print_int +end)) + +module State_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_state + + let compare = compare + let print = Format.pp_print_int +end)) + +module AgentRule_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_name * c_rule_id + + let compare = compare + let print = Pp.pair Format.pp_print_int Format.pp_print_int +end)) + +module RuleAgent_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_rule_id * c_agent_id + + let compare = compare + let print = Pp.pair Format.pp_print_int Format.pp_print_int +end)) (*use in site_accross_bonds_domain*) -module SiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_site_name * c_state - let compare = compare - let print = Pp.pair Format.pp_print_int Format.pp_print_int - end)) +module SiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_site_name * c_state -module AgentSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_name * c_site_name * c_state - let compare = compare - let print f (a,b,c) = Format.fprintf f "(%i, %i, %i)" a b c - end)) - -module Rule_setmap = - SetMap.Make ( - struct - type t = c_rule_id - let compare = compare - let print = Format.pp_print_int - end) - -module Agent_id_setmap = - SetMap.Make ( - struct - type t = c_agent_id - let compare = compare - let print = Format.pp_print_int - end) - -module PairRule_setmap = - SetMap.Make - (struct - type t = c_rule_id * c_rule_id - let compare = compare - let print = Pp.pair Format.pp_print_int Format.pp_print_int - end) + let compare = compare + let print = Pp.pair Format.pp_print_int Format.pp_print_int +end)) + +module AgentSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_name * c_site_name * c_state + + let compare = compare + let print f (a, b, c) = Format.fprintf f "(%i, %i, %i)" a b c +end)) + +module Rule_setmap = SetMap.Make (struct + type t = c_rule_id + + let compare = compare + let print = Format.pp_print_int +end) + +module Agent_id_setmap = SetMap.Make (struct + type t = c_agent_id + + let compare = compare + let print = Format.pp_print_int +end) + +module PairRule_setmap = SetMap.Make (struct + type t = c_rule_id * c_rule_id + + let compare = compare + let print = Pp.pair Format.pp_print_int Format.pp_print_int +end) (****************************************************************************) -module AgentSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_name * c_site_name - let compare = compare - let print = Pp.pair Format.pp_print_int Format.pp_print_int - end)) +module AgentSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_name * c_site_name -module Agents_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_id * c_agent_name - let compare = compare - let print = Pp.pair Format.pp_print_int Format.pp_print_int - end)) + let compare = compare + let print = Pp.pair Format.pp_print_int Format.pp_print_int +end)) -module AgentsSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_id * c_agent_name * c_site_name - let compare = compare - let print f (a,b,c) = Format.fprintf f "(%i, %i, %i)" a b c - end)) +module Agents_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_id * c_agent_name -module AgentsSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_id * c_agent_name * c_site_name * c_state - let compare = compare - let print f (a,b,c,d) = Format.fprintf f "(%i, %i, %i, %i)" a b c d - end)) + let compare = compare + let print = Pp.pair Format.pp_print_int Format.pp_print_int +end)) + +module AgentsSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_id * c_agent_name * c_site_name + + let compare = compare + let print f (a, b, c) = Format.fprintf f "(%i, %i, %i)" a b c +end)) + +module AgentsSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_id * c_agent_name * c_site_name * c_state + + let compare = compare + let print f (a, b, c, d) = Format.fprintf f "(%i, %i, %i, %i)" a b c d +end)) type pair_of_states = c_state option * c_state option -module AgentsSitePState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = c_agent_id * c_agent_name * c_site_name * pair_of_states - let compare = compare - (*let print f (a,b,c,d) = Format.fprintf f "(%i, %i, %i, %i)" a b c d*) - let print _ _ = () - end)) +module AgentsSitePState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = c_agent_id * c_agent_name * c_site_name * pair_of_states + + let compare = compare + + (*let print f (a,b,c,d) = Format.fprintf f "(%i, %i, %i, %i)" a b c d*) + let print _ _ = () +end)) (***************************************************************************) (*bonds in rhs and lhs*) @@ -1339,67 +1163,59 @@ module AgentsSitePState_map_and_set = let print = Pp.pair Format.pp_print_int Format.pp_print_int end))*) -module PairAgentSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = (c_agent_name * c_site_name) * - (c_agent_name * c_site_name) - let compare = compare - let print _ _ = () - end)) +module PairAgentSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = (c_agent_name * c_site_name) * (c_agent_name * c_site_name) -module PairAgentsSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = (c_agent_id * c_agent_name * c_site_name * c_state) * - (c_agent_id * c_agent_name * c_site_name * c_state) - let compare = compare - let print _ _ = () - end)) + let compare = compare + let print _ _ = () +end)) -module PairAgentSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = (c_agent_name * c_site_name * c_state) * - (c_agent_name * c_site_name * c_state) - let compare = compare - let print _ _ = () - end)) +module PairAgentsSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (c_agent_id * c_agent_name * c_site_name * c_state) + * (c_agent_id * c_agent_name * c_site_name * c_state) -module PairAgentSitesState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (c_agent_name * c_site_name * c_site_name * c_state) * - (c_agent_name * c_site_name * c_site_name * c_state) - let compare = compare - let print _ _ = () - end)) + let compare = compare + let print _ _ = () +end)) + +module PairAgentSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (c_agent_name * c_site_name * c_state) + * (c_agent_name * c_site_name * c_state) + + let compare = compare + let print _ _ = () +end)) + +module PairAgentSitesState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (c_agent_name * c_site_name * c_site_name * c_state) + * (c_agent_name * c_site_name * c_site_name * c_state) + + let compare = compare + let print _ _ = () +end)) (*******************************************************************) -module Views_bdu = - (Mvbdu_wrapper.Mvbdu: Mvbdu_wrapper.Mvbdu - with type key = c_site_name - and type value = c_state - with type mvbdu = Mvbdu_wrapper.Mvbdu.mvbdu) +module Views_bdu : + Mvbdu_wrapper.Mvbdu + with type key = c_site_name + and type value = c_state + with type mvbdu = Mvbdu_wrapper.Mvbdu.mvbdu = + Mvbdu_wrapper.Mvbdu module Views_intbdu = Mvbdu_wrapper.Internalize (Views_bdu) -type side_effects = - { - not_seen_yet: - (c_agent_name * c_site_name * c_state) - AgentsSiteState_map_and_set.Map.t ; - seen: AgentSiteState_map_and_set.Set.t - } +type side_effects = { + not_seen_yet: + (c_agent_name * c_site_name * c_state) AgentsSiteState_map_and_set.Map.t; + seen: AgentSiteState_map_and_set.Set.t; +} let empty_side_effects = { - not_seen_yet = AgentsSiteState_map_and_set.Map.empty ; - seen = AgentSiteState_map_and_set.Set.empty + not_seen_yet = AgentsSiteState_map_and_set.Map.empty; + seen = AgentSiteState_map_and_set.Set.empty; } diff --git a/core/KaSa_rep/frontend/ckappa_sig.mli b/core/KaSa_rep/frontend/ckappa_sig.mli index b5cceeaf09..0b5272e80b 100644 --- a/core/KaSa_rep/frontend/ckappa_sig.mli +++ b/core/KaSa_rep/frontend/ckappa_sig.mli @@ -16,9 +16,9 @@ module Int_Set_and_Map : Map_wrapper.S_with_logs with type elt = int (***************************************************************************) -type position = Locality.t -type agent_name = string -type site_name = string +type position = Loc.t +type agent_name = string +type site_name = string type internal_state = string type counter_name = string type counter_state = int @@ -41,406 +41,408 @@ val write_c_rule_id : Buffer.t -> c_rule_id -> unit val string_of_c_rule_id : ?len:int -> c_rule_id -> string val read_c_rule_id : Yojson.Safe.lexer_state -> Lexing.lexbuf -> c_rule_id val c_rule_id_of_string : string -> c_rule_id -val string_of_c_link_value: c_link_value -> string - +val string_of_c_link_value : c_link_value -> string val dummy_agent_name : c_agent_name val dummy_site_name : c_site_name val dummy_state_index : c_state val dummy_rule_id : c_rule_id val dummy_agent_id : c_agent_id -val dummy_link_value: c_link_value +val dummy_link_value : c_link_value val dummy_site_name_1 : c_site_name val dummy_site_name_minus1 : c_site_name - -val next_lnk_value: c_link_value -> c_link_value +val next_link_value : c_link_value -> c_link_value val fst_site : c_site_name val snd_site : c_site_name - val dummy_state_index_1 : c_state - val string_of_agent_name : c_agent_name -> string val int_of_agent_name : c_agent_name -> int val agent_name_of_int : int -> c_agent_name -val string_of_agent_id: c_agent_id -> string +val string_of_agent_id : c_agent_id -> string val site_name_of_int : int -> c_site_name val int_of_site_name : c_site_name -> int val string_of_site_name : c_site_name -> string - -val state_index_of_int: int -> c_state -val int_of_state_index: c_state -> int +val state_index_of_int : int -> c_state +val int_of_state_index : c_state -> int val string_of_state_index : c_state -> string + val string_of_state_index_option_min : - Remanent_parameters_sig.parameters -> - c_state option -> string + Remanent_parameters_sig.parameters -> c_state option -> string + val string_of_state_index_option_max : - Remanent_parameters_sig.parameters -> - c_state option -> string + Remanent_parameters_sig.parameters -> c_state option -> string val int_of_rule_id : c_rule_id -> int val rule_id_of_int : int -> c_rule_id val string_of_rule_id : c_rule_id -> string - val int_of_agent_id : c_agent_id -> int val agent_id_of_int : int -> c_agent_id -val lnk_value_of_int: int -> c_link_value -val add_agent_id: c_agent_id -> int -> c_agent_id -val sub_rule_id: c_rule_id -> int -> c_rule_id -val add_rule_id: c_rule_id -> int -> c_rule_id -val next_agent_id: c_agent_id -> c_agent_id -val next_agent_name: c_agent_name -> c_agent_name -val next_rule_id: c_rule_id -> c_rule_id -val next_site_name: c_site_name -> c_site_name -val next_state_index: c_state -> c_state -val pred_site_name: c_site_name -> c_site_name -val pred_agent_name: c_agent_name -> c_agent_name -val pred_state_index: c_state -> c_state -val compare_agent_id: c_agent_id -> c_agent_id -> int -val compare_rule_id: c_rule_id -> c_rule_id -> int -val compare_site_name: c_site_name -> c_site_name -> int -val compare_state_index: c_state -> c_state -> int -val compare_state_index_option_min: c_state option -> c_state option -> int -val compare_state_index_option_max: c_state option -> c_state option -> int -val compare_agent_name: c_agent_name -> c_agent_name -> int - -val get_agent_shape: c_site_name -> Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape -val get_agent_color: c_site_name -> Remanent_parameters_sig.parameters -> -Graph_loggers_sig.color - +val lnk_value_of_int : int -> c_link_value +val add_agent_id : c_agent_id -> int -> c_agent_id +val sub_rule_id : c_rule_id -> int -> c_rule_id +val add_rule_id : c_rule_id -> int -> c_rule_id +val next_agent_id : c_agent_id -> c_agent_id +val next_agent_name : c_agent_name -> c_agent_name +val next_rule_id : c_rule_id -> c_rule_id +val next_site_name : c_site_name -> c_site_name +val next_state_index : c_state -> c_state +val pred_site_name : c_site_name -> c_site_name +val pred_agent_name : c_agent_name -> c_agent_name +val pred_state_index : c_state -> c_state +val compare_agent_id : c_agent_id -> c_agent_id -> int +val compare_rule_id : c_rule_id -> c_rule_id -> int +val compare_site_name : c_site_name -> c_site_name -> int +val compare_state_index : c_state -> c_state -> int +val compare_state_index_option_min : c_state option -> c_state option -> int +val compare_state_index_option_max : c_state option -> c_state option -> int +val compare_agent_name : c_agent_name -> c_agent_name -> int + +val get_agent_shape : + c_site_name -> Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape + +val get_agent_color : + c_site_name -> Remanent_parameters_sig.parameters -> Graph_loggers_sig.color val compare_unit : unit -> unit -> int -val compare_unit_agent_name: unit -> unit -> c_agent_name -val compare_unit_site_name: unit -> unit -> c_site_name -val compare_unit_state_index: unit -> unit -> c_state +val compare_unit_agent_name : unit -> unit -> c_agent_name +val compare_unit_site_name : unit -> unit -> c_site_name +val compare_unit_state_index : unit -> unit -> c_state val compare_unit_agent_site : unit -> unit -> int (****************************************************************************) -type binding_state = - | Free - | Lnk_type of agent_name * site_name +type binding_state = Free | Lnk_type of agent_name * site_name type mixture = - | SKIP of mixture + | SKIP of mixture | COMMA of agent * mixture - | DOT of c_agent_id * agent * mixture - | PLUS of c_agent_id * agent * mixture + | DOT of c_agent_id * agent * mixture + | PLUS of c_agent_id * agent * mixture | EMPTY_MIX -and agent = - { - ag_nme : string; - ag_intf : interface; - ag_nme_pos : position (*; ag_pos:position*) - } +and agent = { + agent_name: string; + ag_intf: interface; + agent_name_pos: position; (*; ag_pos:position*) +} and interface = | EMPTY_INTF | PORT_SEP of port * interface | COUNTER_SEP of counter * interface -and port = - { - port_nme : string; - port_int : internal; - port_lnk : link; - port_free : bool option - } - -and counter = - { - count_nme : string; - count_test : counter_test option; - count_delta: int option - } +and port = { + port_name: string; + port_int: internal; + port_link: link; + port_free: bool option; +} -and counter_test = - | CEQ of int | CGTE of int | CVAR of string | UNKNOWN +and counter = { + counter_name: string; + counter_test: counter_test option; + counter_delta: int option; +} +and counter_test = CEQ of int | CGTE of int | CVAR of string | UNKNOWN and internal = string option list and link = | LNK_VALUE of (c_agent_id * agent_name * site_name * c_link_value * position) | FREE - | LNK_ANY of position - | LNK_SOME of position - | LNK_TYPE of (string Locality.annot * string Locality.annot) + | LNK_ANY of position + | LNK_SOME of position + | LNK_TYPE of (string Loc.annoted * string Loc.annoted) | LNK_MISSING -val skip_only: mixture -> bool +val skip_only : mixture -> bool type direction = Direct | Reverse -type 'pattern rule = - { - position: Locality.t; - prefix: int; - interprete_delta: direction ; - delta: int; - (* to go from Ckappa id to KaSim id: *) - (* in direct mode: - substract delta to agents with id >= prefix in the rhs *) - (* in reverse mode: - substract delta to agents with id >= prefix in the lhs *) - lhs : 'pattern; - rhs : 'pattern; - k_def : ('pattern,string) Alg_expr.e Locality.annot; - k_un : ('pattern,string) Alg_expr.e Locality.annot option; - ast: string ; - ast_no_rate: string ; - original_ast: string ; - original_ast_no_rate: string ; - from_a_biderectional_rule: bool; - } - -type ('pattern,'rule) perturbation = - ('pattern,'pattern,string,'rule) Ast.perturbation - -type ('pattern,'rule) modif_expr = - ('pattern,'pattern,string,'rule) Ast.modif_expr - -type 'pattern variable = ('pattern,string) Ast.variable_def - -type ('agent,'pattern,'mixture,'rule) compil = +type 'pattern rule = { + position: Loc.t; + prefix: int; + interprete_delta: direction; + delta: int; + (* to go from Ckappa id to KaSim id: *) + (* in direct mode: + substract delta to agents with id >= prefix in the rhs *) + (* in reverse mode: + substract delta to agents with id >= prefix in the lhs *) + lhs: 'pattern; + rhs: 'pattern; + k_def: ('pattern, string) Alg_expr.e Loc.annoted; + k_un: ('pattern, string) Alg_expr.e Loc.annoted option; + ast: string; + ast_no_rate: string; + original_ast: string; + original_ast_no_rate: string; + from_a_biderectional_rule: bool; +} + +type ('pattern, 'rule) perturbation = + ('pattern, 'pattern, string, 'rule) Ast.perturbation + +type ('pattern, 'rule) modif_expr = + ('pattern, 'pattern, string, 'rule) Ast.modif_expr + +type 'pattern variable = ('pattern, string) Ast.variable_def + +type ('agent, 'pattern, 'mixture, 'rule) compil = ('agent, 'pattern, 'mixture, string, 'rule) Ast.compil -type ('a,'b,'c) site_type = - | Internal of 'a - | Binding of 'b - | Counter of 'c - -type site = (site_name, site_name, site_name) site_type - +type ('a, 'b, 'c) site_type = Internal of 'a | Binding of 'b | Counter of 'c +type site = (site_name, site_name, site_name) site_type type state = (internal_state, binding_state, counter_state) site_type -val rename_link: +val rename_link : Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - c_agent_id -> - Exception.method_handler * c_agent_id) -> + Exception.method_handler -> + c_agent_id -> + Exception.method_handler * c_agent_id) -> link -> Exception.method_handler * link -val rename_mixture: +val rename_mixture : Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - c_agent_id -> - Exception.method_handler * c_agent_id) -> + Exception.method_handler -> + c_agent_id -> + Exception.method_handler * c_agent_id) -> mixture -> Exception.method_handler * mixture -val join_link: +val join_link : Remanent_parameters_sig.parameters -> Exception.method_handler -> - link -> link -> + link -> + link -> Exception.method_handler * link -val join_mixture: +val join_mixture : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + mixture -> + mixture -> + Exception.method_handler * mixture + +val add_agent : Remanent_parameters_sig.parameters -> Exception.method_handler -> - mixture -> mixture -> + c_agent_id -> + agent_name -> + mixture -> Exception.method_handler * mixture -val add_agent: Remanent_parameters_sig.parameters -> +val add_site : + Remanent_parameters_sig.parameters -> Exception.method_handler -> - c_agent_id -> agent_name -> mixture -> Exception.method_handler * mixture + c_agent_id -> + site_name -> + mixture -> + Exception.method_handler * mixture -val add_site: Remanent_parameters_sig.parameters -> - Exception.method_handler -> c_agent_id -> site_name -> mixture -> Exception.method_handler * mixture +val add_counter : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + c_agent_id -> + counter_name -> + mixture -> + Exception.method_handler * mixture -val add_counter: Remanent_parameters_sig.parameters -> - Exception.method_handler -> c_agent_id -> counter_name -> mixture -> Exception.method_handler * mixture -val add_internal_state: Remanent_parameters_sig.parameters -> - Exception.method_handler -> c_agent_id -> site_name -> internal_state -> mixture -> Exception.method_handler * mixture +val add_internal_state : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + c_agent_id -> + site_name -> + internal_state -> + mixture -> + Exception.method_handler * mixture -val add_link: Remanent_parameters_sig.parameters -> - Exception.method_handler -> c_agent_id -> ?agent_name:agent_name -> site_name -> c_agent_id -> ?agent_name':agent_name -> site_name -> c_link_value -> mixture -> Exception.method_handler * mixture +val add_link : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + c_agent_id -> + ?agent_name:agent_name -> + site_name -> + c_agent_id -> + ?agent_name':agent_name -> + site_name -> + c_link_value -> + mixture -> + Exception.method_handler * mixture -val add_binding_type: Remanent_parameters_sig.parameters -> - Exception.method_handler -> c_agent_id -> site_name -> agent_name -> site_name -> mixture -> Exception.method_handler * mixture +val add_binding_type : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + c_agent_id -> + site_name -> + agent_name -> + site_name -> + mixture -> + Exception.method_handler * mixture -val add_bound: Remanent_parameters_sig.parameters -> - Exception.method_handler -> c_agent_id -> site_name -> mixture -> Exception.method_handler * mixture +val add_bound : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + c_agent_id -> + site_name -> + mixture -> + Exception.method_handler * mixture -val add_free: Remanent_parameters_sig.parameters -> - Exception.method_handler -> c_agent_id -> site_name -> mixture -> Exception.method_handler * mixture +val add_free : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + c_agent_id -> + site_name -> + mixture -> + Exception.method_handler * mixture (*******************************************************) (*C type*) (*******************************************************) -type c_binding_state = - | C_Free - | C_Lnk_type of c_agent_name * c_site_name - +type c_binding_state = C_Free | C_Lnk_type of c_agent_name * c_site_name type state' = (internal_state, c_binding_state, counter_state) site_type -module Dictionary_of_States: Dictionary.Dictionary - with type key = c_state - and type value = state' - -type internal_state_specification = - { - string : internal_state option; - } - -module Dictionary_of_agents: Dictionary.Dictionary - with type key = c_agent_name - and type value = agent_name - -module Dictionary_of_sites : Dictionary.Dictionary - with type key = c_site_name - and type value = site - - -type site_list = - { - used : (site_name list * position) list; - declared : (site_name list * position) list; - creation : (site_name list * position) list - } - -type agent_dic = (unit,unit) Dictionary_of_agents.dictionary -type site_dic = (unit,unit) Dictionary_of_sites.dictionary -type state_dic = (unit,unit) Dictionary_of_States.dictionary - -type agent_specification = - { - binding_sites_usage : site_list; - marked_sites_usage : site_list - } - -type kappa_handler = - { - agents_dic : agent_dic; - interface_constraints : agent_specification Int_storage.Nearly_inf_Imperatif.t; - sites : site_dic Int_storage.Nearly_inf_Imperatif.t; - states_dic : state_dic Int_storage.Nearly_inf_Imperatif.t - Int_storage.Nearly_inf_Imperatif.t - } - -type 'a interval = {min:'a option; max:'a option} - -type c_port = - { - c_site_name : c_site_name; - c_site_position : position; - c_site_interval : c_state interval - } - -module Site_map_and_set: Map_wrapper.S_with_logs - with type elt = c_site_name +module Dictionary_of_States : + Dictionary.Dictionary with type key = c_state and type value = state' -type c_interface = c_port Site_map_and_set.Map.t +type internal_state_specification = { string: internal_state option } -type c_proper_agent = - { - c_agent_kasim_id : c_agent_id; - c_agent_name : c_agent_name; - c_agent_interface : c_interface; - c_agent_position : position - } +module Dictionary_of_agents : + Dictionary.Dictionary with type key = c_agent_name and type value = agent_name -type site_address = - { - agent_index : c_agent_id; - site : c_site_name - } +module Dictionary_of_sites : + Dictionary.Dictionary with type key = c_site_name and type value = site -type c_bond = site_address * site_address +type site_list = { + used: (site_name list * position) list; + declared: (site_name list * position) list; + creation: (site_name list * position) list; +} + +type agent_dic = (unit, unit) Dictionary_of_agents.dictionary +type site_dic = (unit, unit) Dictionary_of_sites.dictionary +type state_dic = (unit, unit) Dictionary_of_States.dictionary + +type agent_specification = { + binding_sites_usage: site_list; + marked_sites_usage: site_list; +} -type c_agent = - | C_ghost - | C_agent of c_proper_agent - -type c_mixture = - { - c_views : c_agent Int_storage.Quick_Nearly_inf_Imperatif.t; - c_bonds : - site_address Site_map_and_set.Map.t Int_storage.Nearly_inf_Imperatif.t; - c_plus : (int * int) list; - c_dot : (int * int) list - } - -type c_variable = (c_mixture,string) Alg_expr.e - -type action = - | Release of c_bond - | Bind of c_bond - | Half_breaf of site_address - -type c_rule = - { - c_rule_lhs : c_mixture; - c_rule_bidirectional : bool; - c_rule_rhs : c_mixture; - c_diff_direct : c_mixture; - c_diff_reverse : c_mixture; - c_side_effects : action list - } +type kappa_handler = { + agents_dic: agent_dic; + interface_constraints: agent_specification Int_storage.Nearly_inf_Imperatif.t; + sites: site_dic Int_storage.Nearly_inf_Imperatif.t; + states_dic: + state_dic Int_storage.Nearly_inf_Imperatif.t + Int_storage.Nearly_inf_Imperatif.t; +} + +type 'a interval = { min: 'a option; max: 'a option } + +type c_port = { + c_site_name: c_site_name; + c_site_position: position; + c_site_interval: c_state interval; +} + +module Site_map_and_set : Map_wrapper.S_with_logs with type elt = c_site_name + +type c_interface = c_port Site_map_and_set.Map.t + +type c_proper_agent = { + c_agent_kasim_id: c_agent_id; + c_agent_name: c_agent_name; + c_agent_interface: c_interface; + c_agent_position: position; +} + +type site_address = { agent_index: c_agent_id; site: c_site_name } +type c_bond = site_address * site_address +type c_agent = C_ghost | C_agent of c_proper_agent + +type c_mixture = { + c_views: c_agent Int_storage.Quick_Nearly_inf_Imperatif.t; + c_bonds: + site_address Site_map_and_set.Map.t Int_storage.Nearly_inf_Imperatif.t; + c_plus: (int * int) list; + c_dot: (int * int) list; +} + +type c_variable = (c_mixture, string) Alg_expr.e +type action = Release of c_bond | Bind of c_bond | Half_breaf of site_address + +type c_rule = { + c_rule_lhs: c_mixture; + c_rule_bidirectional: bool; + c_rule_rhs: c_mixture; + c_diff_direct: c_mixture; + c_diff_reverse: c_mixture; + c_side_effects: action list; +} type c_modif_expr = - | C_APPLY of ((c_mixture,string) Alg_expr.e * c_rule * position) - | C_UPDATE of - (string * (c_mixture,string) Alg_expr.e * position) (*TODO: pause*) - | C_STOP of position + | C_APPLY of ((c_mixture, string) Alg_expr.e * c_rule * position) + | C_UPDATE of (string * (c_mixture, string) Alg_expr.e * position) + (*TODO: pause*) + | C_STOP of position | C_SNAPSHOT of position (*maybe later of mixture too*) type c_perturbation = - ((((c_mixture,string) Alg_expr.bool) * position) - * (c_modif_expr list) - * ((c_mixture,string) Alg_expr.bool * position) option) + (((c_mixture, string) Alg_expr.bool * position) + * c_modif_expr list + * ((c_mixture, string) Alg_expr.bool * position) option) * position -type enriched_rule = - { - e_rule_label : (string * position) option; - e_rule_direct : bool; - e_rule_rule : c_mixture rule; - e_rule_c_rule : c_rule - } - -type enriched_init = - { - e_init_factor : int; - e_init_mixture : mixture; - e_init_c_mixture : c_mixture; - e_init_pos : position - } - -type c_compil = - { - c_variables : c_variable Int_storage.Nearly_inf_Imperatif.t; - (*pattern declaration for reusing as variable in perturbations or kinetic rate*) - c_signatures : (agent * position) Int_storage.Nearly_inf_Imperatif.t; - (*agent signature declaration*) - c_rules : enriched_rule Int_storage.Nearly_inf_Imperatif.t; - (*rules (possibly named)*) - c_observables : (c_mixture,string) Alg_expr.e Int_storage.Nearly_inf_Imperatif.t; - (*list of patterns to plot*) - c_init : enriched_init Int_storage.Nearly_inf_Imperatif.t ; - (*initial graph declaration*) - c_perturbations : - (c_mixture Locality.annot,enriched_rule) perturbation Int_storage.Nearly_inf_Imperatif.t - } +type enriched_rule = { + e_rule_label: (string * position) option; + e_rule_direct: bool; + e_rule_rule: c_mixture rule; + e_rule_c_rule: c_rule; +} + +type enriched_init = { + e_init_factor: int; + e_init_mixture: mixture; + e_init_c_mixture: c_mixture; + e_init_pos: position; +} + +type c_compil = { + c_variables: c_variable Int_storage.Nearly_inf_Imperatif.t; + (*pattern declaration for reusing as variable in perturbations or kinetic rate*) + c_signatures: (agent * position) Int_storage.Nearly_inf_Imperatif.t; + (*agent signature declaration*) + c_rules: enriched_rule Int_storage.Nearly_inf_Imperatif.t; + (*rules (possibly named)*) + c_observables: + (c_mixture, string) Alg_expr.e Int_storage.Nearly_inf_Imperatif.t; + (*list of patterns to plot*) + c_init: enriched_init Int_storage.Nearly_inf_Imperatif.t; + (*initial graph declaration*) + c_perturbations: + (c_mixture Loc.annoted, enriched_rule) perturbation + Int_storage.Nearly_inf_Imperatif.t; +} (*******************************************************) -module Rule_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_rule_id - and type dimension = int - -val array_of_list_rule_id: - (Rule_nearly_Inf_Int_storage_Imperatif.dimension, - 'a Rule_nearly_Inf_Int_storage_Imperatif.t) - Int_storage.unary -> - (Rule_nearly_Inf_Int_storage_Imperatif.key, 'a, - 'a Rule_nearly_Inf_Int_storage_Imperatif.t, - 'a Rule_nearly_Inf_Int_storage_Imperatif.t) - Int_storage.ternary -> +module Rule_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_rule_id and type dimension = int + +val array_of_list_rule_id : + ( Rule_nearly_Inf_Int_storage_Imperatif.dimension, + 'a Rule_nearly_Inf_Int_storage_Imperatif.t ) + Int_storage.unary -> + ( Rule_nearly_Inf_Int_storage_Imperatif.key, + 'a, + 'a Rule_nearly_Inf_Int_storage_Imperatif.t, + 'a Rule_nearly_Inf_Int_storage_Imperatif.t ) + Int_storage.ternary -> Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a list -> @@ -448,162 +450,147 @@ val array_of_list_rule_id: (***************************************************************************) -module Agent_type_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_agent_name - and type dimension = int +module Agent_type_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_name and type dimension = int -module Agent_type_quick_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_agent_name - and type dimension = int +module Agent_type_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_name and type dimension = int -module Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif: +module Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif : Int_storage.Storage - with type key = c_agent_name * c_site_name - and type dimension = int * int + with type key = c_agent_name * c_site_name + and type dimension = int * int -module Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif: +module Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif : Int_storage.Storage - with type key = c_agent_name * c_site_name - and type dimension = int * int + with type key = c_agent_name * c_site_name + and type dimension = int * int -module - Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif: Int_storage.Storage - with type key = c_agent_name * (c_site_name * c_state) - and type dimension = int * (int * int) +module Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif : + Int_storage.Storage + with type key = c_agent_name * (c_site_name * c_state) + and type dimension = int * (int * int) -module Site_type_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_site_name - and type dimension = int +module Site_type_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_site_name and type dimension = int -module Site_type_quick_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_site_name - and type dimension = int +module Site_type_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_site_name and type dimension = int -module State_index_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_state - and type dimension = int +module State_index_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_state and type dimension = int -module State_index_quick_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_state - and type dimension = int +module State_index_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_state and type dimension = int -module Rule_quick_nearly_Inf_Int_storage_Imperatif : Int_storage.Storage - with type key = c_rule_id - and type dimension = int +module Rule_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_rule_id and type dimension = int -module Site_union_find: Union_find.Union_find - with type t = c_site_name Site_type_nearly_Inf_Int_storage_Imperatif.t - and type dimension = int - and type key = c_site_name +module Site_union_find : + Union_find.Union_find + with type t = c_site_name Site_type_nearly_Inf_Int_storage_Imperatif.t + and type dimension = int + and type key = c_site_name (******************************************************************************) (*FIFO*) -module Rule_FIFO : Working_list.Work_list - with type elt = c_rule_id +module Rule_FIFO : Working_list.Work_list with type elt = c_rule_id (******************************************************************************) -module Agent_id_nearly_Inf_Int_storage_Imperatif : Int_storage.Storage - with type key = c_agent_id - and type dimension = int +module Agent_id_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_id and type dimension = int -module Agent_id_quick_nearly_Inf_Int_storage_Imperatif: Int_storage.Storage - with type key = c_agent_id - and type dimension = int +module Agent_id_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_agent_id and type dimension = int -module Rule_id_quick_nearly_Inf_Int_storage_Imperatif: - Int_storage.Storage - with type key = c_rule_id - and type dimension = int +module Rule_id_quick_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = c_rule_id and type dimension = int (****************************************************************************) -module Agent_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_name +module Agent_map_and_set : Map_wrapper.S_with_logs with type elt = c_agent_name +module Agent_id_map_and_set : Map_wrapper.S_with_logs with type elt = c_agent_id +module Lnk_id_map_and_set : Map_wrapper.S_with_logs with type elt = c_link_value +module Rule_map_and_set : Map_wrapper.S_with_logs with type elt = c_rule_id +module State_map_and_set : Map_wrapper.S_with_logs with type elt = c_state -module Agent_id_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_id +module AgentRule_map_and_set : + Map_wrapper.S_with_logs with type elt = c_agent_name * c_rule_id -module Lnk_id_map_and_set: Map_wrapper.S_with_logs - with type elt = c_link_value - -module Rule_map_and_set: Map_wrapper.S_with_logs - with type elt = c_rule_id - -module State_map_and_set: Map_wrapper.S_with_logs - with type elt = c_state - -module AgentRule_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_name * c_rule_id - -module RuleAgent_map_and_set: Map_wrapper.S_with_logs - with type elt = c_rule_id * c_agent_id +module RuleAgent_map_and_set : + Map_wrapper.S_with_logs with type elt = c_rule_id * c_agent_id (*use in site_accross_bonds_domain*) -module SiteState_map_and_set : Map_wrapper.S_with_logs - with type elt = c_site_name * c_state - -module AgentSiteState_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_name * c_site_name * c_state +module SiteState_map_and_set : + Map_wrapper.S_with_logs with type elt = c_site_name * c_state -module Rule_setmap: SetMap.S with type elt = c_rule_id - -module Agent_id_setmap: SetMap.S with type elt = c_agent_id +module AgentSiteState_map_and_set : + Map_wrapper.S_with_logs with type elt = c_agent_name * c_site_name * c_state +module Rule_setmap : SetMap.S with type elt = c_rule_id +module Agent_id_setmap : SetMap.S with type elt = c_agent_id module PairRule_setmap : SetMap.S with type elt = c_rule_id * c_rule_id -module PairAgentSite_map_and_set : Map_wrapper.S_with_logs - with type elt = (c_agent_name * c_site_name) * - (c_agent_name * c_site_name) +module PairAgentSite_map_and_set : + Map_wrapper.S_with_logs + with type elt = (c_agent_name * c_site_name) * (c_agent_name * c_site_name) -module AgentSite_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_name * c_site_name +module AgentSite_map_and_set : + Map_wrapper.S_with_logs with type elt = c_agent_name * c_site_name -module Agents_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_id * c_agent_name +module Agents_map_and_set : + Map_wrapper.S_with_logs with type elt = c_agent_id * c_agent_name -module AgentsSite_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_id * c_agent_name * c_site_name +module AgentsSite_map_and_set : + Map_wrapper.S_with_logs + with type elt = c_agent_id * c_agent_name * c_site_name -module AgentsSiteState_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_id * c_agent_name * c_site_name * c_state +module AgentsSiteState_map_and_set : + Map_wrapper.S_with_logs + with type elt = c_agent_id * c_agent_name * c_site_name * c_state type pair_of_states = c_state option * c_state option -module AgentsSitePState_map_and_set: Map_wrapper.S_with_logs - with type elt = c_agent_id * c_agent_name * c_site_name * pair_of_states +module AgentsSitePState_map_and_set : + Map_wrapper.S_with_logs + with type elt = c_agent_id * c_agent_name * c_site_name * pair_of_states -module Views_bdu: Mvbdu_wrapper.Mvbdu with type key = c_site_name and type value = c_state +module Views_bdu : + Mvbdu_wrapper.Mvbdu with type key = c_site_name and type value = c_state -module Views_intbdu: Mvbdu_wrapper.Internalized_mvbdu - with type key = c_site_name and type value = c_state and type mvbdu = Views_bdu.mvbdu +module Views_intbdu : + Mvbdu_wrapper.Internalized_mvbdu + with type key = c_site_name + and type value = c_state + and type mvbdu = Views_bdu.mvbdu (***************************************************************************) +module PairAgentsSiteState_map_and_set : + Map_wrapper.S_with_logs + with type elt = + (c_agent_id * c_agent_name * c_site_name * c_state) + * (c_agent_id * c_agent_name * c_site_name * c_state) -module PairAgentsSiteState_map_and_set: Map_wrapper.S_with_logs - with type elt = - (c_agent_id * c_agent_name * c_site_name * c_state) * - (c_agent_id * c_agent_name * c_site_name * c_state) - -module PairAgentSiteState_map_and_set: Map_wrapper.S_with_logs - with type elt = - (c_agent_name * c_site_name * c_state) * - (c_agent_name * c_site_name * c_state) +module PairAgentSiteState_map_and_set : + Map_wrapper.S_with_logs + with type elt = + (c_agent_name * c_site_name * c_state) + * (c_agent_name * c_site_name * c_state) -module PairAgentSitesState_map_and_set: Map_wrapper.S_with_logs - with type elt = - (c_agent_name * c_site_name * c_site_name * c_state) * - (c_agent_name * c_site_name * c_site_name * c_state) +module PairAgentSitesState_map_and_set : + Map_wrapper.S_with_logs + with type elt = + (c_agent_name * c_site_name * c_site_name * c_state) + * (c_agent_name * c_site_name * c_site_name * c_state) -type side_effects = - { - not_seen_yet: - (c_agent_name * c_site_name * c_state) - AgentsSiteState_map_and_set.Map.t ; - seen: AgentSiteState_map_and_set.Set.t - } +type side_effects = { + not_seen_yet: + (c_agent_name * c_site_name * c_state) AgentsSiteState_map_and_set.Map.t; + seen: AgentSiteState_map_and_set.Set.t; +} -val empty_side_effects: side_effects +val empty_side_effects : side_effects diff --git a/core/KaSa_rep/frontend/dune b/core/KaSa_rep/frontend/dune index 51e7cc945b..8fb1f74a54 100644 --- a/core/KaSa_rep/frontend/dune +++ b/core/KaSa_rep/frontend/dune @@ -1,15 +1,27 @@ (library - (name kappa_kasa_frontend ) - (libraries kappa_kasa_kastor_toolset kappa_classical_graphs kappa_mvbdu) - (flags (:standard -w @a - -open Kappa_kasa_kastor_toolset - -open Kappa_generic_toolset - -open Kappa_parameters - -open Kappa_logging - -open Kappa_classical_graphs - -open Kappa_terms - -open Kappa_grammar - -open Kappa_errors - -open Kappa_mvbdu - -open Kappa_kasa_type_interface - ))) + (name kappa_kasa_frontend) + (libraries kappa_kasa_kastor_toolset kappa_classical_graphs kappa_mvbdu) + (flags + (:standard + -w + @a + -open + Kappa_kasa_kastor_toolset + -open + Kappa_generic_toolset + -open + Kappa_parameters + -open + Kappa_logging + -open + Kappa_classical_graphs + -open + Kappa_terms + -open + Kappa_grammar + -open + Kappa_errors + -open + Kappa_mvbdu + -open + Kappa_kasa_type_interface))) diff --git a/core/KaSa_rep/frontend/handler.ml b/core/KaSa_rep/frontend/handler.ml index 1ed7e304fd..fb259ff3f6 100644 --- a/core/KaSa_rep/frontend/handler.ml +++ b/core/KaSa_rep/frontend/handler.ml @@ -13,7 +13,6 @@ * under the terms of the GNU Library General Public License *) let local_trace = false - let nrules _parameter _error handler = handler.Cckappa_sig.nrules let nvars _parameter _error handler = handler.Cckappa_sig.nvars let nagents _parameter _error handler = handler.Cckappa_sig.nagents @@ -22,206 +21,149 @@ let check_pos parameter ka_pos ml_pos message error error' = match ml_pos with | None -> error' | Some ml_pos -> - Exception.check_point - Exception.warn parameter ~message ?pos:ka_pos error error' ml_pos Exit - -let translate_agent - ?ml_pos:(ml_pos=None) ?ka_pos - ?message:(message="") - parameter error handler ag = - let error',(a, _, _) = + Exception.check_point Exception.warn parameter ~message ?pos:ka_pos error + error' ml_pos Exit + +let translate_agent ?(ml_pos = None) ?ka_pos ?(message = "") parameter error + handler ag = + let error', (a, _, _) = Misc_sa.unsome - (Ckappa_sig.Dictionary_of_agents.translate - parameter - error - ag - handler.Cckappa_sig.agents_dic) - (fun error -> - Exception.warn parameter error __POS__ Exit ("",(),())) + (Ckappa_sig.Dictionary_of_agents.translate parameter error ag + handler.Cckappa_sig.agents_dic) (fun error -> + Exception.warn parameter error __POS__ Exit ("", (), ())) in - check_pos parameter ka_pos ml_pos message error error', - a + check_pos parameter ka_pos ml_pos message error error', a -let translate_site - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler agent_name site = +let translate_site ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameter + error handler agent_name site = let error', dic = Misc_sa.unsome - (Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameter - error - agent_name - handler.Cckappa_sig.sites) - (fun error -> - Exception.warn parameter error __POS__ Exit - (Ckappa_sig.Dictionary_of_sites.init ())) + (Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameter + error agent_name handler.Cckappa_sig.sites) (fun error -> + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.Dictionary_of_sites.init ())) in let error', (a, _, _) = Misc_sa.unsome (Ckappa_sig.Dictionary_of_sites.translate parameter error' site dic) (fun error -> - Exception.warn parameter error __POS__ Exit - (Ckappa_sig.Internal "", (), ())) + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.Internal "", (), ())) in - check_pos parameter ka_pos ml_pos message error error', - a + check_pos parameter ka_pos ml_pos message error error', a -let translate_state - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler agent site state = +let translate_state ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameter + error handler agent site state = let error', dic = Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameter - error - (agent, site) - handler.Cckappa_sig.states_dic) - (fun error -> Exception.warn parameter error __POS__ Exit + (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameter error (agent, site) handler.Cckappa_sig.states_dic) + (fun error -> + Exception.warn parameter error __POS__ Exit (Ckappa_sig.Dictionary_of_States.init ())) in let error', (a, _, _) = Misc_sa.unsome (Ckappa_sig.Dictionary_of_States.translate parameter error' state dic) (fun error -> - Exception.warn parameter error __POS__ Exit (Ckappa_sig.Internal "",(),())) + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.Internal "", (), ())) in - check_pos parameter ka_pos ml_pos message error error', - a + check_pos parameter ka_pos ml_pos message error error', a let translate_binding_type parameter error handler agent site = - let error, agent_name = - translate_agent parameter error handler agent - in + let error, agent_name = translate_agent parameter error handler agent in let error, site_name = - match - translate_site parameter error handler agent site - with + match translate_site parameter error handler agent site with | error, Ckappa_sig.Binding s -> error, s | error, (Ckappa_sig.Internal s | Ckappa_sig.Counter s) -> Exception.warn parameter error __POS__ Exit s in - let binding_type_symbol = - Remanent_parameters.get_at_symbol parameter - in - error, - Public_data.string_of_binding_type - ~binding_type_symbol - ~agent_name - ~site_name () + let binding_type_symbol = Remanent_parameters.get_at_symbol parameter in + ( error, + Public_data.string_of_binding_type ~binding_type_symbol ~agent_name + ~site_name () ) -let dual - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler agent site state = +let dual ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameter error + handler agent site state = let error', a = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.unsafe_get - parameter - error + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .unsafe_get parameter error (agent, (site, state)) handler.Cckappa_sig.dual in - check_pos parameter ka_pos ml_pos message error error', - a + check_pos parameter ka_pos ml_pos message error error', a -let is_binding_site - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler agent site = - let error,site = - translate_site - ~ml_pos ~ka_pos ~message - parameter error handler agent site +let is_binding_site ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameter + error handler agent site = + let error, site = + translate_site ~ml_pos ~ka_pos ~message parameter error handler agent site in match site with - | Ckappa_sig.Internal _ | Ckappa_sig.Counter _ -> error,false - | Ckappa_sig.Binding _ -> error,true - -let is_internal_site - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler agent site = - let error,site = - translate_site - ~ml_pos ~ka_pos ~message - parameter error handler agent site + | Ckappa_sig.Internal _ | Ckappa_sig.Counter _ -> error, false + | Ckappa_sig.Binding _ -> error, true + +let is_internal_site ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameter + error handler agent site = + let error, site = + translate_site ~ml_pos ~ka_pos ~message parameter error handler agent site in match site with - | Ckappa_sig.Internal _ -> error,true - | Ckappa_sig.Counter _ | Ckappa_sig.Binding _ -> error,false - -let is_counter - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler agent site = - let error,site = - translate_site - ~ml_pos ~ka_pos ~message - parameter error handler agent site + | Ckappa_sig.Internal _ -> error, true + | Ckappa_sig.Counter _ | Ckappa_sig.Binding _ -> error, false + +let is_counter ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameter error + handler agent site = + let error, site = + translate_site ~ml_pos ~ka_pos ~message parameter error handler agent site in match site with - | Ckappa_sig.Counter _ -> error,true - | Ckappa_sig.Internal _ | Ckappa_sig.Binding _ -> error,false + | Ckappa_sig.Counter _ -> error, true + | Ckappa_sig.Internal _ | Ckappa_sig.Binding _ -> error, false -let last_site_of_agent - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") +let last_site_of_agent ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameters error handler agent_name = let error', dic = Misc_sa.unsome - ( - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_name - handler.Cckappa_sig.sites) - (fun error -> Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_name handler.Cckappa_sig.sites) (fun error -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.Dictionary_of_sites.init ())) in let error', last_entry = Ckappa_sig.Dictionary_of_sites.last_entry parameters error' dic in - check_pos parameters ka_pos ml_pos message error error', - last_entry + check_pos parameters ka_pos ml_pos message error error', last_entry -let last_state_of_site - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") +let last_state_of_site ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameters error handler agent_name site_name = let error', dic = Misc_sa.unsome - ( - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, site_name) - handler.Cckappa_sig.states_dic) - (fun error -> Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, site_name) + handler.Cckappa_sig.states_dic) + (fun error -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.Dictionary_of_States.init ())) in let error', last_entry = Ckappa_sig.Dictionary_of_States.last_entry parameters error' dic in - check_pos parameters ka_pos ml_pos message error error', - last_entry + check_pos parameters ka_pos ml_pos message error error', last_entry -let complementary_interface - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") +let complementary_interface ?(ml_pos = None) ?(ka_pos = None) ?(message = "") parameters error handler agent_name interface = let error, last_entry = - last_site_of_agent - ~ml_pos ~ka_pos ~message parameters error handler agent_name + last_site_of_agent ~ml_pos ~ka_pos ~message parameters error handler + agent_name in let l = let rec aux k output = - if - Ckappa_sig.compare_site_name k Ckappa_sig.dummy_site_name < 0 - then + if Ckappa_sig.compare_site_name k Ckappa_sig.dummy_site_name < 0 then output else - aux (Ckappa_sig.pred_site_name k) (k::output) + aux (Ckappa_sig.pred_site_name k) (k :: output) in aux last_entry [] in @@ -229,84 +171,68 @@ let complementary_interface let is_reverse parameters error compiled rule_id = let rules = compiled.Cckappa_sig.rules in - let error,rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - rule_id - rules + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error + rule_id rules in - match rule - with - | None -> - Exception.warn - parameters error __POS__ Exit - false + match rule with + | None -> Exception.warn parameters error __POS__ Exit false | Some rule -> error, rule.Cckappa_sig.e_rule_initial_direction = Ckappa_sig.Reverse let has_no_label parameters error compiled rule_id = let rules = compiled.Cckappa_sig.rules in - let error,rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - rule_id - rules + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error + rule_id rules in match rule with - | None -> - Exception.warn parameters error __POS__ Exit true + | None -> Exception.warn parameters error __POS__ Exit true | Some rule -> - error, - match rule.Cckappa_sig.e_rule_label with - None -> true - | Some _ -> false - + ( error, + (match rule.Cckappa_sig.e_rule_label with + | None -> true + | Some _ -> false) ) -let info_of_rule - parameters ?(with_rates=false) ?(original=false) error compiled (rule_id: Ckappa_sig.c_rule_id) = +let info_of_rule parameters ?(with_rates = false) ?(original = false) error + compiled (rule_id : Ckappa_sig.c_rule_id) = let rules = compiled.Cckappa_sig.rules in - let error,rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - rule_id - rules + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error + rule_id rules in match rule with | None -> - Exception.warn - parameters error __POS__ Exit - ("",Locality.dummy,Public_data.Dummy_rule_direction,"",Ckappa_sig.dummy_rule_id) + Exception.warn parameters error __POS__ Exit + ( "", + Loc.dummy, + Public_data.Dummy_rule_direction, + "", + Ckappa_sig.dummy_rule_id ) | Some rule -> let label_opt = rule.Cckappa_sig.e_rule_label in let error, (label, _) = - Misc_sa.unsome (error,label_opt) - (fun error -> error,Locality.dummy_annot "") in + Misc_sa.unsome (error, label_opt) (fun error -> + error, Loc.annot_with_dummy "") + in let label = - if label="" then "" - else - match - rule.Cckappa_sig.e_rule_initial_direction - with + if label = "" then + "" + else ( + match rule.Cckappa_sig.e_rule_initial_direction with | Ckappa_sig.Direct -> label | Ckappa_sig.Reverse -> Ast.flip_label label + ) in - let position = - rule.Cckappa_sig.e_rule_rule.Ckappa_sig.position - in + let position = rule.Cckappa_sig.e_rule_rule.Ckappa_sig.position in let direction = - match - rule.Cckappa_sig.e_rule_initial_direction - with + match rule.Cckappa_sig.e_rule_initial_direction with | Ckappa_sig.Direct -> Public_data.Direct_rule | Ckappa_sig.Reverse -> Public_data.Reverse_rule in let ast = match original, with_rates with - | true, true -> - rule.Cckappa_sig.e_rule_rule.Ckappa_sig.original_ast + | true, true -> rule.Cckappa_sig.e_rule_rule.Ckappa_sig.original_ast | true, false -> rule.Cckappa_sig.e_rule_rule.Ckappa_sig.original_ast_no_rate | false, true -> rule.Cckappa_sig.e_rule_rule.Ckappa_sig.ast @@ -314,139 +240,140 @@ let info_of_rule in error, (label, position, direction, ast, rule_id) +let hide rule = { rule with Public_data.rule_hidden = true } -let hide rule = {rule with Public_data.rule_hidden = true} - -let info_of_agent - parameters error handler _compiled agent = - let info_of_agents = - handler.Cckappa_sig.agents_annotation - in +let info_of_agent parameters error handler _compiled agent = + let info_of_agents = handler.Cckappa_sig.agents_annotation in let error, info_opt = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent - info_of_agents + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters error + agent info_of_agents in let error, (agent_name, positions) = - match - info_opt - with - | None -> - Exception.warn - parameters error __POS__ Exit - ("",[]) - | Some (agent_name, positions) -> - error, (agent_name, positions) + match info_opt with + | None -> Exception.warn parameters error __POS__ Exit ("", []) + | Some (agent_name, positions) -> error, (agent_name, positions) in error, (agent_name, positions, agent) - -let info_of_var parameters error handler compiled (rule_id: Ckappa_sig.c_rule_id) = +let info_of_var parameters error handler compiled + (rule_id : Ckappa_sig.c_rule_id) = let vars = compiled.Cckappa_sig.variables in let nrules = nrules parameters error handler in let var_id = Ckappa_sig.sub_rule_id rule_id nrules in - let error,var = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - var_id + let error, var = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error var_id vars in match var with - | None -> Exception.warn parameters error __POS__ Exit - (("VAR " ^ (Ckappa_sig.string_of_rule_id var_id)),Locality.dummy,Public_data.Variable,"",var_id) - | Some var -> - error,(fst var.Cckappa_sig.e_id_dot, - snd var.Cckappa_sig.e_id, - Public_data.Variable, - "" (* TO DO: string for the ast representation (from var.Cckappa_sig.c_variable?) *) , - var_id) - -let string_of_info ?with_rule:(with_rule=true) - ?with_rule_name:(with_rule_name=true) ?with_rule_id:(with_rule_id=true) ?with_loc:(with_loc=true) ?with_ast:(with_ast=true) ?kind:(kind="rule ") (label,pos,_direction,ast,id) = + | None -> + Exception.warn parameters error __POS__ Exit + ( "VAR " ^ Ckappa_sig.string_of_rule_id var_id, + Loc.dummy, + Public_data.Variable, + "", + var_id ) + | Some var -> + ( error, + ( fst var.Cckappa_sig.e_id_dot, + snd var.Cckappa_sig.e_id, + Public_data.Variable, + "" + (* TO DO: string for the ast representation (from var.Cckappa_sig.c_variable?) *), + var_id ) ) + +let string_of_info ?(with_rule = true) ?(with_rule_name = true) + ?(with_rule_id = true) ?(with_loc = true) ?(with_ast = true) + ?(kind = "rule ") (label, pos, _direction, ast, id) = let label = - if with_rule_name then label else "" + if with_rule_name then + label + else + "" in let pos = - if not with_loc || pos=Locality.dummy - then "" - else Locality.to_string pos + if (not with_loc) || pos = Loc.dummy then + "" + else + Loc.to_string pos in let ast = - if not with_ast then "" else ast + if not with_ast then + "" + else + ast in let id = - if not with_rule_id - then "" - else Ckappa_sig.string_of_rule_id id + if not with_rule_id then + "" + else + Ckappa_sig.string_of_rule_id id in let prefix = - if not with_rule then "" else kind + if not with_rule then + "" + else + kind in let s = match label, pos, ast, id with - | "","","",s - | "","",s,_ - | "",s,"",_ - | s,"",_,_ -> prefix^s - | "",s2,s1,_ - | s1,s2,_,_ -> prefix^s1^" ("^s2^")" + | "", "", "", s | "", "", s, _ | "", s, "", _ | s, "", _, _ -> prefix ^ s + | "", s2, s1, _ | s1, s2, _, _ -> prefix ^ s1 ^ " (" ^ s2 ^ ")" in s -let pos_of_info (_,info,_,_,_) = info +let pos_of_info (_, info, _, _, _) = info -let string_of_rule ?with_rule:(with_rule=true) - ?with_rule_name:(with_rule_name=true) ?with_rule_id:(with_rule_id=true) ?with_loc:(with_loc=true) ?with_ast:(with_ast=true) - parameters error compiled rule_id = +let string_of_rule ?(with_rule = true) ?(with_rule_name = true) + ?(with_rule_id = true) ?(with_loc = true) ?(with_ast = true) parameters + error compiled rule_id = let kind = - if with_rule then "rule " else "" - in - let error, info = - info_of_rule parameters error compiled rule_id + if with_rule then + "rule " + else + "" in - error, - string_of_info - ~with_rule_name ~with_rule_id ~with_loc ~with_ast ~kind info + let error, info = info_of_rule parameters error compiled rule_id in + ( error, + string_of_info ~with_rule_name ~with_rule_id ~with_loc ~with_ast ~kind info + ) let pos_of_rule parameters error _ compiled rule_id = - let error, info = - info_of_rule parameters error compiled rule_id - in - error, - pos_of_info info + let error, info = info_of_rule parameters error compiled rule_id in + error, pos_of_info info -let string_of_var ?with_rule:(with_rule=true) - ?with_rule_name:(with_rule_name=true) ?with_rule_id:(with_rule_id=true) ?with_loc:(with_loc=true) ?with_ast:(with_ast=true) parameters error handler compiled (rule_id: Ckappa_sig.c_rule_id) = +let string_of_var ?(with_rule = true) ?(with_rule_name = true) + ?(with_rule_id = true) ?(with_loc = true) ?(with_ast = true) parameters + error handler compiled (rule_id : Ckappa_sig.c_rule_id) = let kind = - if with_rule then "var " else "" + if with_rule then + "var " + else + "" in let error, info = - info_of_var - parameters error handler compiled (rule_id: Ckappa_sig.c_rule_id) + info_of_var parameters error handler compiled + (rule_id : Ckappa_sig.c_rule_id) in - error, - string_of_info - ~with_rule_name ~with_rule_id ~with_loc ~with_ast ~kind info + ( error, + string_of_info ~with_rule_name ~with_rule_id ~with_loc ~with_ast ~kind info + ) let pos_of_var parameters error handler compiled rule_id = - let error, info = - info_of_var parameters error handler compiled rule_id - in - error, - pos_of_info info + let error, info = info_of_var parameters error handler compiled rule_id in + error, pos_of_info info -let convert_id rule var parameters error handler compiled id = +let convert_id rule var parameters error handler compiled id = let int = Ckappa_sig.int_of_rule_id id in let nrules = nrules parameters error handler in - if int < nrules then - let error,(a,b,c,d,e) = info_of_rule parameters error compiled id in - error,Public_data.Rule (rule e b a d c) - - else - let error, (a,b,c,d,e) = info_of_var parameters error handler compiled id in - error,Public_data.Var (var e b a d c) + if int < nrules then ( + let error, (a, b, c, d, e) = info_of_rule parameters error compiled id in + error, Public_data.Rule (rule e b a d c) + ) else ( + let error, (a, b, c, d, e) = + info_of_var parameters error handler compiled id + in + error, Public_data.Var (var e b a d c) + ) let convert_id_short = convert_id @@ -456,82 +383,79 @@ let convert_id_short = let convert_id_refined = convert_id (fun a b d e c -> - { - Public_data.rule_id=Ckappa_sig.int_of_rule_id a ; - Public_data.rule_position=b; - Public_data.rule_direction=c; - Public_data.rule_label=d; - Public_data.rule_ast=e; - Public_data.rule_hidden=false - }) + { + Public_data.rule_id = Ckappa_sig.int_of_rule_id a; + Public_data.rule_position = b; + Public_data.rule_direction = c; + Public_data.rule_label = d; + Public_data.rule_ast = e; + Public_data.rule_hidden = false; + }) (fun a b d e _ -> - { - Public_data.var_id=Ckappa_sig.int_of_rule_id a ; - Public_data.var_position=b; - Public_data.var_label=d; - Public_data.var_ast=e - }) - -let string_of_rule_or_var - ?with_rule:(with_rule=true) - ?with_rule_name:(with_rule_name=true) ?with_rule_id:(with_rule_id=true) ?with_loc:(with_loc=true) ?with_ast:(with_ast=true) parameters error handler compiled (rule_id: Ckappa_sig.c_rule_id) = - let nrules = nrules parameters error handler in - if - Ckappa_sig.compare_rule_id rule_id (Ckappa_sig.rule_id_of_int nrules) < 0 - then - string_of_rule - ~with_rule ~with_rule_name ~with_rule_id ~with_loc ~with_ast - parameters error compiled rule_id - else - string_of_var - ~with_rule ~with_rule_name ~with_rule_id ~with_loc ~with_ast - parameters error handler compiled rule_id + { + Public_data.var_id = Ckappa_sig.int_of_rule_id a; + Public_data.var_position = b; + Public_data.var_label = d; + Public_data.var_ast = e; + }) + +let string_of_rule_or_var ?(with_rule = true) ?(with_rule_name = true) + ?(with_rule_id = true) ?(with_loc = true) ?(with_ast = true) parameters + error handler compiled (rule_id : Ckappa_sig.c_rule_id) = + let nrules = nrules parameters error handler in + if Ckappa_sig.compare_rule_id rule_id (Ckappa_sig.rule_id_of_int nrules) < 0 + then + string_of_rule ~with_rule ~with_rule_name ~with_rule_id ~with_loc ~with_ast + parameters error compiled rule_id + else + string_of_var ~with_rule ~with_rule_name ~with_rule_id ~with_loc ~with_ast + parameters error handler compiled rule_id (*mapping agent of type int to string*) -let string_of_agent parameter error handler_kappa (agent_type:Ckappa_sig.c_agent_name) = +let string_of_agent parameter error handler_kappa + (agent_type : Ckappa_sig.c_agent_name) = let agents_dic = handler_kappa.Cckappa_sig.agents_dic in (*get sites dictionary*) let error, output = - Ckappa_sig.Dictionary_of_agents.translate - parameter - error - agent_type + Ckappa_sig.Dictionary_of_agents.translate parameter error agent_type agents_dic in match output with | None -> Exception.warn parameter error __POS__ Exit "" | Some (agent_name, _, _) -> error, agent_name -let print_site parameter ?state ?add_parentheses:(add_parentheses=false) site = +let print_site parameter ?state ?(add_parentheses = false) site = let state = match state with | None -> - if add_parentheses then Some "" - else state + if add_parentheses then + Some "" + else + state | Some _ -> state in match site, state with | Ckappa_sig.Counter a, Some state -> - a^ - (Remanent_parameters.get_open_counterval parameter) ^ - (Remanent_parameters.get_counterval_symbol parameter) ^ - (state)^ - (Remanent_parameters.get_close_counterval parameter) + a + ^ Remanent_parameters.get_open_counterval parameter + ^ Remanent_parameters.get_counterval_symbol parameter + ^ state + ^ Remanent_parameters.get_close_counterval parameter | Ckappa_sig.Internal a, Some state -> a - ^ - (Remanent_parameters.get_open_internal_state parameter) ^ - (Remanent_parameters.get_internal_state_symbol parameter) ^ - (state)^ - (Remanent_parameters.get_close_internal_state parameter) - | Ckappa_sig.Binding a, Some state -> + ^ Remanent_parameters.get_open_internal_state parameter + ^ Remanent_parameters.get_internal_state_symbol parameter + ^ state + ^ Remanent_parameters.get_close_internal_state parameter + | Ckappa_sig.Binding a, Some state -> + a + ^ Remanent_parameters.get_open_binding_state parameter + ^ Remanent_parameters.get_bound_symbol parameter + ^ state + ^ Remanent_parameters.get_close_binding_state parameter + | (Ckappa_sig.Binding a | Ckappa_sig.Internal a | Ckappa_sig.Counter a), None + -> a - ^ - (Remanent_parameters.get_open_binding_state parameter) ^ - (Remanent_parameters.get_bound_symbol parameter)^ - (state)^ - (Remanent_parameters.get_close_binding_state parameter) - | (Ckappa_sig.Binding a | Ckappa_sig.Internal a | Ckappa_sig.Counter a), None -> a (*print function for contact map*) @@ -548,88 +472,80 @@ let print_state parameter error handler state = | Ckappa_sig.Internal a -> error, a | Ckappa_sig.Counter a -> error, string_of_int a | Ckappa_sig.Binding Ckappa_sig.C_Free -> - error, - Remanent_parameters.get_free_symbol parameter - | Ckappa_sig.Binding Ckappa_sig.C_Lnk_type (a, b) -> + error, Remanent_parameters.get_free_symbol parameter + | Ckappa_sig.Binding (Ckappa_sig.C_Lnk_type (a, b)) -> let error, s = translate_binding_type parameter error handler a b in - error, - s + error, s let print_state_fully_deciphered parameter error handler_kappa state = match state with | Ckappa_sig.Internal a -> - error, - (Remanent_parameters.get_open_internal_state parameter) ^ - (Remanent_parameters.get_internal_state_symbol parameter) ^ - a - ^ (Remanent_parameters.get_close_internal_state parameter) + ( error, + Remanent_parameters.get_open_internal_state parameter + ^ Remanent_parameters.get_internal_state_symbol parameter + ^ a + ^ Remanent_parameters.get_close_internal_state parameter ) | Ckappa_sig.Counter a -> - error, - (Remanent_parameters.get_open_counterval parameter)^ - (Remanent_parameters.get_counterval_symbol parameter) ^ - (string_of_int a)^ - (Remanent_parameters.get_close_counterval parameter) - + ( error, + Remanent_parameters.get_open_counterval parameter + ^ Remanent_parameters.get_counterval_symbol parameter + ^ string_of_int a + ^ Remanent_parameters.get_close_counterval parameter ) | Ckappa_sig.Binding Ckappa_sig.C_Free -> - error, - (Remanent_parameters.get_open_binding_state parameter) ^ - (Remanent_parameters.get_free_symbol parameter) ^ - (Remanent_parameters.get_close_binding_state parameter) - | Ckappa_sig.Binding Ckappa_sig.C_Lnk_type (agent_name, b) -> - let error, s = translate_binding_type parameter error - handler_kappa agent_name b + ( error, + Remanent_parameters.get_open_binding_state parameter + ^ Remanent_parameters.get_free_symbol parameter + ^ Remanent_parameters.get_close_binding_state parameter ) + | Ckappa_sig.Binding (Ckappa_sig.C_Lnk_type (agent_name, b)) -> + let error, s = + translate_binding_type parameter error handler_kappa agent_name b in - error, - (Remanent_parameters.get_open_binding_state parameter) ^ - s ^ - (Remanent_parameters.get_close_binding_state parameter) + ( error, + Remanent_parameters.get_open_binding_state parameter + ^ s + ^ Remanent_parameters.get_close_binding_state parameter ) -let string_of_state_gen print_state parameter error handler_kappa agent_name site_name state = +let string_of_state_gen print_state parameter error handler_kappa agent_name + site_name state = let error, b_counter = is_counter parameter error handler_kappa agent_name site_name in if b_counter then print_state parameter error handler_kappa (Ckappa_sig.Counter (Ckappa_sig.int_of_state_index state)) - else + else ( let error, state_dic = match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameter - error - (agent_name, site_name) + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameter error (agent_name, site_name) handler_kappa.Cckappa_sig.states_dic with | error, None -> Exception.warn parameter error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init()) + (Ckappa_sig.Dictionary_of_States.init ()) | error, Some i -> error, i in let error, value = match - Ckappa_sig.Dictionary_of_States.translate - parameter - error - state + Ckappa_sig.Dictionary_of_States.translate parameter error state state_dic with | error, None -> - Exception.warn parameter error __POS__ - Exit (Ckappa_sig.Internal "") + Exception.warn parameter error __POS__ Exit (Ckappa_sig.Internal "") | error, Some (value, _, _) -> error, value in print_state parameter error handler_kappa value + ) let string_of_state = string_of_state_gen print_state let string_of_state_fully_deciphered = string_of_state_gen print_state_fully_deciphered - -let string_of_site_aux - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler_kappa ?state agent_name (site_int: Ckappa_sig.c_site_name) = +let string_of_site_aux ?(ml_pos = None) ?(ka_pos = None) ?(message = "") + parameter error handler_kappa ?state agent_name + (site_int : Ckappa_sig.c_site_name) = let error', site_type = translate_site parameter error handler_kappa agent_name site_int in @@ -638,277 +554,256 @@ let string_of_site_aux | None -> error', None | Some a -> let error', s = - string_of_state - parameter error' handler_kappa agent_name site_int a - in error', Some s + string_of_state parameter error' handler_kappa agent_name site_int a + in + error', Some s in - check_pos parameter ka_pos ml_pos message error error', - site_type, - state + check_pos parameter ka_pos ml_pos message error error', site_type, state -let string_of_site parameter error handler_kappa - ?state ?add_parentheses:(add_parentheses=false) agent_type site_int = - let error, site_type,state = +let string_of_site parameter error handler_kappa ?state + ?(add_parentheses = false) agent_type site_int = + let error, site_type, state = string_of_site_aux parameter error handler_kappa ?state agent_type site_int in error, print_site parameter ?state ~add_parentheses site_type (*this function used in views_domain*) -let string_of_site_update_views parameter error handler_kappa agent_type site_int = +let string_of_site_update_views parameter error handler_kappa agent_type + site_int = let error, site_type, _ = string_of_site_aux parameter error handler_kappa agent_type site_int in let add_parentheses = true in error, print_site parameter ~add_parentheses site_type -let string_of_site_in_natural_language parameter error handler_kapp - agent_type (site_int: Ckappa_sig.c_site_name) = - let error, site_type,_ = - string_of_site_aux parameter error handler_kapp - agent_type site_int - in - match - site_type - with - | Ckappa_sig.Internal x -> error, ("the internal state of site "^ x) - | Ckappa_sig.Binding x -> error, ("the binding state of site "^ x) - | Ckappa_sig.Counter x -> error, ("the value of counter "^x) - -let string_of_site_in_file_name parameter error handler_kapp - agent_type (site_int: Ckappa_sig.c_site_name) = +let string_of_site_in_natural_language parameter error handler_kapp agent_type + (site_int : Ckappa_sig.c_site_name) = let error, site_type, _ = - string_of_site_aux parameter error handler_kapp - agent_type site_int - in - match - site_type - with - | Ckappa_sig.Internal x -> error, (x^"_") - | Ckappa_sig.Binding x -> error, (x^"^") - | Ckappa_sig.Counter x -> error, (x^"=") - -let string_of_site_contact_map - ?ml_pos:(ml_pos=None) ?ka_pos:(ka_pos=None) - ?message:(message="") - parameter error handler_kappa agent_name site_int = + string_of_site_aux parameter error handler_kapp agent_type site_int + in + match site_type with + | Ckappa_sig.Internal x -> error, "the internal state of site " ^ x + | Ckappa_sig.Binding x -> error, "the binding state of site " ^ x + | Ckappa_sig.Counter x -> error, "the value of counter " ^ x + +let string_of_site_in_file_name parameter error handler_kapp agent_type + (site_int : Ckappa_sig.c_site_name) = let error, site_type, _ = - string_of_site_aux - ~ml_pos ~ka_pos ~message - parameter error handler_kappa agent_name site_int + string_of_site_aux parameter error handler_kapp agent_type site_int in - error, (print_site_contact_map site_type) + match site_type with + | Ckappa_sig.Internal x -> error, x ^ "_" + | Ckappa_sig.Binding x -> error, x ^ "^" + | Ckappa_sig.Counter x -> error, x ^ "=" +let string_of_site_contact_map ?(ml_pos = None) ?(ka_pos = None) ?(message = "") + parameter error handler_kappa agent_name site_int = + let error, site_type, _ = + string_of_site_aux ~ml_pos ~ka_pos ~message parameter error handler_kappa + agent_name site_int + in + error, print_site_contact_map site_type let print_labels parameters error handler couple = - let _ = Quark_type.Labels.dump_couple parameters error handler couple - in error + let _ = Quark_type.Labels.dump_couple parameters error handler couple in + error -let get_label_of_rule_txt _parameters error rule = error, rule.Cckappa_sig.e_rule_label +let get_label_of_rule_txt _parameters error rule = + error, rule.Cckappa_sig.e_rule_label -let get_label_of_rule_dot _parameters error rule = error, rule.Cckappa_sig.e_rule_label_dot +let get_label_of_rule_dot _parameters error rule = + error, rule.Cckappa_sig.e_rule_label_dot let get_label_of_var_txt _parameters error rule = - error,fst rule.Cckappa_sig.e_id + error, fst rule.Cckappa_sig.e_id let get_label_of_var_dot _parameters error rule = - error,fst rule.Cckappa_sig.e_id_dot + error, fst rule.Cckappa_sig.e_id_dot let print_rule_txt parameters error rule_id m1 _m2 rule = - let m = "'"^ m1 ^"' " in - let error, _ = error, - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" - (if m = "" - then ("rule(" ^ (Ckappa_sig.string_of_rule_id rule_id) ^ "): ") - else ("rule(" ^ Ckappa_sig.string_of_rule_id rule_id) ^ "):"^ m) in + let m = "'" ^ m1 ^ "' " in + let error, _ = + ( error, + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (if m = "" then + "rule(" ^ Ckappa_sig.string_of_rule_id rule_id ^ "): " + else + ("rule(" ^ Ckappa_sig.string_of_rule_id rule_id) ^ "):" ^ m) ) + in let error = Print_ckappa.print_rule parameters error rule in error let print_var_txt parameters error var_id m1 _m2 var = - let m = "'"^m1^"' " in - let error,_ = - error, Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s" - (if m="" - then - ("var(" ^ (Ckappa_sig.string_of_rule_id var_id)^")") - else ("var(" ^ Ckappa_sig.string_of_rule_id var_id)^"):"^m) in - let error = Print_ckappa.print_alg parameters error var in + let m = "'" ^ m1 ^ "' " in + let error, _ = + ( error, + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (if m = "" then + "var(" ^ Ckappa_sig.string_of_rule_id var_id ^ ")" + else + ("var(" ^ Ckappa_sig.string_of_rule_id var_id) ^ "):" ^ m) ) + in + let error = Print_ckappa.print_alg parameters error var in error let print_rule_dot parameters error _rule_id m1 m2 rule = let error = - if m1<>"" && (not (Remanent_parameters.get_prompt_full_rule_def parameters)) - then - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" m1 in + if m1 <> "" && not (Remanent_parameters.get_prompt_full_rule_def parameters) + then ( + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" m1 + in error - else - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s:" m2 in + ) else ( + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s:" m2 + in let error = Print_ckappa.print_rule parameters error rule in error + ) in error -let print_var_dot parameters (error:Exception.method_handler) _var_id m1 m2 var = +let print_var_dot parameters (error : Exception.method_handler) _var_id m1 m2 + var = let error = - if m1<>"" && (not (Remanent_parameters.get_prompt_full_var_def parameters)) - then + if m1 <> "" && not (Remanent_parameters.get_prompt_full_var_def parameters) + then ( let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" m1 - in error - else + in + error + ) else ( let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s:" m2 in - let error = Print_ckappa.print_alg parameters error var - in error + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s:" m2 + in + let error = Print_ckappa.print_alg parameters error var in + error + ) in error -let print_rule_or_var parameters error handler compiled print_rule print_var get_label_of_rule get_label_of_var rule_id = +let print_rule_or_var parameters error handler compiled print_rule print_var + get_label_of_rule get_label_of_var rule_id = let rules = compiled.Cckappa_sig.rules in let vars = compiled.Cckappa_sig.variables in let nrules = nrules parameters error handler in if Ckappa_sig.compare_rule_id rule_id (Ckappa_sig.rule_id_of_int nrules) < 0 - then - begin - let error,rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - rule_id - rules + then ( + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error + rule_id rules + in + match rule with + | None -> + let a, b = Exception.warn parameters error __POS__ Exit () in + a, false, b + | Some rule -> + let error, label = get_label_of_rule parameters error rule in + let error, (m1, _) = + Misc_sa.unsome (error, label) (fun error -> + error, Loc.annot_with_dummy "") in - match rule - with - | None -> - let a,b = Exception.warn parameters error __POS__ Exit () in - a,false,b - | Some rule -> - let error,label = get_label_of_rule parameters error rule in - let error, (m1,_) = - Misc_sa.unsome (error,label) (fun error -> error,(Locality.dummy_annot "")) in - let m1 = - if m1 = "" - then m1 - else - match rule.Cckappa_sig.e_rule_initial_direction with - | Ckappa_sig.Direct -> m1 - | Ckappa_sig.Reverse -> Ast.flip_label m1 - in - let error = - print_rule - parameters - error - rule_id - m1 - (Ckappa_sig.string_of_rule_id rule_id) - rule.Cckappa_sig.e_rule_rule - in - error,true,() - end - else - begin - let var_id = Ckappa_sig.sub_rule_id rule_id nrules in - let error,var = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - var_id - vars + let m1 = + if m1 = "" then + m1 + else ( + match rule.Cckappa_sig.e_rule_initial_direction with + | Ckappa_sig.Direct -> m1 + | Ckappa_sig.Reverse -> Ast.flip_label m1 + ) in - match var - with - | None -> - let a,b = Exception.warn parameters error __POS__ Exit () - in a,false,b - | Some var -> - let b = var.Cckappa_sig.c_variable in - let error,m1 = get_label_of_var parameters error var in - let m2 = Ckappa_sig.string_of_rule_id var_id in - let error = - print_var parameters error var_id m1 m2 b - in error,true,() - end + let error = + print_rule parameters error rule_id m1 + (Ckappa_sig.string_of_rule_id rule_id) + rule.Cckappa_sig.e_rule_rule + in + error, true, () + ) else ( + let var_id = Ckappa_sig.sub_rule_id rule_id nrules in + let error, var = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error + var_id vars + in + match var with + | None -> + let a, b = Exception.warn parameters error __POS__ Exit () in + a, false, b + | Some var -> + let b = var.Cckappa_sig.c_variable in + let error, m1 = get_label_of_var parameters error var in + let m2 = Ckappa_sig.string_of_rule_id var_id in + let error = print_var parameters error var_id m1 m2 b in + error, true, () + ) let has_a_binding_state parameter error kappa_handler agent_type site = - let error,site = + let error, site = translate_site parameter error kappa_handler agent_type site in match site with | Ckappa_sig.Internal s | Ckappa_sig.Counter s -> let new_site = Ckappa_sig.Binding s in let error, dic_opt = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameter error agent_type kappa_handler.Cckappa_sig.sites + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameter error + agent_type kappa_handler.Cckappa_sig.sites in - begin - match dic_opt with - | None -> - Exception.warn parameter error __POS__ Exit false - | Some dic -> - Ckappa_sig.Dictionary_of_sites.member - parameter error new_site dic - end - | Ckappa_sig.Binding _ -> - Exception.warn parameter error __POS__ Exit false - -let id_of_binding_type - parameter error handler_kappa - agent_type site agent_type' site' = - let state = Ckappa_sig.C_Lnk_type (agent_type',site') in + (match dic_opt with + | None -> Exception.warn parameter error __POS__ Exit false + | Some dic -> + Ckappa_sig.Dictionary_of_sites.member parameter error new_site dic) + | Ckappa_sig.Binding _ -> Exception.warn parameter error __POS__ Exit false + +let id_of_binding_type parameter error handler_kappa agent_type site agent_type' + site' = + let state = Ckappa_sig.C_Lnk_type (agent_type', site') in let error, state_dic = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameter error - (agent_type,site) - handler_kappa.Cckappa_sig.states_dic + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameter error (agent_type, site) handler_kappa.Cckappa_sig.states_dic in match state_dic with | None -> - Exception.warn - parameter error __POS__ - Exit Ckappa_sig.dummy_state_index + Exception.warn parameter error __POS__ Exit Ckappa_sig.dummy_state_index | Some state_dic -> - begin - let error, bool = - Ckappa_sig.Dictionary_of_States.member - parameter error - (Ckappa_sig.Binding state) - state_dic - in - if not bool then - Exception.warn - parameter error __POS__ - ~message:("agent "^(string_of_int (Ckappa_sig.int_of_agent_name agent_type))^" site"^ - (string_of_int (Ckappa_sig.int_of_site_name site))^"agent "^(string_of_int (Ckappa_sig.int_of_agent_name agent_type'))^" site"^ - (string_of_int (Ckappa_sig.int_of_site_name site'))) - Exit Ckappa_sig.dummy_state_index - else - match - Ckappa_sig.Dictionary_of_States.allocate_bool - parameter error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Binding state) - () - Misc_sa.const_unit - state_dic - with - | error, (_bool, None) -> - Exception.warn - parameter error __POS__ - Exit Ckappa_sig.dummy_state_index - | error, (_bool, (Some (a,_,_,_))) -> - error, a - end + let error, bool = + Ckappa_sig.Dictionary_of_States.member parameter error + (Ckappa_sig.Binding state) state_dic + in + if not bool then + Exception.warn parameter error __POS__ + ~message: + ("agent " + ^ string_of_int (Ckappa_sig.int_of_agent_name agent_type) + ^ " site" + ^ string_of_int (Ckappa_sig.int_of_site_name site) + ^ "agent " + ^ string_of_int (Ckappa_sig.int_of_agent_name agent_type') + ^ " site" + ^ string_of_int (Ckappa_sig.int_of_site_name site')) + Exit Ckappa_sig.dummy_state_index + else ( + match + Ckappa_sig.Dictionary_of_States.allocate_bool parameter error + Ckappa_sig.compare_unit_state_index (Ckappa_sig.Binding state) () + Misc_sa.const_unit state_dic + with + | error, (_bool, None) -> + Exception.warn parameter error __POS__ Exit Ckappa_sig.dummy_state_index + | error, (_bool, Some (a, _, _, _)) -> error, a + ) let state_list parameter handler error agent_type site_type = let error, n = - last_state_of_site - parameter error handler agent_type site_type + last_state_of_site parameter error handler agent_type site_type in let rec aux k l = - if Ckappa_sig.compare_state_index Ckappa_sig.dummy_state_index k > 0 - then l + if Ckappa_sig.compare_state_index Ckappa_sig.dummy_state_index k > 0 then + l else - aux (Ckappa_sig.pred_state_index k) (k::l) + aux (Ckappa_sig.pred_state_index k) (k :: l) in error, aux n [] diff --git a/core/KaSa_rep/frontend/handler.mli b/core/KaSa_rep/frontend/handler.mli index 94964641c4..06716505e6 100644 --- a/core/KaSa_rep/frontend/handler.mli +++ b/core/KaSa_rep/frontend/handler.mli @@ -1,28 +1,32 @@ -val local_trace:bool +val local_trace : bool -val get_label_of_var_txt: - Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> +val get_label_of_var_txt : + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> Cckappa_sig.enriched_variable -> Exception_without_parameter.method_handler * string -val get_label_of_var_dot: - Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> +val get_label_of_var_dot : + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> Cckappa_sig.enriched_variable -> Exception_without_parameter.method_handler * string -val get_label_of_rule_txt: - Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> +val get_label_of_rule_txt : + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> Cckappa_sig.enriched_rule -> - Exception_without_parameter.method_handler * (string * Locality.t) option + Exception_without_parameter.method_handler * (string * Loc.t) option -val get_label_of_rule_dot: - Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> +val get_label_of_rule_dot : + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> Cckappa_sig.enriched_rule -> - Exception_without_parameter.method_handler * (string * Locality.t) option + Exception_without_parameter.method_handler * (string * Loc.t) option -val print_site_contact_map: ('a, 'a, 'a) Ckappa_sig.site_type -> 'a +val print_site_contact_map : ('a, 'a, 'a) Ckappa_sig.site_type -> 'a -val print_rule_txt: +val print_rule_txt : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.c_rule_id -> @@ -31,7 +35,7 @@ val print_rule_txt: Ckappa_sig.mixture Ckappa_sig.rule -> Exception_without_parameter.method_handler -val print_var_txt: +val print_var_txt : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.c_rule_id -> @@ -40,7 +44,7 @@ val print_var_txt: (Ckappa_sig.mixture, string) Alg_expr.e -> Exception_without_parameter.method_handler -val print_rule_dot: +val print_rule_dot : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> 'a -> @@ -49,7 +53,7 @@ val print_rule_dot: Ckappa_sig.mixture Ckappa_sig.rule -> Exception_without_parameter.method_handler -val print_var_dot: +val print_var_dot : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> 'a -> @@ -58,35 +62,37 @@ val print_var_dot: (Ckappa_sig.mixture, string) Alg_expr.e -> Exception_without_parameter.method_handler - -val print_rule_or_var: +val print_rule_or_var : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> (Remanent_parameters_sig.parameters -> - 'a -> - Ckappa_sig.c_rule_id -> - string -> - string -> - Ckappa_sig.mixture Ckappa_sig.rule -> - Exception_without_parameter.method_handler) -> + 'a -> + Ckappa_sig.c_rule_id -> + string -> + string -> + Ckappa_sig.mixture Ckappa_sig.rule -> + Exception_without_parameter.method_handler) -> (Remanent_parameters_sig.parameters -> - 'b -> - Ckappa_sig.c_rule_id -> - 'c -> - string -> - (Ckappa_sig.mixture, string) Alg_expr.e -> - Exception_without_parameter.method_handler) -> + 'b -> + Ckappa_sig.c_rule_id -> + 'c -> + string -> + (Ckappa_sig.mixture, string) Alg_expr.e -> + Exception_without_parameter.method_handler) -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - Cckappa_sig.enriched_rule -> 'a * string Locality.annot option) -> + Exception_without_parameter.method_handler -> + Cckappa_sig.enriched_rule -> + 'a * string Loc.annoted option) -> (Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - Cckappa_sig.enriched_variable -> 'b * 'c) -> + Exception_without_parameter.method_handler -> + Cckappa_sig.enriched_variable -> + 'b * 'c) -> Ckappa_sig.c_rule_id -> Exception_without_parameter.method_handler * bool * unit -val has_a_binding_state: + +val has_a_binding_state : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -94,7 +100,7 @@ val has_a_binding_state: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool -val id_of_binding_type: +val id_of_binding_type : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -104,18 +110,17 @@ val id_of_binding_type: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * Ckappa_sig.c_state -val state_list: +val state_list : Remanent_parameters_sig.parameters -> Cckappa_sig.kappa_handler -> Exception_without_parameter.method_handler -> Quark_type.agent_quark -> Ckappa_sig.c_site_name -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_state list + Exception_without_parameter.method_handler * Ckappa_sig.c_state list -val last_site_of_agent: +val last_site_of_agent : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -123,9 +128,9 @@ val last_site_of_agent: Quark_type.agent_quark -> Exception_without_parameter.method_handler * Ckappa_sig.c_site_name -val last_state_of_site: +val last_state_of_site : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -134,9 +139,9 @@ val last_state_of_site: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * Ckappa_sig.c_state -val translate_agent: +val translate_agent : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t -> + ?ka_pos:Loc.t -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -144,16 +149,16 @@ val translate_agent: Quark_type.agent_quark -> Exception_without_parameter.method_handler * string -val string_of_agent: +val string_of_agent : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Quark_type.agent_quark -> Exception_without_parameter.method_handler * string -val is_counter: +val is_counter : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -162,10 +167,9 @@ val is_counter: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool - -val is_internal_site: +val is_internal_site : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -174,9 +178,9 @@ val is_internal_site: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool -val is_binding_site: +val is_binding_site : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -185,14 +189,14 @@ val is_binding_site: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool -val print_labels: +val print_labels : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Quark_type.Labels.label_set_couple -> Exception_without_parameter.method_handler -val string_of_site: +val string_of_site : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -202,7 +206,7 @@ val string_of_site: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * string -val string_of_site_in_file_name: +val string_of_site_in_file_name : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -210,7 +214,7 @@ val string_of_site_in_file_name: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * string -val string_of_site_update_views: +val string_of_site_update_views : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -218,9 +222,9 @@ val string_of_site_update_views: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * string -val string_of_site_contact_map: +val string_of_site_contact_map : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -229,7 +233,7 @@ val string_of_site_contact_map: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * string -val string_of_site_in_natural_language: +val string_of_site_in_natural_language : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -237,7 +241,7 @@ val string_of_site_in_natural_language: Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * string -val string_of_state: +val string_of_state : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -246,7 +250,7 @@ val string_of_state: Ckappa_sig.c_state -> Exception_without_parameter.method_handler * string -val string_of_state_fully_deciphered: +val string_of_state_fully_deciphered : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -255,7 +259,7 @@ val string_of_state_fully_deciphered: Ckappa_sig.c_state -> Exception_without_parameter.method_handler * string -val string_of_rule: +val string_of_rule : ?with_rule:bool -> ?with_rule_name:bool -> ?with_rule_id:bool -> @@ -267,8 +271,7 @@ val string_of_rule: Ckappa_sig.c_rule_id -> Exception_without_parameter.method_handler * string - -val string_of_rule_or_var: +val string_of_rule_or_var : ?with_rule:bool -> ?with_rule_name:bool -> ?with_rule_id:bool -> @@ -281,93 +284,93 @@ val string_of_rule_or_var: Ckappa_sig.c_rule_id -> Exception_without_parameter.method_handler * string - -val convert_id_refined: +val convert_id_refined : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> Ckappa_sig.c_rule_id -> - Exception_without_parameter.method_handler * - (Public_data.rule, Public_data.var) Public_data.influence_node + Exception_without_parameter.method_handler + * (Public_data.rule, Public_data.var) Public_data.influence_node -val convert_id_short: +val convert_id_short : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> Ckappa_sig.c_rule_id -> - Exception_without_parameter.method_handler * - (int, int) Public_data.influence_node + Exception_without_parameter.method_handler + * (int, int) Public_data.influence_node -val pos_of_var: +val pos_of_var : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> Ckappa_sig.c_rule_id -> - Exception_without_parameter.method_handler * Locality.t + Exception_without_parameter.method_handler * Loc.t -val pos_of_rule: +val pos_of_rule : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> Ckappa_sig.c_rule_id -> - Exception_without_parameter.method_handler * Locality.t + Exception_without_parameter.method_handler * Loc.t -val hide: Public_data.rule -> Public_data.rule +val hide : Public_data.rule -> Public_data.rule -val info_of_agent: +val info_of_agent : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> Quark_type.agent_quark -> - Exception_without_parameter.method_handler * - (string * Locality.t list * Quark_type.agent_quark) + Exception_without_parameter.method_handler + * (string * Loc.t list * Quark_type.agent_quark) -val info_of_rule: +val info_of_rule : Remanent_parameters_sig.parameters -> ?with_rates:bool -> ?original:bool -> Exception_without_parameter.method_handler -> Cckappa_sig.compil -> Ckappa_sig.c_rule_id -> - Exception_without_parameter.method_handler * - (string * Locality.t * Public_data.rule_direction * string * - Ckappa_sig.c_rule_id) - + Exception_without_parameter.method_handler + * (string + * Loc.t + * Public_data.rule_direction + * string + * Ckappa_sig.c_rule_id) -val has_no_label: +val has_no_label : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.compil -> Ckappa_sig.c_rule_id -> Exception_without_parameter.method_handler * bool -val is_reverse: +val is_reverse : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.compil -> Ckappa_sig.c_rule_id -> Exception_without_parameter.method_handler * bool -val complementary_interface: +val complementary_interface : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Quark_type.agent_quark -> Ckappa_sig.c_site_name list -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_site_name list + Exception_without_parameter.method_handler * Ckappa_sig.c_site_name list -val dual: +val dual : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -375,12 +378,13 @@ val dual: Quark_type.agent_quark -> Ckappa_sig.c_site_name -> Ckappa_sig.c_state -> - Exception_without_parameter.method_handler * - (Quark_type.agent_quark * Ckappa_sig.c_site_name * Ckappa_sig.c_state) option + Exception_without_parameter.method_handler + * (Quark_type.agent_quark * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + option -val translate_state: +val translate_state : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> @@ -388,32 +392,35 @@ val translate_state: Quark_type.agent_quark -> Ckappa_sig.c_site_name -> Ckappa_sig.c_state -> - Exception_without_parameter.method_handler * - Ckappa_sig.Dictionary_of_States.value + Exception_without_parameter.method_handler + * Ckappa_sig.Dictionary_of_States.value -val translate_site: +val translate_site : ?ml_pos:(string * int * int * int) option -> - ?ka_pos:Locality.t option -> + ?ka_pos:Loc.t option -> ?message:string -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Quark_type.agent_quark -> Ckappa_sig.c_site_name -> - Exception_without_parameter.method_handler * - Ckappa_sig.Dictionary_of_sites.value + Exception_without_parameter.method_handler + * Ckappa_sig.Dictionary_of_sites.value -val nagents: +val nagents : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Cckappa_sig.kappa_handler -> Quark_type.agent_quark + Cckappa_sig.kappa_handler -> + Quark_type.agent_quark -val nvars: +val nvars : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Cckappa_sig.kappa_handler -> int + Cckappa_sig.kappa_handler -> + int -val nrules: +val nrules : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Cckappa_sig.kappa_handler -> int + Cckappa_sig.kappa_handler -> + int diff --git a/core/KaSa_rep/frontend/influence_labels.ml b/core/KaSa_rep/frontend/influence_labels.ml index 03c7be0665..5dbc79daa3 100644 --- a/core/KaSa_rep/frontend/influence_labels.ml +++ b/core/KaSa_rep/frontend/influence_labels.ml @@ -12,352 +12,431 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Labels = -sig +module type Labels = sig type label - val label_of_int: Remanent_parameters_sig.parameters -> Exception.method_handler -> int -> Exception.method_handler * label - val to_string:Remanent_parameters_sig.parameters -> Exception.method_handler -> label -> Exception.method_handler * string - val dump: Remanent_parameters_sig.parameters -> Exception.method_handler -> label -> Exception.method_handler - val print: Format.formatter -> label -> unit - val int_of_label: label -> int + val label_of_int : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + int -> + Exception.method_handler * label + + val to_string : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + label -> + Exception.method_handler * string + + val dump : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + label -> + Exception.method_handler + + val print : Format.formatter -> label -> unit + val int_of_label : label -> int end -module Int_labels = - (struct - type label = int +module Int_labels : Labels with type label = int = struct + type label = int - let label_of_int _ error i = error,i + let label_of_int _ error i = error, i - let to_string _parameter error i = - if i < 0 then - error,(string_of_int (-i-1))^"*" - else - error,string_of_int i + let to_string _parameter error i = + if i < 0 then + error, string_of_int (-i - 1) ^ "*" + else + error, string_of_int i - let print f i = - if i < 0 then Format.fprintf f "%i*" (-i-1) - else Format.pp_print_int f i + let print f i = + if i < 0 then + Format.fprintf f "%i*" (-i - 1) + else + Format.pp_print_int f i - let dump h error i = - let error,s = to_string h error i in - let _ = Loggers.fprintf (Remanent_parameters.get_logger h) "%s" s in - error + let dump h error i = + let error, s = to_string h error i in + let _ = Loggers.fprintf (Remanent_parameters.get_logger h) "%s" s in + error - let int_of_label i = i - - end:Labels with type label=int) + let int_of_label i = i +end -module type Label_handler = -sig +module type Label_handler = sig type label type label_set type label_set_couple - val label_of_int: Remanent_parameters_sig.parameters -> Exception.method_handler -> int -> Exception.method_handler * label - val member: label -> label_set -> bool - val empty: label_set - val empty_couple: label_set_couple - val is_empty_couple: label_set_couple -> bool - val add_set: label -> label_set -> label_set - val remove_set: label -> label_set -> label_set - val add_couple: Remanent_parameters_sig.parameters -> Exception.method_handler -> bool -> label_set -> label_set -> label_set_couple -> Exception.method_handler * label_set_couple - val dump: Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> label_set -> Exception.method_handler - val dump_couple: Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler ->label_set_couple -> Exception.method_handler - val filter_couple: Remanent_parameters_sig.parameters -> - 'a -> Cckappa_sig.kappa_handler -> ('a ->label -> label -> 'a * bool) -> label_set_couple -> 'a * label_set_couple - val to_string : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler ->label_set -> Exception.method_handler * string list - val to_string_couple : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler ->label_set_couple -> Exception.method_handler * string list - val convert_label_set_couple : label_set_couple -> (int * int) list + val label_of_int : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + int -> + Exception.method_handler * label + + val member : label -> label_set -> bool + val empty : label_set + val empty_couple : label_set_couple + val is_empty_couple : label_set_couple -> bool + val add_set : label -> label_set -> label_set + val remove_set : label -> label_set -> label_set + + val add_couple : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + bool -> + label_set -> + label_set -> + label_set_couple -> + Exception.method_handler * label_set_couple + + val dump : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set -> + Exception.method_handler + + val dump_couple : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set_couple -> + Exception.method_handler + + val filter_couple : + Remanent_parameters_sig.parameters -> + 'a -> + Cckappa_sig.kappa_handler -> + ('a -> label -> label -> 'a * bool) -> + label_set_couple -> + 'a * label_set_couple + + val to_string : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set -> + Exception.method_handler * string list + + val to_string_couple : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set_couple -> + Exception.method_handler * string list + val convert_label_set_couple : label_set_couple -> (int * int) list end -module Empty = - (struct - type label = unit - type label_set = unit - type label_set_couple = unit - - let label_of_int _handler error _ = error,() - let empty = () - let empty_couple = () - let member _label _labelset = false - let is_empty_couple _ = false - let add_set _ _ = () - let remove_set _ _ = () - let add_couple _ error _ _ _ _ = error,() - let dump _ error _ _ = error - let to_string _ error _ _ = error,[] - let dump_couple _ error _ _ = error - let filter_couple _ error _ _ a = error,a - let to_string_couple _ error _ _ = error,[] - let convert_label_set_couple _ = [0,0] - end:Label_handler with type label=unit) +module Empty : Label_handler with type label = unit = struct + type label = unit + type label_set = unit + type label_set_couple = unit + + let label_of_int _handler error _ = error, () + let empty = () + let empty_couple = () + let member _label _labelset = false + let is_empty_couple _ = false + let add_set _ _ = () + let remove_set _ _ = () + let add_couple _ error _ _ _ _ = error, () + let dump _ error _ _ = error + let to_string _ error _ _ = error, [] + let dump_couple _ error _ _ = error + let filter_couple _ error _ _ a = error, a + let to_string_couple _ error _ _ = error, [] + let convert_label_set_couple _ = [ 0, 0 ] +end module Extensive = - (functor (L:Labels) -> - (struct - type label = L.label - module LSetMap = - SetMap.Make (struct type t=label let compare = compare let print = L.print end) - module Set = LSetMap.Set - type label_set = Set.t - module Pair_Set = - SetMap.Make - (struct type t=label*label - let compare = compare - let print f (a,b) = - Format.fprintf f "(%a, %a)" L.print a L.print b end) - type label_set_couple = Pair_Set.Set.t - - let label_of_int = L.label_of_int - let empty = Set.empty - let member = Set.mem - let empty_couple = Pair_Set.Set.empty - let is_empty_couple = Pair_Set.Set.is_empty - let add_set = Set.add - let remove_set = Set.remove - let add_couple _remanent error bool a b sol = - Set.fold - (fun a (error,sol) -> - Set.fold - (fun b (error,sol) -> - if not bool && a=b - then - error,sol - else - error,Pair_Set.Set.add (a,b) sol - ) - b - (error,sol) - ) - a - (error,sol) - - - let dump parameter error _handler a = - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameter) "[" in - let _,error = - Set.fold - (fun a (bool,error) -> - let error,a' = L.to_string parameter error a in - let _ = - if bool - then - Loggers.fprintf (Remanent_parameters.get_logger parameter) ";%s" a' - else - Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" a' - in - true,error - ) - a - (false,error) - in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameter) "]" in - error - - let to_string parameter error _handler a = - let sol = ["["] in - let _,sol,error = - Set.fold - (fun a (bool,sol,error) -> - let error,a' = L.to_string parameter error a in - let _ = - if bool - then - (";"^a')::sol - else - a'::sol - in true,sol,error) - a - (false,sol,error) - in - let sol = List.rev ("]"::sol) in - error,sol - - let dump_couple parameter error _handler a = - let _,error = - Pair_Set.Set.fold - (fun (a,b) (bool,error) -> - let error,a' = L.to_string parameter error a in - let error,b' = L.to_string parameter error b in - let _ = - if bool - then - Loggers.fprintf (Remanent_parameters.get_logger parameter) ";[%s->%s]" a' b' - else - Loggers.fprintf (Remanent_parameters.get_logger parameter) "[%s->%s]" a' b' - in - true,error - ) - a - (false,error) - in - error - - let filter_couple _parameter error _handler f a = - Pair_Set.Set.fold - (fun (a,b) (error,set')-> - let error,bool = f error a b in - error,if bool - then Pair_Set.Set.add (a,b) set' - else set') - a - (error,Pair_Set.Set.empty) - - let to_string_couple parameter error _handler a = - let sol = [] in - let _,sol,error = - Pair_Set.Set.fold - (fun (a,b) (bool,sol,error) -> - let error,a' = L.to_string parameter error a in - let error,b' = L.to_string parameter error b in - let _ = - if bool - then - (";["^a'^"->"^b'^"]")::sol - else - ("["^a'^"->"^b'^"]")::sol - in true,sol,error) - a - (false,sol,error) - in - let sol = List.rev sol in - error,sol - - let convert_label_set_couple set = - Pair_Set.Set.fold - (fun (a,b) list -> - (L.int_of_label a,L.int_of_label b)::list) - set - [] - - end:Label_handler with type label = L.label)) +functor + (L : Labels) + -> + ( + struct + type label = L.label + + module LSetMap = SetMap.Make (struct + type t = label + + let compare = compare + let print = L.print + end) + + module Set = LSetMap.Set + + type label_set = Set.t + + module Pair_Set = SetMap.Make (struct + type t = label * label + + let compare = compare + let print f (a, b) = Format.fprintf f "(%a, %a)" L.print a L.print b + end) + + type label_set_couple = Pair_Set.Set.t + + let label_of_int = L.label_of_int + let empty = Set.empty + let member = Set.mem + let empty_couple = Pair_Set.Set.empty + let is_empty_couple = Pair_Set.Set.is_empty + let add_set = Set.add + let remove_set = Set.remove + + let add_couple _remanent error bool a b sol = + Set.fold + (fun a (error, sol) -> + Set.fold + (fun b (error, sol) -> + if (not bool) && a = b then + error, sol + else + error, Pair_Set.Set.add (a, b) sol) + b (error, sol)) + a (error, sol) + + let dump parameter error _handler a = + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "[" + in + let _, error = + Set.fold + (fun a (bool, error) -> + let error, a' = L.to_string parameter error a in + let _ = + if bool then + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + ";%s" a' + else + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s" a' + in + true, error) + a (false, error) + in + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "]" + in + error + + let to_string parameter error _handler a = + let sol = [ "[" ] in + let _, sol, error = + Set.fold + (fun a (bool, sol, error) -> + let error, a' = L.to_string parameter error a in + let _ = + if bool then + (";" ^ a') :: sol + else + a' :: sol + in + true, sol, error) + a (false, sol, error) + in + let sol = List.rev ("]" :: sol) in + error, sol + + let dump_couple parameter error _handler a = + let _, error = + Pair_Set.Set.fold + (fun (a, b) (bool, error) -> + let error, a' = L.to_string parameter error a in + let error, b' = L.to_string parameter error b in + let _ = + if bool then + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + ";[%s->%s]" a' b' + else + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "[%s->%s]" a' b' + in + true, error) + a (false, error) + in + error + + let filter_couple _parameter error _handler f a = + Pair_Set.Set.fold + (fun (a, b) (error, set') -> + let error, bool = f error a b in + ( error, + if bool then + Pair_Set.Set.add (a, b) set' + else + set' )) + a + (error, Pair_Set.Set.empty) + + let to_string_couple parameter error _handler a = + let sol = [] in + let _, sol, error = + Pair_Set.Set.fold + (fun (a, b) (bool, sol, error) -> + let error, a' = L.to_string parameter error a in + let error, b' = L.to_string parameter error b in + let _ = + if bool then + (";[" ^ a' ^ "->" ^ b' ^ "]") :: sol + else + ("[" ^ a' ^ "->" ^ b' ^ "]") :: sol + in + true, sol, error) + a (false, sol, error) + in + let sol = List.rev sol in + error, sol + + let convert_label_set_couple set = + Pair_Set.Set.fold + (fun (a, b) list -> (L.int_of_label a, L.int_of_label b) :: list) + set [] + end : + Label_handler with type label = L.label) module Implicit = - (functor (L:Labels) -> - (struct - type label = L.label - module LSetMap = - SetMap.Make - (struct type t=label let compare = compare let print = L.print end) - module Set = LSetMap.Set - type label_set = Set.t - type label_set_couple = (label_set * label_set) list - let member = Set.mem - let label_of_int = L.label_of_int - let empty = Set.empty - let empty_couple = [] - let is_empty_couple x = x=[] - let add_set = Set.add - let remove_set = Set.remove - let add_couple _remanent error _bool a b sol = error,(a,b)::sol - - let dump parameter error _handler a = - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameter) "[" in - let error, _ = - Set.fold - (fun x (error, bool) -> - let error,x' = L.to_string parameter error x in - let _ = - if bool - then - Loggers.fprintf (Remanent_parameters.get_logger parameter) ";%s" x' - else - Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" x' - in error, true) - a - (error, false) - in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameter) "]" in - error - - let to_string parameter error _handler a = - let sol = [] in - let _,error, sol = - Set.fold - (fun x (bool,error, sol) -> - let error,x' = L.to_string parameter error x in - let sol = - if bool - then - (";"^x')::sol - else - x'::sol - in true, error, sol) - a - (false, error, sol) - in - let sol = List.rev (sol) in - error,sol - - let dump_couple parameter error _handler a = - let error, _ = - List.fold_left - (fun (error, bool) (a,b) -> - Set.fold - (fun x (error, bool) -> - let error,x' = L.to_string parameter error x in - Set.fold - (fun y (error, bool) -> - let error,y' = L.to_string parameter error y in - let _ = - if bool - then - Loggers.fprintf (Remanent_parameters.get_logger parameter) ";[%s->%s]" x' y' - else - Loggers.fprintf (Remanent_parameters.get_logger parameter) "[%s->%s]" x' y' - in error, true) - b - (error, bool)) - a - (error, bool)) - (error, false) - a - in - error - - let filter_couple _parameter error _handler _f list = error,list (* to do *) - - let to_string_couple parameter error _handler a = - let sol = ["["] in - let _,error, sol = - List.fold_left - (fun (bool,error, sol) (a,b) -> - Set.fold - (fun x (bool, error, sol) -> - let error,x' = L.to_string parameter error x in - Set.fold - (fun y (bool, error, sol) -> - let error,y' = L.to_string parameter error y in - let sol = - if bool - then - (";["^x'^"->"^y'^"]")::sol - else - ("["^x'^"->"^y'^"]")::sol - in true, error, sol) - a - (bool, error, sol)) - b - (bool, error, sol)) - (false, error, sol) - a - in - let sol = List.rev ("]"::sol) in - error, sol - - let convert_label_set_couple set = - List.fold_left - (fun list (seta,setb) -> +functor + (L : Labels) + -> + ( + struct + type label = L.label + + module LSetMap = SetMap.Make (struct + type t = label + + let compare = compare + let print = L.print + end) + + module Set = LSetMap.Set + + type label_set = Set.t + type label_set_couple = (label_set * label_set) list + + let member = Set.mem + let label_of_int = L.label_of_int + let empty = Set.empty + let empty_couple = [] + let is_empty_couple x = x = [] + let add_set = Set.add + let remove_set = Set.remove + let add_couple _remanent error _bool a b sol = error, (a, b) :: sol + + let dump parameter error _handler a = + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "[" + in + let error, _ = + Set.fold + (fun x (error, bool) -> + let error, x' = L.to_string parameter error x in + let _ = + if bool then + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + ";%s" x' + else + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s" x' + in + error, true) + a (error, false) + in + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "]" + in + error + + let to_string parameter error _handler a = + let sol = [] in + let _, error, sol = + Set.fold + (fun x (bool, error, sol) -> + let error, x' = L.to_string parameter error x in + let sol = + if bool then + (";" ^ x') :: sol + else + x' :: sol + in + true, error, sol) + a (false, error, sol) + in + let sol = List.rev sol in + error, sol + + let dump_couple parameter error _handler a = + let error, _ = + List.fold_left + (fun (error, bool) (a, b) -> Set.fold - (fun a list -> - Set.fold - (fun b list-> - (L.int_of_label a,L.int_of_label b)::list) - setb list) - seta list) - [] - set - - end:Label_handler with type label = L.label)) + (fun x (error, bool) -> + let error, x' = L.to_string parameter error x in + Set.fold + (fun y (error, bool) -> + let error, y' = L.to_string parameter error y in + let _ = + if bool then + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + ";[%s->%s]" x' y' + else + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "[%s->%s]" x' y' + in + error, true) + b (error, bool)) + a (error, bool)) + (error, false) a + in + error + + let filter_couple _parameter error _handler _f list = + error, list (* to do *) + + let to_string_couple parameter error _handler a = + let sol = [ "[" ] in + let _, error, sol = + List.fold_left + (fun (bool, error, sol) (a, b) -> + Set.fold + (fun x (bool, error, sol) -> + let error, x' = L.to_string parameter error x in + Set.fold + (fun y (bool, error, sol) -> + let error, y' = L.to_string parameter error y in + let sol = + if bool then + (";[" ^ x' ^ "->" ^ y' ^ "]") :: sol + else + ("[" ^ x' ^ "->" ^ y' ^ "]") :: sol + in + true, error, sol) + a (bool, error, sol)) + b (bool, error, sol)) + (false, error, sol) a + in + let sol = List.rev ("]" :: sol) in + error, sol + + let convert_label_set_couple set = + List.fold_left + (fun list (seta, setb) -> + Set.fold + (fun a list -> + Set.fold + (fun b list -> (L.int_of_label a, L.int_of_label b) :: list) + setb list) + seta list) + [] set + end : + Label_handler with type label = L.label) diff --git a/core/KaSa_rep/frontend/influence_labels.mli b/core/KaSa_rep/frontend/influence_labels.mli index 29d0d09f6f..0e6a7256ba 100644 --- a/core/KaSa_rep/frontend/influence_labels.mli +++ b/core/KaSa_rep/frontend/influence_labels.mli @@ -1,39 +1,100 @@ -module type Label_handler = -sig +module type Label_handler = sig type label type label_set type label_set_couple - val label_of_int: Remanent_parameters_sig.parameters -> Exception.method_handler -> int -> Exception.method_handler * label - val member: label -> label_set -> bool - val empty: label_set - val empty_couple: label_set_couple - val is_empty_couple: label_set_couple -> bool - val add_set: label -> label_set -> label_set - val remove_set: label -> label_set -> label_set - val add_couple: Remanent_parameters_sig.parameters -> Exception.method_handler -> bool -> label_set -> label_set -> label_set_couple -> Exception.method_handler * label_set_couple - val dump: Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> label_set -> Exception.method_handler - val dump_couple: Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler ->label_set_couple -> Exception.method_handler - val filter_couple: Remanent_parameters_sig.parameters -> - 'a -> Cckappa_sig.kappa_handler -> ('a ->label -> label -> 'a * bool) -> label_set_couple -> 'a * label_set_couple - val to_string : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler ->label_set -> Exception.method_handler * string list - val to_string_couple : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler ->label_set_couple -> Exception.method_handler * string list - val convert_label_set_couple : label_set_couple -> (int * int) list + val label_of_int : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + int -> + Exception.method_handler * label + + val member : label -> label_set -> bool + val empty : label_set + val empty_couple : label_set_couple + val is_empty_couple : label_set_couple -> bool + val add_set : label -> label_set -> label_set + val remove_set : label -> label_set -> label_set + + val add_couple : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + bool -> + label_set -> + label_set -> + label_set_couple -> + Exception.method_handler * label_set_couple + + val dump : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set -> + Exception.method_handler + + val dump_couple : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set_couple -> + Exception.method_handler + + val filter_couple : + Remanent_parameters_sig.parameters -> + 'a -> + Cckappa_sig.kappa_handler -> + ('a -> label -> label -> 'a * bool) -> + label_set_couple -> + 'a * label_set_couple + + val to_string : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set -> + Exception.method_handler * string list + + val to_string_couple : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Cckappa_sig.kappa_handler -> + label_set_couple -> + Exception.method_handler * string list + val convert_label_set_couple : label_set_couple -> (int * int) list end -module type Labels = -sig +module type Labels = sig type label - val label_of_int: Remanent_parameters_sig.parameters -> Exception.method_handler -> int -> Exception.method_handler * label - val to_string:Remanent_parameters_sig.parameters -> Exception.method_handler -> label -> Exception.method_handler * string - val dump: Remanent_parameters_sig.parameters -> Exception.method_handler -> label -> Exception.method_handler - val print: Format.formatter -> label -> unit - val int_of_label: label -> int + val label_of_int : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + int -> + Exception.method_handler * label + + val to_string : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + label -> + Exception.method_handler * string + + val dump : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + label -> + Exception.method_handler + + val print : Format.formatter -> label -> unit + val int_of_label : label -> int end -module Int_labels:Labels with type label=int -module Implicit : functor (L:Labels) -> Label_handler with type label=L.label -module Extensive: functor (L:Labels) -> Label_handler with type label=L.label -module Empty:Label_handler with type label=unit +module Int_labels : Labels with type label = int + +module Implicit : functor (L : Labels) -> + Label_handler with type label = L.label + +module Extensive : functor (L : Labels) -> + Label_handler with type label = L.label + +module Empty : Label_handler with type label = unit diff --git a/core/KaSa_rep/frontend/list_tokens.ml b/core/KaSa_rep/frontend/list_tokens.ml index 9b947cecb6..bb0614bb65 100644 --- a/core/KaSa_rep/frontend/list_tokens.ml +++ b/core/KaSa_rep/frontend/list_tokens.ml @@ -17,182 +17,138 @@ module Int_Set_and_Map = Mods.IntSetMap let local_trace = false let empty_site_list = - { - Ckappa_sig.used = []; - Ckappa_sig.declared = []; - Ckappa_sig.creation = [] - } + { Ckappa_sig.used = []; Ckappa_sig.declared = []; Ckappa_sig.creation = [] } let empty_agent_specification = { Ckappa_sig.binding_sites_usage = empty_site_list; - Ckappa_sig.marked_sites_usage = empty_site_list + Ckappa_sig.marked_sites_usage = empty_site_list; } let empty_handler parameters error = let error, int_constraints = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in - let error,sites = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create - parameters - error - 0 (*dimension*) + let error, sites = + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 (*dimension*) in let error, agent_annotation = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create - parameters - error - 0 (*dimension*) + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 (*dimension*) in let error, states_dic = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create - parameters error (0, 0) + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameters error (0, 0) in - let error,dual = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.create - parameters error + let error, dual = + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .create parameters error (0, (0, 0)) in - error, - { - Cckappa_sig.nvars = 0 ; - Cckappa_sig.nagents = Ckappa_sig.dummy_agent_name ; - Cckappa_sig.nrules = 0 ; - Cckappa_sig.agents_dic = Ckappa_sig.Dictionary_of_agents.init (); - Cckappa_sig.agents_annotation = agent_annotation ; - Cckappa_sig.interface_constraints = int_constraints; - Cckappa_sig.sites = sites; - Cckappa_sig.states_dic = states_dic; - Cckappa_sig.dual = dual; - } + ( error, + { + Cckappa_sig.nvars = 0; + Cckappa_sig.nagents = Ckappa_sig.dummy_agent_name; + Cckappa_sig.nrules = 0; + Cckappa_sig.agents_dic = Ckappa_sig.Dictionary_of_agents.init (); + Cckappa_sig.agents_annotation = agent_annotation; + Cckappa_sig.interface_constraints = int_constraints; + Cckappa_sig.sites; + Cckappa_sig.states_dic; + Cckappa_sig.dual; + } ) let create_binding_state_dictionary parameters error = let dic = Ckappa_sig.Dictionary_of_States.init () in - let error, output= - Ckappa_sig.Dictionary_of_States.allocate - parameters - error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Binding Ckappa_sig.C_Free) - () - Misc_sa.const_unit - dic + let error, output = + Ckappa_sig.Dictionary_of_States.allocate parameters error + Ckappa_sig.compare_unit_state_index (Ckappa_sig.Binding Ckappa_sig.C_Free) + () Misc_sa.const_unit dic in match output with - | None -> error,dic - | Some (_, _, _, x) -> error,x + | None -> error, dic + | Some (_, _, _, x) -> error, x let create_internal_state_dictionary _parameters error = let dic = Ckappa_sig.Dictionary_of_States.init () in error, dic let init_agent_declaration parameters error handler agent_id agent_string = - let agent_annotation = (agent_string,[]) in + let agent_annotation = agent_string, [] in let error, agents_annotation = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_id - agent_annotation - handler.Cckappa_sig.agents_annotation + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters error + agent_id agent_annotation handler.Cckappa_sig.agents_annotation in - error, - { - handler with - Cckappa_sig.agents_annotation = agents_annotation - } + error, { handler with Cckappa_sig.agents_annotation } let add_agent_declaration parameters error handler agent_id pos_opt = match pos_opt with - | None -> - error, handler + | None -> error, handler | Some pos -> let error, info_opt = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_id - handler.Cckappa_sig.agents_annotation + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_id handler.Cckappa_sig.agents_annotation in - let error, (ag_name, list) = - match - info_opt - with - | None -> - Exception.warn - parameters error __POS__ Exit ("",[]) + let error, (agent_name, list) = + match info_opt with + | None -> Exception.warn parameters error __POS__ Exit ("", []) | Some info -> error, info in - let agent_annotation = (ag_name, pos::list) in + let agent_annotation = agent_name, pos :: list in let error, agents_annotation = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_id - agent_annotation - handler.Cckappa_sig.agents_annotation + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_id agent_annotation handler.Cckappa_sig.agents_annotation in - error, {handler with Cckappa_sig.agents_annotation = agents_annotation} + error, { handler with Cckappa_sig.agents_annotation } let declare_agent parameters error handler agent_string pos = let agents_dic = handler.Cckappa_sig.agents_dic in let error, (bool, output) = - Ckappa_sig.Dictionary_of_agents.allocate_bool - parameters - error - Ckappa_sig.compare_unit_agent_name - agent_string - () - Misc_sa.const_unit + Ckappa_sig.Dictionary_of_agents.allocate_bool parameters error + Ckappa_sig.compare_unit_agent_name agent_string () Misc_sa.const_unit agents_dic in let error, (handler, agent_name) = match output with - | None -> Exception.warn parameters error __POS__ - Exit (handler, Ckappa_sig.dummy_agent_name) + | None -> + Exception.warn parameters error __POS__ Exit + (handler, Ckappa_sig.dummy_agent_name) | Some (k, _, _, dic) -> - if bool - then + if bool then ( let error, int_constraints = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters - error - k - empty_agent_specification + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters + error k empty_agent_specification handler.Cckappa_sig.interface_constraints in let error, sites = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters - error - k + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters + error k (Ckappa_sig.Dictionary_of_sites.init ()) handler.Cckappa_sig.sites in let handler = let k' = Ckappa_sig.next_agent_name k in - if - Ckappa_sig.compare_agent_name k' handler.Cckappa_sig.nagents - > 0 + if Ckappa_sig.compare_agent_name k' handler.Cckappa_sig.nagents > 0 then - {handler with - Cckappa_sig.nagents = k'} - else handler + { handler with Cckappa_sig.nagents = k' } + else + handler in let error, handler = - init_agent_declaration - parameters error - {handler with - Cckappa_sig.agents_dic = dic ; + init_agent_declaration parameters error + { + handler with + Cckappa_sig.agents_dic = dic; Cckappa_sig.interface_constraints = int_constraints; - Cckappa_sig.sites = sites; + Cckappa_sig.sites; } - k - agent_string + k agent_string in error, (handler, k) - else + ) else error, (handler, k) in let error, handler = @@ -205,201 +161,146 @@ let declare_site create parameters make_site make_state (error, handler) let site = make_site site_name in let states_dic = handler.Cckappa_sig.states_dic in let error, sites = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_name - handler.Cckappa_sig.sites + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters error + agent_name handler.Cckappa_sig.sites in match sites with - | None -> Exception.warn parameters error __POS__ Exit - (handler, [], Ckappa_sig.dummy_site_name) + | None -> + Exception.warn parameters error __POS__ Exit + (handler, [], Ckappa_sig.dummy_site_name) | Some sites -> let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - site - () - Misc_sa.const_unit - sites + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name site () Misc_sa.const_unit sites in - begin - match output with - | None -> Exception.warn parameters error __POS__ Exit - (handler, [], Ckappa_sig.dummy_site_name) - | Some (k, _, _, sites) -> - let error, (states_dic, dic_states, handler) = - if bool - then - let error, dic_states = create parameters error in - let error, states_dic = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameters - error - (agent_name, k) - dic_states - states_dic + (match output with + | None -> + Exception.warn parameters error __POS__ Exit + (handler, [], Ckappa_sig.dummy_site_name) + | Some (k, _, _, sites) -> + let error, (states_dic, dic_states, handler) = + if bool then ( + let error, dic_states = create parameters error in + let error, states_dic = + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error (agent_name, k) dic_states states_dic + in + let error, new_sites = + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_name sites handler.Cckappa_sig.sites + in + ( error, + ( states_dic, + dic_states, + { handler with Cckappa_sig.sites = new_sites } ) ) + ) else ( + match + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, k) states_dic + with + | error, None -> + let error, dic = create parameters error in + Exception.warn parameters error __POS__ Exit + (states_dic, dic, handler) + | error, Some _u -> + let error, dic_states = + match + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, k) states_dic + with + | error, None -> + let error, dic_states = create parameters error in + Exception.warn parameters error __POS__ Exit dic_states + | error, Some dic_states -> error, dic_states in - let error, new_sites = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_name - sites - handler.Cckappa_sig.sites + error, (states_dic, dic_states, handler) + ) + in + let error, (new_dic_states, l, bool) = + List.fold_left + (fun (error, (dic_states, l, bool)) internal -> + let state = make_state internal in + let error, (bool2, output) = + Ckappa_sig.Dictionary_of_States.allocate_bool parameters error + Ckappa_sig.compare_unit_state_index state () Misc_sa.const_unit + dic_states in - error, - (states_dic, dic_states, - { - handler with Cckappa_sig.sites = new_sites - }) - else - match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, k) - states_dic - with - | error, None -> - let error, dic = create parameters error in - Exception.warn parameters error __POS__ Exit (states_dic, dic, handler) - | error, Some _u -> - let error, dic_states = - match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, k) - states_dic - with - | error, None -> - let error, dic_states = (create parameters error) in - Exception.warn parameters error __POS__ Exit dic_states - | error, Some dic_states -> error, dic_states - in - error, (states_dic, dic_states, handler) - in - let error, (new_dic_states, l, bool) = - List.fold_left - (fun (error, (dic_states, l, bool)) internal -> - let state = make_state internal in - let error, (bool2, output) = - Ckappa_sig.Dictionary_of_States.allocate_bool - parameters - error - Ckappa_sig.compare_unit_state_index - state - () - Misc_sa.const_unit - dic_states - in - begin - match output with - | None -> - Exception.warn parameters error __POS__ Exit (dic_states, l, bool2) - | Some (state_id, _, _, dic) -> - let l = (agent_name, k, state_id) :: l in - if bool2 - then - error, (dic, l, bool2) - else - error,(dic_states, l, bool) - end) - (error, (dic_states, [], bool)) - list + match output with + | None -> + Exception.warn parameters error __POS__ Exit (dic_states, l, bool2) + | Some (state_id, _, _, dic) -> + let l = (agent_name, k, state_id) :: l in + if bool2 then + error, (dic, l, bool2) + else + error, (dic_states, l, bool)) + (error, (dic_states, [], bool)) + list + in + if bool then ( + let error, states_dic = + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error (agent_name, k) new_dic_states states_dic in - begin - if bool - then - let error, states_dic = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameters - error - (agent_name, k) - new_dic_states - states_dic - in - let error, handler = - error, - { - handler with Cckappa_sig.states_dic = states_dic - } - in - error, (handler, l, k) - else - error, (handler, l, k) - end - end + let error, handler = error, { handler with Cckappa_sig.states_dic } in + error, (handler, l, k) + ) else + error, (handler, l, k)) let declare_site_with_internal_states parameters = - declare_site - create_internal_state_dictionary - parameters + declare_site create_internal_state_dictionary parameters (fun x -> Ckappa_sig.Internal x) (fun x -> Ckappa_sig.Internal x) let declare_site_with_binding_states parameters = - declare_site - create_binding_state_dictionary - parameters + declare_site create_binding_state_dictionary parameters (fun x -> Ckappa_sig.Binding x) (fun x -> Ckappa_sig.Binding x) -let declare_site_with_counter parameters (error,handler) ag site = - declare_site - create_internal_state_dictionary - parameters +let declare_site_with_counter parameters (error, handler) ag site = + declare_site create_internal_state_dictionary parameters (fun x -> Ckappa_sig.Counter x) (fun x -> Ckappa_sig.Counter x) - (error,handler) - ag site - [] + (error, handler) ag site [] -let declare_dual parameter error handler ag site state ag' site' state'= +let declare_dual parameter error handler ag site state ag' site' state' = let dual = handler.Cckappa_sig.dual in let error, dual = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.set - parameter - error + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .set parameter error (ag, (site, state)) - (ag', site', state') - dual + (ag', site', state') dual in let error, dual = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.set - parameter - error + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .set parameter error (ag', (site', state')) - (ag, site, state) - dual + (ag, site, state) dual in - error, {handler with Cckappa_sig.dual = dual} + error, { handler with Cckappa_sig.dual } let scan_agent parameters (error, handler) agent = let error, (handler, ag_id) = - declare_agent - parameters - error - handler - agent.Ckappa_sig.ag_nme - (Some agent.Ckappa_sig.ag_nme_pos) + declare_agent parameters error handler agent.Ckappa_sig.agent_name + (Some agent.Ckappa_sig.agent_name_pos) in let rec aux error interface handler = match interface with | Ckappa_sig.EMPTY_INTF -> error, handler | Ckappa_sig.COUNTER_SEP (counter, interface) -> let error, (handler, _, _c) = - declare_site_with_counter - parameters - (error, handler) - ag_id - counter.Ckappa_sig.count_nme - in aux error interface handler + declare_site_with_counter parameters (error, handler) ag_id + counter.Ckappa_sig.counter_name + in + aux error interface handler | Ckappa_sig.PORT_SEP (port, interface) -> - let site_name = port.Ckappa_sig.port_nme in + let site_name = port.Ckappa_sig.port_name in let error, handler = match port.Ckappa_sig.port_int with | [] -> error, handler @@ -407,215 +308,183 @@ let scan_agent parameters (error, handler) agent = let list = List.fold_left (fun list x -> - match x with - | None -> list - | Some x -> x::list) + match x with + | None -> list + | Some x -> x :: list) [] (List.rev list) in - begin - let error, (handler, _, _c) = - declare_site_with_internal_states - parameters - (error, handler) - ag_id - site_name - list - in - error, handler - end + let error, (handler, _, _c) = + declare_site_with_internal_states parameters (error, handler) ag_id + site_name list + in + error, handler in let error, handler = - match port.Ckappa_sig.port_lnk with - | Ckappa_sig.LNK_MISSING | Ckappa_sig.FREE | Ckappa_sig.LNK_ANY _ -> error, handler + match port.Ckappa_sig.port_link with + | Ckappa_sig.LNK_MISSING | Ckappa_sig.FREE | Ckappa_sig.LNK_ANY _ -> + error, handler | Ckappa_sig.LNK_VALUE (_, agent', site', _, _) | Ckappa_sig.LNK_TYPE ((agent', _), (site', _)) -> - (let error, (handler, ag_id') = - declare_agent parameters error handler agent' None - in - let error, (handler, _, _site_id) = - declare_site_with_binding_states - parameters - (error,handler) - ag_id - site_name - [] - in - let error, (handler, _, site_id') = - declare_site_with_binding_states - parameters - (error, handler) - ag_id' - site' - [] - in - let error, (handler, l1, site_id) = - declare_site_with_binding_states - parameters - (error, handler) - ag_id - site_name - [Ckappa_sig.C_Lnk_type (ag_id', site_id')] - in - let error, (handler, l2, _site_id') = - declare_site_with_binding_states - parameters - (error, handler) - ag_id' - site' - [Ckappa_sig.C_Lnk_type (ag_id, site_id)] - in - let error, handler = - begin - match l1, l2 with - | [agent_id1,site_id1,state_id1],[agent_id2,site_id2,state_id2] -> - declare_dual - parameters - error - handler - agent_id1 - site_id1 - state_id1 - agent_id2 - site_id2 - state_id2 - | _ -> Exception.warn parameters error __POS__ Exit handler - end - in - error, handler) - | Ckappa_sig.LNK_SOME _ -> + let error, (handler, ag_id') = + declare_agent parameters error handler agent' None + in let error, (handler, _, _site_id) = - declare_site_with_binding_states - parameters - (error, handler) - ag_id + declare_site_with_binding_states parameters (error, handler) ag_id + site_name [] + in + let error, (handler, _, site_id') = + declare_site_with_binding_states parameters (error, handler) ag_id' + site' [] + in + let error, (handler, l1, site_id) = + declare_site_with_binding_states parameters (error, handler) ag_id site_name - [] + [ Ckappa_sig.C_Lnk_type (ag_id', site_id') ] + in + let error, (handler, l2, _site_id') = + declare_site_with_binding_states parameters (error, handler) ag_id' + site' + [ Ckappa_sig.C_Lnk_type (ag_id, site_id) ] + in + let error, handler = + match l1, l2 with + | ( [ (agent_id1, site_id1, state_id1) ], + [ (agent_id2, site_id2, state_id2) ] ) -> + declare_dual parameters error handler agent_id1 site_id1 state_id1 + agent_id2 site_id2 state_id2 + | _ -> Exception.warn parameters error __POS__ Exit handler + in + error, handler + | Ckappa_sig.LNK_SOME _ -> + let error, (handler, _, _site_id) = + declare_site_with_binding_states parameters (error, handler) ag_id + site_name [] in error, handler - in aux error interface handler - in aux error agent.Ckappa_sig.ag_intf handler + in + aux error interface handler + in + aux error agent.Ckappa_sig.ag_intf handler let rec scan_mixture parameters remanent mixture = match mixture with | Ckappa_sig.EMPTY_MIX -> remanent | Ckappa_sig.SKIP mixture -> scan_mixture parameters remanent mixture - | Ckappa_sig.COMMA(agent,mixture) - | Ckappa_sig.DOT(_,agent,mixture) - | Ckappa_sig.PLUS(_,agent,mixture) -> + | Ckappa_sig.COMMA (agent, mixture) + | Ckappa_sig.DOT (_, agent, mixture) + | Ckappa_sig.PLUS (_, agent, mixture) -> let remanent = scan_agent parameters remanent agent in scan_mixture parameters remanent mixture -let scan_token parameters remanent _alg = (*TO DO*) +let scan_token parameters remanent _alg = + (*TO DO*) match Remanent_parameters.get_called_from parameters with | Remanent_parameters_sig.KaSa -> let error, remanent = remanent in - Exception.warn - parameters error __POS__ - ~message:"Tokens are not implemented in KaSa yet" - Exit remanent - | Remanent_parameters_sig.KaSim - | Remanent_parameters_sig.Internalised + Exception.warn parameters error __POS__ + ~message:"Tokens are not implemented in KaSa yet" Exit remanent + | Remanent_parameters_sig.KaSim | Remanent_parameters_sig.Internalised | Remanent_parameters_sig.Server -> remanent -let scan_alg _parameters remanent _alg = (*TO DO*) +let scan_alg _parameters remanent _alg = + (*TO DO*) remanent let scan_initial_states parameters = - List.fold_left - (fun remanent ((alg,_pos),init_t) -> - let remanent = scan_alg parameters remanent alg in - match - init_t - with - | Ast.INIT_MIX (mixture,_pos') -> - scan_mixture parameters remanent mixture - | Ast.INIT_TOK tk_l -> - List.fold_left (scan_token parameters) remanent tk_l) + List.fold_left (fun remanent ((alg, _pos), init_t) -> + let remanent = scan_alg parameters remanent alg in + match init_t with + | Ast.INIT_MIX (mixture, _pos') -> + scan_mixture parameters remanent mixture + | Ast.INIT_TOK tk_l -> + List.fold_left (scan_token parameters) remanent tk_l) -let scan_declarations parameters = - List.fold_left - (fun remanent a -> scan_agent parameters remanent a) +let scan_declarations parameters = + List.fold_left (fun remanent a -> scan_agent parameters remanent a) -let scan_observables _scan_mixt _parameters remanent _variable = (*TODO*) +let scan_observables _scan_mixt _parameters remanent _variable = + (*TODO*) remanent let scan_perts scan_mixt parameters = - List.fold_left - (fun remanent ((_,_,m,_),_) -> - List.fold_left - (fun remanent m -> - match m with - | Ast.APPLY (_,(r,_)) -> - scan_mixture - parameters - (scan_mixt parameters remanent r.Ckappa_sig.lhs) - r.Ckappa_sig.rhs - | (Ast.CFLOWMIX (_,(m,_))) | Ast.SPECIES_OF (_,_,(m,_))-> - scan_mixt parameters remanent m - | Ast.UPDATE _ | Ast.STOP _ | Ast.SNAPSHOT _ | Ast.PLOTENTRY - | Ast.PRINT _ | Ast.CFLOWLABEL _ - | Ast.DINOFF _ | Ast.DIN _ -> remanent - ) remanent m) + List.fold_left (fun remanent ((_, _, m, _), _) -> + List.fold_left + (fun remanent m -> + match m with + | Ast.APPLY (_, (r, _)) -> + scan_mixture parameters + (scan_mixt parameters remanent r.Ckappa_sig.lhs) + r.Ckappa_sig.rhs + | Ast.CFLOWMIX (_, (m, _)) | Ast.SPECIES_OF (_, _, (m, _)) -> + scan_mixt parameters remanent m + | Ast.UPDATE _ | Ast.STOP _ | Ast.SNAPSHOT _ | Ast.PLOTENTRY + | Ast.PRINT _ | Ast.CFLOWLABEL _ | Ast.DINOFF _ | Ast.DIN _ -> + remanent) + remanent m) let scan_rules scan_mixt parameters a b = let _ = - if Remanent_parameters.get_trace parameters - then - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "Scan rules!" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + if Remanent_parameters.get_trace parameters then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Scan rules!" + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in () + ) in List.fold_left - (fun remanent (_,(rule,_)) -> - scan_mixture - parameters - (scan_mixt parameters remanent rule.Ckappa_sig.lhs) rule.Ckappa_sig.rhs) + (fun remanent (_, (rule, _)) -> + scan_mixture parameters + (scan_mixt parameters remanent rule.Ckappa_sig.lhs) + rule.Ckappa_sig.rhs) a b let reverse_agents_annotation parameters (error, remanent) = - let agents_annotation = - remanent.Cckappa_sig.agents_annotation - in + let agents_annotation = remanent.Cckappa_sig.agents_annotation in let error, agents_annotation = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error i (a,l) agents_annotation -> - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters error i (a,List.rev l) agents_annotation) - agents_annotation - agents_annotation - + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold parameters error + (fun parameters error i (a, l) agents_annotation -> + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters + error i + (a, List.rev l) + agents_annotation) + agents_annotation agents_annotation in - (error, - {remanent with Cckappa_sig.agents_annotation = agents_annotation}) + error, { remanent with Cckappa_sig.agents_annotation } let scan_compil parameters error compil = let parameters = - Remanent_parameters.set_trace - parameters - (local_trace || (Remanent_parameters.get_trace parameters)) + Remanent_parameters.set_trace parameters + (local_trace || Remanent_parameters.get_trace parameters) in let also_explore_tested_agents = Remanent_parameters.lexical_analysis_of_tested_only_patterns parameters in let scan_tested_mixture = - if also_explore_tested_agents - then scan_mixture - else (fun _parameters remanent _mixture -> remanent) + if also_explore_tested_agents then + scan_mixture + else + fun _parameters remanent _mixture -> + remanent in let remanent = empty_handler parameters error in - let remanent = scan_declarations parameters remanent compil.Ast.signatures in + let remanent = scan_declarations parameters remanent compil.Ast.signatures in let remanent = scan_initial_states parameters remanent compil.Ast.init in - let remanent = scan_observables scan_tested_mixture parameters remanent + let remanent = + scan_observables scan_tested_mixture parameters remanent compil.Ast.observables in - let remanent = scan_perts scan_tested_mixture parameters remanent - compil.Ast.perturbations - in - let remanent = scan_rules scan_tested_mixture parameters remanent compil.Ast.rules + let remanent = + scan_perts scan_tested_mixture parameters remanent compil.Ast.perturbations in - let remanent = reverse_agents_annotation parameters remanent + let remanent = + scan_rules scan_tested_mixture parameters remanent compil.Ast.rules in + let remanent = reverse_agents_annotation parameters remanent in remanent diff --git a/core/KaSa_rep/frontend/list_tokens.mli b/core/KaSa_rep/frontend/list_tokens.mli index 0183002fac..e2e4c846a0 100644 --- a/core/KaSa_rep/frontend/list_tokens.mli +++ b/core/KaSa_rep/frontend/list_tokens.mli @@ -1,18 +1,19 @@ -val local_trace:bool +val local_trace : bool -module Int_Set_and_Map:SetMap.S with type elt = int +module Int_Set_and_Map : SetMap.S with type elt = int -val scan_compil: -Remanent_parameters_sig.parameters -> - Exception_without_parameter.method_handler -> - (Ckappa_sig.agent, Ckappa_sig.mixture, Ckappa_sig.mixture, 'a, - Ckappa_sig.mixture Ckappa_sig.rule) - Ast.compil -> - Exception_without_parameter.method_handler * - Cckappa_sig.kappa_handler +val scan_compil : + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> + ( Ckappa_sig.agent, + Ckappa_sig.mixture, + Ckappa_sig.mixture, + 'a, + Ckappa_sig.mixture Ckappa_sig.rule ) + Ast.compil -> + Exception_without_parameter.method_handler * Cckappa_sig.kappa_handler -val empty_handler: +val empty_handler : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Exception_without_parameter.method_handler * - Cckappa_sig.kappa_handler + Exception_without_parameter.method_handler * Cckappa_sig.kappa_handler diff --git a/core/KaSa_rep/frontend/prepreprocess.ml b/core/KaSa_rep/frontend/prepreprocess.ml index 4cb1a9175c..de09d0174f 100644 --- a/core/KaSa_rep/frontend/prepreprocess.ml +++ b/core/KaSa_rep/frontend/prepreprocess.ml @@ -16,53 +16,36 @@ let local_trace = false let check_freshness parameters error str id id_set = - let error,id_set = - if Mods.StringSet.mem id id_set - then - begin - Exception.warn - parameters error __POS__ ~message:(str^" '"^id^"' is already used") Exit id_set - end + let error, id_set = + if Mods.StringSet.mem id id_set then + Exception.warn parameters error __POS__ + ~message:(str ^ " '" ^ id ^ "' is already used") + Exit id_set else - error,Mods.StringSet.add id id_set + error, Mods.StringSet.add id id_set in - error,id_set - - -let add_entry parameters id agent site index (error,map) = - let error,old_list = - Ckappa_sig.Agent_id_map_and_set.Map.find_default_without_logs - parameters - error - [] - id - map - (* this is a partial map which stores the occurrences of binding - labels *) + error, id_set + +let add_entry parameters id agent site index (error, map) = + let error, old_list = + Ckappa_sig.Agent_id_map_and_set.Map.find_default_without_logs parameters + error [] id map + (* this is a partial map which stores the occurrences of binding + labels *) in - Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite - parameters - error - id + Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite parameters error id ((agent, site, index) :: old_list) map -let add_entry_lnk parameters id agent site index (error,map) = - let error,old_list = - Ckappa_sig.Lnk_id_map_and_set.Map.find_default_without_logs - parameters - error - [] - id - map -(* this is a partial map which stores the occurrences of binding +let add_entry_link parameters id agent site index (error, map) = + let error, old_list = + Ckappa_sig.Lnk_id_map_and_set.Map.find_default_without_logs parameters error + [] id map + (* this is a partial map which stores the occurrences of binding - labels *) + labels *) in - Ckappa_sig.Lnk_id_map_and_set.Map.add_or_overwrite - parameters - error - id + Ckappa_sig.Lnk_id_map_and_set.Map.add_or_overwrite parameters error id ((agent, site, index) :: old_list) map @@ -76,977 +59,899 @@ let rev_ast = List.rev | agent :: mixture -> aux mixture (agent :: sol) in aux mixture []*) -let pop_entry parameters error id (map,set) = - let error,list = - Ckappa_sig.Lnk_id_map_and_set.Map.find_option - parameters - error - id - map +let pop_entry parameters error id (map, set) = + let error, list = + Ckappa_sig.Lnk_id_map_and_set.Map.find_option parameters error id map in - if - Ckappa_sig.Lnk_id_map_and_set.Set.mem - id - set - then + if Ckappa_sig.Lnk_id_map_and_set.Set.mem id set then ( match list with - | Some [_] -> - let error,map = - Ckappa_sig.Lnk_id_map_and_set.Map.remove - parameters - error - id - map + | Some [ _ ] -> + let error, map = + Ckappa_sig.Lnk_id_map_and_set.Map.remove parameters error id map in - Exception.warn - parameters error __POS__ - ~message:"dangling bond detected" - Exit (None,map) + Exception.warn parameters error __POS__ ~message:"dangling bond detected" + Exit (None, map) | Some [] -> - Exception.warn - parameters error __POS__ - ~message:"internal bug, link id is ignored" - Exit (None,map) - | Some (_::t) -> - let error,map = - Ckappa_sig.Lnk_id_map_and_set.Map.overwrite - parameters - error - id - t - map + Exception.warn parameters error __POS__ + ~message:"internal bug, link id is ignored" Exit (None, map) + | Some (_ :: t) -> + let error, map = + Ckappa_sig.Lnk_id_map_and_set.Map.overwrite parameters error id t map in - Exception.warn - parameters error __POS__ - ~message:"internal bug, link id is ignored" - Exit (None,map) + Exception.warn parameters error __POS__ + ~message:"internal bug, link id is ignored" Exit (None, map) | None -> - Exception.warn - parameters error __POS__ - ~message:"internal bug, link id is ignored" - Exit (None,map) - else + Exception.warn parameters error __POS__ + ~message:"internal bug, link id is ignored" Exit (None, map) + ) else ( match list with - | Some [a] -> - let error,map = - Ckappa_sig.Lnk_id_map_and_set.Map.remove - parameters - error - id - map + | Some [ a ] -> + let error, map = + Ckappa_sig.Lnk_id_map_and_set.Map.remove parameters error id map in - error,(Some a,map) - | Some [b;a] -> - let error,map = - Ckappa_sig.Lnk_id_map_and_set.Map.overwrite - parameters - error - id - [a] + error, (Some a, map) + | Some [ b; a ] -> + let error, map = + Ckappa_sig.Lnk_id_map_and_set.Map.overwrite parameters error id [ a ] map in - error,(Some b,map) - | Some (_::t) -> - let error,map = - Ckappa_sig.Lnk_id_map_and_set.Map.overwrite - parameters - error - id - t - map + error, (Some b, map) + | Some (_ :: t) -> + let error, map = + Ckappa_sig.Lnk_id_map_and_set.Map.overwrite parameters error id t map in - Exception.warn - parameters error __POS__ - ~message:"too many instances of a link identifier, ignore them" - Exit (None,map) + Exception.warn parameters error __POS__ + ~message:"too many instances of a link identifier, ignore them" Exit + (None, map) | Some [] -> - Exception.warn - parameters error __POS__ - ~message:"internal bug, link identifier" - Exit (None,map) - | None -> - Exception.warn parameters error __POS__ Exit (None,map) + Exception.warn parameters error __POS__ + ~message:"internal bug, link identifier" Exit (None, map) + | None -> Exception.warn parameters error __POS__ Exit (None, map) + ) -let rec scan_interface parameters k agent interface ((error,a),(set_sites,set_counters) as remanent)= +let rec scan_interface parameters k agent interface + (((error, a), (set_sites, set_counters)) as remanent) = match interface with | [] -> remanent - | Ast.Counter counter::interface -> + | Ast.Counter counter :: interface -> let error, set_counters = - check_freshness parameters error "Counter" (fst counter.Ast.count_nme) set_counters + check_freshness parameters error "Counter" + (fst counter.Ast.counter_name) + set_counters in - scan_interface parameters k agent interface ((error,a),(set_sites,set_counters)) - | Ast.Port port::interface -> - let error,set_sites = - check_freshness parameters error "Site" (fst port.Ast.port_nme) set_sites + scan_interface parameters k agent interface + ((error, a), (set_sites, set_counters)) + | Ast.Port port :: interface -> + let error, set_sites = + check_freshness parameters error "Site" (fst port.Ast.port_name) set_sites in - let remanent = error,a in + let remanent = error, a in scan_interface parameters k agent interface - ((match port.Ast.port_lnk with - | [LKappa.LNK_VALUE (i,()),_] -> - add_entry_lnk - parameters - (Ckappa_sig.lnk_value_of_int i) - agent - (fst port.Ast.port_nme) - k - remanent - | [] | ((LKappa.LNK_ANY | LKappa.LNK_FREE | LKappa.LNK_TYPE _ | LKappa.LNK_SOME - | LKappa.ANY_FREE | LKappa.LNK_VALUE (_,())),_) :: _ -> remanent),(set_sites,set_counters)) + ( (match port.Ast.port_link with + | [ (LKappa.LNK_VALUE (i, ()), _) ] -> + add_entry_link parameters + (Ckappa_sig.lnk_value_of_int i) + agent (fst port.Ast.port_name) k remanent + | [] + | ( ( LKappa.LNK_ANY | LKappa.LNK_FREE | LKappa.LNK_TYPE _ + | LKappa.LNK_SOME | LKappa.ANY_FREE + | LKappa.LNK_VALUE (_, ()) ), + _ ) + :: _ -> + remanent), + (set_sites, set_counters) ) let scan_agent parameters k ag remanent = match ag with | Ast.Absent _ -> remanent - | Ast.Present ((name,_),intf,_modif) -> + | Ast.Present ((name, _), intf, _modif) -> fst - (scan_interface parameters k name intf (remanent,(Mods.StringSet.empty,Mods.StringSet.empty))) + (scan_interface parameters k name intf + (remanent, (Mods.StringSet.empty, Mods.StringSet.empty))) -let rec collect_binding_label - parameters mixture f k remanent = +let rec collect_binding_label parameters mixture f k remanent = match mixture with - | agent :: mixture (*| Ast.DOT (_,agent,mixture) | Ast.PLUS(_,agent,mixture)*) -> - collect_binding_label - parameters - mixture - f + | agent :: mixture (*| Ast.DOT (_,agent,mixture) | Ast.PLUS(_,agent,mixture)*) + -> + collect_binding_label parameters mixture f (Ckappa_sig.next_agent_id k) (scan_agent parameters (f k) agent remanent) | [] -> remanent let collect_binding_label parameters mixture f k remanent = - let error,map = - collect_binding_label - parameters - mixture - f - k - remanent - in + let error, map = collect_binding_label parameters mixture f k remanent in Ckappa_sig.Lnk_id_map_and_set.Map.fold - (fun x l (error,(map,set)) -> - if (List.length l = 1) - then - let error,map = - Ckappa_sig.Lnk_id_map_and_set.Map.remove - parameters - error - x - map - in - let error,set = - Ckappa_sig.Lnk_id_map_and_set.Set.add - parameters - error - x - set - in - Exception.warn - parameters error __POS__ - ~message:"dangling bond detected" - Exit (map,set) - else - (error,(map,set))) + (fun x l (error, (map, set)) -> + if List.length l = 1 then ( + let error, map = + Ckappa_sig.Lnk_id_map_and_set.Map.remove parameters error x map + in + let error, set = + Ckappa_sig.Lnk_id_map_and_set.Set.add parameters error x set + in + Exception.warn parameters error __POS__ + ~message:"dangling bond detected" Exit (map, set) + ) else + error, (map, set)) map - (error, (map, - Ckappa_sig.Lnk_id_map_and_set.Set.empty - )) + (error, (map, Ckappa_sig.Lnk_id_map_and_set.Set.empty)) -let translate_lnk_state parameters lnk_state remanent = +let translate_link_state parameters lnk_state remanent = match lnk_state with - | [LKappa.LNK_VALUE (id,()),pos] -> - begin - let error, remanent = remanent in - let error, (triple, map) = - pop_entry - parameters - error - (Ckappa_sig.lnk_value_of_int id) (*NOTE: I don't want to change the type in Ast*) - remanent + | [ (LKappa.LNK_VALUE (id, ()), pos) ] -> + let error, remanent = remanent in + let error, (triple, map) = + pop_entry parameters error + (Ckappa_sig.lnk_value_of_int id) + (*NOTE: I don't want to change the type in Ast*) + remanent + in + (match triple with + | None -> + let site = Ckappa_sig.LNK_SOME pos in + let remanent = + Exception.warn parameters error __POS__ + ~message:"one dangling bond has been replaced by a wild card" ~pos + Exit remanent in - match triple with - | None -> + site, remanent + | Some (agent, site, index) -> + if (agent, site, index) = ("", "", (*0*) Ckappa_sig.dummy_agent_id) then ( let site = Ckappa_sig.LNK_SOME pos in - let remanent = - Exception.warn parameters error __POS__ - ~message:"one dangling bond has been replaced by a wild card" - ~pos - Exit - remanent - in + let remanent = Exception.warn parameters error __POS__ Exit remanent in site, remanent - | Some (agent,site,index) -> - if (agent,site,index) = ("", "", (*0*)Ckappa_sig.dummy_agent_id) - then - let site = Ckappa_sig.LNK_SOME pos in - let remanent = - Exception.warn parameters error __POS__ Exit remanent - in - site,remanent - else - Ckappa_sig.LNK_VALUE - (index, - agent, - site, - (Ckappa_sig.lnk_value_of_int id), - pos), - (error, (map, (snd remanent))) - end - | [(LKappa.LNK_FREE|LKappa.ANY_FREE),_] -> Ckappa_sig.FREE,remanent + ) else + ( Ckappa_sig.LNK_VALUE + (index, agent, site, Ckappa_sig.lnk_value_of_int id, pos), + (error, (map, snd remanent)) )) + | [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] -> Ckappa_sig.FREE, remanent | [] -> - begin - match Remanent_parameters.get_syntax_version parameters with - | Ast.V3 -> Ckappa_sig.FREE, remanent - | Ast.V4 -> Ckappa_sig.LNK_MISSING, remanent - end - | [LKappa.LNK_ANY,position] -> - Ckappa_sig.LNK_ANY position,remanent - | [LKappa.LNK_SOME,position] -> Ckappa_sig.LNK_SOME position,remanent - | [LKappa.LNK_TYPE (x,y),_position] -> Ckappa_sig.LNK_TYPE (y,x),remanent - | _::(_,pos)::_ -> + (match Remanent_parameters.get_syntax_version parameters with + | Ast.V3 -> Ckappa_sig.FREE, remanent + | Ast.V4 -> Ckappa_sig.LNK_MISSING, remanent) + | [ (LKappa.LNK_ANY, position) ] -> Ckappa_sig.LNK_ANY position, remanent + | [ (LKappa.LNK_SOME, position) ] -> Ckappa_sig.LNK_SOME position, remanent + | [ (LKappa.LNK_TYPE (x, y), _position) ] -> + Ckappa_sig.LNK_TYPE (y, x), remanent + | _ :: (_, pos) :: _ -> let error, va = remanent in - Ckappa_sig.LNK_ANY pos, - Exception.warn parameters error __POS__ - ~message:"More than one link state for a single site" ~pos - Exit va - + ( Ckappa_sig.LNK_ANY pos, + Exception.warn parameters error __POS__ + ~message:"More than one link state for a single site" ~pos Exit va ) let translate_port is_signature parameters int_set port remanent = - let error,map = remanent in - let error,_ = - check_freshness parameters error "Site" (fst (port.Ast.port_nme)) int_set + let error, map = remanent in + let error, _ = + check_freshness parameters error "Site" (fst port.Ast.port_name) int_set + in + let error', is_free = + match port.Ast.port_link with + | [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] -> error, Some true + | [] -> + (match Remanent_parameters.get_syntax_version parameters with + | Ast.V3 -> error, Some true + | Ast.V4 -> error, None) + | [ (LKappa.LNK_ANY, _) ] -> error, None + | ( ( LKappa.LNK_SOME | LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _ + | LKappa.ANY_FREE | LKappa.LNK_FREE | LKappa.LNK_ANY ), + _ ) + :: _ -> + error, Some false in - let error',is_free = - match port.Ast.port_lnk - with [(LKappa.LNK_FREE|LKappa.ANY_FREE),_] -> error,Some true - | [] -> - begin - match Remanent_parameters.get_syntax_version parameters with - | Ast.V3 -> - error, Some true - | Ast.V4 -> error, None - end - | [LKappa.LNK_ANY,_] -> error,None - | ((LKappa.LNK_SOME | LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _ | LKappa.ANY_FREE - | LKappa.LNK_FREE | LKappa.LNK_ANY),_) :: _ -> error,Some false in - let lnk,remanent = - if is_signature then Ckappa_sig.FREE,remanent else - translate_lnk_state parameters port.Ast.port_lnk (error',map) in - { - Ckappa_sig.port_nme = fst (port.Ast.port_nme) ; - Ckappa_sig.port_int = - List.rev_map fst (List.rev port.Ast.port_int) ; - Ckappa_sig.port_lnk = lnk ; - Ckappa_sig.port_free = is_free }, - remanent + let lnk, remanent = + if is_signature then + Ckappa_sig.FREE, remanent + else + translate_link_state parameters port.Ast.port_link (error', map) + in + ( { + Ckappa_sig.port_name = fst port.Ast.port_name; + Ckappa_sig.port_int = List.rev_map fst (List.rev port.Ast.port_int); + Ckappa_sig.port_link = lnk; + Ckappa_sig.port_free = is_free; + }, + remanent ) let translate_counter_test test = match test with | Ast.CEQ i -> Ckappa_sig.CEQ i | Ast.CGTE i -> Ckappa_sig.CGTE i | Ast.CVAR x -> Ckappa_sig.CVAR x + | Ast.CLTE _i -> failwith "CLTE not yet implemented" (* TODO *) let fst_opt a_opt = - match - a_opt - with + match a_opt with | None -> None - | Some (a,_) -> Some (translate_counter_test a) + | Some (a, _) -> Some (translate_counter_test a) let translate_counter parameters error int_set counter = - let error,_ = - check_freshness parameters error "Counters" - (fst (counter.Ast.count_nme)) int_set - in - error, { - Ckappa_sig.count_nme= fst (counter.Ast.count_nme); - Ckappa_sig.count_test= fst_opt (counter.Ast.count_test) ; - Ckappa_sig.count_delta= - let a = fst counter.Ast.count_delta in - if a=0 then - None - else Some a - } - -let rec translate_interface parameters is_signature int_set_sites int_set_counters interface remanent = + let error, _ = + check_freshness parameters error "Counters" + (fst counter.Ast.counter_name) + int_set + in + ( error, + { + Ckappa_sig.counter_name = fst counter.Ast.counter_name; + Ckappa_sig.counter_test = fst_opt counter.Ast.counter_test; + Ckappa_sig.counter_delta = + (let a = fst counter.Ast.counter_delta in + if a = 0 then + None + else + Some a); + } ) + +let rec translate_interface parameters is_signature int_set_sites + int_set_counters interface remanent = match interface with - | [] -> Ckappa_sig.EMPTY_INTF,remanent - | Ast.Counter counter::interface -> + | [] -> Ckappa_sig.EMPTY_INTF, remanent + | Ast.Counter counter :: interface -> let error, a = remanent in let error, counter = translate_counter parameters error int_set_counters counter in let interface, remanent = - translate_interface - parameters is_signature int_set_sites int_set_counters interface - (error,a) + translate_interface parameters is_signature int_set_sites int_set_counters + interface (error, a) in Ckappa_sig.COUNTER_SEP (counter, interface), remanent - | Ast.Port port::interface -> - let port,remanent = + | Ast.Port port :: interface -> + let port, remanent = translate_port is_signature parameters int_set_sites port remanent in - let interface,remanent = - translate_interface - parameters is_signature - int_set_sites int_set_counters + let interface, remanent = + translate_interface parameters is_signature int_set_sites int_set_counters interface remanent in - Ckappa_sig.PORT_SEP (port,interface),remanent + Ckappa_sig.PORT_SEP (port, interface), remanent let translate_interface parameters is_signature = - translate_interface - parameters is_signature Mods.StringSet.empty Mods.StringSet.empty + translate_interface parameters is_signature Mods.StringSet.empty + Mods.StringSet.empty let translate_agent parameters is_signature ag remanent = match ag with - | Ast.Absent _pos -> - None, remanent - | Ast.Present ((ag_nme,ag_nme_pos),intf,_modif) -> - let interface,remanent = - translate_interface parameters is_signature intf remanent in - Some {Ckappa_sig.ag_nme; - Ckappa_sig.ag_intf = interface ; - Ckappa_sig.ag_nme_pos; - }, - remanent + | Ast.Absent _pos -> None, remanent + | Ast.Present ((agent_name, agent_name_pos), intf, _modif) -> + let interface, remanent = + translate_interface parameters is_signature intf remanent + in + ( Some + { + Ckappa_sig.agent_name; + Ckappa_sig.ag_intf = interface; + Ckappa_sig.agent_name_pos; + }, + remanent ) let rec build_skip k mixture = - if k = 0 - then mixture + if k = 0 then + mixture else - build_skip - (k - 1) - (Ckappa_sig.SKIP(mixture)) + build_skip (k - 1) (Ckappa_sig.SKIP mixture) let add_agent agent_opt mixture remanent = match agent_opt with - | None -> Ckappa_sig.SKIP(mixture), remanent - | Some agent -> - Ckappa_sig.COMMA(agent,mixture),remanent - + | None -> Ckappa_sig.SKIP mixture, remanent + | Some agent -> Ckappa_sig.COMMA (agent, mixture), remanent -let rec translate_mixture_zero_zero parameters mixture remanent tail_size = +let rec translate_mixture_zero_zero parameters mixture remanent tail_size = match mixture with - | [] -> build_skip tail_size Ckappa_sig.EMPTY_MIX,remanent + | [] -> build_skip tail_size Ckappa_sig.EMPTY_MIX, remanent | agent :: mixture -> - let agent_opt,remanent = - translate_agent parameters false agent remanent in - let mixture,remanent = - translate_mixture_zero_zero parameters mixture remanent tail_size in + let agent_opt, remanent = translate_agent parameters false agent remanent in + let mixture, remanent = + translate_mixture_zero_zero parameters mixture remanent tail_size + in add_agent agent_opt mixture remanent - -let rec translate_mixture_in_rule parameters mixture remanent prefix_size empty_size tail_size = - if prefix_size = 0 - then +let rec translate_mixture_in_rule parameters mixture remanent prefix_size + empty_size tail_size = + if prefix_size = 0 then ( let tail, remanent = - translate_mixture_zero_zero - parameters - mixture - remanent - tail_size + translate_mixture_zero_zero parameters mixture remanent tail_size in - build_skip - empty_size - tail, remanent - else + build_skip empty_size tail, remanent + ) else ( match mixture with | [] -> Ckappa_sig.EMPTY_MIX, remanent | agent :: mixture -> let agent_opt, remanent = - translate_agent parameters false agent remanent in + translate_agent parameters false agent remanent + in let mixture, remanent = - translate_mixture_in_rule - parameters - mixture - remanent - (prefix_size - 1) - empty_size - tail_size + translate_mixture_in_rule parameters mixture remanent (prefix_size - 1) + empty_size tail_size in add_agent agent_opt mixture remanent + ) -let rec translate_mixture parameters mixture remanent = +let rec translate_mixture parameters mixture remanent = match mixture with - | [] -> Ckappa_sig.EMPTY_MIX,remanent + | [] -> Ckappa_sig.EMPTY_MIX, remanent | agent :: mixture -> - let agent_opt,remanent = translate_agent parameters false agent remanent in - let mixture,remanent = translate_mixture parameters mixture remanent in + let agent_opt, remanent = translate_agent parameters false agent remanent in + let mixture, remanent = translate_mixture parameters mixture remanent in add_agent agent_opt mixture remanent let support_agent = function | Ast.Absent _ -> None - | Ast.Present ((name,_),intfs,_) -> + | Ast.Present ((name, _), intfs, _) -> let list = let rec scan intf list = match intf with | [] -> List.sort compare list - | Ast.Port port::intf -> - scan intf ((fst port.Ast.port_nme)::list) - | Ast.Counter _::intf -> scan intf list + | Ast.Port port :: intf -> scan intf (fst port.Ast.port_name :: list) + | Ast.Counter _ :: intf -> scan intf list in scan intfs [] in - Some (name,list) + Some (name, list) let compatible_agent ag1 ag2 = - match support_agent ag1,support_agent ag2 with + match support_agent ag1, support_agent ag2 with | None, _ | _, None -> true - | Some a, Some b -> a=b + | Some a, Some b -> a = b let length mixture = let rec aux mixture k = match mixture with | [] -> k - | _ :: mixture -> aux mixture (k+1) - in aux mixture 0 - + | _ :: mixture -> aux mixture (k + 1) + in + aux mixture 0 let longuest_prefix mixture1 mixture2 = let rec common_prefix mixture1 mixture2 k = match mixture1 with - | [] -> (k,mixture1,mixture2) + | [] -> k, mixture1, mixture2 | agent :: mixture -> - begin - match mixture2 with - | [] -> (k,mixture1,mixture2) - | agent' :: mixture' -> - begin - if compatible_agent agent agent' - then - common_prefix mixture mixture' (k+1) - else - k,mixture1,mixture2 - end - end + (match mixture2 with + | [] -> k, mixture1, mixture2 + | agent' :: mixture' -> + if compatible_agent agent agent' then + common_prefix mixture mixture' (k + 1) + else + k, mixture1, mixture2) in - let common_size,tail_lhs,tail_rhs = common_prefix mixture1 mixture2 0 in - common_size,length tail_lhs,length tail_rhs + let common_size, tail_lhs, tail_rhs = common_prefix mixture1 mixture2 0 in + common_size, length tail_lhs, length tail_rhs -let refine_mixture_in_rule parameters error prefix_size empty_size tail_size mixture = +let refine_mixture_in_rule parameters error prefix_size empty_size tail_size + mixture = let f i = if - Ckappa_sig.compare_agent_id - i - (Ckappa_sig.agent_id_of_int (prefix_size-1)) + Ckappa_sig.compare_agent_id i + (Ckappa_sig.agent_id_of_int (prefix_size - 1)) > 0 then Ckappa_sig.add_agent_id i empty_size - else i + else + i in let remanent = - collect_binding_label - parameters - mixture - f - Ckappa_sig.dummy_agent_id - (error, - Ckappa_sig.Lnk_id_map_and_set.Map.empty - ) + collect_binding_label parameters mixture f Ckappa_sig.dummy_agent_id + (error, Ckappa_sig.Lnk_id_map_and_set.Map.empty) in - let mixture,(error,_map) = - translate_mixture_in_rule - parameters - mixture - remanent - prefix_size - empty_size + let mixture, (error, _map) = + translate_mixture_in_rule parameters mixture remanent prefix_size empty_size tail_size in - error,mixture + error, mixture let refine_mixture parameters error mixture = let mixture = List.flatten mixture in let remanent = - collect_binding_label - parameters - mixture + collect_binding_label parameters mixture (fun i -> i) Ckappa_sig.dummy_agent_id - (error, - Ckappa_sig.Lnk_id_map_and_set.Map.empty - ) + (error, Ckappa_sig.Lnk_id_map_and_set.Map.empty) in - let mixture,(error,_map) = translate_mixture parameters mixture remanent in + let mixture, (error, _map) = translate_mixture parameters mixture remanent in error, mixture - let rec alg_map f error alg = - match - alg - with - | Alg_expr.BIN_ALG_OP (op,(m1,pos1),(m2,pos2)) -> - let error,m1' = alg_map f error m1 in - let error,m2' = alg_map f error m2 in - error,Alg_expr.BIN_ALG_OP (op,(m1',pos1),(m2',pos2)) - | Alg_expr.UN_ALG_OP (op,(m1,pos1)) -> - let error,m1' = alg_map f error m1 in - error,Alg_expr.UN_ALG_OP (op,(m1',pos1)) - | Alg_expr.DIFF_KAPPA_INSTANCE ((m1,pos1),pattern) -> - let error,m1' = alg_map f error m1 in + match alg with + | Alg_expr.BIN_ALG_OP (op, (m1, pos1), (m2, pos2)) -> + let error, m1' = alg_map f error m1 in + let error, m2' = alg_map f error m2 in + error, Alg_expr.BIN_ALG_OP (op, (m1', pos1), (m2', pos2)) + | Alg_expr.UN_ALG_OP (op, (m1, pos1)) -> + let error, m1' = alg_map f error m1 in + error, Alg_expr.UN_ALG_OP (op, (m1', pos1)) + | Alg_expr.DIFF_KAPPA_INSTANCE ((m1, pos1), pattern) -> + let error, m1' = alg_map f error m1 in let error, pattern' = f error pattern in - error,Alg_expr.DIFF_KAPPA_INSTANCE ((m1',pos1),pattern') - | Alg_expr.DIFF_TOKEN ((m1,pos1),token) -> - let error,m1' = alg_map f error m1 in - error,Alg_expr.DIFF_TOKEN ((m1',pos1),token) - | Alg_expr.STATE_ALG_OP s -> error,Alg_expr.STATE_ALG_OP s - | Alg_expr.ALG_VAR s -> error,Alg_expr.ALG_VAR s - | Alg_expr.TOKEN_ID s -> error,Alg_expr.TOKEN_ID s + error, Alg_expr.DIFF_KAPPA_INSTANCE ((m1', pos1), pattern') + | Alg_expr.DIFF_TOKEN ((m1, pos1), token) -> + let error, m1' = alg_map f error m1 in + error, Alg_expr.DIFF_TOKEN ((m1', pos1), token) + | Alg_expr.STATE_ALG_OP s -> error, Alg_expr.STATE_ALG_OP s + | Alg_expr.ALG_VAR s -> error, Alg_expr.ALG_VAR s + | Alg_expr.TOKEN_ID s -> error, Alg_expr.TOKEN_ID s | Alg_expr.KAPPA_INSTANCE mixture -> - let error,mixture' = f error mixture in - error,Alg_expr.KAPPA_INSTANCE mixture' - | Alg_expr.CONST x -> error,Alg_expr.CONST x - | Alg_expr.IF ((cond,cond_pos),(yes,yes_pos),(no,no_pos)) -> - let error,cond' = bool_map f error cond in - let error,yes' = alg_map f error yes in - let error,no' = alg_map f error no in - (error,Alg_expr.IF ((cond',cond_pos),(yes',yes_pos),(no',no_pos))) -and bool_map f error alg = - match - alg - with - | Alg_expr.TRUE -> error,Alg_expr.TRUE - | Alg_expr.FALSE -> error,Alg_expr.FALSE - | Alg_expr.UN_BOOL_OP(Operator.NOT,(b1,pos1)) -> - let error,b1' = bool_map f error b1 in - error,Alg_expr.UN_BOOL_OP(Operator.NOT,(b1',pos1)) - | Alg_expr.BIN_BOOL_OP(Operator.AND,(b1,pos1),(b2,pos2)) -> - let error,b1' = bool_map f error b1 in - let error,b2' = bool_map f error b2 in - error,Alg_expr.BIN_BOOL_OP(Operator.AND,(b1',pos1),(b2',pos2)) - | Alg_expr.BIN_BOOL_OP(Operator.OR,(b1,pos1),(b2,pos2)) -> - let error,b1' = bool_map f error b1 in - let error,b2' = bool_map f error b2 in - error,Alg_expr.BIN_BOOL_OP(Operator.OR,(b1',pos1),(b2',pos2)) - | Alg_expr.COMPARE_OP(Operator.GREATER,(m1,pos1),(m2,pos2)) -> - let error,m1' = alg_map f error m1 in - let error,m2' = alg_map f error m2 in - error,Alg_expr.COMPARE_OP(Operator.GREATER,(m1',pos1),(m2',pos2)) - | Alg_expr.COMPARE_OP(Operator.SMALLER,(m1,pos1),(m2,pos2)) -> - let error,m1' = alg_map f error m1 in - let error,m2' = alg_map f error m2 in - error,Alg_expr.COMPARE_OP(Operator.SMALLER,(m1',pos1),(m2',pos2)) - | Alg_expr.COMPARE_OP(Operator.EQUAL,(m1,pos1),(m2,pos2)) -> - let error,m1' = alg_map f error m1 in - let error,m2' = alg_map f error m2 in - error,Alg_expr.COMPARE_OP(Operator.EQUAL,(m1',pos1),(m2',pos2)) - | Alg_expr.COMPARE_OP(Operator.DIFF,(m1,pos1),(m2,pos2)) -> - let error,m1' = alg_map f error m1 in - let error,m2' = alg_map f error m2 in - error,Alg_expr.COMPARE_OP(Operator.DIFF,(m1',pos1),(m2',pos2)) + let error, mixture' = f error mixture in + error, Alg_expr.KAPPA_INSTANCE mixture' + | Alg_expr.CONST x -> error, Alg_expr.CONST x + | Alg_expr.IF ((cond, cond_pos), (yes, yes_pos), (no, no_pos)) -> + let error, cond' = bool_map f error cond in + let error, yes' = alg_map f error yes in + let error, no' = alg_map f error no in + error, Alg_expr.IF ((cond', cond_pos), (yes', yes_pos), (no', no_pos)) -let print_expr_map f error alg = - match - alg - with - | Primitives.Str_pexpr(s) -> error,Primitives.Str_pexpr(s) - | Primitives.Alg_pexpr (alg,pos) -> - let error,alg' = alg_map f error alg in - error,Primitives.Alg_pexpr (alg',pos) - -let map_with_pos map = - (fun f error (x,pos) -> - let error,x' = map f error x in - error,(x',pos) ) +and bool_map f error alg = + match alg with + | Alg_expr.TRUE -> error, Alg_expr.TRUE + | Alg_expr.FALSE -> error, Alg_expr.FALSE + | Alg_expr.UN_BOOL_OP (Operator.NOT, (b1, pos1)) -> + let error, b1' = bool_map f error b1 in + error, Alg_expr.UN_BOOL_OP (Operator.NOT, (b1', pos1)) + | Alg_expr.BIN_BOOL_OP (Operator.AND, (b1, pos1), (b2, pos2)) -> + let error, b1' = bool_map f error b1 in + let error, b2' = bool_map f error b2 in + error, Alg_expr.BIN_BOOL_OP (Operator.AND, (b1', pos1), (b2', pos2)) + | Alg_expr.BIN_BOOL_OP (Operator.OR, (b1, pos1), (b2, pos2)) -> + let error, b1' = bool_map f error b1 in + let error, b2' = bool_map f error b2 in + error, Alg_expr.BIN_BOOL_OP (Operator.OR, (b1', pos1), (b2', pos2)) + | Alg_expr.COMPARE_OP (Operator.GREATER, (m1, pos1), (m2, pos2)) -> + let error, m1' = alg_map f error m1 in + let error, m2' = alg_map f error m2 in + error, Alg_expr.COMPARE_OP (Operator.GREATER, (m1', pos1), (m2', pos2)) + | Alg_expr.COMPARE_OP (Operator.SMALLER, (m1, pos1), (m2, pos2)) -> + let error, m1' = alg_map f error m1 in + let error, m2' = alg_map f error m2 in + error, Alg_expr.COMPARE_OP (Operator.SMALLER, (m1', pos1), (m2', pos2)) + | Alg_expr.COMPARE_OP (Operator.EQUAL, (m1, pos1), (m2, pos2)) -> + let error, m1' = alg_map f error m1 in + let error, m2' = alg_map f error m2 in + error, Alg_expr.COMPARE_OP (Operator.EQUAL, (m1', pos1), (m2', pos2)) + | Alg_expr.COMPARE_OP (Operator.DIFF, (m1, pos1), (m2, pos2)) -> + let error, m1' = alg_map f error m1 in + let error, m2' = alg_map f error m2 in + error, Alg_expr.COMPARE_OP (Operator.DIFF, (m1', pos1), (m2', pos2)) + +let print_expr_map f error alg = + match alg with + | Primitives.Str_pexpr s -> error, Primitives.Str_pexpr s + | Primitives.Alg_pexpr (alg, pos) -> + let error, alg' = alg_map f error alg in + error, Primitives.Alg_pexpr (alg', pos) + +let map_with_pos map f error (x, pos) = + let error, x' = map f error x in + error, (x', pos) let alg_with_pos_map = map_with_pos alg_map let modif_map f_rule f_allowing_question_marks error alg = - match - alg - with - | Ast.APPLY (alg,mixture) -> - let error,alg' = (map_with_pos alg_map) f_allowing_question_marks error alg in - let error,mixture' = f_rule error mixture in - error,Ast.APPLY(alg',mixture') - | Ast.UPDATE (pos,alg) -> - let error,alg' = (map_with_pos alg_map) f_allowing_question_marks error alg in - error,Ast.UPDATE (pos,alg') + match alg with + | Ast.APPLY (alg, mixture) -> + let error, alg' = + (map_with_pos alg_map) f_allowing_question_marks error alg + in + let error, mixture' = f_rule error mixture in + error, Ast.APPLY (alg', mixture') + | Ast.UPDATE (pos, alg) -> + let error, alg' = + (map_with_pos alg_map) f_allowing_question_marks error alg + in + error, Ast.UPDATE (pos, alg') | Ast.STOP list -> - let error,list' = + let error, list' = List.fold_left - (fun (error,list) elt -> - let error,elt' = print_expr_map f_allowing_question_marks error elt in - error,elt'::list) - (error,[]) (List.rev list) + (fun (error, list) elt -> + let error, elt' = + print_expr_map f_allowing_question_marks error elt + in + error, elt' :: list) + (error, []) (List.rev list) in - error,Ast.STOP list' - | Ast.SNAPSHOT (raw,list) -> - let error,list' = + error, Ast.STOP list' + | Ast.SNAPSHOT (raw, list) -> + let error, list' = List.fold_left - (fun (error,list) elt -> - let error,elt' = print_expr_map f_allowing_question_marks error elt in - error,elt'::list) - (error,[]) (List.rev list) + (fun (error, list) elt -> + let error, elt' = + print_expr_map f_allowing_question_marks error elt + in + error, elt' :: list) + (error, []) (List.rev list) in - error,Ast.SNAPSHOT (raw,list') - | Ast.PRINT (list1,list2) -> - let error,list1' = + error, Ast.SNAPSHOT (raw, list') + | Ast.PRINT (list1, list2) -> + let error, list1' = List.fold_left - (fun (error,list) elt -> - let error,elt' = print_expr_map f_allowing_question_marks error elt in - error,elt'::list) - (error,[]) (List.rev list1) + (fun (error, list) elt -> + let error, elt' = + print_expr_map f_allowing_question_marks error elt + in + error, elt' :: list) + (error, []) (List.rev list1) in - let error,list2' = + let error, list2' = List.fold_left - (fun (error,list) elt -> - let error,elt' = print_expr_map f_allowing_question_marks error elt in - error,elt'::list) - (error,[]) (List.rev list2) + (fun (error, list) elt -> + let error, elt' = + print_expr_map f_allowing_question_marks error elt + in + error, elt' :: list) + (error, []) (List.rev list2) in - error,Ast.PRINT (list1',list2') - | Ast.PLOTENTRY -> error,Ast.PLOTENTRY - | Ast.CFLOWLABEL (a,b) -> error,Ast.CFLOWLABEL(a,b) - | Ast.CFLOWMIX (a,(mix,pos)) -> - let error,mix' = f_allowing_question_marks error mix in - error,Ast.CFLOWMIX(a,(mix',pos)) - | Ast.DIN (rel,list) -> - let error,list' = + error, Ast.PRINT (list1', list2') + | Ast.PLOTENTRY -> error, Ast.PLOTENTRY + | Ast.CFLOWLABEL (a, b) -> error, Ast.CFLOWLABEL (a, b) + | Ast.CFLOWMIX (a, (mix, pos)) -> + let error, mix' = f_allowing_question_marks error mix in + error, Ast.CFLOWMIX (a, (mix', pos)) + | Ast.DIN (rel, list) -> + let error, list' = List.fold_left - (fun (error,list) elt -> - let error,elt' = print_expr_map f_allowing_question_marks error elt in - error,elt'::list) - (error,[]) (List.rev list) + (fun (error, list) elt -> + let error, elt' = + print_expr_map f_allowing_question_marks error elt + in + error, elt' :: list) + (error, []) (List.rev list) in - error,Ast.DIN (rel,list') + error, Ast.DIN (rel, list') | Ast.DINOFF list -> - let error,list' = + let error, list' = List.fold_left - (fun (error,list) elt -> - let error,elt' = print_expr_map f_allowing_question_marks error elt in - error,elt'::list) - (error,[]) (List.rev list) + (fun (error, list) elt -> + let error, elt' = + print_expr_map f_allowing_question_marks error elt + in + error, elt' :: list) + (error, []) (List.rev list) in - error,Ast.DINOFF list' - | Ast.SPECIES_OF (a,list,(mix,pos)) -> - let error,list' = + error, Ast.DINOFF list' + | Ast.SPECIES_OF (a, list, (mix, pos)) -> + let error, list' = List.fold_left - (fun (error,list) elt -> - let error,elt' = print_expr_map f_allowing_question_marks error elt in - error,elt'::list) - (error,[]) (List.rev list) + (fun (error, list) elt -> + let error, elt' = + print_expr_map f_allowing_question_marks error elt + in + error, elt' :: list) + (error, []) (List.rev list) in - let error,mix' = f_allowing_question_marks error mix in - error,Ast.SPECIES_OF(a,list',(mix',pos)) - - + let error, mix' = f_allowing_question_marks error mix in + error, Ast.SPECIES_OF (a, list', (mix', pos)) let bool_with_pos_map = map_with_pos bool_map -let with_option_map map f = - (fun error alg -> - match alg - with - | None -> error,None - | Some alg -> - let error,alg'=map f error alg in - error,(Some alg')) +let with_option_map map f error alg = + match alg with + | None -> error, None + | Some alg -> + let error, alg' = map f error alg in + error, Some alg' let alg_with_pos_with_option_map = with_option_map alg_with_pos_map let bool_with_pos_with_option_map = with_option_map bool_with_pos_map let refine_token parameters error token = match Remanent_parameters.get_called_from parameters with -| Remanent_parameters_sig.KaSa -> - Exception.warn - parameters error __POS__ - ~message:"Tokens are not implemented in KaSa yet" - Exit token -| Remanent_parameters_sig.KaSim -| Remanent_parameters_sig.Internalised -| Remanent_parameters_sig.Server -> - error, token + | Remanent_parameters_sig.KaSa -> + Exception.warn parameters error __POS__ + ~message:"Tokens are not implemented in KaSa yet" Exit token + | Remanent_parameters_sig.KaSim | Remanent_parameters_sig.Internalised + | Remanent_parameters_sig.Server -> + error, token let refine_init_t parameters error = function - | Ast.INIT_MIX (mixture,pos) -> - let error,mixture = refine_mixture parameters error mixture in - error,(Ast.INIT_MIX (mixture,pos)) + | Ast.INIT_MIX (mixture, pos) -> + let error, mixture = refine_mixture parameters error mixture in + error, Ast.INIT_MIX (mixture, pos) | Ast.INIT_TOK tk_l -> - let tk_l',error = + let tk_l', error = List_util.fold_right_map - (fun x error -> let (a,b) = refine_token parameters error x in (b,a)) - tk_l error in - error,(Ast.INIT_TOK tk_l') + (fun x error -> + let a, b = refine_token parameters error x in + b, a) + tk_l error + in + error, Ast.INIT_TOK tk_l' let refine_agent parameters error agent_set agent = - let error,agent_set = + let error, agent_set = match agent with - | Ast.Absent _ -> error,agent_set - | Ast.Present ((name,_),_,_) -> - check_freshness parameters error "Agent" name agent_set in + | Ast.Absent _ -> error, agent_set + | Ast.Present ((name, _), _, _) -> + check_freshness parameters error "Agent" name agent_set + in let error, map = - scan_agent - parameters - Ckappa_sig.dummy_agent_id - agent - (error, - Ckappa_sig.Lnk_id_map_and_set.Map.empty - ) + scan_agent parameters Ckappa_sig.dummy_agent_id agent + (error, Ckappa_sig.Lnk_id_map_and_set.Map.empty) in - let agent,(error,_map) = - translate_agent - parameters true agent - (error, (map, - Ckappa_sig.Lnk_id_map_and_set.Set.empty - )) + let agent, (error, _map) = + translate_agent parameters true agent + (error, (map, Ckappa_sig.Lnk_id_map_and_set.Set.empty)) in error, agent_set, agent let refine_var parameters error id_set var = match var with - | ((string,pos),(alg,pos')) -> - let error,id_set = check_freshness parameters error "Label" string id_set in - let error,alg' = alg_map (refine_mixture parameters) error alg - in error,id_set,((string,pos),(alg',pos')) - + | (string, pos), (alg, pos') -> + let error, id_set = + check_freshness parameters error "Label" string id_set + in + let error, alg' = alg_map (refine_mixture parameters) error alg in + error, id_set, ((string, pos), (alg', pos')) let dump_rule rule = let buf = Buffer.create 0 in let fmt = Format.formatter_of_buffer buf in - let () = - Ast.print_ast_rule fmt rule - in + let () = Ast.print_ast_rule fmt rule in let () = Format.pp_print_flush fmt () in Buffer.contents buf let dump_rule_no_rate rule = - let buf = Buffer.create 0 in - let fmt = Format.formatter_of_buffer buf in - let () = - Ast.print_rule_content - ~bidirectional:rule.Ast.bidirectional fmt rule.Ast.rewrite - in - let () = Format.pp_print_flush fmt () in - Buffer.contents buf + let buf = Buffer.create 0 in + let fmt = Format.formatter_of_buffer buf in + let () = + Ast.print_rule_content ~bidirectional:rule.Ast.bidirectional fmt + rule.Ast.rewrite + in + let () = Format.pp_print_flush fmt () in + Buffer.contents buf let translate_compil parameters error compil = - let translate_rule error (rule,pos) = - let (ast_lhs,ast_rhs),(prefix,tail_lhs,tail_rhs) = + let translate_rule error (rule, pos) = + let (ast_lhs, ast_rhs), (prefix, tail_lhs, tail_rhs) = match rule.Ast.rewrite with | Ast.Edit e -> - let (l,r) = Ast.split_mixture e.Ast.mix in + let l, r = Ast.split_mixture e.Ast.mix in (List.flatten l, List.flatten r), (List.length e.Ast.mix, 0, 0) | Ast.Arrow a -> let l = List.flatten a.Ast.lhs in let r = List.flatten a.Ast.rhs in - (l,r), longuest_prefix l r in + (l, r), longuest_prefix l r + in if Remanent_parameters.get_syntax_version parameters = Ast.V4 - && (tail_lhs>0 || tail_rhs>0 ) + && (tail_lhs > 0 || tail_rhs > 0) then - Exception.warn - parameters error ~pos + Exception.warn parameters error ~pos ~message:"missaligned rule: the rule is ignored" __POS__ Exit None - else - let error,lhs = - refine_mixture_in_rule parameters error prefix 0 tail_rhs ast_lhs in - let error,rhs = - refine_mixture_in_rule parameters error prefix tail_lhs 0 ast_rhs in - let error,k_def = - alg_with_pos_map (refine_mixture parameters) error rule.Ast.k_def in - let error,k_un = + else ( + let error, lhs = + refine_mixture_in_rule parameters error prefix 0 tail_rhs ast_lhs + in + let error, rhs = + refine_mixture_in_rule parameters error prefix tail_lhs 0 ast_rhs + in + let error, k_def = + alg_with_pos_map (refine_mixture parameters) error rule.Ast.k_def + in + let error, k_un = alg_with_pos_with_option_map - (refine_mixture parameters) error - (Tools_kasa.fst_option rule.Ast.k_un) in + (refine_mixture parameters) + error + (Tools_kasa.fst_option rule.Ast.k_un) + in let original_ast = dump_rule rule in let original_ast_no_rate = dump_rule_no_rate rule in - let rule_direct = {rule with Ast.bidirectional = false} in + let rule_direct = { rule with Ast.bidirectional = false } in let direct_ast = dump_rule rule_direct in let direct_ast_no_rate = dump_rule_no_rate rule_direct in - error, - Some { - Ckappa_sig.position = pos ; - Ckappa_sig.prefix = prefix ; - Ckappa_sig.interprete_delta = Ckappa_sig.Direct ; - Ckappa_sig.delta = tail_lhs ; - Ckappa_sig.lhs = lhs ; - Ckappa_sig.rhs = rhs ; - Ckappa_sig.k_def = k_def ; - Ckappa_sig.k_un = k_un ; - Ckappa_sig.ast = direct_ast ; - Ckappa_sig.ast_no_rate = direct_ast_no_rate ; - Ckappa_sig.original_ast = original_ast ; - Ckappa_sig.original_ast_no_rate = original_ast_no_rate ; - Ckappa_sig.from_a_biderectional_rule = rule.Ast.bidirectional; - } in + ( error, + Some + { + Ckappa_sig.position = pos; + Ckappa_sig.prefix; + Ckappa_sig.interprete_delta = Ckappa_sig.Direct; + Ckappa_sig.delta = tail_lhs; + Ckappa_sig.lhs; + Ckappa_sig.rhs; + Ckappa_sig.k_def; + Ckappa_sig.k_un; + Ckappa_sig.ast = direct_ast; + Ckappa_sig.ast_no_rate = direct_ast_no_rate; + Ckappa_sig.original_ast; + Ckappa_sig.original_ast_no_rate; + Ckappa_sig.from_a_biderectional_rule = rule.Ast.bidirectional; + } ) + ) + in let id_set = Mods.StringSet.empty in let agent_set = Mods.StringSet.empty in - let error,id_set,var_rev = + let error, id_set, var_rev = List.fold_left - (fun (error,id_set,list) var -> - let error,id_set,var = refine_var parameters error id_set var in - error,id_set,(var::list)) - (error,id_set,[]) - compil.Ast.variables + (fun (error, id_set, list) var -> + let error, id_set, var = refine_var parameters error id_set var in + error, id_set, var :: list) + (error, id_set, []) compil.Ast.variables in - let error,_agent_set,signatures_rev = + let error, _agent_set, signatures_rev = List.fold_left - (fun (error,agent_set,list) agent-> - let error,agent_set,agent = - refine_agent parameters error agent_set agent in - match agent with - | None -> - let error, () = - Exception.warn parameters error __POS__ Exit ~message:"There shall be no missing agents in agent declarations" () in - error, agent_set, list - | Some agent -> - error,agent_set,(agent::list)) - (error,agent_set,[]) - compil.Ast.signatures + (fun (error, agent_set, list) agent -> + let error, agent_set, agent = + refine_agent parameters error agent_set agent + in + match agent with + | None -> + let error, () = + Exception.warn parameters error __POS__ Exit + ~message:"There shall be no missing agents in agent declarations" + () + in + error, agent_set, list + | Some agent -> error, agent_set, agent :: list) + (error, agent_set, []) compil.Ast.signatures in - let error,observables_rev = + let error, observables_rev = List.fold_left - (fun (error,list) alg -> - let error,alg' = - alg_with_pos_map (refine_mixture parameters) error alg in - error,alg'::list) - (error,[]) - compil.Ast.observables + (fun (error, list) alg -> + let error, alg' = + alg_with_pos_map (refine_mixture parameters) error alg + in + error, alg' :: list) + (error, []) compil.Ast.observables in - let error,_id_set,rules_rev = + let error, _id_set, rules_rev = List.fold_left - (fun (error,id_set,list) (id,(rule,p)) -> - let error,id_set = - match id with - | None -> error,id_set - | Some id -> check_freshness parameters error "Label" (fst id) id_set - in - match translate_rule error (rule,p) with - | error, None -> error, id_set, list - | error, Some direct -> - if rule.Ast.bidirectional then - let rewrite = match rule.Ast.rewrite with - | Ast.Edit _ -> - failwith "bidirectional edit rules are impossible" - | Ast.Arrow a -> - Ast.Arrow { - Ast.lhs = a.Ast.rhs; - Ast.rhs = a.Ast.lhs; - Ast.rm_token = a.Ast.add_token; - Ast.add_token = a.Ast.rm_token; - } in - let reverse_rule = - { - Ast.rewrite; - Ast.bidirectional = false; - Ast.k_def = - (match rule.Ast.k_op with - | None -> Alg_expr.const Nbr.zero - | Some k -> k); - Ast.k_un = rule.Ast.k_op_un ; - Ast.k_op_un = None ; - Ast.k_op = None; - } - in - let reverse_ast = dump_rule reverse_rule in - let reverse_ast_no_rate = dump_rule_no_rate reverse_rule in - let error,reverse = - let error,k_op = - alg_with_pos_map - (refine_mixture parameters) error - (Option_util.unsome (Alg_expr.const Nbr.zero) rule.Ast.k_op) in - let error,k_op_un = - alg_with_pos_with_option_map (refine_mixture parameters) error - (Tools_kasa.fst_option rule.Ast.k_op_un) in - error, - { - Ckappa_sig.position = p ; - Ckappa_sig.prefix = direct.Ckappa_sig.prefix ; - Ckappa_sig.delta = direct.Ckappa_sig.delta ; - Ckappa_sig.interprete_delta = Ckappa_sig.Reverse ; - Ckappa_sig.lhs = direct.Ckappa_sig.rhs ; - Ckappa_sig.rhs = direct.Ckappa_sig.lhs ; - Ckappa_sig.k_def = k_op ; - Ckappa_sig.k_un = k_op_un ; - Ckappa_sig.ast = reverse_ast ; - Ckappa_sig.ast_no_rate = reverse_ast_no_rate ; - Ckappa_sig.original_ast = direct.Ckappa_sig.original_ast ; - Ckappa_sig.original_ast_no_rate = - direct.Ckappa_sig.original_ast_no_rate ; - Ckappa_sig.from_a_biderectional_rule = rule.Ast.bidirectional ; - } in - error, id_set, (id,(reverse,p))::(id,(direct,p))::list - else error, id_set, (id,(direct,p))::list) - (error,id_set,[]) - compil.Ast.rules + (fun (error, id_set, list) (id, (rule, p)) -> + let error, id_set = + match id with + | None -> error, id_set + | Some id -> check_freshness parameters error "Label" (fst id) id_set + in + match translate_rule error (rule, p) with + | error, None -> error, id_set, list + | error, Some direct -> + if rule.Ast.bidirectional then ( + let rewrite = + match rule.Ast.rewrite with + | Ast.Edit _ -> failwith "bidirectional edit rules are impossible" + | Ast.Arrow a -> + Ast.Arrow + { + Ast.lhs = a.Ast.rhs; + Ast.rhs = a.Ast.lhs; + Ast.rm_token = a.Ast.add_token; + Ast.add_token = a.Ast.rm_token; + } + in + let reverse_rule = + { + Ast.rewrite; + Ast.bidirectional = false; + Ast.k_def = + (match rule.Ast.k_op with + | None -> Alg_expr.const Nbr.zero + | Some k -> k); + Ast.k_un = rule.Ast.k_op_un; + Ast.k_op_un = None; + Ast.k_op = None; + } + in + let reverse_ast = dump_rule reverse_rule in + let reverse_ast_no_rate = dump_rule_no_rate reverse_rule in + let error, reverse = + let error, k_op = + alg_with_pos_map + (refine_mixture parameters) + error + (Option_util.unsome (Alg_expr.const Nbr.zero) rule.Ast.k_op) + in + let error, k_op_un = + alg_with_pos_with_option_map + (refine_mixture parameters) + error + (Tools_kasa.fst_option rule.Ast.k_op_un) + in + ( error, + { + Ckappa_sig.position = p; + Ckappa_sig.prefix = direct.Ckappa_sig.prefix; + Ckappa_sig.delta = direct.Ckappa_sig.delta; + Ckappa_sig.interprete_delta = Ckappa_sig.Reverse; + Ckappa_sig.lhs = direct.Ckappa_sig.rhs; + Ckappa_sig.rhs = direct.Ckappa_sig.lhs; + Ckappa_sig.k_def = k_op; + Ckappa_sig.k_un = k_op_un; + Ckappa_sig.ast = reverse_ast; + Ckappa_sig.ast_no_rate = reverse_ast_no_rate; + Ckappa_sig.original_ast = direct.Ckappa_sig.original_ast; + Ckappa_sig.original_ast_no_rate = + direct.Ckappa_sig.original_ast_no_rate; + Ckappa_sig.from_a_biderectional_rule = rule.Ast.bidirectional; + } ) + in + error, id_set, (id, (reverse, p)) :: (id, (direct, p)) :: list + ) else + error, id_set, (id, (direct, p)) :: list) + (error, id_set, []) compil.Ast.rules in - let error,init_rev = + let error, init_rev = List.fold_left - (fun (error,list) (alg_ex,init_t) -> - let error,alg = - alg_with_pos_map (refine_mixture parameters) error alg_ex in - let error,init = refine_init_t parameters error init_t in - error,(alg,init)::list) - (error,[]) - compil.Ast.init in - let error,perturbations_rev,rules_rev = + (fun (error, list) (alg_ex, init_t) -> + let error, alg = + alg_with_pos_map (refine_mixture parameters) error alg_ex + in + let error, init = refine_init_t parameters error init_t in + error, (alg, init) :: list) + (error, []) compil.Ast.init + in + let error, perturbations_rev, rules_rev = List.fold_left - (fun (error,list,rules_rev) ((alarm,b,m,o),p) -> - let error,b' = match b with - | None -> error,None - | Some b -> - let error,b' = - bool_with_pos_map (refine_mixture parameters) error b in - error,Some b' - in - let error,o' = - bool_with_pos_with_option_map (refine_mixture parameters) error o - in - let error,m',rules_rev' = - List.fold_left - (fun (error,list,rules_rev) m -> - match m with - | Ast.APPLY (a,(_,p as r)) -> - let error,a' = alg_with_pos_map (refine_mixture parameters) error a in - (match translate_rule error r with - | error, None -> error,list,rules_rev - | error, Some m' -> - error,Ast.APPLY(a',(m',p))::list,(None,(m',p))::rules_rev) - | Ast.UPDATE (x,y) -> - let error,y' = alg_with_pos_map (refine_mixture parameters) error y in - error,(Ast.UPDATE (x,y'))::list,rules_rev - | Ast.STOP l -> - let error,l' = - List.fold_left - (fun (error,l) x -> - let error,x' = print_expr_map (refine_mixture parameters) error x in - error,(x'::l) - ) - (error,[]) (List.rev l) - in - error,(Ast.STOP l')::list,rules_rev - | Ast.SNAPSHOT (raw,l) -> - let error,l' = - List.fold_left - (fun (error,l) x -> - let error,x' = print_expr_map (refine_mixture parameters) error x in - error,(x'::l) - ) - (error,[]) (List.rev l) - in - error,(Ast.SNAPSHOT (raw,l'))::list,rules_rev - | Ast.PRINT _ | Ast.DIN _ | Ast.DINOFF _ | Ast.CFLOWMIX _ - | Ast.PLOTENTRY | Ast.CFLOWLABEL _ | Ast.SPECIES_OF _ -> - error,list,rules_rev (*to do*)) - (error,[],rules_rev) - m - in - error,((alarm,b',List.rev m',o'),p)::list,rules_rev' - ) - (error,[],rules_rev) - compil.Ast.perturbations + (fun (error, list, rules_rev) ((alarm, b, m, o), p) -> + let error, b' = + match b with + | None -> error, None + | Some b -> + let error, b' = + bool_with_pos_map (refine_mixture parameters) error b + in + error, Some b' + in + let error, o' = + bool_with_pos_with_option_map (refine_mixture parameters) error o + in + let error, m', rules_rev' = + List.fold_left + (fun (error, list, rules_rev) m -> + match m with + | Ast.APPLY (a, ((_, p) as r)) -> + let error, a' = + alg_with_pos_map (refine_mixture parameters) error a + in + (match translate_rule error r with + | error, None -> error, list, rules_rev + | error, Some m' -> + ( error, + Ast.APPLY (a', (m', p)) :: list, + (None, (m', p)) :: rules_rev )) + | Ast.UPDATE (x, y) -> + let error, y' = + alg_with_pos_map (refine_mixture parameters) error y + in + error, Ast.UPDATE (x, y') :: list, rules_rev + | Ast.STOP l -> + let error, l' = + List.fold_left + (fun (error, l) x -> + let error, x' = + print_expr_map (refine_mixture parameters) error x + in + error, x' :: l) + (error, []) (List.rev l) + in + error, Ast.STOP l' :: list, rules_rev + | Ast.SNAPSHOT (raw, l) -> + let error, l' = + List.fold_left + (fun (error, l) x -> + let error, x' = + print_expr_map (refine_mixture parameters) error x + in + error, x' :: l) + (error, []) (List.rev l) + in + error, Ast.SNAPSHOT (raw, l') :: list, rules_rev + | Ast.PRINT _ | Ast.DIN _ | Ast.DINOFF _ | Ast.CFLOWMIX _ + | Ast.PLOTENTRY | Ast.CFLOWLABEL _ | Ast.SPECIES_OF _ -> + error, list, rules_rev (*to do*)) + (error, [], rules_rev) m + in + error, ((alarm, b', List.rev m', o'), p) :: list, rules_rev') + (error, [], rules_rev) compil.Ast.perturbations in - error,{ - Ast.filenames = compil.Ast.filenames; - Ast.variables = List.rev var_rev; - Ast.signatures = List.rev signatures_rev; - Ast.rules = List.rev rules_rev ; - Ast.observables = List.rev observables_rev; - Ast.init = List.rev init_rev ; - Ast.perturbations = List.rev perturbations_rev ; - Ast.configurations = compil.Ast.configurations ; - Ast.tokens = compil.Ast.tokens ; - Ast.volumes = compil.Ast.volumes - } + ( error, + { + Ast.filenames = compil.Ast.filenames; + Ast.variables = List.rev var_rev; + Ast.signatures = List.rev signatures_rev; + Ast.rules = List.rev rules_rev; + Ast.observables = List.rev observables_rev; + Ast.init = List.rev init_rev; + Ast.perturbations = List.rev perturbations_rev; + Ast.configurations = compil.Ast.configurations; + Ast.tokens = compil.Ast.tokens; + Ast.volumes = compil.Ast.volumes; + } ) diff --git a/core/KaSa_rep/frontend/prepreprocess.mli b/core/KaSa_rep/frontend/prepreprocess.mli index 88276d1175..175261cffd 100644 --- a/core/KaSa_rep/frontend/prepreprocess.mli +++ b/core/KaSa_rep/frontend/prepreprocess.mli @@ -1,48 +1,66 @@ -val local_trace:bool +val local_trace : bool -val translate_compil: +val translate_compil : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - (Ast.agent, Ast.mixture, Ast.agent list list, string, Ast.rule) - Ast.compil -> - Exception_without_parameter.method_handler * - (Ckappa_sig.agent, Ckappa_sig.mixture, Ckappa_sig.mixture, - string, Ckappa_sig.mixture Ckappa_sig.rule) + (Ast.agent, Ast.mixture, Ast.agent list list, string, Ast.rule) Ast.compil -> + Exception_without_parameter.method_handler + * ( Ckappa_sig.agent, + Ckappa_sig.mixture, + Ckappa_sig.mixture, + string, + Ckappa_sig.mixture Ckappa_sig.rule ) Ast.compil -val modif_map: - ('a -> 'b Locality.annot -> 'a * 'c Locality.annot) -> +val modif_map : + ('a -> 'b Loc.annoted -> 'a * 'c Loc.annoted) -> ('a -> 'd -> 'a * 'e) -> 'a -> ('d, 'f, 'g, 'b) Ast.modif_expr -> 'a * ('e, 'h, 'g, 'c) Ast.modif_expr -val rev_ast:'a list -> 'a list -val add_entry: +val rev_ast : 'a list -> 'a list + +val add_entry : Remanent_parameters_sig.parameters -> Ckappa_sig.c_agent_id -> 'a -> 'b -> 'c -> - Exception_without_parameter.method_handler * - ('a * 'b * 'c) list Ckappa_sig.Agent_id_map_and_set.Map.t -> - Exception_without_parameter.method_handler * - ('a * 'b * 'c) list Ckappa_sig.Agent_id_map_and_set.Map.t + Exception_without_parameter.method_handler + * ('a * 'b * 'c) list Ckappa_sig.Agent_id_map_and_set.Map.t -> + Exception_without_parameter.method_handler + * ('a * 'b * 'c) list Ckappa_sig.Agent_id_map_and_set.Map.t -val map_with_pos: +val map_with_pos : ('a -> 'b -> 'c -> Exception_without_parameter.method_handler * 'e) -> - 'a -> 'b -> 'c * 'f -> Exception_without_parameter.method_handler * ('e * 'f) + 'a -> + 'b -> + 'c * 'f -> + Exception_without_parameter.method_handler * ('e * 'f) -val alg_map: - (Exception_without_parameter.method_handler -> 'b -> - Exception_without_parameter.method_handler * 'c) -> - Exception_without_parameter.method_handler -> ('b, 'd) Alg_expr.e -> +val alg_map : + (Exception_without_parameter.method_handler -> + 'b -> + Exception_without_parameter.method_handler * 'c) -> + Exception_without_parameter.method_handler -> + ('b, 'd) Alg_expr.e -> Exception_without_parameter.method_handler * ('c, 'd) Alg_expr.e -val bool_map: - (Exception_without_parameter.method_handler -> 'b -> Exception_without_parameter.method_handler * 'c) -> - Exception_without_parameter.method_handler -> ('b, 'd) Alg_expr.bool -> Exception_without_parameter.method_handler * ('c, 'd) Alg_expr.bool +val bool_map : + (Exception_without_parameter.method_handler -> + 'b -> + Exception_without_parameter.method_handler * 'c) -> + Exception_without_parameter.method_handler -> + ('b, 'd) Alg_expr.bool -> + Exception_without_parameter.method_handler * ('c, 'd) Alg_expr.bool -val with_option_map: - ('a -> Exception_without_parameter.method_handler -> 'c -> Exception_without_parameter.method_handler * 'd) -> - 'a -> Exception_without_parameter.method_handler -> 'c option -> Exception_without_parameter.method_handler * 'd option +val with_option_map : + ('a -> + Exception_without_parameter.method_handler -> + 'c -> + Exception_without_parameter.method_handler * 'd) -> + 'a -> + Exception_without_parameter.method_handler -> + 'c option -> + Exception_without_parameter.method_handler * 'd option diff --git a/core/KaSa_rep/frontend/preprocess.ml b/core/KaSa_rep/frontend/preprocess.ml index 3f9fa45afb..9441581231 100644 --- a/core/KaSa_rep/frontend/preprocess.ml +++ b/core/KaSa_rep/frontend/preprocess.ml @@ -15,1522 +15,1340 @@ let local_trace = false let empty_agent handler error = - let error, interface = Int_storage.Quick_Nearly_inf_Imperatif.create handler error 0 in - error, { - Cckappa_sig.agent_kasim_id = Ckappa_sig.dummy_agent_id; - Cckappa_sig.agent_name = Ckappa_sig.dummy_agent_name; - Cckappa_sig.agent_interface = interface; - Cckappa_sig.agent_position = Locality.dummy; - Cckappa_sig.is_created = false; - } + let error, interface = + Int_storage.Quick_Nearly_inf_Imperatif.create handler error 0 + in + ( error, + { + Cckappa_sig.agent_kasim_id = Ckappa_sig.dummy_agent_id; + Cckappa_sig.agent_name = Ckappa_sig.dummy_agent_name; + Cckappa_sig.agent_interface = interface; + Cckappa_sig.agent_position = Loc.dummy; + Cckappa_sig.is_created = false; + } ) let empty_mixture handler error = let error, views = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create handler error 0 + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create handler + error 0 in let error, bonds = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create - handler - error - 0 - in - error, - { - Cckappa_sig.views= views ; - Cckappa_sig.bonds= bonds; - Cckappa_sig.plus=[]; - Cckappa_sig.dot=[]; - Cckappa_sig.c_mixture = Ckappa_sig.EMPTY_MIX} + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create handler + error 0 + in + ( error, + { + Cckappa_sig.views; + Cckappa_sig.bonds; + Cckappa_sig.plus = []; + Cckappa_sig.dot = []; + Cckappa_sig.c_mixture = Ckappa_sig.EMPTY_MIX; + } ) -let empty_pos = ("",0,0) +let empty_pos = "", 0, 0 -let empty_rule handler error = +let empty_rule handler error = let error, empty_lhs = empty_mixture handler error in let error, empty_rhs = empty_mixture handler error in let error, empty_direct = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create handler error 0 + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create handler + error 0 in let error, empty_reverse = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create handler error 0 - in - error, { - Cckappa_sig.prefix = 0 ; - Cckappa_sig.delta = 0 ; - Cckappa_sig.rule_lhs = empty_lhs ; - Cckappa_sig.rule_rhs = empty_rhs ; - diff_direct = empty_direct ; - diff_reverse = empty_reverse ; - actions = Cckappa_sig.empty_actions - } + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create handler + error 0 + in + ( error, + { + Cckappa_sig.prefix = 0; + Cckappa_sig.delta = 0; + Cckappa_sig.rule_lhs = empty_lhs; + Cckappa_sig.rule_rhs = empty_rhs; + diff_direct = empty_direct; + diff_reverse = empty_reverse; + actions = Cckappa_sig.empty_actions; + } ) let empty_e_rule handler error = - let error,rule = empty_rule handler error in - error, - { - Cckappa_sig.e_rule_label= None ; - Cckappa_sig.e_rule_label_dot = None ; - Cckappa_sig.e_rule_initial_direction = Ckappa_sig.Direct ; - Cckappa_sig.e_rule_rule = - { - Ckappa_sig.position = Locality.dummy ; - Ckappa_sig.prefix = 0; - Ckappa_sig.delta = 0; - Ckappa_sig.interprete_delta = Ckappa_sig.Direct ; - Ckappa_sig.lhs = Ckappa_sig.EMPTY_MIX ; - Ckappa_sig.rhs = Ckappa_sig.EMPTY_MIX; - Ckappa_sig.k_def = Alg_expr.const Nbr.zero; - Ckappa_sig.k_un = None ; - Ckappa_sig.ast = ""; - Ckappa_sig.ast_no_rate = ""; - Ckappa_sig.original_ast = ""; - Ckappa_sig.original_ast_no_rate = ""; - Ckappa_sig.from_a_biderectional_rule = false ; - }; - Cckappa_sig.e_rule_c_rule = rule } + let error, rule = empty_rule handler error in + ( error, + { + Cckappa_sig.e_rule_label = None; + Cckappa_sig.e_rule_label_dot = None; + Cckappa_sig.e_rule_initial_direction = Ckappa_sig.Direct; + Cckappa_sig.e_rule_rule = + { + Ckappa_sig.position = Loc.dummy; + Ckappa_sig.prefix = 0; + Ckappa_sig.delta = 0; + Ckappa_sig.interprete_delta = Ckappa_sig.Direct; + Ckappa_sig.lhs = Ckappa_sig.EMPTY_MIX; + Ckappa_sig.rhs = Ckappa_sig.EMPTY_MIX; + Ckappa_sig.k_def = Alg_expr.const Nbr.zero; + Ckappa_sig.k_un = None; + Ckappa_sig.ast = ""; + Ckappa_sig.ast_no_rate = ""; + Ckappa_sig.original_ast = ""; + Ckappa_sig.original_ast_no_rate = ""; + Ckappa_sig.from_a_biderectional_rule = false; + }; + Cckappa_sig.e_rule_c_rule = rule; + } ) let rename_rule_rlhs handler error id_agent tab = - let error,agent = + let error, agent = Misc_sa.unsome - (Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get handler error id_agent tab) - (fun error -> - Exception.warn handler error __POS__ Exit Cckappa_sig.Ghost) + (Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get handler + error id_agent tab) (fun error -> + Exception.warn handler error __POS__ Exit Cckappa_sig.Ghost) in match agent with - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent _ -> + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + -> Exception.warn handler error __POS__ Exit Ckappa_sig.dummy_agent_id - | Cckappa_sig.Agent ag -> error,ag.Cckappa_sig.agent_kasim_id + | Cckappa_sig.Agent ag -> error, ag.Cckappa_sig.agent_kasim_id let rename_rule_rhs handler error id_agent rule = - rename_rule_rlhs handler error id_agent rule.Cckappa_sig.rule_rhs.Cckappa_sig.views + rename_rule_rlhs handler error id_agent + rule.Cckappa_sig.rule_rhs.Cckappa_sig.views let rename_rule_lhs handler error id_agent rule = - rename_rule_rlhs handler error id_agent rule.Cckappa_sig.rule_lhs.Cckappa_sig.views + rename_rule_rlhs handler error id_agent + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views let length_mixture mixture = let rec aux mixture size = match mixture with | Ckappa_sig.EMPTY_MIX -> size - | Ckappa_sig.COMMA(_,mixture) - | Ckappa_sig.DOT(_,_,mixture) - | Ckappa_sig.PLUS(_,_,mixture) - | Ckappa_sig.SKIP(mixture)-> aux mixture (size+1) - in aux mixture 0 + | Ckappa_sig.COMMA (_, mixture) + | Ckappa_sig.DOT (_, _, mixture) + | Ckappa_sig.PLUS (_, _, mixture) + | Ckappa_sig.SKIP mixture -> + aux mixture (size + 1) + in + aux mixture 0 -let add_bond parameters error _i id_agent _agent site id_agent' agent' site' bond_list = - let error,old = +let add_bond parameters error _i id_agent _agent site id_agent' agent' site' + bond_list = + let error, old = match Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - id_agent - bond_list + parameters error id_agent bond_list with - | _,None -> error, Ckappa_sig.Site_map_and_set.Map.empty - | _,Some i -> error,i + | _, None -> error, Ckappa_sig.Site_map_and_set.Map.empty + | _, Some i -> error, i in let error', updated = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site + Ckappa_sig.Site_map_and_set.Map.add parameters error site { - Cckappa_sig.agent_index = id_agent' ; - Cckappa_sig.agent_type = agent' ; - Cckappa_sig.site = site' - } old + Cckappa_sig.agent_index = id_agent'; + Cckappa_sig.agent_type = agent'; + Cckappa_sig.site = site'; + } + old in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - id_agent - updated - bond_list + Exception.check_point Exception.warn parameters error error' __POS__ Exit + in + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error id_agent updated bond_list -let translate_agent_sig - parameters error handler agent (kasim_id:Ckappa_sig.c_agent_id) map = +let translate_agent_sig parameters error handler agent + (kasim_id : Ckappa_sig.c_agent_id) map = let error, (bool, output) = - Ckappa_sig.Dictionary_of_agents.allocate_bool - parameters - error - Ckappa_sig.compare_unit_agent_name - agent.Ckappa_sig.ag_nme - () - Misc_sa.const_unit - handler.Cckappa_sig.agents_dic + Ckappa_sig.Dictionary_of_agents.allocate_bool parameters error + Ckappa_sig.compare_unit_agent_name agent.Ckappa_sig.agent_name () + Misc_sa.const_unit handler.Cckappa_sig.agents_dic in let error, agent_name = match bool, output with - | _ , None - | true, _ -> Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_agent_name - | _ , Some (i, _, _, _) -> - error, i + | _, None | true, _ -> + Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_agent_name + | _, Some (i, _, _, _) -> error, i in let error, site_dic = match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_name - handler.Cckappa_sig.sites + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_name handler.Cckappa_sig.sites with - | error,None -> - Exception.warn - parameters error __POS__ Exit + | error, None -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.Dictionary_of_sites.init ()) | error, Some i -> error, i in let error, c_interface = error, Ckappa_sig.Site_map_and_set.Map.empty in let rec aux interface error c_interface map = match interface with - | Ckappa_sig.EMPTY_INTF -> error,c_interface,map - | Ckappa_sig.COUNTER_SEP(counter,interface) -> + | Ckappa_sig.EMPTY_INTF -> error, c_interface, map + | Ckappa_sig.COUNTER_SEP (counter, interface) -> let error, c_interface, map = let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Counter counter.Ckappa_sig.count_nme) - () - Misc_sa.const_unit - site_dic + (Ckappa_sig.Counter counter.Ckappa_sig.counter_name) () + Misc_sa.const_unit site_dic in let error, counter_name = match bool, output with - | _, None - | true, _ -> - Exception.warn parameters error - __POS__ - ~message:(agent.Ckappa_sig.ag_nme ^ - " " ^ - counter.Ckappa_sig.count_nme) - Exit (Ckappa_sig.dummy_site_name) - | _, Some (i,_,_,_) -> error, i + | _, None | true, _ -> + Exception.warn parameters error __POS__ + ~message: + (agent.Ckappa_sig.agent_name ^ " " + ^ counter.Ckappa_sig.counter_name) + Exit Ckappa_sig.dummy_site_name + | _, Some (i, _, _, _) -> error, i in - let (error',c_interface),test = + let (error', c_interface), test = let test = - match - counter.Ckappa_sig.count_test - with - | Some (Ckappa_sig.CEQ i) -> - [Ckappa_sig.state_index_of_int i] + match counter.Ckappa_sig.counter_test with + | Some (Ckappa_sig.CEQ i) -> [ Ckappa_sig.state_index_of_int i ] | Some (Ckappa_sig.CGTE _) - | Some (Ckappa_sig.CVAR _ ) + | Some (Ckappa_sig.CVAR _) | Some Ckappa_sig.UNKNOWN - | None -> [] + | None -> + [] in - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - counter_name - { - Cckappa_sig.site_name = counter_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_state = test ; - Cckappa_sig.site_free = None - } c_interface, test + ( Ckappa_sig.Site_map_and_set.Map.add parameters error counter_name + { + Cckappa_sig.site_name = counter_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_state = test; + Cckappa_sig.site_free = None; + } + c_interface, + test ) in let error = - Exception.check_point Exception.warn parameters error error' __POS__ Exit in + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in let error, map = - Ckappa_sig.AgentSite_map_and_set.Map.add - parameters error + Ckappa_sig.AgentSite_map_and_set.Map.add parameters error (agent_name, counter_name) (match test with - | [i] -> Some i - | [] | _::_::_ -> None) + | [ i ] -> Some i + | [] | _ :: _ :: _ -> None) map in error, c_interface, map - in aux interface error c_interface map - | Ckappa_sig.PORT_SEP(port,interface) -> - let error,c_interface = + in + aux interface error c_interface map + | Ckappa_sig.PORT_SEP (port, interface) -> + let error, c_interface = match port.Ckappa_sig.port_int with - | [] - -> error,c_interface + | [] -> error, c_interface | list -> let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Internal port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic + (Ckappa_sig.Internal port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic in let error, site_name = match bool, output with - | _ , None - | true, _ -> Exception.warn parameters error - __POS__ - ~message:(agent.Ckappa_sig.ag_nme ^ - " " ^ - port.Ckappa_sig.port_nme) - Exit (Ckappa_sig.dummy_site_name) - | _ , Some (i, _, _, _) -> error, i + | _, None | true, _ -> + Exception.warn parameters error __POS__ + ~message: + (agent.Ckappa_sig.agent_name ^ " " ^ port.Ckappa_sig.port_name) + Exit Ckappa_sig.dummy_site_name + | _, Some (i, _, _, _) -> error, i in let error, state_dic = Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, site_name) + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, site_name) handler.Cckappa_sig.states_dic) (fun error -> - Exception.warn parameters error __POS__ Exit + Exception.warn parameters error __POS__ Exit (Ckappa_sig.Dictionary_of_States.init ())) in let error, internal_list = List.fold_left (fun (error, internal_list) state -> - match state with - | None -> - Exception.warn parameters error - __POS__ Exit - internal_list - | Some a -> - - let error, (bool, output) = - Ckappa_sig.Dictionary_of_States.allocate_bool - parameters - error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Internal a) - () - Misc_sa.const_unit - state_dic - in - let error, internal = - match bool, output with - | _ , None - | true, _ -> Exception.warn - parameters error __POS__ Exit ( Ckappa_sig.dummy_state_index) - | _ , Some (i, _, _, _) -> - error, i - in - error, internal :: internal_list) + match state with + | None -> + Exception.warn parameters error __POS__ Exit internal_list + | Some a -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_States.allocate_bool parameters + error Ckappa_sig.compare_unit_state_index + (Ckappa_sig.Internal a) () Misc_sa.const_unit state_dic + in + let error, internal = + match bool, output with + | _, None | true, _ -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_state_index + | _, Some (i, _, _, _) -> error, i + in + error, internal :: internal_list) (error, []) list in - let error',c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; (*port.Ckappa_sig.port_pos ;*) - Cckappa_sig.site_state = internal_list ; - Cckappa_sig.site_free = port.Ckappa_sig.port_free - } c_interface + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + (*port.Ckappa_sig.port_pos ;*) + Cckappa_sig.site_state = internal_list; + Cckappa_sig.site_free = port.Ckappa_sig.port_free; + } + c_interface in let error = - Exception.check_point Exception.warn parameters error error' __POS__ Exit in + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in error, c_interface in let error, c_interface = - match port.Ckappa_sig.port_lnk with + match port.Ckappa_sig.port_link with | Ckappa_sig.LNK_ANY _ | Ckappa_sig.LNK_MISSING -> Exception.warn parameters error __POS__ Exit c_interface | Ckappa_sig.FREE -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + (match bool, output with + | _, None | true, _ -> error, c_interface + | _, Some (site_name, _, _, _) -> + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_state = [ Ckappa_sig.dummy_state_index ]; + Cckappa_sig.site_free = port.Ckappa_sig.port_free; + } + c_interface in - match bool, output with - | _ , None - | true, _ -> error, c_interface - | _ , Some (site_name, _, _, _) -> - let error', c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters error site_name - { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_state = [ Ckappa_sig.dummy_state_index] ; - Cckappa_sig.site_free = port.Ckappa_sig.port_free - } - c_interface - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error, c_interface - - end + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + error, c_interface) | Ckappa_sig.LNK_SOME _pos -> - Exception.warn - parameters error __POS__ Exit c_interface + Exception.warn parameters error __POS__ Exit c_interface | Ckappa_sig.LNK_VALUE (_i, _agent', _site', _id_agent', _pos) -> Exception.warn parameters error __POS__ Exit c_interface - | Ckappa_sig.LNK_TYPE (_agent',_site') -> + | Ckappa_sig.LNK_TYPE (_agent', _site') -> Exception.warn parameters error __POS__ Exit c_interface - in aux interface error c_interface map - in - let error,c_interface,map = aux agent.Ckappa_sig.ag_intf error c_interface map in - error, - ({ - Cckappa_sig.agent_kasim_id = kasim_id ; - Cckappa_sig.agent_name = agent_name ; - Cckappa_sig.agent_interface = c_interface ; - Cckappa_sig.agent_position = Locality.dummy ; - Cckappa_sig.is_created = false ; - }:Cckappa_sig.agent_sig), map - -let translate_view parameters error handler (k:Ckappa_sig.c_agent_id) - (kasim_id:Ckappa_sig.c_agent_id) ~creation agent bond_list question_marks delta = + in + aux interface error c_interface map + in + let error, c_interface, map = + aux agent.Ckappa_sig.ag_intf error c_interface map + in + ( error, + ({ + Cckappa_sig.agent_kasim_id = kasim_id; + Cckappa_sig.agent_name; + Cckappa_sig.agent_interface = c_interface; + Cckappa_sig.agent_position = Loc.dummy; + Cckappa_sig.is_created = false; + } + : Cckappa_sig.agent_sig), + map ) + +let translate_view parameters error handler (k : Ckappa_sig.c_agent_id) + (kasim_id : Ckappa_sig.c_agent_id) ~creation agent bond_list question_marks + delta = let error, (bool, output) = - Ckappa_sig.Dictionary_of_agents.allocate_bool - parameters - error - Ckappa_sig.compare_unit_agent_name - agent.Ckappa_sig.ag_nme - () - Misc_sa.const_unit - handler.Cckappa_sig.agents_dic + Ckappa_sig.Dictionary_of_agents.allocate_bool parameters error + Ckappa_sig.compare_unit_agent_name agent.Ckappa_sig.agent_name () + Misc_sa.const_unit handler.Cckappa_sig.agents_dic in match bool, output with - | _ , None -> + | _, None -> let error, ag = Exception.warn parameters error __POS__ Exit - (Cckappa_sig.Unknown_agent (agent.Ckappa_sig.ag_nme, kasim_id)) + (Cckappa_sig.Unknown_agent (agent.Ckappa_sig.agent_name, kasim_id)) in error, bond_list, question_marks, delta, ag | true, _ -> - error, bond_list, question_marks, delta, - Cckappa_sig.Unknown_agent (agent.Ckappa_sig.ag_nme, kasim_id) - | _ , Some (agent_name, _, _, _) -> - begin - let error, site_dic = - match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_name - handler.Cckappa_sig.sites - with - | error,None -> - Exception.warn parameters error __POS__ Exit - (Ckappa_sig.Dictionary_of_sites.init ()) - | error,Some i -> error,i - in - let error, c_interface = error, Ckappa_sig.Site_map_and_set.Map.empty in - let rec aux interface error bond_list - c_interface question_marks dead_sites dead_state_sites dead_link_sites delta = - match interface with - | Ckappa_sig.EMPTY_INTF -> error, - bond_list, c_interface, question_marks, - dead_sites, dead_state_sites, dead_link_sites, - delta - | Ckappa_sig.COUNTER_SEP (counter, interface) -> - begin - let error, (c_interface, dead_sites, _dead_states_sites, delta) = + ( error, + bond_list, + question_marks, + delta, + Cckappa_sig.Unknown_agent (agent.Ckappa_sig.agent_name, kasim_id) ) + | _, Some (agent_name, _, _, _) -> + let error, site_dic = + match + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_name handler.Cckappa_sig.sites + with + | error, None -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_sites.init ()) + | error, Some i -> error, i + in + let error, c_interface = error, Ckappa_sig.Site_map_and_set.Map.empty in + let rec aux interface error bond_list c_interface question_marks dead_sites + dead_state_sites dead_link_sites delta = + match interface with + | Ckappa_sig.EMPTY_INTF -> + ( error, + bond_list, + c_interface, + question_marks, + dead_sites, + dead_state_sites, + dead_link_sites, + delta ) + | Ckappa_sig.COUNTER_SEP (counter, interface) -> + let error, (c_interface, dead_sites, _dead_states_sites, delta) = + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Counter counter.Ckappa_sig.counter_name) () + Misc_sa.const_unit site_dic + in + match bool, output with + | _, None -> + Exception.warn parameters error __POS__ + ~message: + (agent.Ckappa_sig.agent_name ^ " " + ^ counter.Ckappa_sig.counter_name) + Exit + (c_interface, dead_sites, dead_state_sites, delta) + | true, _ -> + let error, dead_sites = + Cckappa_sig.KaSim_Site_map_and_set.Set.add parameters error + (Ckappa_sig.Counter counter.Ckappa_sig.counter_name) dead_sites + in + error, (c_interface, dead_sites, dead_state_sites, delta) + | _, Some (site_name, _, _, _) -> + let error, delta = + match counter.Ckappa_sig.counter_delta with + | None | Some 0 -> error, delta + | Some n -> + Ckappa_sig.AgentsSite_map_and_set.Map.add parameters error + (k, agent_name, site_name) n delta + in + let error, c_interface = + match counter.Ckappa_sig.counter_test with + | Some (Ckappa_sig.CEQ _) | Some (Ckappa_sig.CGTE _) -> + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_name; + Cckappa_sig.site_free = None; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_state = + (match counter.Ckappa_sig.counter_test with + | Some (Ckappa_sig.CEQ i) -> + { + Cckappa_sig.min = + Some (Ckappa_sig.state_index_of_int i); + Cckappa_sig.max = + Some (Ckappa_sig.state_index_of_int i); + } + | Some (Ckappa_sig.CGTE i) -> + { + Cckappa_sig.min = + Some (Ckappa_sig.state_index_of_int i); + Cckappa_sig.max = None; + } + | None + | Some Ckappa_sig.UNKNOWN + | Some (Ckappa_sig.CVAR _) -> + { Cckappa_sig.min = None; Cckappa_sig.max = None }); + } + c_interface + | None | Some Ckappa_sig.UNKNOWN | Some (Ckappa_sig.CVAR _) -> + error, c_interface + in + error, (c_interface, dead_sites, dead_state_sites, delta) + in + aux interface error bond_list c_interface question_marks dead_sites + dead_state_sites dead_link_sites delta + | Ckappa_sig.PORT_SEP (port, interface) -> + let error, (c_interface, question_marks, dead_sites, _dead_states_sites) + = + match port.Ckappa_sig.port_int with + | [] -> + error, (c_interface, question_marks, dead_sites, dead_state_sites) + | [ None ] -> let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Counter counter.Ckappa_sig.count_nme) - () - Misc_sa.const_unit - site_dic + (Ckappa_sig.Internal port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic in - match bool, output with + (match bool, output with | _, None -> Exception.warn parameters error __POS__ - ~message:( - agent.Ckappa_sig.ag_nme ^ " " ^ counter.Ckappa_sig.count_nme) - Exit (c_interface, dead_sites, dead_state_sites, delta) + ~message: + (agent.Ckappa_sig.agent_name ^ " " ^ port.Ckappa_sig.port_name) + Exit + (c_interface, question_marks, dead_sites, dead_state_sites) | true, _ -> let error, dead_sites = - Cckappa_sig.KaSim_Site_map_and_set.Set.add - parameters - error - (Ckappa_sig.Counter counter.Ckappa_sig.count_nme) - dead_sites + Cckappa_sig.KaSim_Site_map_and_set.Set.add parameters error + (Ckappa_sig.Internal port.Ckappa_sig.port_name) dead_sites in - error, (c_interface, dead_sites, dead_state_sites, delta) + error, (c_interface, question_marks, dead_sites, dead_state_sites) | _, Some (site_name, _, _, _) -> - begin - let error, delta = - match counter.Ckappa_sig.count_delta with - | None | Some 0 -> - error, delta - | Some n -> - Ckappa_sig.AgentsSite_map_and_set.Map.add - parameters error - (k,agent_name,site_name) n delta + if bool then ( + let error', _dead_state_sites = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + (Ckappa_sig.Internal None) dead_state_sites in - let error,c_interface = - match counter.Ckappa_sig.count_test with - | Some (Ckappa_sig.CEQ _ ) | Some (Ckappa_sig.CGTE _ ) -> - begin - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name + ( Exception.check_point Exception.warn parameters error error' + __POS__ + ~message: + "a site even dead should occur only once in an interface" + Exit, + (c_interface, question_marks, dead_sites, dead_state_sites) ) + ) else ( + let error, last = + Handler.last_state_of_site parameters error handler agent_name + site_name + in + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = None; + Cckappa_sig.site_state = { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_free = None; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_state = - begin - match counter.Ckappa_sig.count_test with - | Some (Ckappa_sig.CEQ i) -> - { - Cckappa_sig.min = Some - (Ckappa_sig.state_index_of_int i); - Cckappa_sig.max = Some - (Ckappa_sig.state_index_of_int i) - } - | Some (Ckappa_sig.CGTE i) -> - { - Cckappa_sig.min = Some - (Ckappa_sig.state_index_of_int i); - Cckappa_sig.max = None - } - | None | Some Ckappa_sig.UNKNOWN - | Some (Ckappa_sig.CVAR _) -> - { - Cckappa_sig.min = None; - Cckappa_sig.max = None - } - end - } - c_interface - end - | None | Some Ckappa_sig.UNKNOWN - | Some (Ckappa_sig.CVAR _) -> error, c_interface + Cckappa_sig.min = Some Ckappa_sig.dummy_state_index; + Cckappa_sig.max = Some last; + }; + } + c_interface + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ + ~message:"a site should occur only once in an interface" + Exit in - error, (c_interface, dead_sites, dead_state_sites, delta) - end - in aux interface error bond_list c_interface - question_marks dead_sites dead_state_sites dead_link_sites delta - end - | Ckappa_sig.PORT_SEP (port, interface) -> - let error, (c_interface, question_marks, dead_sites, _dead_states_sites) = - match port.Ckappa_sig.port_int with - | [] -> error, (c_interface, question_marks, dead_sites, dead_state_sites) - | [None] -> - begin + ( error, + ( c_interface, + (k, site_name) :: question_marks, + dead_sites, + dead_state_sites ) ) + )) + | [ Some state ] -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Internal port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + (match bool, output with + | _, None -> + Exception.warn parameters error __POS__ + ~message: + (agent.Ckappa_sig.agent_name ^ " " ^ port.Ckappa_sig.port_name) + Exit + (c_interface, question_marks, dead_sites, dead_state_sites) + | true, _ -> + let error, dead_sites = + Cckappa_sig.KaSim_Site_map_and_set.Set.add parameters error + (Ckappa_sig.Internal port.Ckappa_sig.port_name) dead_sites + in + error, (c_interface, question_marks, dead_sites, dead_state_sites) + | _, Some (site_name, _, _, _) -> + let error, state_dic = + Misc_sa.unsome + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, site_name) + handler.Cckappa_sig.states_dic) + (fun error -> + Exception.warn parameters error __POS__ + ~message: + (agent.Ckappa_sig.agent_name ^ " " + ^ port.Ckappa_sig.port_name) + Exit + (Ckappa_sig.Dictionary_of_States.init ())) + in let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Internal port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic + Ckappa_sig.Dictionary_of_States.allocate_bool parameters error + Ckappa_sig.compare_unit_state_index + (Ckappa_sig.Internal state) () Misc_sa.const_unit state_dic in - match bool, output with - | _, None -> - Exception.warn parameters error __POS__ - ~message:( agent.Ckappa_sig.ag_nme ^ " " ^ port.Ckappa_sig.port_nme) - Exit (c_interface, question_marks, dead_sites, dead_state_sites) - | true, _ -> - let error, dead_sites = - Cckappa_sig.KaSim_Site_map_and_set.Set.add - parameters - error - (Ckappa_sig.Internal port.Ckappa_sig.port_nme) - dead_sites + (match bool, output with + | _, None | true, _ -> + let error', _dead_state_sites = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + (Ckappa_sig.Internal (Some state)) dead_state_sites in - error, (c_interface, question_marks, dead_sites, dead_state_sites) - | _, Some (site_name, _, _, _) -> - begin - if bool then - let error',_dead_state_sites = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name - (Ckappa_sig.Internal None) - dead_state_sites - in - Exception.check_point - Exception.warn parameters error error' __POS__ - ~message:"a site even dead should occur only once in an interface" - Exit, - (c_interface, question_marks, dead_sites, dead_state_sites) - else - let error, last = - Handler.last_state_of_site - parameters error handler agent_name site_name - in - let error',c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name + ( Exception.check_point Exception.warn parameters error error' + __POS__ + ~message: + "a site even dead should occur only once in an interface" + Exit, + (c_interface, question_marks, dead_sites, dead_state_sites) ) + | _, Some (internal, _, _, _) -> + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = None; + Cckappa_sig.site_state = { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_free = None ; - Cckappa_sig.site_state = - { - Cckappa_sig.min = Some Ckappa_sig.dummy_state_index ; - Cckappa_sig.max = Some last - }; - } c_interface in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ - ~message:"a site should occur only once in an interface" - Exit - in - error, (c_interface, - (k,site_name)::question_marks, dead_sites, dead_state_sites) - end - end - | [Some state] -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Internal port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic + Cckappa_sig.min = Some (internal : Ckappa_sig.c_state); + Cckappa_sig.max = Some internal; + }; + } + c_interface in - match bool, output with - | _, None -> - Exception.warn parameters error __POS__ - ~message:( agent.Ckappa_sig.ag_nme ^ " " ^ port.Ckappa_sig.port_nme) - Exit (c_interface, question_marks, dead_sites, dead_state_sites) - | true, _ -> - let error, dead_sites = - Cckappa_sig.KaSim_Site_map_and_set.Set.add - parameters - error - (Ckappa_sig.Internal port.Ckappa_sig.port_nme) - dead_sites - in - error, (c_interface, question_marks, dead_sites, dead_state_sites) - | _, Some (site_name, _, _, _) -> - begin - let error, state_dic = - Misc_sa.unsome - ( - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, site_name) - handler.Cckappa_sig.states_dic) - (fun error -> - Exception.warn parameters error __POS__ - ~message:(agent.Ckappa_sig.ag_nme ^ " " ^ - port.Ckappa_sig.port_nme) Exit - (Ckappa_sig.Dictionary_of_States.init ())) - in - let error,(bool,output) = - Ckappa_sig.Dictionary_of_States.allocate_bool - parameters - error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Internal state) - () - Misc_sa.const_unit - state_dic - in - match bool, output with - | _ , None - | true, _ -> - let error',_dead_state_sites = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name - (Ckappa_sig.Internal (Some state)) - dead_state_sites - in - Exception.check_point - Exception.warn parameters error error' __POS__ - ~message:"a site even dead should occur only once in an interface" - Exit, - (c_interface, question_marks, dead_sites, dead_state_sites) - | _ , Some (internal, _, _, _) -> - let error',c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name - { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_free = None ; - Cckappa_sig.site_state = - { - Cckappa_sig.min = Some (internal:Ckappa_sig.c_state) ; - Cckappa_sig.max = Some internal - }; - } c_interface in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ - ~message:"a site should occur only once in an interface" - Exit - in - error, - (c_interface, question_marks, dead_sites, dead_state_sites) - end - end - | _ -> Exception.warn - parameters error __POS__ Exit - (c_interface,question_marks,dead_sites,dead_state_sites) - in - let error,(c_interface,bond_list,question_marks,dead_sites,dead_link_sites) = - match port.Ckappa_sig.port_lnk with - | Ckappa_sig.LNK_MISSING when creation -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ + ~message:"a site should occur only once in an interface" + Exit in - match bool, output with - | _ , None - | true, _ -> error, - (c_interface, bond_list, question_marks, dead_sites, dead_link_sites) - | _ , Some (site_name, _, _, _) -> - let error',c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name + ( error, + (c_interface, question_marks, dead_sites, dead_state_sites) ))) + | _ -> + Exception.warn parameters error __POS__ Exit + (c_interface, question_marks, dead_sites, dead_state_sites) + in + let ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) = + match port.Ckappa_sig.port_link with + | Ckappa_sig.LNK_MISSING when creation -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + (match bool, output with + | _, None | true, _ -> + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + | _, Some (site_name, _, _, _) -> + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = port.Ckappa_sig.port_free; + Cckappa_sig.site_state = { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_free = port.Ckappa_sig.port_free ; - Cckappa_sig.site_state = - {Cckappa_sig.min = - Some (Ckappa_sig.dummy_state_index) ; - Cckappa_sig.max = - Some (Ckappa_sig.dummy_state_index) - } - } - c_interface - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error,(c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - end - | Ckappa_sig.LNK_MISSING - | Ckappa_sig.LNK_ANY _ -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic + Cckappa_sig.min = Some Ckappa_sig.dummy_state_index; + Cckappa_sig.max = Some Ckappa_sig.dummy_state_index; + }; + } + c_interface + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) )) + | Ckappa_sig.LNK_MISSING | Ckappa_sig.LNK_ANY _ -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + (match bool, output with + | true, _ -> + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + (* OK if question marks in a site that is never bound *) + | _, None -> + Exception.warn parameters error __POS__ Exit + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) + | _, Some (site_name, _, _, _) -> + let error, state_dic = + Misc_sa.unsome + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, site_name) + handler.Cckappa_sig.states_dic) + (fun error -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) + in + let error, max = + Ckappa_sig.Dictionary_of_States.last_entry parameters error + state_dic + in + let state_min = + if + Ckappa_sig.compare_state_index max + Ckappa_sig.dummy_state_index + < 0 + then + max + else + Ckappa_sig.dummy_state_index + in + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_name; + Cckappa_sig.site_free = port.Ckappa_sig.port_free; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_state = + { + Cckappa_sig.min = Some state_min; + Cckappa_sig.max = Some max; + }; + } + c_interface + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + ( error, + ( c_interface, + bond_list, + (k, site_name) :: question_marks, + dead_sites, + dead_link_sites ) )) + | Ckappa_sig.FREE -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + (match bool, output with + | _, None | true, _ -> + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + | _, Some (site_name, _, _, _) -> + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = port.Ckappa_sig.port_free; + Cckappa_sig.site_state = + { + Cckappa_sig.min = Some Ckappa_sig.dummy_state_index; + Cckappa_sig.max = Some Ckappa_sig.dummy_state_index; + }; + } + c_interface + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) )) + | Ckappa_sig.LNK_SOME pos -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + (match bool, output with + | _, None -> + Exception.warn parameters error __POS__ + ~message: + ("this site cannot be bound, " ^ agent.Ckappa_sig.agent_name + ^ " " ^ port.Ckappa_sig.port_name) + ~pos Exit + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) + | true, _ -> + let error, dead_sites = + Cckappa_sig.KaSim_Site_map_and_set.Set.add parameters error + (Ckappa_sig.Binding port.Ckappa_sig.port_name) dead_sites + in + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + | _, Some (site_name, _, _, _) -> + (match + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, site_name) + handler.Cckappa_sig.states_dic + with + | error, None -> + let error', dead_link_sites = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + port.Ckappa_sig.port_link dead_link_sites in - begin - match bool, output with - | true, _ -> - error, - (c_interface, bond_list, question_marks, dead_sites, dead_link_sites) - (* OK if question marks in a site that is never bound *) - | _, None -> Exception.warn - parameters error __POS__ Exit - (c_interface, bond_list, question_marks, dead_sites, dead_link_sites) - | _ , Some (site_name, _, _, _) -> - let error,state_dic = - Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, site_name) - handler.Cckappa_sig.states_dic) - (fun error -> - Exception.warn parameters error - __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init ())) - in - let error, max = - Ckappa_sig.Dictionary_of_States.last_entry - parameters error state_dic - in - let state_min = - if Ckappa_sig.compare_state_index max Ckappa_sig.dummy_state_index < 0 then - max - else - Ckappa_sig.dummy_state_index - in - let error',c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name - { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_free = port.Ckappa_sig.port_free; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_state = - {Cckappa_sig.min = Some state_min; - Cckappa_sig.max = Some max} - } - c_interface - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit in - error, (c_interface, bond_list, - (k, site_name) :: question_marks, dead_sites, dead_link_sites) - end - end - | Ckappa_sig.FREE -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic + ( Exception.check_point Exception.warn parameters error error' + __POS__ + ~message: + "a site even dead should occur only once in an interface" + ~pos Exit, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + | error, Some state_dic -> + let error, max = + Ckappa_sig.Dictionary_of_States.last_entry parameters error + state_dic in - match bool, output with - | _ , None - | true, _ -> error, - (c_interface, bond_list, question_marks, dead_sites, dead_link_sites) - | _ , Some (site_name, _, _, _) -> - let error',c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error + if + Ckappa_sig.compare_state_index max + Ckappa_sig.dummy_state_index + = 0 + then ( + let error', dead_link_sites = + Ckappa_sig.Site_map_and_set.Map.add parameters error + site_name port.Ckappa_sig.port_link dead_link_sites + in + ( Exception.check_point Exception.warn parameters error error' + __POS__ + ~message: + "a site even dead should occur only once in an \ + interface" + ~pos Exit, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + ) else ( + let state_min = + if + Ckappa_sig.compare_state_index max + Ckappa_sig.dummy_state_index_1 + < 0 + then + max + else + Ckappa_sig.dummy_state_index_1 + in + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_free = port.Ckappa_sig.port_free ; + Cckappa_sig.site_name; + Cckappa_sig.site_free = port.Ckappa_sig.port_free; + Cckappa_sig.site_position = Loc.dummy; Cckappa_sig.site_state = - {Cckappa_sig.min = - Some (Ckappa_sig.dummy_state_index) ; - Cckappa_sig.max = - Some (Ckappa_sig.dummy_state_index) - } + { + Cckappa_sig.min = Some state_min; + Cckappa_sig.max = Some max; + }; } c_interface in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error,(c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - end - | Ckappa_sig.LNK_SOME pos -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic - in - match bool,output with - | _ , None -> - Exception.warn parameters error __POS__ - ~message:( - "this site cannot be bound, " ^ - agent.Ckappa_sig.ag_nme ^ - " " ^ - port.Ckappa_sig.port_nme) - ~pos Exit - (c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - | true, _ -> - let error, dead_sites = - Cckappa_sig.KaSim_Site_map_and_set.Set.add - parameters error (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - dead_sites + Exception.check_point Exception.warn parameters error error' + __POS__ ~pos Exit in - error,(c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - | _ , Some (site_name,_,_,_) -> - begin - match - ( - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, site_name) - handler.Cckappa_sig.states_dic) - with - | error, None -> - let error', dead_link_sites = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name - port.Ckappa_sig.port_lnk - dead_link_sites - in - Exception.check_point - Exception.warn parameters error error' __POS__ - ~message:"a site even dead should occur only once in an interface" - ~pos Exit, - (c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - | error,Some state_dic -> - let error,max = Ckappa_sig.Dictionary_of_States.last_entry parameters error state_dic in - if Ckappa_sig.compare_state_index max Ckappa_sig.dummy_state_index = 0 - then - let error',dead_link_sites = - Ckappa_sig.Site_map_and_set.Map.add parameters error site_name port.Ckappa_sig.port_lnk dead_link_sites - in - Exception.check_point - Exception.warn parameters error error' __POS__ - ~message:"a site even dead should occur only once in an interface" - ~pos Exit, - (c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - else - let state_min = - if Ckappa_sig.compare_state_index - max - Ckappa_sig.dummy_state_index_1 - < 0 - then max - else - Ckappa_sig.dummy_state_index_1 - in - let error',c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name - { - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_free = port.Ckappa_sig.port_free; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_state = - {Cckappa_sig.min = - Some state_min ; - Cckappa_sig.max = - Some max - } - } - c_interface - in - let error = - Exception.check_point - Exception.warn - parameters error error' __POS__ ~pos Exit - in - error,(c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - end - end - | Ckappa_sig.LNK_VALUE (id_agent',agent',site',i,pos) -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic - in - match bool,output with - | _ , None -> - Exception.warn - parameters error __POS__ - ~message:("this site cannot be bound, "^agent.Ckappa_sig.ag_nme^" "^port.Ckappa_sig.port_nme) - ~pos - Exit (c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - | true, _ -> - let error,dead_sites = - Cckappa_sig.KaSim_Site_map_and_set.Set.add parameters error (Ckappa_sig.Binding port.Ckappa_sig.port_nme) dead_sites in - error,(c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - | _ , Some (site_name,_,_,_) -> - begin - match - ( - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, site_name) - handler.Cckappa_sig.states_dic) - with - | error,None -> - let error',dead_link_sites = - Ckappa_sig.Site_map_and_set.Map.add parameters error - site_name port.Ckappa_sig.port_lnk dead_link_sites - in - Exception.check_point Exception.warn - parameters error error' __POS__ - ~message:"a site even dead should occur only once in an interface" - ~pos Exit, - (c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - | error,Some state_dic -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_agents.allocate_bool - parameters - error - Ckappa_sig.compare_unit_agent_name - agent' - () - Misc_sa.const_unit - handler.Cckappa_sig.agents_dic - in - let error,agent_name' = - match bool,output with - | _ , None - | true, _ -> - Exception.warn - parameters error __POS__ ~pos - Exit Ckappa_sig.dummy_agent_name - | _ , Some (i,_,_,_) -> error, i - in - let error, site_dic' = - match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_name' - handler.Cckappa_sig.sites - with - | error, None -> - Exception.warn parameters error __POS__ ~pos - Exit (Ckappa_sig.Dictionary_of_sites.init ()) - | error, Some i -> error, i - in - let error,(bool,output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding site') - () Misc_sa.const_unit - site_dic' - in - let error, site_name' = - match bool,output with - | _ , None - | true, _ -> - Exception.warn parameters error - __POS__ ~pos Exit Ckappa_sig.dummy_site_name - | _ , Some (i, _, _, _) -> - error,i - in - let error, bond_list = - add_bond - parameters - error - i - k - agent_name - site_name - id_agent' - agent_name' - site_name' - bond_list - in - let state = Ckappa_sig.C_Lnk_type (agent_name', site_name') in - let error, (bool, output) = - Ckappa_sig.Dictionary_of_States.allocate_bool - parameters - error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Binding state) - () - Misc_sa.const_unit - state_dic - in - let error, c_interface = - match bool, output with - | _ , None - | true, _ -> - Exception.warn parameters error - __POS__ ~message:"this link can never be formed" - ~pos Exit c_interface - | _ , Some (i, _, _, _) -> - let error', c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error - site_name - { - Cckappa_sig.site_free = port.Ckappa_sig.port_free; - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; - Cckappa_sig.site_state = - { - Cckappa_sig.min = - Some i; - Cckappa_sig.max = - Some i - } - } - c_interface - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ ~pos Exit - in - error, c_interface - in - error, - (c_interface, bond_list, question_marks, - dead_sites, dead_link_sites) - end - end - end - | Ckappa_sig.LNK_TYPE (agent', site') -> - begin - let error, (bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding port.Ckappa_sig.port_nme) - () - Misc_sa.const_unit - site_dic - in - let error, site_name = - match bool, output with - | _ , None - | true, _ -> - Exception.warn - parameters error __POS__ Exit Ckappa_sig.dummy_site_name - | _ , Some (i, _, _, _) -> error, i + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + ))) + | Ckappa_sig.LNK_VALUE (id_agent', agent', site', i, pos) -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + (match bool, output with + | _, None -> + Exception.warn parameters error __POS__ + ~message: + ("this site cannot be bound, " ^ agent.Ckappa_sig.agent_name + ^ " " ^ port.Ckappa_sig.port_name) + ~pos Exit + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) + | true, _ -> + let error, dead_sites = + Cckappa_sig.KaSim_Site_map_and_set.Set.add parameters error + (Ckappa_sig.Binding port.Ckappa_sig.port_name) dead_sites + in + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + | _, Some (site_name, _, _, _) -> + (match + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, site_name) + handler.Cckappa_sig.states_dic + with + | error, None -> + let error', dead_link_sites = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + port.Ckappa_sig.port_link dead_link_sites in + ( Exception.check_point Exception.warn parameters error error' + __POS__ + ~message: + "a site even dead should occur only once in an interface" + ~pos Exit, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + | error, Some state_dic -> let error, (bool, output) = - Ckappa_sig.Dictionary_of_agents.allocate_bool - parameters - error - Ckappa_sig.compare_unit_agent_name - (fst agent') - () - Misc_sa.const_unit - handler.Cckappa_sig.agents_dic + Ckappa_sig.Dictionary_of_agents.allocate_bool parameters error + Ckappa_sig.compare_unit_agent_name agent' () + Misc_sa.const_unit handler.Cckappa_sig.agents_dic in let error, agent_name' = match bool, output with - | _ , None - | true, _ -> - Exception.warn - parameters error __POS__ Exit Ckappa_sig.dummy_agent_name - | _ , Some (i, _, _, _) -> error, i + | _, None | true, _ -> + Exception.warn parameters error __POS__ ~pos Exit + Ckappa_sig.dummy_agent_name + | _, Some (i, _, _, _) -> error, i in let error, site_dic' = match Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_name' - handler.Cckappa_sig.sites + parameters error agent_name' handler.Cckappa_sig.sites with | error, None -> - Exception.warn - parameters error __POS__ Exit + Exception.warn parameters error __POS__ ~pos Exit (Ckappa_sig.Dictionary_of_sites.init ()) | error, Some i -> error, i in - let error,(bool, output) = - Ckappa_sig.Dictionary_of_sites.allocate_bool - parameters - error - Ckappa_sig.compare_unit_site_name - (Ckappa_sig.Binding (fst site')) - () - Misc_sa.const_unit - site_dic' + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name (Ckappa_sig.Binding site') + () Misc_sa.const_unit site_dic' in let error, site_name' = match bool, output with - | _ , None - | true, _ -> - Exception.warn - parameters error __POS__ Exit Ckappa_sig.dummy_site_name - | _ , Some (i, _, _, _) -> error, i + | _, None | true, _ -> + Exception.warn parameters error __POS__ ~pos Exit + Ckappa_sig.dummy_site_name + | _, Some (i, _, _, _) -> error, i in - let state = Ckappa_sig.C_Lnk_type (agent_name', site_name') in - let error, state_dic = - Misc_sa.unsome - ( - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_name, site_name) - handler.Cckappa_sig.states_dic) - (fun error -> - Exception.warn parameters error __POS__ - ~message: - ((Ckappa_sig.string_of_agent_name agent_name') ^ - (Ckappa_sig.string_of_site_name site_name')) - Exit - (Ckappa_sig.Dictionary_of_States.init ())) + let error, bond_list = + add_bond parameters error i k agent_name site_name id_agent' + agent_name' site_name' bond_list in + let state = Ckappa_sig.C_Lnk_type (agent_name', site_name') in let error, (bool, output) = - Ckappa_sig.Dictionary_of_States.allocate_bool - parameters - error + Ckappa_sig.Dictionary_of_States.allocate_bool parameters error Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Binding state) - () - Misc_sa.const_unit - state_dic + (Ckappa_sig.Binding state) () Misc_sa.const_unit state_dic in let error, c_interface = match bool, output with - | _ , None - | true, _ -> - Exception.warn parameters error __POS__ Exit c_interface - | _ , Some (i, _, _, _) -> + | _, None | true, _ -> + Exception.warn parameters error __POS__ + ~message:"this link can never be formed" ~pos Exit + c_interface + | _, Some (i, _, _, _) -> let error', c_interface = - Ckappa_sig.Site_map_and_set.Map.add - parameters - error + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name { Cckappa_sig.site_free = port.Ckappa_sig.port_free; - Cckappa_sig.site_name = site_name ; - Cckappa_sig.site_position = Locality.dummy ; + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; Cckappa_sig.site_state = { - Cckappa_sig.min = - Some i; - Cckappa_sig.max = - Some i - } + Cckappa_sig.min = Some i; + Cckappa_sig.max = Some i; + }; } c_interface in let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error + error' __POS__ ~pos Exit in - error,c_interface + error, c_interface + in + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ))) + | Ckappa_sig.LNK_TYPE (agent', site') -> + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding port.Ckappa_sig.port_name) () + Misc_sa.const_unit site_dic + in + let error, site_name = + match bool, output with + | _, None | true, _ -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_site_name + | _, Some (i, _, _, _) -> error, i + in + let error, (bool, output) = + Ckappa_sig.Dictionary_of_agents.allocate_bool parameters error + Ckappa_sig.compare_unit_agent_name (fst agent') () + Misc_sa.const_unit handler.Cckappa_sig.agents_dic + in + let error, agent_name' = + match bool, output with + | _, None | true, _ -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_agent_name + | _, Some (i, _, _, _) -> error, i + in + let error, site_dic' = + match + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_name' handler.Cckappa_sig.sites + with + | error, None -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_sites.init ()) + | error, Some i -> error, i + in + let error, (bool, output) = + Ckappa_sig.Dictionary_of_sites.allocate_bool parameters error + Ckappa_sig.compare_unit_site_name + (Ckappa_sig.Binding (fst site')) + () Misc_sa.const_unit site_dic' + in + let error, site_name' = + match bool, output with + | _, None | true, _ -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_site_name + | _, Some (i, _, _, _) -> error, i + in + let state = Ckappa_sig.C_Lnk_type (agent_name', site_name') in + let error, state_dic = + Misc_sa.unsome + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_name, site_name) + handler.Cckappa_sig.states_dic) + (fun error -> + Exception.warn parameters error __POS__ + ~message: + (Ckappa_sig.string_of_agent_name agent_name' + ^ Ckappa_sig.string_of_site_name site_name') + Exit + (Ckappa_sig.Dictionary_of_States.init ())) + in + let error, (bool, output) = + Ckappa_sig.Dictionary_of_States.allocate_bool parameters error + Ckappa_sig.compare_unit_state_index (Ckappa_sig.Binding state) + () Misc_sa.const_unit state_dic + in + let error, c_interface = + match bool, output with + | _, None | true, _ -> + Exception.warn parameters error __POS__ Exit c_interface + | _, Some (i, _, _, _) -> + let error', c_interface = + Ckappa_sig.Site_map_and_set.Map.add parameters error site_name + { + Cckappa_sig.site_free = port.Ckappa_sig.port_free; + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_state = + { Cckappa_sig.min = Some i; Cckappa_sig.max = Some i }; + } + c_interface + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in - error,(c_interface,bond_list,question_marks,dead_sites,dead_link_sites) - end + error, c_interface + in + ( error, + ( c_interface, + bond_list, + question_marks, + dead_sites, + dead_link_sites ) ) + in - in aux interface error bond_list c_interface - question_marks dead_sites dead_state_sites dead_link_sites delta - in - let deadsites = Cckappa_sig.KaSim_Site_map_and_set.Set.empty in - let deadstate = Ckappa_sig.Site_map_and_set.Map.empty in - let deadlink = Ckappa_sig.Site_map_and_set.Map.empty in - let error,bond_list,c_interface,question_marks, dead_sites, dead_state_sites,dead_link_sites,delta = - aux - agent.Ckappa_sig.ag_intf - error - bond_list c_interface - question_marks deadsites deadstate deadlink delta - in - error,bond_list,question_marks,delta, - if deadlink == dead_link_sites && - deadstate==dead_state_sites && deadsites == dead_sites - then Cckappa_sig.Agent + aux interface error bond_list c_interface question_marks dead_sites + dead_state_sites dead_link_sites delta + in + let deadsites = Cckappa_sig.KaSim_Site_map_and_set.Set.empty in + let deadstate = Ckappa_sig.Site_map_and_set.Map.empty in + let deadlink = Ckappa_sig.Site_map_and_set.Map.empty in + let ( error, + bond_list, + c_interface, + question_marks, + dead_sites, + dead_state_sites, + dead_link_sites, + delta ) = + aux agent.Ckappa_sig.ag_intf error bond_list c_interface question_marks + deadsites deadstate deadlink delta + in + ( error, + bond_list, + question_marks, + delta, + if + deadlink == dead_link_sites + && deadstate == dead_state_sites + && deadsites == dead_sites + then + Cckappa_sig.Agent { - Cckappa_sig.agent_kasim_id = kasim_id ; - Cckappa_sig.agent_name = agent_name ; - Cckappa_sig.agent_interface = c_interface ; - Cckappa_sig.agent_position = Locality.dummy ; - Cckappa_sig.is_created = creation ; + Cckappa_sig.agent_kasim_id = kasim_id; + Cckappa_sig.agent_name; + Cckappa_sig.agent_interface = c_interface; + Cckappa_sig.agent_position = Loc.dummy; + Cckappa_sig.is_created = creation; } else Cckappa_sig.Dead_agent ( { - Cckappa_sig.agent_kasim_id = kasim_id ; - Cckappa_sig.agent_name = agent_name ; - Cckappa_sig.agent_interface = c_interface ; - Cckappa_sig.agent_position = Locality.dummy ; - Cckappa_sig.is_created = creation ; - }, + Cckappa_sig.agent_kasim_id = kasim_id; + Cckappa_sig.agent_name; + Cckappa_sig.agent_interface = c_interface; + Cckappa_sig.agent_position = Loc.dummy; + Cckappa_sig.is_created = creation; + }, dead_sites, dead_state_sites, - dead_link_sites) - end + dead_link_sites ) ) let update parameters error creation lhs_opt k = - if creation then error, creation - else + if creation then + error, creation + else ( match lhs_opt with - | None -> error, creation - | Some lhs -> + | None -> error, creation + | Some lhs -> let error, agent = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - k - lhs.Cckappa_sig.views + parameters error k lhs.Cckappa_sig.views in - match agent with + (match agent with | None | Some Cckappa_sig.Ghost -> error, true - | Some (Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Agent _ ) -> error, creation + | Some + ( Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Agent _ ) -> + error, creation) + ) let translate_mixture parameters error handler ~creation ?lhs mixture = - let syntax_version = - Remanent_parameters.get_syntax_version parameters - in + let syntax_version = Remanent_parameters.get_syntax_version parameters in let size = length_mixture mixture in - let rec aux mixture error (k:Ckappa_sig.c_agent_id) (kasim_id:Ckappa_sig.c_agent_id) - bond_list questionmarks dot_list plus_list array delta = + let rec aux mixture error (k : Ckappa_sig.c_agent_id) + (kasim_id : Ckappa_sig.c_agent_id) bond_list questionmarks dot_list + plus_list array delta = match mixture with - | Ckappa_sig.EMPTY_MIX -> error,bond_list,questionmarks,dot_list,plus_list,array,delta - | Ckappa_sig.COMMA(agent,mixture) -> + | Ckappa_sig.EMPTY_MIX -> + error, bond_list, questionmarks, dot_list, plus_list, array, delta + | Ckappa_sig.COMMA (agent, mixture) -> let error, creation = update parameters error creation lhs k in - let error,bond_list,questionmarks,delta,view = - translate_view - parameters - error - handler - ~creation - k - kasim_id - agent - bond_list - questionmarks - delta + let error, bond_list, questionmarks, delta, view = + translate_view parameters error handler ~creation k kasim_id agent + bond_list questionmarks delta in - let error,array = + let error, array = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - k - view - array + parameters error k view array in - aux - mixture - error + aux mixture error (Ckappa_sig.next_agent_id k) (Ckappa_sig.next_agent_id kasim_id) - bond_list - questionmarks - dot_list - plus_list - array - delta - | Ckappa_sig.DOT(id, agent, mixture) -> + bond_list questionmarks dot_list plus_list array delta + | Ckappa_sig.DOT (id, agent, mixture) -> let error, creation = update parameters error creation lhs k in let dot_list = (k, id) :: dot_list in - let error,bond_list,questionmarks, delta, view = - translate_view - parameters - error - handler - ~creation - k - kasim_id - agent - bond_list - questionmarks - delta + let error, bond_list, questionmarks, delta, view = + translate_view parameters error handler ~creation k kasim_id agent + bond_list questionmarks delta in let error, array = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - k - view - array + parameters error k view array in aux mixture error (Ckappa_sig.next_agent_id k) (Ckappa_sig.next_agent_id kasim_id) - bond_list - questionmarks - dot_list - plus_list - array - delta - | Ckappa_sig.PLUS(id, agent, mixture) -> + bond_list questionmarks dot_list plus_list array delta + | Ckappa_sig.PLUS (id, agent, mixture) -> let error, creation = update parameters error creation lhs k in let plus_list = (k, id) :: plus_list in - let error,bond_list,questionmarks,delta,view = - translate_view - parameters - error - handler - ~creation - k - kasim_id - agent - bond_list - questionmarks - delta + let error, bond_list, questionmarks, delta, view = + translate_view parameters error handler ~creation k kasim_id agent + bond_list questionmarks delta in - let error,array = + let error, array = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - k - view - array + parameters error k view array in aux mixture error (Ckappa_sig.next_agent_id k) (Ckappa_sig.next_agent_id kasim_id) - bond_list - questionmarks - dot_list - plus_list - array - delta - | Ckappa_sig.SKIP(mixture) -> - let error,array = + bond_list questionmarks dot_list plus_list array delta + | Ckappa_sig.SKIP mixture -> + let error, array = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - k - Cckappa_sig.Ghost - array + parameters error k Cckappa_sig.Ghost array in aux mixture error (Ckappa_sig.next_agent_id k) - (if syntax_version = Ast.V3 then kasim_id - else Ckappa_sig.next_agent_id kasim_id) + (if syntax_version = Ast.V3 then + kasim_id + else + Ckappa_sig.next_agent_id kasim_id) bond_list questionmarks dot_list plus_list array delta in - let error,array = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create - parameters - error - size + let error, array = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error size in - let error,bonds = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create - parameters - error - size + let error, bonds = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error size in let delta = Ckappa_sig.AgentsSite_map_and_set.Map.empty in - let error,bond_list,questionmarks,dot_list,plus_list,array,delta = - aux - mixture - error - Ckappa_sig.dummy_agent_id - Ckappa_sig.dummy_agent_id - bonds - [] - [] - [] - array - delta - in - error, - { - Cckappa_sig.views = array ; - Cckappa_sig.dot = dot_list ; - Cckappa_sig.plus = plus_list ; - Cckappa_sig.bonds = bond_list ; - Cckappa_sig.c_mixture = mixture },questionmarks,delta + let error, bond_list, questionmarks, dot_list, plus_list, array, delta = + aux mixture error Ckappa_sig.dummy_agent_id Ckappa_sig.dummy_agent_id bonds + [] [] [] array delta + in + ( error, + { + Cckappa_sig.views = array; + Cckappa_sig.dot = dot_list; + Cckappa_sig.plus = plus_list; + Cckappa_sig.bonds = bond_list; + Cckappa_sig.c_mixture = mixture; + }, + questionmarks, + delta ) let clean_agent = Cckappa_sig.map_agent (fun _ -> ()) let clean_agent2 map = let l = Ckappa_sig.Site_map_and_set.Map.fold - (fun i _ l -> i::l) - map.Cckappa_sig.agent_interface - [] + (fun i _ l -> i :: l) + map.Cckappa_sig.agent_interface [] in l let set_bound_sites parameters error k ag set = Ckappa_sig.Site_map_and_set.Map.fold - (fun site state (error,set) -> - if state.Cckappa_sig.site_free = Some true - then error,set - else - let error',set = - Cckappa_sig.Address_map_and_set.Set.add - parameters - error - { - Cckappa_sig.agent_index = k; - Cckappa_sig.agent_type = ag.Cckappa_sig.agent_name; - Cckappa_sig.site = site} - set - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error,set) - ag.Cckappa_sig.agent_interface - (error,set) + (fun site state (error, set) -> + if state.Cckappa_sig.site_free = Some true then + error, set + else ( + let error', set = + Cckappa_sig.Address_map_and_set.Set.add parameters error + { + Cckappa_sig.agent_index = k; + Cckappa_sig.agent_type = ag.Cckappa_sig.agent_name; + Cckappa_sig.site; + } + set + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, set + )) + ag.Cckappa_sig.agent_interface (error, set) let set_released_sites parameters error k ag ag' set = Ckappa_sig.Site_map_and_set.Map.fold2 parameters error (fun parameters error _site _state _ -> - Exception.warn parameters error __POS__ Exit set) + Exception.warn parameters error __POS__ Exit set) (fun parameters error site state set -> - if state.Cckappa_sig.site_free = Some true - then - let error',set = - Cckappa_sig.Address_map_and_set.Set.add - parameters error - { - Cckappa_sig.agent_index = k; - Cckappa_sig.agent_type = ag.Cckappa_sig.agent_name; - Cckappa_sig.site = site} set - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error,set - else error,set) + if state.Cckappa_sig.site_free = Some true then ( + let error', set = + Cckappa_sig.Address_map_and_set.Set.add parameters error + { + Cckappa_sig.agent_index = k; + Cckappa_sig.agent_type = ag.Cckappa_sig.agent_name; + Cckappa_sig.site; + } + set + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, set + ) else + error, set) (fun parameters error site state state' set -> - if state.Cckappa_sig.site_free = state'.Cckappa_sig.site_free - || state.Cckappa_sig.site_free = Some true - then error,set - else - let error',set = - Cckappa_sig.Address_map_and_set.Set.add - parameters - error - { - Cckappa_sig.agent_index = k; - Cckappa_sig.agent_type = ag.Cckappa_sig.agent_name; - Cckappa_sig.site = site - } - set - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error,set) + if + state.Cckappa_sig.site_free = state'.Cckappa_sig.site_free + || state.Cckappa_sig.site_free = Some true + then + error, set + else ( + let error', set = + Cckappa_sig.Address_map_and_set.Set.add parameters error + { + Cckappa_sig.agent_index = k; + Cckappa_sig.agent_type = ag.Cckappa_sig.agent_name; + Cckappa_sig.site; + } + set + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, set + )) ag.Cckappa_sig.agent_interface ag'.Cckappa_sig.agent_interface set let equ_port s1 s2 = @@ -1540,265 +1358,251 @@ let equ_port s1 s2 = let clean_question_marks parameters error l mixture = let rec aux error l views = - match - l - with - | [] -> error,views - | (k,s)::t -> - let error,views = - let error,agent = + match l with + | [] -> error, views + | (k, s) :: t -> + let error, views = + let error, agent = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error k views in - let error,agent = - match agent - with + parameters error k views + in + let error, agent = + match agent with | Some Cckappa_sig.Ghost -> - begin - match Remanent_parameters.get_syntax_version parameters - with - | Ast.V3 -> - Exception.warn - parameters error __POS__ - ~message:"question marks should not appear on the rhs or in introduction" - Exit (Cckappa_sig.Ghost) - | Ast.V4 -> - error,Cckappa_sig.Ghost - end - | Some Cckappa_sig.Unknown_agent _ | None -> - Exception.warn - parameters error __POS__ - ~message:"question marks should not appear on the rhs or in introduction" - Exit (Cckappa_sig.Ghost) - | Some Cckappa_sig.Dead_agent (ag,set,l,l') -> - let error',interface = Ckappa_sig.Site_map_and_set.Map.remove parameters error s ag.Cckappa_sig.agent_interface in + (match Remanent_parameters.get_syntax_version parameters with + | Ast.V3 -> + Exception.warn parameters error __POS__ + ~message: + "question marks should not appear on the rhs or in \ + introduction" + Exit Cckappa_sig.Ghost + | Ast.V4 -> error, Cckappa_sig.Ghost) + | Some (Cckappa_sig.Unknown_agent _) | None -> + Exception.warn parameters error __POS__ + ~message: + "question marks should not appear on the rhs or in introduction" + Exit Cckappa_sig.Ghost + | Some (Cckappa_sig.Dead_agent (ag, set, l, l')) -> + let error', interface = + Ckappa_sig.Site_map_and_set.Map.remove parameters error s + ag.Cckappa_sig.agent_interface + in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + ( error, + Cckappa_sig.Dead_agent + ({ ag with Cckappa_sig.agent_interface = interface }, set, l, l') + ) + | Some (Cckappa_sig.Agent ag) -> + let error', interface = + Ckappa_sig.Site_map_and_set.Map.remove parameters error s + ag.Cckappa_sig.agent_interface in - error,Cckappa_sig.Dead_agent ({ag with Cckappa_sig.agent_interface = interface},set,l,l') - | Some Cckappa_sig.Agent ag -> - let error',interface = Ckappa_sig.Site_map_and_set.Map.remove parameters error s ag.Cckappa_sig.agent_interface in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in - error,Cckappa_sig.Agent {ag with Cckappa_sig.agent_interface = interface} + ( error, + Cckappa_sig.Agent + { ag with Cckappa_sig.agent_interface = interface } ) in - let error,views = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set parameters error k agent views + let error, views = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error k agent views in - error,views + error, views in aux error t views in - let error,views = aux error l mixture.Cckappa_sig.views in - error,{mixture with Cckappa_sig.views = views} + let error, views = aux error l mixture.Cckappa_sig.views in + error, { mixture with Cckappa_sig.views } let filter parameters error l mixture = let views = mixture.Cckappa_sig.views in let rec aux error l output = - match - l - with - | [] -> error,output - | (k,s)::t -> - let error,agent = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters error k views in - let error,keep = - match agent - with - | None -> - Exception.warn parameters error __POS__ Exit false - | Some Cckappa_sig.Ghost -> error,true - | Some Cckappa_sig.Unknown_agent _ - | Some Cckappa_sig.Dead_agent _ -> - Exception.warn - parameters error __POS__ - ~message:"there should be no dead agent in rhs" - Exit false - | Some Cckappa_sig.Agent _ -> error,false + match l with + | [] -> error, output + | (k, s) :: t -> + let error, agent = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error k views in - aux error t (if keep then ((k,s)::output) else output) - in aux error l [] + let error, keep = + match agent with + | None -> Exception.warn parameters error __POS__ Exit false + | Some Cckappa_sig.Ghost -> error, true + | Some (Cckappa_sig.Unknown_agent _) | Some (Cckappa_sig.Dead_agent _) + -> + Exception.warn parameters error __POS__ + ~message:"there should be no dead agent in rhs" Exit false + | Some (Cckappa_sig.Agent _) -> error, false + in + aux error t + (if keep then + (k, s) :: output + else + output) + in + aux error l [] let check_freeness parameters lhs source (error, half_release_set) = let k = source.Cckappa_sig.agent_index in let site = source.Cckappa_sig.site in let error, lhsk = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error k lhs.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters + error k lhs.Cckappa_sig.views in - match lhsk - with - | None | Some Cckappa_sig.Unknown_agent _ | Some Cckappa_sig.Dead_agent _ -> + match lhsk with + | None | Some (Cckappa_sig.Unknown_agent _) | Some (Cckappa_sig.Dead_agent _) + -> Exception.warn parameters error __POS__ Exit half_release_set - | Some Cckappa_sig.Ghost -> - error, half_release_set - | Some Cckappa_sig.Agent lagk -> - begin - let error, port_opt = - Ckappa_sig.Site_map_and_set.Map.find_option - parameters - error - site - lagk.Cckappa_sig.agent_interface - in - match port_opt with - | None -> - Exception.warn parameters error __POS__ Exit half_release_set - | Some port -> - (match port.Cckappa_sig.site_free with - | Some true -> - error, half_release_set - | _ -> - Cckappa_sig.Address_map_and_set.Set.add_when_not_in - parameters - error - source - half_release_set) - end - + | Some Cckappa_sig.Ghost -> error, half_release_set + | Some (Cckappa_sig.Agent lagk) -> + let error, port_opt = + Ckappa_sig.Site_map_and_set.Map.find_option parameters error site + lagk.Cckappa_sig.agent_interface + in + (match port_opt with + | None -> Exception.warn parameters error __POS__ Exit half_release_set + | Some port -> + (match port.Cckappa_sig.site_free with + | Some true -> error, half_release_set + | _ -> + Cckappa_sig.Address_map_and_set.Set.add_when_not_in parameters error + source half_release_set)) let translate_rule parameters error handler rule = - let label,(rule,position) = rule in + let label, (rule, position) = rule in let direction = rule.Ckappa_sig.interprete_delta in - let error,c_rule_lhs,question_marks_l,delta_l = translate_mixture parameters error handler ~creation:false rule.Ckappa_sig.lhs in + let error, c_rule_lhs, question_marks_l, delta_l = + translate_mixture parameters error handler ~creation:false + rule.Ckappa_sig.lhs + in let lhs = c_rule_lhs in - let error,c_rule_rhs,question_marks_r,delta_r = translate_mixture parameters error handler ~creation:false ~lhs rule.Ckappa_sig.rhs in + let error, c_rule_rhs, question_marks_r, delta_r = + translate_mixture parameters error handler ~creation:false ~lhs + rule.Ckappa_sig.rhs + in let error, delta = - Ckappa_sig.AgentsSite_map_and_set.Map.map2 - parameters error + Ckappa_sig.AgentsSite_map_and_set.Map.map2 parameters error (fun _parameters error i -> error, i) (fun _parameters error i -> error, i) - (fun _parameters error i j -> error,i+j) - delta_l - delta_r - in - let error,c_rule_lhs = clean_question_marks parameters error question_marks_r c_rule_lhs in (* remove ? in the lhs when they occur in the rhs (according to the BNF, they have to occur in the lhs as well *) - let error,filtered_question_marks_l = filter parameters error question_marks_l c_rule_rhs in - let error,c_rule_lhs = clean_question_marks parameters error filtered_question_marks_l c_rule_lhs in (* remove ? that occur in the lhs in degraded agent *) - let error,c_rule_rhs = clean_question_marks parameters error question_marks_r c_rule_rhs in (* remove ? that occurs in the rhs *) - let error, (counter_precondition, - list_new, - list_removed) = + (fun _parameters error i j -> error, i + j) + delta_l delta_r + in + let error, c_rule_lhs = + clean_question_marks parameters error question_marks_r c_rule_lhs + in + (* remove ? in the lhs when they occur in the rhs (according to the BNF, they have to occur in the lhs as well *) + let error, filtered_question_marks_l = + filter parameters error question_marks_l c_rule_rhs + in + let error, c_rule_lhs = + clean_question_marks parameters error filtered_question_marks_l c_rule_lhs + in + (* remove ? that occur in the lhs in degraded agent *) + let error, c_rule_rhs = + clean_question_marks parameters error question_marks_r c_rule_rhs + in + (* remove ? that occurs in the rhs *) + let error, (counter_precondition, list_new, list_removed) = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold2_common parameters error - (fun parameters error agent_id view1 view2 (counter_precondition, list_new, list_removed) -> - match view1, view2 with - | Cckappa_sig.Agent ag, - Cckappa_sig.Ghost -> + (fun parameters error agent_id view1 view2 + (counter_precondition, list_new, list_removed) -> + match view1, view2 with + | Cckappa_sig.Agent ag, Cckappa_sig.Ghost -> let agent_type = ag.Cckappa_sig.agent_name in let error, list_removed = Ckappa_sig.Site_map_and_set.Map.fold (fun site port (error, list_removed) -> - let error, bool = - Handler.is_counter parameters error - handler - agent_type site - in - if bool - then - error, - (Cckappa_sig.build_address agent_id agent_type site, - port.Cckappa_sig.site_state)::list_removed - else - error, list_removed) - ag.Cckappa_sig.agent_interface - (error, list_removed) + let error, bool = + Handler.is_counter parameters error handler agent_type site + in + if bool then + ( error, + ( Cckappa_sig.build_address agent_id agent_type site, + port.Cckappa_sig.site_state ) + :: list_removed ) + else + error, list_removed) + ag.Cckappa_sig.agent_interface (error, list_removed) in error, (counter_precondition, list_new, list_removed) - - | Cckappa_sig.Ghost, Cckappa_sig.Agent ag -> + | Cckappa_sig.Ghost, Cckappa_sig.Agent ag -> let agent_type = ag.Cckappa_sig.agent_name in let error, list_new = Ckappa_sig.Site_map_and_set.Map.fold (fun site port (error, list_new) -> - let error, bool = - Handler.is_counter - parameters error handler - agent_type site - in - if bool - then - match port.Cckappa_sig.site_state.Cckappa_sig.min, - port.Cckappa_sig.site_state.Cckappa_sig.max - with - | Some a, Some b when a=b -> - error, - (Cckappa_sig.build_address agent_id agent_type site, - a) - ::list_new - | Some _, Some _ - | None,_ | _,None -> - Exception.warn parameters error __POS__ Exit list_new - else - error, list_new) - ag.Cckappa_sig.agent_interface - (error, list_new) + let error, bool = + Handler.is_counter parameters error handler agent_type site + in + if bool then ( + match + ( port.Cckappa_sig.site_state.Cckappa_sig.min, + port.Cckappa_sig.site_state.Cckappa_sig.max ) + with + | Some a, Some b when a = b -> + ( error, + (Cckappa_sig.build_address agent_id agent_type site, a) + :: list_new ) + | Some _, Some _ | None, _ | _, None -> + Exception.warn parameters error __POS__ Exit list_new + ) else + error, list_new) + ag.Cckappa_sig.agent_interface (error, list_new) in error, (counter_precondition, list_new, list_removed) - | Cckappa_sig.Agent ag, Cckappa_sig.Agent _ -> - let agent_type = ag.Cckappa_sig.agent_name in - let error, counter_precondition = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site port (error, counter_precondition) -> - let error, bool = - Handler.is_counter parameters error - handler - agent_type site - in - if bool - then - Ckappa_sig.AgentsSite_map_and_set.Map.add - parameters error - (agent_id,agent_type,site) - port.Cckappa_sig.site_state - counter_precondition - else - error, counter_precondition) - ag.Cckappa_sig.agent_interface - (error, counter_precondition) in + | Cckappa_sig.Agent ag, Cckappa_sig.Agent _ -> + let agent_type = ag.Cckappa_sig.agent_name in + let error, counter_precondition = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site port (error, counter_precondition) -> + let error, bool = + Handler.is_counter parameters error handler agent_type site + in + if bool then + Ckappa_sig.AgentsSite_map_and_set.Map.add parameters error + (agent_id, agent_type, site) + port.Cckappa_sig.site_state counter_precondition + else + error, counter_precondition) + ag.Cckappa_sig.agent_interface + (error, counter_precondition) + in - error, (counter_precondition, list_new, list_removed) - | Cckappa_sig.Ghost, Cckappa_sig.Ghost - | (Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _),_ - | _, (Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _) - -> error, (counter_precondition, list_new, list_removed) - ) - c_rule_lhs.Cckappa_sig.views - c_rule_rhs.Cckappa_sig.views - (Ckappa_sig.AgentsSite_map_and_set.Map.empty, - [],[]) + | Cckappa_sig.Ghost, Cckappa_sig.Ghost + | (Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _), _ + | _, (Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _) -> + error, (counter_precondition, list_new, list_removed)) + c_rule_lhs.Cckappa_sig.views c_rule_rhs.Cckappa_sig.views + (Ckappa_sig.AgentsSite_map_and_set.Map.empty, [], []) in let add1 delta b = match b with | None -> None - | Some i -> Some - (Ckappa_sig.state_index_of_int - ((Ckappa_sig.int_of_state_index i)+delta)) + | Some i -> + Some + (Ckappa_sig.state_index_of_int + (Ckappa_sig.int_of_state_index i + delta)) in let add delta interval = { - Cckappa_sig.min = - add1 delta interval.Cckappa_sig.min; - Cckappa_sig.max = - add1 delta interval.Cckappa_sig.max + Cckappa_sig.min = add1 delta interval.Cckappa_sig.min; + Cckappa_sig.max = add1 delta interval.Cckappa_sig.max; } in - let full_interval = - {Cckappa_sig.min = None; - Cckappa_sig.max = None} - in + let full_interval = { Cckappa_sig.min = None; Cckappa_sig.max = None } in let error, counter_map = - Ckappa_sig.AgentsSite_map_and_set.Map.map2 - parameters error - (fun _parameters error i -> error,(i,i,0)) - (fun _parameters error (i:int) -> error,(full_interval,full_interval,i)) - (fun _parameters error i j -> error,(i,add j i,j)) - counter_precondition - delta + Ckappa_sig.AgentsSite_map_and_set.Map.map2 parameters error + (fun _parameters error i -> error, (i, i, 0)) + (fun _parameters error (i : int) -> + error, (full_interval, full_interval, i)) + (fun _parameters error i j -> error, (i, add j i, j)) + counter_precondition delta in (*let error, counter_map = Ckappa_sig.AgentsSite_map_and_set.Map.fold @@ -1819,702 +1623,750 @@ let translate_rule parameters error handler rule = let overwrite_counter_test parameters error site i c_mixture = let agent_id, _, site_name = site in let error, view = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_id - c_mixture.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_id c_mixture.Cckappa_sig.views in - match view - with + match view with | Some Cckappa_sig.Ghost -> error, c_mixture - | Some Cckappa_sig.Agent ag -> + | Some (Cckappa_sig.Agent ag) -> let error, old_port = - Ckappa_sig.Site_map_and_set.Map.find_default_without_logs - parameters error + Ckappa_sig.Site_map_and_set.Map.find_default_without_logs parameters + error { - Cckappa_sig.site_name=site_name; - Cckappa_sig.site_position=Locality.dummy; - Cckappa_sig.site_free=None; - Cckappa_sig.site_state= - { - Cckappa_sig.min=None; - Cckappa_sig.max=None - } + Cckappa_sig.site_name; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = None; + Cckappa_sig.site_state = + { Cckappa_sig.min = None; Cckappa_sig.max = None }; } - site_name - ag.Cckappa_sig.agent_interface + site_name ag.Cckappa_sig.agent_interface in let new_port = - match i.Cckappa_sig.min, i.Cckappa_sig.max with + match i.Cckappa_sig.min, i.Cckappa_sig.max with | None, None -> old_port - | Some _, _ | _, Some _ -> (* The agent cannot have been created *) - { old_port with - Cckappa_sig.site_state = i} + | Some _, _ | _, Some _ -> + (* The agent cannot have been created *) + { old_port with Cckappa_sig.site_state = i } in let error, new_interface = - Ckappa_sig.Site_map_and_set.Map.add_or_overwrite - parameters error site_name new_port ag.Cckappa_sig.agent_interface + Ckappa_sig.Site_map_and_set.Map.add_or_overwrite parameters error + site_name new_port ag.Cckappa_sig.agent_interface in - let new_agent = {ag with Cckappa_sig.agent_interface = new_interface} in + let new_agent = { ag with Cckappa_sig.agent_interface = new_interface } in let error, views = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - agent_id - (Cckappa_sig.Agent new_agent) + parameters error agent_id (Cckappa_sig.Agent new_agent) c_mixture.Cckappa_sig.views in - error, {c_mixture with Cckappa_sig.views = views} - | None | Some ( Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Dead_agent _) -> + error, { c_mixture with Cckappa_sig.views } + | None | Some (Cckappa_sig.Unknown_agent _ | Cckappa_sig.Dead_agent _) -> Exception.warn parameters error __POS__ Exit c_mixture in let error, (c_rule_lhs, c_rule_rhs, translate) = Ckappa_sig.AgentsSite_map_and_set.Map.fold - (fun - site (i,j,delta) - (error, (c_rule_lhs, c_rule_rhs, translate)) -> + (fun site (i, j, delta) (error, (c_rule_lhs, c_rule_rhs, translate)) -> let error, c_rule_lhs = overwrite_counter_test parameters error site i c_rule_lhs in let error, c_rule_rhs = overwrite_counter_test parameters error site j c_rule_rhs in - let (agent_id,agent_type,site_name) = site in - error, - (c_rule_lhs, - c_rule_rhs, - ({Cckappa_sig.agent_type=agent_type; - Cckappa_sig.site=site_name; - Cckappa_sig.agent_index=agent_id}, - { - Cckappa_sig.precondition=i; - Cckappa_sig.postcondition=j; - Cckappa_sig.increment=delta})::translate) - ) + let agent_id, agent_type, site_name = site in + ( error, + ( c_rule_lhs, + c_rule_rhs, + ( { + Cckappa_sig.agent_type; + Cckappa_sig.site = site_name; + Cckappa_sig.agent_index = agent_id; + }, + { + Cckappa_sig.precondition = i; + Cckappa_sig.postcondition = j; + Cckappa_sig.increment = delta; + } ) + :: translate ) )) counter_map (error, (c_rule_lhs, c_rule_rhs, [])) in - let error,size = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.dimension parameters error c_rule_lhs.Cckappa_sig.views in - let error,direct = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters error size in - let error,reverse = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters error size in + let error, size = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.dimension + parameters error c_rule_lhs.Cckappa_sig.views + in + let error, direct = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error size + in + let error, reverse = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error size + in let actions = Cckappa_sig.empty_actions in - let actions = {actions with Cckappa_sig.translate_counters = translate ; removed_counters = list_removed ; new_counters = list_new } + let actions = + { + actions with + Cckappa_sig.translate_counters = translate; + removed_counters = list_removed; + new_counters = list_new; + } in let half_release_set = Cckappa_sig.Address_map_and_set.Set.empty in let full_release_set = Cckappa_sig.Address_map_and_set.Set.empty in - let rec aux_agent (k:Ckappa_sig.c_agent_id) - (error,(direct,reverse,actions,half_release_set,full_release_set,dead)) = - if Ckappa_sig.compare_agent_id k (Ckappa_sig.agent_id_of_int size) >= 0 - then - (error,(direct,reverse,actions,half_release_set,full_release_set,dead)) - else - begin - let error,lhsk = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error k c_rule_lhs.Cckappa_sig.views - in - let error,rhsk = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error k c_rule_rhs.Cckappa_sig.views - in - let error,(direct,reverse,actions,half_release_set,agent_type,lbondk,rbondk,dead) = - match lhsk,rhsk with - | Some Cckappa_sig.Ghost, Some Cckappa_sig.Ghost - (* nothing *) - | Some Cckappa_sig.Unknown_agent _, Some Cckappa_sig.Ghost -> (* suppression of a dead agent *) - error, ( - direct, + let rec aux_agent (k : Ckappa_sig.c_agent_id) + ( error, + (direct, reverse, actions, half_release_set, full_release_set, dead) ) = + if Ckappa_sig.compare_agent_id k (Ckappa_sig.agent_id_of_int size) >= 0 then + error, (direct, reverse, actions, half_release_set, full_release_set, dead) + else ( + let error, lhsk = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error k c_rule_lhs.Cckappa_sig.views + in + let error, rhsk = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error k c_rule_rhs.Cckappa_sig.views + in + let ( error, + ( direct, + reverse, + actions, + half_release_set, + agent_type, + lbondk, + rbondk, + dead ) ) = + match lhsk, rhsk with + | Some Cckappa_sig.Ghost, Some Cckappa_sig.Ghost + (* nothing *) + | Some (Cckappa_sig.Unknown_agent _), Some Cckappa_sig.Ghost -> + (* suppression of a dead agent *) + ( error, + ( direct, + reverse, + actions, + half_release_set, + None, + Ckappa_sig.Site_map_and_set.Map.empty, + Ckappa_sig.Site_map_and_set.Map.empty, + true ) ) + | Some (Cckappa_sig.Agent lagk), Some Cckappa_sig.Ghost + | Some (Cckappa_sig.Dead_agent (lagk, _, _, _)), Some Cckappa_sig.Ghost + -> + (*suppression*) + let agent_type = lagk.Cckappa_sig.agent_name in + let error, reverse = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error k (*Cckappa_sig.upgrade_some_interface*) lagk + reverse + in + let error, lbondk = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error k c_rule_lhs.Cckappa_sig.bonds + in + let lbondk = + match lbondk with + | None -> Ckappa_sig.Site_map_and_set.Map.empty + | Some a -> a + in + let rbondk = Ckappa_sig.Site_map_and_set.Map.empty in + let error, half_release_set = + set_bound_sites parameters error k lagk half_release_set + in + let actions = + { + actions with + Cckappa_sig.remove = + (k, clean_agent lagk, []) :: actions.Cckappa_sig.remove; + } + in + ( error, + ( direct, + reverse, + actions, + half_release_set, + Some agent_type, + lbondk, + rbondk, + dead + || + match lhsk with + | Some (Cckappa_sig.Dead_agent _) -> true + | Some (Cckappa_sig.Unknown_agent _) + | Some Cckappa_sig.Ghost + | Some (Cckappa_sig.Agent _) + | None -> + false ) ) + | Some Cckappa_sig.Ghost, Some (Cckappa_sig.Agent ragk) -> + (*creation*) + let agent_type = ragk.Cckappa_sig.agent_name in + let error, direct = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error k (*Cckappa_sig.upgrade_some_interface*) ragk + direct + in + let error, rbondk = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error k c_rule_rhs.Cckappa_sig.bonds + in + let rbondk = + match rbondk with + | None -> Ckappa_sig.Site_map_and_set.Map.empty + | Some a -> a + in + let lbondk = Ckappa_sig.Site_map_and_set.Map.empty in + ( error, + ( direct, + reverse, + { + actions with + Cckappa_sig.creation = + (k, ragk.Cckappa_sig.agent_name) + :: actions.Cckappa_sig.creation; + }, + half_release_set, + Some agent_type, + lbondk, + rbondk, + dead ) ) + | Some (Cckappa_sig.Agent lagk), Some (Cckappa_sig.Agent ragk) + | ( Some (Cckappa_sig.Dead_agent (lagk, _, _, _)), + Some + (Cckappa_sig.Dead_agent (ragk, _, _, _) | Cckappa_sig.Agent ragk) + ) -> + (* TO DO Exception.check_point Exception.warn what happen if one site is dead *) + let agent_type = lagk.Cckappa_sig.agent_name in + let error', ldiff, rdiff = + Ckappa_sig.Site_map_and_set.Map.diff_pred parameters error equ_port + lagk.Cckappa_sig.agent_interface ragk.Cckappa_sig.agent_interface + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error, lbondk = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error k c_rule_lhs.Cckappa_sig.bonds + in + let error, rbondk = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error k c_rule_rhs.Cckappa_sig.bonds + in + let lbondk = + match lbondk with + | None -> Ckappa_sig.Site_map_and_set.Map.empty + | Some a -> a + in + let rbondk = + match rbondk with + | None -> Ckappa_sig.Site_map_and_set.Map.empty + | Some a -> a + in + let error, direct = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error k + (Cckappa_sig.upgrade_interface lagk rdiff) + direct + in + let error, reverse = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error k + (Cckappa_sig.upgrade_interface ragk ldiff) + reverse + in + let error, half_release_set = + set_released_sites parameters error k lagk ragk half_release_set + in + ( error, + ( direct, + reverse, + actions, + half_release_set, + Some agent_type, + lbondk, + rbondk, + dead + || + match lhsk with + | Some (Cckappa_sig.Dead_agent _) -> true + | Some (Cckappa_sig.Unknown_agent _) + | Some Cckappa_sig.Ghost + | Some (Cckappa_sig.Agent _) + | None -> + false ) ) + | Some (Cckappa_sig.Unknown_agent _), _ + | _, Some (Cckappa_sig.Unknown_agent _) + | _, Some (Cckappa_sig.Dead_agent _) + | None, _ + | _, None -> + Exception.warn parameters error __POS__ ~pos:position Exit + ( direct, reverse, actions, half_release_set, None, Ckappa_sig.Site_map_and_set.Map.empty, Ckappa_sig.Site_map_and_set.Map.empty, - true - ) - | Some Cckappa_sig.Agent lagk, Some Cckappa_sig.Ghost - | Some Cckappa_sig.Dead_agent (lagk,_,_,_), Some Cckappa_sig.Ghost -> (*suppression*) - begin - let agent_type = lagk.Cckappa_sig.agent_name in - let error,reverse = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - k - ((*Cckappa_sig.upgrade_some_interface*) lagk) - reverse - in - let error,lbondk = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - k - c_rule_lhs.Cckappa_sig.bonds - in - let lbondk = - match lbondk with - | None -> Ckappa_sig.Site_map_and_set.Map.empty - | Some a -> a - in - let rbondk = Ckappa_sig.Site_map_and_set.Map.empty in - let error,half_release_set = set_bound_sites parameters error k lagk half_release_set in - let actions = - {actions - with Cckappa_sig.remove = (k,clean_agent lagk,[])::actions.Cckappa_sig.remove} + true ) + in + let error', bond_l, bond_r = + Ckappa_sig.Site_map_and_set.Map.diff parameters error lbondk rbondk + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let release = actions.Cckappa_sig.release in + let error, (full_release_set, release) = + match agent_type with + | None -> error, (full_release_set, release) + | Some agent_type -> + Ckappa_sig.Site_map_and_set.Map.fold + (fun site target (error, (full_release_set, release)) -> + let source = Cckappa_sig.build_address k agent_type site in + let error', full_release_set = + Cckappa_sig.Address_map_and_set.Set.add parameters error source + full_release_set in - error, ( - direct, - reverse, - actions, - half_release_set, - Some agent_type, - lbondk, - rbondk, - dead || - (match lhsk - with - | Some Cckappa_sig.Dead_agent _ -> true - | Some Cckappa_sig.Unknown_agent _ - | Some Cckappa_sig.Ghost - | Some Cckappa_sig.Agent _ - | None -> false) - ) - end - | Some Cckappa_sig.Ghost, Some Cckappa_sig.Agent ragk -> (*creation*) - begin - let agent_type = ragk.Cckappa_sig.agent_name in - let error,direct = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error k ((*Cckappa_sig.upgrade_some_interface*) ragk) direct + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in - let error,rbondk = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error k c_rule_rhs.Cckappa_sig.bonds + let release = + if compare source target < 0 then + (source, target) :: release + else + release in - let rbondk = - match rbondk with - | None -> Ckappa_sig.Site_map_and_set.Map.empty - | Some a -> a + error, (full_release_set, release)) + bond_l + (error, (full_release_set, release)) + in + let bind = actions.Cckappa_sig.bind in + let error, bind = + match agent_type with + | None -> error, bind + | Some agent_type -> + Ckappa_sig.Site_map_and_set.Map.fold + (fun site target (error, bind) -> + let source = Cckappa_sig.build_address k agent_type site in + let bind = + if compare source target < 0 then + (source, target) :: bind + else + bind in - let lbondk = Ckappa_sig.Site_map_and_set.Map.empty in - error, - ( - direct, - reverse, - { - actions - with Cckappa_sig.creation = (k,ragk.Cckappa_sig.agent_name)::actions.Cckappa_sig.creation - }, - half_release_set, - Some agent_type, - lbondk, - rbondk, - dead - ) - end - | Some Cckappa_sig.Agent lagk,Some Cckappa_sig.Agent ragk - | Some Cckappa_sig.Dead_agent (lagk,_,_,_), - Some (Cckappa_sig.Dead_agent (ragk,_,_,_) | Cckappa_sig.Agent ragk) -> - (* TO DO Exception.check_point Exception.warn what happen if one site is dead *) - let agent_type = lagk.Cckappa_sig.agent_name in - let error',ldiff,rdiff = - Ckappa_sig.Site_map_and_set.Map.diff_pred - parameters - error - equ_port - lagk.Cckappa_sig.agent_interface - ragk.Cckappa_sig.agent_interface - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let error,lbondk = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - k - c_rule_lhs.Cckappa_sig.bonds - in - let error,rbondk = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - k - c_rule_rhs.Cckappa_sig.bonds - in - let lbondk = - match lbondk with - | None -> Ckappa_sig.Site_map_and_set.Map.empty - | Some a -> a - in - let rbondk = - match rbondk with - | None -> Ckappa_sig.Site_map_and_set.Map.empty - | Some a -> a - in - let error,direct = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error k (Cckappa_sig.upgrade_interface lagk rdiff) direct - in - let error,reverse = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error k (Cckappa_sig.upgrade_interface ragk ldiff) reverse - in - let error,half_release_set = - set_released_sites parameters error k lagk ragk half_release_set - in - error,(direct,reverse,actions,half_release_set,Some agent_type,lbondk,rbondk, - dead || - (match lhsk - with - | Some Cckappa_sig.Dead_agent _ -> true - | Some Cckappa_sig.Unknown_agent _ - | Some Cckappa_sig.Ghost - | Some Cckappa_sig.Agent _| None -> false)) - | Some Cckappa_sig.Unknown_agent _, _ - | _, Some Cckappa_sig.Unknown_agent _ - | _,Some Cckappa_sig.Dead_agent _ | None,_ | _,None -> - ( Exception.warn - parameters error __POS__ - ~pos:position - Exit - (direct, - reverse, - actions, - half_release_set, - None, - Ckappa_sig.Site_map_and_set.Map.empty, Ckappa_sig.Site_map_and_set.Map.empty,true)) - in - let error',bond_l,bond_r = Ckappa_sig.Site_map_and_set.Map.diff parameters error lbondk rbondk in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let release = actions.Cckappa_sig.release in - let error,(full_release_set,release) = - match agent_type - with - None -> error,(full_release_set,release) - | Some agent_type -> - Ckappa_sig.Site_map_and_set.Map.fold - (fun site target (error,(full_release_set,release)) -> - let source = Cckappa_sig.build_address k agent_type site in - let error',full_release_set = - Cckappa_sig.Address_map_and_set.Set.add parameters error - source full_release_set - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let release = - if compare source target < 0 - then (source,target)::release - else release - in - (error,(full_release_set,release))) - bond_l - (error,(full_release_set,release)) - in - let bind = actions.Cckappa_sig.bind in - let error,bind = - match agent_type - with - | None -> error,bind - | Some agent_type -> - Ckappa_sig.Site_map_and_set.Map.fold - (fun site target (error,bind) -> - let source = Cckappa_sig.build_address k agent_type site in - let bind = - if compare source target < 0 - then (source,target)::bind - else bind - in - (error,bind)) - bond_r - (error,bind) - in - let actions = {actions with Cckappa_sig.release = release ; Cckappa_sig.bind = bind } in - let error, half_release_set = - List.fold_left - (fun (error, half_release_set) (source,target) -> - check_freeness parameters c_rule_lhs target - (check_freeness parameters c_rule_lhs source (error, half_release_set))) - (error, half_release_set) - bind - in - aux_agent - (Ckappa_sig.next_agent_id k) - (error,(direct,reverse,actions,half_release_set,full_release_set,dead)) - end - in - let error,(direct,reverse,actions,half_release_set,full_release_set,_dead) = - aux_agent - Ckappa_sig.dummy_agent_id - (error,(direct,reverse,actions,half_release_set,full_release_set,false)) - in - let error',half_release_set = - Cckappa_sig.Address_map_and_set.Set.minus parameters error half_release_set full_release_set + error, bind) + bond_r (error, bind) + in + let actions = { actions with Cckappa_sig.release; Cckappa_sig.bind } in + let error, half_release_set = + List.fold_left + (fun (error, half_release_set) (source, target) -> + check_freeness parameters c_rule_lhs target + (check_freeness parameters c_rule_lhs source + (error, half_release_set))) + (error, half_release_set) bind + in + aux_agent + (Ckappa_sig.next_agent_id k) + ( error, + (direct, reverse, actions, half_release_set, full_release_set, dead) + ) + ) + in + let ( error, + (direct, reverse, actions, half_release_set, full_release_set, _dead) ) + = + aux_agent Ckappa_sig.dummy_agent_id + ( error, + (direct, reverse, actions, half_release_set, full_release_set, false) ) + in + let error', half_release_set = + Cckappa_sig.Address_map_and_set.Set.minus parameters error half_release_set + full_release_set in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let list = Cckappa_sig.Address_map_and_set.Set.elements half_release_set in - let error,list = + let error, list = List.fold_left - (fun (error,list) add -> - let error,ag = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error add.Cckappa_sig.agent_index c_rule_lhs.Cckappa_sig.views - in - match ag - with - | None | Some Cckappa_sig.Ghost -> - Exception.warn parameters error __POS__ Exit ((add,None)::list) - | Some (Cckappa_sig.Unknown_agent _) -> error,list - | Some (Cckappa_sig.Dead_agent (ag,_,_,l')) -> - let interface = ag.Cckappa_sig.agent_interface in - begin - match + (fun (error, list) add -> + let error, ag = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error add.Cckappa_sig.agent_index + c_rule_lhs.Cckappa_sig.views + in + match ag with + | None | Some Cckappa_sig.Ghost -> + Exception.warn parameters error __POS__ Exit ((add, None) :: list) + | Some (Cckappa_sig.Unknown_agent _) -> error, list + | Some (Cckappa_sig.Dead_agent (ag, _, _, l')) -> + let interface = ag.Cckappa_sig.agent_interface in + (match + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters + error add.Cckappa_sig.site interface + with + | error, None -> + (match Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters error add.Cckappa_sig.site interface + parameters error add.Cckappa_sig.site l' with - | error,None -> - begin - match Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters error add.Cckappa_sig.site l' - with - | error,None -> - begin - Exception.warn - parameters error __POS__ ~message:"dead site" - Not_found ((add,None)::list) - end - | error,Some _ -> - error,(add,None)::list - end - | error',Some state -> - Exception.check_point - Exception.warn parameters error error' __POS__ Exit, - (add,Some state.Cckappa_sig.site_state)::list - end - | Some (Cckappa_sig.Agent ag) -> - let interface = ag.Cckappa_sig.agent_interface in - match Ckappa_sig.Site_map_and_set.Map.find_option - parameters error add.Cckappa_sig.site interface + | error, None -> + Exception.warn parameters error __POS__ ~message:"dead site" + Not_found ((add, None) :: list) + | error, Some _ -> error, (add, None) :: list) + | error', Some state -> + ( Exception.check_point Exception.warn parameters error error' + __POS__ Exit, + (add, Some state.Cckappa_sig.site_state) :: list )) + | Some (Cckappa_sig.Agent ag) -> + let interface = ag.Cckappa_sig.agent_interface in + (match + Ckappa_sig.Site_map_and_set.Map.find_option parameters error + add.Cckappa_sig.site interface with - | error',None -> - Exception.warn parameters - (Exception.check_point Exception.warn parameters error error' __POS__ Exit) - __POS__ - Not_found ((add,None)::list) - | error',Some state -> - Exception.check_point - Exception.warn parameters error error' __POS__ Exit, - (add,Some state.Cckappa_sig.site_state)::list) - (error,[]) - (List.rev list) - in - let actions = {actions with Cckappa_sig.half_break = list} in - let error,label_dot = - match - label - with - | None -> error,None - | Some (string,pos) -> - let error,s = Tools_kasa.make_id_compatible_with_dot_format parameters error string in - error,Some(s,pos) - in - error, - ({Cckappa_sig.e_rule_label = label; - Cckappa_sig.e_rule_label_dot = label_dot; - Cckappa_sig.e_rule_initial_direction = direction; - Cckappa_sig.e_rule_rule = rule; - Cckappa_sig.e_rule_c_rule = - { Cckappa_sig.prefix = rule.Ckappa_sig.prefix; - Cckappa_sig.delta = rule.Ckappa_sig.delta; - Cckappa_sig.rule_lhs = c_rule_lhs ; - Cckappa_sig.rule_rhs = c_rule_rhs ; - Cckappa_sig.actions = actions; - Cckappa_sig.diff_direct = direct ; - Cckappa_sig.diff_reverse = reverse ; - } - }) - -let refine_removal_action parameters error handler (i,ag,_l) = + | error', None -> + Exception.warn parameters + (Exception.check_point Exception.warn parameters error error' + __POS__ Exit) + __POS__ Not_found ((add, None) :: list) + | error', Some state -> + ( Exception.check_point Exception.warn parameters error error' + __POS__ Exit, + (add, Some state.Cckappa_sig.site_state) :: list ))) + (error, []) (List.rev list) + in + let actions = { actions with Cckappa_sig.half_break = list } in + let error, label_dot = + match label with + | None -> error, None + | Some (string, pos) -> + let error, s = + Tools_kasa.make_id_compatible_with_dot_format parameters error string + in + error, Some (s, pos) + in + ( error, + { + Cckappa_sig.e_rule_label = label; + Cckappa_sig.e_rule_label_dot = label_dot; + Cckappa_sig.e_rule_initial_direction = direction; + Cckappa_sig.e_rule_rule = rule; + Cckappa_sig.e_rule_c_rule = + { + Cckappa_sig.prefix = rule.Ckappa_sig.prefix; + Cckappa_sig.delta = rule.Ckappa_sig.delta; + Cckappa_sig.rule_lhs = c_rule_lhs; + Cckappa_sig.rule_rhs = c_rule_rhs; + Cckappa_sig.actions; + Cckappa_sig.diff_direct = direct; + Cckappa_sig.diff_reverse = reverse; + }; + } ) + +let refine_removal_action parameters error handler (i, ag, _l) = let l_documented = List.sort compare (clean_agent2 ag) in let error, l_undocumented = - Handler.complementary_interface - parameters - error - handler - ag.Cckappa_sig.agent_name - l_documented - in - (error, (i, ag, l_undocumented)) + Handler.complementary_interface parameters error handler + ag.Cckappa_sig.agent_name l_documented + in + error, (i, ag, l_undocumented) let refine_rule parameters error handler rule = let error, removal_actions = List.fold_left (fun (error, l) act -> - let error, act' = - refine_removal_action parameters error handler act in - error, act' :: l) + let error, act' = refine_removal_action parameters error handler act in + error, act' :: l) (error, []) (List.rev rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions.Cckappa_sig.remove) in - error, - {rule - with Cckappa_sig.e_rule_c_rule = - {rule.Cckappa_sig.e_rule_c_rule - with Cckappa_sig.actions = - {rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions - with Cckappa_sig.remove = removal_actions}}} - -let lift_forbidding_question_marks parameters handler = - (fun error x -> - let a,b,_,_ = translate_mixture parameters error handler ~creation:false x - in a,b) + ( error, + { + rule with + Cckappa_sig.e_rule_c_rule = + { + rule.Cckappa_sig.e_rule_c_rule with + Cckappa_sig.actions = + { + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions with + Cckappa_sig.remove = removal_actions; + }; + }; + } ) -let lift_allowing_question_marks parameters handler = - (fun error x -> - let a,b,c,_ = translate_mixture parameters error handler ~creation:false x in - clean_question_marks parameters a c b) +let lift_forbidding_question_marks parameters handler error x = + let a, b, _, _ = + translate_mixture parameters error handler ~creation:false x + in + a, b +let lift_allowing_question_marks parameters handler error x = + let a, b, c, _ = + translate_mixture parameters error handler ~creation:false x + in + clean_question_marks parameters a c b -let translate_pert_init error (alg,_) (c_alg,_) mixture c_mixture _pos' = - error, - {Cckappa_sig.e_init_factor = alg ; - Cckappa_sig.e_init_c_factor = c_alg ; - Cckappa_sig.e_init_mixture = mixture ; - Cckappa_sig.e_init_c_mixture = c_mixture } +let translate_pert_init error (alg, _) (c_alg, _) mixture c_mixture _pos' = + ( error, + { + Cckappa_sig.e_init_factor = alg; + Cckappa_sig.e_init_c_factor = c_alg; + Cckappa_sig.e_init_mixture = mixture; + Cckappa_sig.e_init_c_mixture = c_mixture; + } ) let alg_with_pos_map = Prepreprocess.map_with_pos Prepreprocess.alg_map - -let translate_pert parameters error handler alg (mixture,pos') = +let translate_pert parameters error handler alg (mixture, pos') = (* let mixture = c_mixture.Cckappa_sig.c_mixture in*) - let error,c_mixture,_,_ = translate_mixture parameters error handler ~creation:false mixture in - let error, c_alg = alg_with_pos_map (lift_allowing_question_marks parameters handler) error alg in + let error, c_mixture, _, _ = + translate_mixture parameters error handler ~creation:false mixture + in + let error, c_alg = + alg_with_pos_map (lift_allowing_question_marks parameters handler) error alg + in translate_pert_init error alg c_alg mixture c_mixture pos' - -let translate_init parameters error handler ((alg,pos_alg),init_t) = - let error,c_alg = +let translate_init parameters error handler ((alg, pos_alg), init_t) = + let error, c_alg = Prepreprocess.alg_map - (lift_allowing_question_marks parameters handler) error alg in - match - init_t - with - | Ast.INIT_MIX (mixture,pos') -> - let error,c_mixture,_,_ = translate_mixture parameters error handler ~creation:true mixture in - translate_pert_init error - (alg,pos_alg) (c_alg,pos_alg) mixture c_mixture pos' - | Ast.INIT_TOK _ -> (*TO DO*) - let error,dft = Cckappa_sig.dummy_init parameters error in - match Remanent_parameters.get_called_from parameters with - | Remanent_parameters_sig.KaSa -> - Exception.warn - parameters error __POS__ - ~message:"token are not supported yet" Exit dft - | Remanent_parameters_sig.KaSim - | Remanent_parameters_sig.Internalised - | Remanent_parameters_sig.Server -> - error, dft - -let translate_var parameters error handler (a,b) = - let error,b' = alg_with_pos_map (lift_allowing_question_marks parameters handler) error b in - let error,a_dot = Tools_kasa.make_id_compatible_with_dot_format parameters error (fst a) in - error, - { - Cckappa_sig.e_id = a; - Cckappa_sig.e_id_dot = a_dot,snd a; - Cckappa_sig.c_variable = fst b ; - Cckappa_sig.e_variable = (a,b')} - - -let translate_obs parameters error handler (a,b) = - let error,a' = Prepreprocess.alg_map (lift_allowing_question_marks parameters handler) error a in - error,(a',b) + (lift_allowing_question_marks parameters handler) + error alg + in + match init_t with + | Ast.INIT_MIX (mixture, pos') -> + let error, c_mixture, _, _ = + translate_mixture parameters error handler ~creation:true mixture + in + translate_pert_init error (alg, pos_alg) (c_alg, pos_alg) mixture c_mixture + pos' + | Ast.INIT_TOK _ -> + (*TO DO*) + let error, dft = Cckappa_sig.dummy_init parameters error in + (match Remanent_parameters.get_called_from parameters with + | Remanent_parameters_sig.KaSa -> + Exception.warn parameters error __POS__ + ~message:"token are not supported yet" Exit dft + | Remanent_parameters_sig.KaSim | Remanent_parameters_sig.Internalised + | Remanent_parameters_sig.Server -> + error, dft) + +let translate_var parameters error handler (a, b) = + let error, b' = + alg_with_pos_map (lift_allowing_question_marks parameters handler) error b + in + let error, a_dot = + Tools_kasa.make_id_compatible_with_dot_format parameters error (fst a) + in + ( error, + { + Cckappa_sig.e_id = a; + Cckappa_sig.e_id_dot = a_dot, snd a; + Cckappa_sig.c_variable = fst b; + Cckappa_sig.e_variable = a, b'; + } ) + +let translate_obs parameters error handler (a, b) = + let error, a' = + Prepreprocess.alg_map + (lift_allowing_question_marks parameters handler) + error a + in + error, (a', b) let bool_with_pos_map = Prepreprocess.map_with_pos Prepreprocess.bool_map -let bool_with_pos_with_option_map = Prepreprocess.with_option_map bool_with_pos_map +let bool_with_pos_with_option_map = + Prepreprocess.with_option_map bool_with_pos_map -let translate_perturb parameters error handler ((alarm,bool1,modif,bool2),pos2) = - let error,bool1' = match bool1 with - | None -> error,None +let translate_perturb parameters error handler + ((alarm, bool1, modif, bool2), pos2) = + let error, bool1' = + match bool1 with + | None -> error, None | Some b -> - let error,b' = - bool_with_pos_map (lift_allowing_question_marks parameters handler) error b in - error,Some b' in - let error,modif' = + let error, b' = + bool_with_pos_map + (lift_allowing_question_marks parameters handler) + error b + in + error, Some b' + in + let error, modif' = List.fold_left - (fun (error,l) elt -> - let error,elt' = - Prepreprocess.modif_map - (fun error (_,pos as x) -> - let err,r = translate_rule parameters error handler (None,x) in - err,(r.Cckappa_sig.e_rule_c_rule,pos)) - (lift_allowing_question_marks parameters handler) error elt in - error,elt'::l) - (error,[]) (List.rev modif) - in - let error,bool2' = bool_with_pos_with_option_map (lift_allowing_question_marks parameters handler) error bool2 in - error,((alarm,bool1',modif',bool2'),pos2) + (fun (error, l) elt -> + let error, elt' = + Prepreprocess.modif_map + (fun error ((_, pos) as x) -> + let err, r = translate_rule parameters error handler (None, x) in + err, (r.Cckappa_sig.e_rule_c_rule, pos)) + (lift_allowing_question_marks parameters handler) + error elt + in + error, elt' :: l) + (error, []) (List.rev modif) + in + let error, bool2' = + bool_with_pos_with_option_map + (lift_allowing_question_marks parameters handler) + error bool2 + in + error, ((alarm, bool1', modif', bool2'), pos2) let translate_c_compil parameters error handler compil = - let error,c_signatures,counter_default = + let error, c_signatures, counter_default = List.fold_left - (fun (error,list,map) agent -> - let error,ag,map = - translate_agent_sig - parameters - error - handler - agent - Ckappa_sig.dummy_agent_id - map - in - error,(ag::list),map) - (error,[],Ckappa_sig.AgentSite_map_and_set.Map.empty) compil.Ast.signatures + (fun (error, list, map) agent -> + let error, ag, map = + translate_agent_sig parameters error handler agent + Ckappa_sig.dummy_agent_id map + in + error, ag :: list, map) + (error, [], Ckappa_sig.AgentSite_map_and_set.Map.empty) + compil.Ast.signatures in - let error,c_variables = + let error, c_variables = List.fold_left - (fun (error,list) var -> - let error,var = translate_var parameters error handler var in - error,(var::list)) - (error,[]) compil.Ast.variables + (fun (error, list) var -> + let error, var = translate_var parameters error handler var in + error, var :: list) + (error, []) compil.Ast.variables in - let error,c_rules = + let error, c_rules = List.fold_left - (fun (error,list) rule -> - let error,c_rule = translate_rule parameters error handler rule in - error,(c_rule::list)) - (error,[]) - compil.Ast.rules + (fun (error, list) rule -> + let error, c_rule = translate_rule parameters error handler rule in + error, c_rule :: list) + (error, []) compil.Ast.rules in - let error,c_observables = + let error, c_observables = List.fold_left - (fun (error,list) obs -> - let error,c_obs = translate_obs parameters error handler obs in - error,c_obs::list) - (error,[]) compil.Ast.observables + (fun (error, list) obs -> + let error, c_obs = translate_obs parameters error handler obs in + error, c_obs :: list) + (error, []) compil.Ast.observables in - let error,c_inits = + let error, c_inits = List.fold_left - (fun (error,list) init -> - let error,c_init = translate_init parameters error handler init in - error,c_init::list) - (error,[]) compil.Ast.init + (fun (error, list) init -> + let error, c_init = translate_init parameters error handler init in + error, c_init :: list) + (error, []) compil.Ast.init in - let error,c_perturbations = + let error, c_perturbations = List.fold_left - (fun (error,list) perturb -> - let error,c_perturb = translate_perturb parameters error handler perturb in - error,c_perturb::list) - (error,[]) compil.Ast.perturbations + (fun (error, list) perturb -> + let error, c_perturb = + translate_perturb parameters error handler perturb + in + error, c_perturb :: list) + (error, []) compil.Ast.perturbations in - let error,c_rules = + let error, c_rules = List.fold_left - (fun (error,list) rule -> - let error,c_rule = refine_rule parameters error handler rule in - error,(c_rule::list)) - (error,[]) (List.rev c_rules) + (fun (error, list) rule -> + let error, c_rule = refine_rule parameters error handler rule in + error, c_rule :: list) + (error, []) (List.rev c_rules) in let n_vars = List.length c_variables in - let error,c_variables = + let error, c_variables = Ckappa_sig.array_of_list_rule_id Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set - parameters - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set parameters error (List.rev c_variables) in - let error,c_signatures = Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create Int_storage.Nearly_inf_Imperatif.set parameters error (List.rev c_signatures) in + let error, c_signatures = + Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create + Int_storage.Nearly_inf_Imperatif.set parameters error + (List.rev c_signatures) + in let n_rules = List.length c_rules in - let error,c_rules = + let error, c_rules = Ckappa_sig.array_of_list_rule_id Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set - parameters error (List.rev c_rules) + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set parameters error + (List.rev c_rules) + in + let error, c_observables = + Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create + Int_storage.Nearly_inf_Imperatif.set parameters error + (List.rev c_observables) + in + let error, c_inits = + Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create + Int_storage.Nearly_inf_Imperatif.set parameters error (List.rev c_inits) + in + let error, c_perturbations = + Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create + Int_storage.Nearly_inf_Imperatif.set parameters error + (List.rev c_perturbations) in - let error,c_observables = Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create Int_storage.Nearly_inf_Imperatif.set parameters error (List.rev c_observables) in - let error,c_inits = Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create Int_storage.Nearly_inf_Imperatif.set parameters error (List.rev c_inits) in - let error,c_perturbations = Misc_sa.array_of_list Int_storage.Nearly_inf_Imperatif.create Int_storage.Nearly_inf_Imperatif.set parameters error (List.rev c_perturbations) in - error, - {handler with Cckappa_sig.nrules = n_rules ; Cckappa_sig.nvars = n_vars }, - { - Cckappa_sig.variables = c_variables ; - Cckappa_sig.signatures = c_signatures ; - Cckappa_sig.counter_default = counter_default ; - Cckappa_sig.rules = c_rules ; - Cckappa_sig.observables = c_observables ; - Cckappa_sig.init = c_inits ; - Cckappa_sig.perturbations = c_perturbations } + ( error, + { handler with Cckappa_sig.nrules = n_rules; Cckappa_sig.nvars = n_vars }, + { + Cckappa_sig.variables = c_variables; + Cckappa_sig.signatures = c_signatures; + Cckappa_sig.counter_default; + Cckappa_sig.rules = c_rules; + Cckappa_sig.observables = c_observables; + Cckappa_sig.init = c_inits; + Cckappa_sig.perturbations = c_perturbations; + } ) let declare_agent parameters error ag sol = -Ckappa_sig.Agent_map_and_set.Map.add parameters error - ag - Ckappa_sig.Site_map_and_set.Map.empty - sol + Ckappa_sig.Agent_map_and_set.Map.add parameters error ag + Ckappa_sig.Site_map_and_set.Map.empty sol -let declare_site parameters error a b sol = +let declare_site parameters error a b sol = let error, sol_a = - Ckappa_sig.Agent_map_and_set.Map.find_default - parameters error + Ckappa_sig.Agent_map_and_set.Map.find_default parameters error Ckappa_sig.Site_map_and_set.Map.empty a sol in let error, sol_a = - Ckappa_sig.Site_map_and_set.Map.add parameters error - b ([],[]) sol_a + Ckappa_sig.Site_map_and_set.Map.add parameters error b ([], []) sol_a in - Ckappa_sig.Agent_map_and_set.Map.overwrite parameters error - a sol_a sol + Ckappa_sig.Agent_map_and_set.Map.overwrite parameters error a sol_a sol -let add_link_in_contact_map parameters error (a,b) (c,d) sol = +let add_link_in_contact_map parameters error (a, b) (c, d) sol = let error, sol_a = - Ckappa_sig.Agent_map_and_set.Map.find_default - parameters error + Ckappa_sig.Agent_map_and_set.Map.find_default parameters error Ckappa_sig.Site_map_and_set.Map.empty a sol in - let error, (l,old) = - Ckappa_sig.Site_map_and_set.Map.find_default - parameters error - ([],[]) b sol_a + let error, (l, old) = + Ckappa_sig.Site_map_and_set.Map.find_default parameters error ([], []) b + sol_a in let error, sol'_a = - Ckappa_sig.Site_map_and_set.Map.overwrite - parameters error b - (l,((c,d)::old)) sol_a + Ckappa_sig.Site_map_and_set.Map.overwrite parameters error b + (l, (c, d) :: old) + sol_a in - Ckappa_sig.Agent_map_and_set.Map.overwrite - parameters error a sol'_a - sol + Ckappa_sig.Agent_map_and_set.Map.overwrite parameters error a sol'_a sol (*----------------------------------------------------------------*) -let add_internal_state_in_contact_map parameters error (a,b) state sol = +let add_internal_state_in_contact_map parameters error (a, b) state sol = let error, sol_a = Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs parameters error Ckappa_sig.Site_map_and_set.Map.empty a sol in - let error, (old,l) = + let error, (old, l) = Ckappa_sig.Site_map_and_set.Map.find_default_without_logs parameters error - ([],[]) b sol_a + ([], []) b sol_a in let error, sol'_a = - Ckappa_sig.Site_map_and_set.Map.add_or_overwrite - parameters error b (state::old,l) sol_a + Ckappa_sig.Site_map_and_set.Map.add_or_overwrite parameters error b + (state :: old, l) + sol_a in - Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite parameters error - a sol'_a sol + Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite parameters error a sol'_a + sol let init_contact_map = Ckappa_sig.Agent_map_and_set.Map.empty @@ -2523,54 +2375,47 @@ let export_contact_map parameters error handler = (*----------------------------------------------------------------*) let error, sol = Ckappa_sig.Dictionary_of_agents.fold - (fun _ _ agent_id (error,sol) -> - declare_agent parameters error agent_id sol) - handler.Cckappa_sig.agents_dic - (error, sol) + (fun _ _ agent_id (error, sol) -> + declare_agent parameters error agent_id sol) + handler.Cckappa_sig.agents_dic (error, sol) in let error, sol = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error agent_id site_dic sol -> - Ckappa_sig.Dictionary_of_sites.fold - (fun _ _ site_id (error,sol) -> - declare_site parameters error agent_id site_id sol) - site_dic (error,sol)) - handler.Cckappa_sig.sites - sol + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold parameters error + (fun parameters error agent_id site_dic sol -> + Ckappa_sig.Dictionary_of_sites.fold + (fun _ _ site_id (error, sol) -> + declare_site parameters error agent_id site_id sol) + site_dic (error, sol)) + handler.Cckappa_sig.sites sol in - let error,sol = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.fold - parameters error - (fun parameters error (i,j) s sol -> - let error,site = - Handler.translate_site parameters error handler i j - in - match site with - | Ckappa_sig.Counter _ - | Ckappa_sig.Binding _ -> error, sol - | Ckappa_sig.Internal _ -> - Ckappa_sig.Dictionary_of_States.fold - (fun _ ((),()) state (error,sol) -> - add_internal_state_in_contact_map parameters error (i,j) state sol - ) - s - (error,sol) - ) - handler.Cckappa_sig.states_dic - sol + let error, sol = + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .fold parameters error + (fun parameters error (i, j) s sol -> + let error, site = Handler.translate_site parameters error handler i j in + match site with + | Ckappa_sig.Counter _ | Ckappa_sig.Binding _ -> error, sol + | Ckappa_sig.Internal _ -> + Ckappa_sig.Dictionary_of_States.fold + (fun _ ((), ()) state (error, sol) -> + add_internal_state_in_contact_map parameters error (i, j) state + sol) + s (error, sol)) + handler.Cckappa_sig.states_dic sol in (*----------------------------------------------------------------*) let error, sol = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.fold - parameters error - (fun _parameters error (i, (j , _k)) (i', j', _k') sol -> - add_link_in_contact_map parameters error (i,j) (i',j') sol) + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .fold parameters error + (fun _parameters error (i, (j, _k)) (i', j', _k') sol -> + add_link_in_contact_map parameters error (i, j) (i', j') sol) handler.Cckappa_sig.dual sol in let sol = Ckappa_sig.Agent_map_and_set.Map.map - (Ckappa_sig.Site_map_and_set.Map.map (fun (l,x) -> List.rev l,List.rev x)) + (Ckappa_sig.Site_map_and_set.Map.map (fun (l, x) -> + List.rev l, List.rev x)) sol in error, sol @@ -2579,59 +2424,50 @@ let export_contact_map parameters error handler = let merge_set parameters error set_opt set = match set_opt with - | None -> error,Some set + | None -> error, Some set | Some set' -> let error, set = Ckappa_sig.PairAgentSite_map_and_set.Set.inter parameters error set set' in - error, - Some set + error, Some set -let convert_scc_maps_into_set - parameters error scc_map = +let convert_scc_maps_into_set parameters error scc_map = match Public_data.AccuracyMap.fold (fun _ m error_set -> - Public_data.AccuracyMap.fold - (fun _ list (error,set_opt) -> - let error, set = - List.fold_left - ( - List.fold_left - (fun (error, set) link -> - Ckappa_sig.PairAgentSite_map_and_set.Set.add_when_not_in - parameters error link set) - ) - (error, Ckappa_sig.PairAgentSite_map_and_set.Set.empty) - list - in - merge_set parameters error set_opt set) - m error_set ) - scc_map - (error,None) + Public_data.AccuracyMap.fold + (fun _ list (error, set_opt) -> + let error, set = + List.fold_left + (List.fold_left (fun (error, set) link -> + Ckappa_sig.PairAgentSite_map_and_set.Set.add_when_not_in + parameters error link set)) + (error, Ckappa_sig.PairAgentSite_map_and_set.Set.empty) + list + in + merge_set parameters error set_opt set) + m error_set) + scc_map (error, None) with | error, None -> error, Ckappa_sig.PairAgentSite_map_and_set.Set.empty | error, Some set -> error, set - let print_list_of_lines parameters list = - List.iter - (fun line -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s" line - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in ()) - list +let print_list_of_lines parameters list = + List.iter + (fun line -> + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" line + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + ()) + list -let gexf_of_contact_map ?logger parameters (error:Exception.method_handler) handler _scc_map contact_map = +let gexf_of_contact_map ?logger parameters (error : Exception.method_handler) + handler _scc_map contact_map = let parameters_gexf = - match - logger - with + match logger with | None -> Remanent_parameters.open_contact_map_file parameters | Some loggers -> Remanent_parameters.set_logger parameters loggers in @@ -2639,7 +2475,9 @@ let gexf_of_contact_map ?logger parameters (error:Exception.method_handler) hand print_list_of_lines parameters_gexf [ ""; - ""; + ""; ""; " "; " "; @@ -2651,171 +2489,161 @@ let gexf_of_contact_map ?logger parameters (error:Exception.method_handler) hand let error = Ckappa_sig.Agent_map_and_set.Map.fold (fun i site_map error -> - let error, agent_name = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters_gexf error handler i - in - let () = - print_list_of_lines parameters_gexf - [ - " "; - " "; - " "; - " "; - " "; - " "; - ] - in - let error = - Ckappa_sig.Site_map_and_set.Map.fold - (fun j _ error -> + let error, agent_name = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters_gexf error handler i + in + let () = + print_list_of_lines parameters_gexf + [ + " "; + " "; + " "; + " "; + " "; + " "; + ] + in + let error = + Ckappa_sig.Site_map_and_set.Map.fold + (fun j _ error -> let error, site = Handler.translate_site parameters_gexf error handler i j in let error = match site with - | Ckappa_sig.Counter _ - | Ckappa_sig.Internal _ -> error + | Ckappa_sig.Counter _ | Ckappa_sig.Internal _ -> error | Ckappa_sig.Binding site -> - let site_name = - agent_name^":"^site - in + let site_name = agent_name ^ ":" ^ site in let () = print_list_of_lines parameters_gexf [ - " "; + " "; " "; " "; " "; " "; " "; ] - in error - in error) - site_map - error - in - error) + in + error + in + error) + site_map error + in + error) contact_map error in - let () = print_list_of_lines parameters_gexf [" ";" "] in - let error, counter = + let () = + print_list_of_lines parameters_gexf [ " "; " " ] + in + let error, counter = Ckappa_sig.Agent_map_and_set.Map.fold (fun i site_map (error, counter) -> - let error, agent_name = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters_gexf error handler i - in - let error, counter = - Ckappa_sig.Site_map_and_set.Map.fold - (fun j _ (error, counter) -> + let error, agent_name = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters_gexf error handler i + in + let error, counter = + Ckappa_sig.Site_map_and_set.Map.fold + (fun j _ (error, counter) -> let error, site = - Handler.translate_site - parameters_gexf error handler i j in - let error, counter = + Handler.translate_site parameters_gexf error handler i j + in + let error, counter = match site with - | Ckappa_sig.Counter _ - | Ckappa_sig.Internal _ -> error, counter + | Ckappa_sig.Counter _ | Ckappa_sig.Internal _ -> error, counter | Ckappa_sig.Binding site_name -> - - let site_name = - agent_name^":"^site_name - in + let site_name = agent_name ^ ":" ^ site_name in let () = print_list_of_lines parameters_gexf [ - " "; + " "; ] in - error, counter+1 + error, counter + 1 in error, counter) - site_map - (error,counter) - in error, counter) - contact_map - (error,0) + site_map (error, counter) + in + error, counter) + contact_map (error, 0) in - let error, _counter = + let error, _counter = Ckappa_sig.Agent_map_and_set.Map.fold - (fun i site_map (error,counter) -> - let error, agent_name = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters_gexf error handler i - in - Ckappa_sig.Site_map_and_set.Map.fold - (fun j (_,b) (error,counter) -> - let error, site = - Handler.translate_site - parameters_gexf error handler i j - in - let error, counter = - match site with - | Ckappa_sig.Internal _ - | Ckappa_sig.Counter _ -> error, counter - | Ckappa_sig.Binding site_name -> - List.fold_left - (fun (error, counter) (i',j') -> - if Ckappa_sig.compare_agent_name i i' < 0 - || (Ckappa_sig.compare_agent_name i i' = 0 && - Ckappa_sig.compare_site_name j j' <= 0) - then - let error, agent_name' = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters_gexf error handler i' - in - let error, site = - Handler.translate_site - parameters_gexf error handler i' j' - in - match site with - | Ckappa_sig.Internal _ - | Ckappa_sig.Counter _ -> - Exception.warn parameters_gexf error __POS__ Exit counter - | Ckappa_sig.Binding site_name' -> - let () = - print_list_of_lines parameters_gexf - [ - " "; - ] - in error, counter+1 - else - error, counter - ) (error,counter) b - in - error, counter ) - site_map - (error, counter)) + (fun i site_map (error, counter) -> + let error, agent_name = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters_gexf error handler i + in + Ckappa_sig.Site_map_and_set.Map.fold + (fun j (_, b) (error, counter) -> + let error, site = + Handler.translate_site parameters_gexf error handler i j + in + let error, counter = + match site with + | Ckappa_sig.Internal _ | Ckappa_sig.Counter _ -> error, counter + | Ckappa_sig.Binding site_name -> + List.fold_left + (fun (error, counter) (i', j') -> + if + Ckappa_sig.compare_agent_name i i' < 0 + || Ckappa_sig.compare_agent_name i i' = 0 + && Ckappa_sig.compare_site_name j j' <= 0 + then ( + let error, agent_name' = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters_gexf error handler + i' + in + let error, site = + Handler.translate_site parameters_gexf error handler i' + j' + in + match site with + | Ckappa_sig.Internal _ | Ckappa_sig.Counter _ -> + Exception.warn parameters_gexf error __POS__ Exit + counter + | Ckappa_sig.Binding site_name' -> + let () = + print_list_of_lines parameters_gexf + [ + " "; + ] + in + error, counter + 1 + ) else + error, counter) + (error, counter) b + in + error, counter) + site_map (error, counter)) contact_map (error, counter) in - let _ = print_list_of_lines parameters_gexf - [ - " "; - " "; - "" - ] + let _ = + print_list_of_lines parameters_gexf + [ " "; " "; "" ] in let () = - match - logger - with - | None -> Loggers.close_logger (Remanent_parameters.get_logger parameters_gexf) - | Some _ -> Loggers.flush_logger (Remanent_parameters.get_logger parameters_gexf) + match logger with + | None -> + Loggers.close_logger (Remanent_parameters.get_logger parameters_gexf) + | Some _ -> + Loggers.flush_logger (Remanent_parameters.get_logger parameters_gexf) in error - -let dot_of_contact_map - ?logger parameters error - handler scc_map contact_map = +let dot_of_contact_map ?logger parameters error handler scc_map contact_map = let parameters_dot = - match - logger - with + match logger with | None -> Remanent_parameters.open_contact_map_file parameters | Some logger -> Remanent_parameters.set_logger parameters logger in @@ -2823,219 +2651,229 @@ let dot_of_contact_map let _ = List.iter (fun x -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "%s%s" - Headers.dot_comment - x - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) in - ()) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "%s%s" Headers.dot_comment x + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + ()) (Headers.head parameters_dot) in let _ = List.iter - (fun x-> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "%s%s" - Headers.dot_comment - x - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in - ()) + (fun x -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "%s%s" Headers.dot_comment x + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + ()) Headers.head_contact_map_in_dot in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) "graph G{ \n" in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "graph G{ \n" + in let error = Ckappa_sig.Agent_map_and_set.Map.fold (fun i site_map error -> - let error, agent_name = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters_dot error handler i - in - let _ = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "subgraph cluster%s {" - (Ckappa_sig.string_of_agent_name i) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in - let n_sites,error = - Ckappa_sig.Site_map_and_set.Map.fold - (fun j _ (n,error) -> - let error, site = Handler.translate_site parameters_dot error handler i j in - let _ = - match site with - | Ckappa_sig.Internal site_name -> - if not (Remanent_parameters.get_pure_contact parameters_dot) - then - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - " %s.%s [style = filled label = \"%s\" %s color = %s size = \"5\"]" - (Ckappa_sig.string_of_agent_name i) - (Ckappa_sig.string_of_site_name j) - site_name - (Graph_loggers.shape_in_dot - (Remanent_parameters.get_internal_site_shape parameters_dot)) - (Graph_loggers.dot_color_encoding - (Remanent_parameters.get_internal_site_color parameters_dot)) - in - Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) - else - () - | Ckappa_sig.Binding site_name -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - " %s.%s [style = filled label = \"%s\" %s color = %s size = \"5\"]" - (Ckappa_sig.string_of_agent_name i) - (Ckappa_sig.string_of_site_name j) - site_name - (Graph_loggers.shape_in_dot - (Remanent_parameters.get_binding_site_shape parameters_dot)) - (Graph_loggers.dot_color_encoding - (Remanent_parameters.get_binding_site_color parameters_dot)) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in () - | Ckappa_sig.Counter site_name -> + let error, agent_name = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters_dot error handler i + in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "subgraph cluster%s {" + (Ckappa_sig.string_of_agent_name i) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + let n_sites, error = + Ckappa_sig.Site_map_and_set.Map.fold + (fun j _ (n, error) -> + let error, site = + Handler.translate_site parameters_dot error handler i j + in + let _ = + match site with + | Ckappa_sig.Internal site_name -> + if not (Remanent_parameters.get_pure_contact parameters_dot) + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) - " %s.%s [style = filled label = \"%s\" %s color = %s size = \"5\"]" + " %s.%s [style = filled label = \"%s\" %s color = %s \ + size = \"5\"]" (Ckappa_sig.string_of_agent_name i) (Ckappa_sig.string_of_site_name j) site_name (Graph_loggers.shape_in_dot - (Remanent_parameters.get_counter_site_shape parameters_dot)) + (Remanent_parameters.get_internal_site_shape + parameters_dot)) (Graph_loggers.dot_color_encoding - (Remanent_parameters.get_counter_site_color parameters_dot)) + (Remanent_parameters.get_internal_site_color + parameters_dot)) in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in () - in - (Ckappa_sig.next_site_name n,error)) - site_map (Ckappa_sig.dummy_site_name,error) - in - let () = - if Ckappa_sig.compare_site_name n_sites Ckappa_sig.dummy_site_name <= 0 - then - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - " %s.0 [shape = plaintext label = \"\"]" - (Ckappa_sig.string_of_agent_name i) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in () - in - let color = - Ckappa_sig.get_agent_color - n_sites parameters_dot - in - let shape = - Ckappa_sig.get_agent_shape - n_sites - parameters_dot - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "label = \"%s\"; %s; color = %s" - agent_name - (Graph_loggers.shape_in_dot shape) - (Graph_loggers.dot_color_encoding color) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) "} ; " in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) - in - error) + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + ) else + () + | Ckappa_sig.Binding site_name -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + " %s.%s [style = filled label = \"%s\" %s color = %s \ + size = \"5\"]" + (Ckappa_sig.string_of_agent_name i) + (Ckappa_sig.string_of_site_name j) + site_name + (Graph_loggers.shape_in_dot + (Remanent_parameters.get_binding_site_shape + parameters_dot)) + (Graph_loggers.dot_color_encoding + (Remanent_parameters.get_binding_site_color + parameters_dot)) + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + in + () + | Ckappa_sig.Counter site_name -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + " %s.%s [style = filled label = \"%s\" %s color = %s \ + size = \"5\"]" + (Ckappa_sig.string_of_agent_name i) + (Ckappa_sig.string_of_site_name j) + site_name + (Graph_loggers.shape_in_dot + (Remanent_parameters.get_counter_site_shape + parameters_dot)) + (Graph_loggers.dot_color_encoding + (Remanent_parameters.get_counter_site_color + parameters_dot)) + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + in + () + in + Ckappa_sig.next_site_name n, error) + site_map + (Ckappa_sig.dummy_site_name, error) + in + let () = + if + Ckappa_sig.compare_site_name n_sites Ckappa_sig.dummy_site_name <= 0 + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + " %s.0 [shape = plaintext label = \"\"]" + (Ckappa_sig.string_of_agent_name i) + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + in + () + ) + in + let color = Ckappa_sig.get_agent_color n_sites parameters_dot in + let shape = Ckappa_sig.get_agent_shape n_sites parameters_dot in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "label = \"%s\"; %s; color = %s" agent_name + (Graph_loggers.shape_in_dot shape) + (Graph_loggers.dot_color_encoding color) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) "} ; " + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + error) contact_map error in let error = Ckappa_sig.Agent_map_and_set.Map.fold (fun i site_map error -> - Ckappa_sig.Site_map_and_set.Map.fold - (fun j (_,b) error -> - let error, site = - Handler.translate_site parameters_dot error handler i j - in - let _ = - match site with - | Ckappa_sig.Internal _ - | Ckappa_sig.Counter _ -> error - | Ckappa_sig.Binding _ -> - List.fold_left - (fun error (i',j') -> - if Ckappa_sig.compare_agent_name i i' < 0 - || (Ckappa_sig.compare_agent_name i i' = 0 && - Ckappa_sig.compare_site_name j j' <= 0) - then - let color = - let b = - Ckappa_sig.PairAgentSite_map_and_set.Set.mem - ((i,j),(i',j')) scc_set - in - if b - then - " [color=\"red\"]" - else "" - in - let _ = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "%s.%s -- %s.%s%s" - (Ckappa_sig.string_of_agent_name i) - (Ckappa_sig.string_of_site_name j) - (Ckappa_sig.string_of_agent_name i') - (Ckappa_sig.string_of_site_name j') - color - in - let _ = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in - error - else - error - ) error b - in - error) - site_map - error) + Ckappa_sig.Site_map_and_set.Map.fold + (fun j (_, b) error -> + let error, site = + Handler.translate_site parameters_dot error handler i j + in + let _ = + match site with + | Ckappa_sig.Internal _ | Ckappa_sig.Counter _ -> error + | Ckappa_sig.Binding _ -> + List.fold_left + (fun error (i', j') -> + if + Ckappa_sig.compare_agent_name i i' < 0 + || Ckappa_sig.compare_agent_name i i' = 0 + && Ckappa_sig.compare_site_name j j' <= 0 + then ( + let color = + let b = + Ckappa_sig.PairAgentSite_map_and_set.Set.mem + ((i, j), (i', j')) + scc_set + in + if b then + " [color=\"red\"]" + else + "" + in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "%s.%s -- %s.%s%s" + (Ckappa_sig.string_of_agent_name i) + (Ckappa_sig.string_of_site_name j) + (Ckappa_sig.string_of_agent_name i') + (Ckappa_sig.string_of_site_name j') + color + in + let _ = + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + in + error + ) else + error) + error b + in + error) + site_map error) contact_map error in let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) "}" in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in let () = - match - logger - with - | None -> Loggers.close_logger (Remanent_parameters.get_logger parameters_dot) - | Some _ -> Loggers.flush_logger (Remanent_parameters.get_logger parameters_dot) + match logger with + | None -> + Loggers.close_logger (Remanent_parameters.get_logger parameters_dot) + | Some _ -> + Loggers.flush_logger (Remanent_parameters.get_logger parameters_dot) in error diff --git a/core/KaSa_rep/frontend/preprocess.mli b/core/KaSa_rep/frontend/preprocess.mli index 2189e0cfb8..8c72b6b862 100644 --- a/core/KaSa_rep/frontend/preprocess.mli +++ b/core/KaSa_rep/frontend/preprocess.mli @@ -1,144 +1,140 @@ -val local_trace:bool +val local_trace : bool +val empty_pos : string * int * int -val empty_pos: string * int * int - -val empty_agent: +val empty_agent : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Exception_without_parameter.method_handler * - 'a Int_storage.Quick_Nearly_inf_Imperatif.t - Cckappa_sig.proper_agent + Exception_without_parameter.method_handler + * 'a Int_storage.Quick_Nearly_inf_Imperatif.t Cckappa_sig.proper_agent -val empty_mixture: +val empty_mixture : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Exception_without_parameter.method_handler * Cckappa_sig.mixture -val empty_rule: +val empty_rule : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Exception_without_parameter.method_handler * Cckappa_sig.rule -val empty_e_rule: +val empty_e_rule : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Exception_without_parameter.method_handler * - Cckappa_sig.enriched_rule + Exception_without_parameter.method_handler * Cckappa_sig.enriched_rule -val init_contact_map: 'a Ckappa_sig.Agent_map_and_set.Map.t +val init_contact_map : 'a Ckappa_sig.Agent_map_and_set.Map.t -val declare_agent: +val declare_agent : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Quark_type.agent_quark -> - 'a Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_map_and_set.Map.t -> - Exception_without_parameter.method_handler * - 'a Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_map_and_set.Map.t + 'a Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t -> + Exception_without_parameter.method_handler + * 'a Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t -val declare_site: +val declare_site : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Quark_type.agent_quark -> Ckappa_sig.c_site_name -> ('a list * 'b list) Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_map_and_set.Map.t -> - Exception_without_parameter.method_handler * - ('a list * 'b list) Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_map_and_set.Map.t -> + Exception_without_parameter.method_handler + * ('a list * 'b list) Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t -val add_internal_state_in_contact_map: +val add_internal_state_in_contact_map : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Quark_type.agent_quark * Ckappa_sig.c_site_name -> 'a -> ('a list * 'b list) Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_map_and_set.Map.t -> - Exception_without_parameter.method_handler * - ('a list * 'b list) Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_map_and_set.Map.t -> + Exception_without_parameter.method_handler + * ('a list * 'b list) Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t -val add_link_in_contact_map: +val add_link_in_contact_map : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Quark_type.agent_quark * Ckappa_sig.c_site_name -> 'a * 'b -> ('c list * ('a * 'b) list) Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_map_and_set.Map.t -> - Exception_without_parameter.method_handler * - ('c list * ('a * 'b) list) Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_map_and_set.Map.t -> + Exception_without_parameter.method_handler + * ('c list * ('a * 'b) list) Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t -val dot_of_contact_map: +val dot_of_contact_map : ?logger:Loggers.t -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> - Ckappa_sig.PairAgentSite_map_and_set.elt list list - Public_data.AccuracyMap.t Public_data.AccuracyMap.t -> + Ckappa_sig.PairAgentSite_map_and_set.elt list list Public_data.AccuracyMap.t + Public_data.AccuracyMap.t -> ('a * (Quark_type.agent_quark * Ckappa_sig.c_site_name) list) - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_map_and_set.Map.t -> + Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_map_and_set.Map.t -> Exception_without_parameter.method_handler -val gexf_of_contact_map: +val gexf_of_contact_map : ?logger:Loggers.t -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> 'a -> ('b * (Quark_type.agent_quark * Ckappa_sig.c_site_name) list) - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_map_and_set.Map.t -> + Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_map_and_set.Map.t -> Exception_without_parameter.method_handler -val export_contact_map: +val export_contact_map : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> - Exception_without_parameter.method_handler * - (Ckappa_sig.c_state list * - (Quark_type.agent_quark * Ckappa_sig.c_site_name) list) + Exception_without_parameter.method_handler + * (Ckappa_sig.c_state list + * (Quark_type.agent_quark * Ckappa_sig.c_site_name) list) Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t -val translate_c_compil: +val translate_c_compil : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> - (Ckappa_sig.agent, Ckappa_sig.mixture, Ckappa_sig.mixture, - string, Ckappa_sig.mixture Ckappa_sig.rule) - Ast.compil -> - Exception_without_parameter.method_handler * - Cckappa_sig.kappa_handler * Cckappa_sig.compil + ( Ckappa_sig.agent, + Ckappa_sig.mixture, + Ckappa_sig.mixture, + string, + Ckappa_sig.mixture Ckappa_sig.rule ) + Ast.compil -> + Exception_without_parameter.method_handler + * Cckappa_sig.kappa_handler + * Cckappa_sig.compil -val translate_pert: +val translate_pert : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> - (Ckappa_sig.mixture, string) Alg_expr.e * Locality.t -> + (Ckappa_sig.mixture, string) Alg_expr.e * Loc.t -> Ckappa_sig.mixture * 'a -> - Exception_without_parameter.method_handler * - Cckappa_sig.enriched_init + Exception_without_parameter.method_handler * Cckappa_sig.enriched_init -val rename_rule_lhs: +val rename_rule_lhs : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.c_agent_id -> Cckappa_sig.rule -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_agent_id + Exception_without_parameter.method_handler * Ckappa_sig.c_agent_id -val rename_rule_rhs: +val rename_rule_rhs : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.c_agent_id -> Cckappa_sig.rule -> - Exception_without_parameter.method_handler * - Ckappa_sig.c_agent_id + Exception_without_parameter.method_handler * Ckappa_sig.c_agent_id -val lift_forbidding_question_marks: +val lift_forbidding_question_marks : Remanent_parameters_sig.parameters -> Cckappa_sig.kappa_handler -> Exception_without_parameter.method_handler -> diff --git a/core/KaSa_rep/frontend/print_cckappa.ml b/core/KaSa_rep/frontend/print_cckappa.ml index 5f0a5355bc..022227e9ff 100644 --- a/core/KaSa_rep/frontend/print_cckappa.ml +++ b/core/KaSa_rep/frontend/print_cckappa.ml @@ -16,116 +16,169 @@ let trace = false let local_trace = false let string_of_port parameters port = - "[state_min:" ^ - (Ckappa_sig.string_of_state_index_option_min parameters port.Cckappa_sig.site_state.Cckappa_sig.min) ^ - ";state_max:" ^ - (Ckappa_sig.string_of_state_index_option_max parameters port.Cckappa_sig.site_state.Cckappa_sig.max) ^ "]" + "[state_min:" + ^ Ckappa_sig.string_of_state_index_option_min parameters + port.Cckappa_sig.site_state.Cckappa_sig.min + ^ ";state_max:" + ^ Ckappa_sig.string_of_state_index_option_max parameters + port.Cckappa_sig.site_state.Cckappa_sig.max + ^ "]" let print_kasim_site x = - match - x - with () -> "" + match x with + | () -> "" let print_agent parameters error _handler agent = match agent with - | Cckappa_sig.Unknown_agent (s,_id) -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sunknown_agent:%s" (Remanent_parameters.get_prefix parameters) s in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + | Cckappa_sig.Unknown_agent (s, _id) -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sunknown_agent:%s" + (Remanent_parameters.get_prefix parameters) + s + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in error - | Cckappa_sig.Dead_agent (agent,s,l,l') -> - let parameters = Remanent_parameters.update_prefix parameters - ("agent_type_"^(Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name)^":") in + | Cckappa_sig.Dead_agent (agent, s, l, l') -> + let parameters = + Remanent_parameters.update_prefix parameters + ("agent_type_" + ^ Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name + ^ ":") + in let error = Ckappa_sig.Site_map_and_set.Map.fold (fun a b error -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%ssite_type_%s->state:%s" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_site_name a) - (string_of_port parameters b) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%ssite_type_%s->state:%s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_site_name a) + (string_of_port parameters b) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in error) - agent.Cckappa_sig.agent_interface - error in + agent.Cckappa_sig.agent_interface error + in let error = Cckappa_sig.KaSim_Site_map_and_set.Set.fold - (fun x error -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sUndefined site:%s" (Remanent_parameters.get_prefix parameters) - (Print_handler.string_of_site parameters x) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - s - error + (fun x error -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sUndefined site:%s" + (Remanent_parameters.get_prefix parameters) + (Print_handler.string_of_site parameters x) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) + s error in let error = Ckappa_sig.Site_map_and_set.Map.fold - (fun s _ error -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sdead site type %s" (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_site_name s) + (fun s _ error -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sdead site type %s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_site_name s) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - l - error + error) + l error in let error = Ckappa_sig.Site_map_and_set.Map.fold - (fun s _ error -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sdead site type %s" (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_site_name s) + (fun s _ error -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sdead site type %s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_site_name s) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - l' - error + error) + l' error in error | Cckappa_sig.Agent agent -> - let parameters = Remanent_parameters.update_prefix parameters - ("agent_type_" ^ - (Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name)^":") + let parameters = + Remanent_parameters.update_prefix parameters + ("agent_type_" + ^ Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name + ^ ":") in Ckappa_sig.Site_map_and_set.Map.fold (fun a b error -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%ssite_type_%s->state:%s" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_site_name a) - (string_of_port parameters b) + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%ssite_type_%s->state:%s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_site_name a) + (string_of_port parameters b) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in error) - agent.Cckappa_sig.agent_interface - error + agent.Cckappa_sig.agent_interface error | Cckappa_sig.Ghost -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sGhost" (Remanent_parameters.get_prefix parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sGhost" + (Remanent_parameters.get_prefix parameters) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in error let print_diffagent parameters error _handler agent = - let parameters = Remanent_parameters.update_prefix parameters - ("agent_type_"^(Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name)^":") in + let parameters = + Remanent_parameters.update_prefix parameters + ("agent_type_" + ^ Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name + ^ ":") + in Ckappa_sig.Site_map_and_set.Map.fold (fun a b error -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%ssite_type_%s->state:%s" (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_site_name a) - (string_of_port parameters b) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%ssite_type_%s->state:%s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_site_name a) + (string_of_port parameters b) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in error) - agent.Cckappa_sig.agent_interface - error + agent.Cckappa_sig.agent_interface error let print_mixture parameters error handler mixture = - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" - (Remanent_parameters.get_prefix parameters) in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_prefix parameters) + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in let error = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.print @@ -133,8 +186,7 @@ let print_mixture parameters error handler mixture = error (fun parameters error a -> let _ = print_agent parameters error handler a in - error - ) + error) mixture.Cckappa_sig.views in let error = @@ -145,48 +197,60 @@ let print_mixture parameters error handler mixture = let error = Ckappa_sig.Site_map_and_set.Map.fold (fun k a error -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%ssite_type_%s->agent_id_%s.site_type_%s" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_site_name k) - (Ckappa_sig.string_of_agent_id a.Cckappa_sig.agent_index) - (Ckappa_sig.string_of_site_name a.Cckappa_sig.site) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%ssite_type_%s->agent_id_%s.site_type_%s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_site_name k) + (Ckappa_sig.string_of_agent_id a.Cckappa_sig.agent_index) + (Ckappa_sig.string_of_site_name a.Cckappa_sig.site) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error - ) - a - error - in error) + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + a error + in + error) mixture.Cckappa_sig.bonds in let error = List.fold_left - (fun error (i,j) -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i+%i" - (Ckappa_sig.int_of_agent_id i) - (Ckappa_sig.int_of_agent_id j) + (fun error (i, j) -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%i+%i" + (Ckappa_sig.int_of_agent_id i) + (Ckappa_sig.int_of_agent_id j) in - error - ) - error - mixture.Cckappa_sig.plus + error) + error mixture.Cckappa_sig.plus in let error = List.fold_left - (fun error (i,j) -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i.%i" - (Ckappa_sig.int_of_agent_id i) - (Ckappa_sig.int_of_agent_id j) - in error ) - error - mixture.Cckappa_sig.dot + (fun error (i, j) -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%i.%i" + (Ckappa_sig.int_of_agent_id i) + (Ckappa_sig.int_of_agent_id j) + in + error) + error mixture.Cckappa_sig.dot in error let print_diffview parameters error handler diff = - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" - (Remanent_parameters.get_prefix parameters) in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_prefix parameters) + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in let error = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.print @@ -194,295 +258,352 @@ let print_diffview parameters error handler diff = error (fun parameters error a -> let _ = print_diffagent parameters error handler a in - error - ) + error) diff in error let rec print_short_alg parameters error handler alg = match alg with - |Alg_expr.BIN_ALG_OP(Operator.MULT,a1,a2),_ -> + | Alg_expr.BIN_ALG_OP (Operator.MULT, a1, a2), _ -> let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s" (Remanent_parameters.get_agent_open_symbol parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "*" in let error = print_short_alg parameters error handler a2 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s" (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.BIN_ALG_OP(Operator.SUM,a1,a2),_ -> + | Alg_expr.BIN_ALG_OP (Operator.SUM, a1, a2), _ -> let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s" (Remanent_parameters.get_agent_sep_plus_symbol parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_agent_sep_plus_symbol parameters) in let error = print_short_alg parameters error handler a2 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.BIN_ALG_OP(Operator.DIV,a1,a2),_ -> + | Alg_expr.BIN_ALG_OP (Operator.DIV, a1, a2), _ -> let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "/" in let error = print_short_alg parameters error handler a2 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.BIN_ALG_OP(Operator.MINUS,a1,a2),_ -> + | Alg_expr.BIN_ALG_OP (Operator.MINUS, a1, a2), _ -> let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "-" in let error = print_short_alg parameters error handler a2 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.BIN_ALG_OP(Operator.POW,a1,a2),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) + | Alg_expr.BIN_ALG_OP (Operator.POW, a1, a2), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s" (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "**" in let error = print_short_alg parameters error handler a2 in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.BIN_ALG_OP(Operator.MODULO,a1,a2),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + | Alg_expr.BIN_ALG_OP (Operator.MODULO, a1, a2), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "mod" in let error = print_short_alg parameters error handler a2 in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.UN_ALG_OP(Operator.LOG,a1),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%slog%s" + | Alg_expr.UN_ALG_OP (Operator.LOG, a1), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%slog%s" (Remanent_parameters.get_agent_open_symbol parameters) (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s" + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s" (Remanent_parameters.get_agent_close_symbol parameters) (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.UN_ALG_OP(Operator.SQRT,a1),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%ssqrt%s" + | Alg_expr.UN_ALG_OP (Operator.SQRT, a1), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%ssqrt%s" (Remanent_parameters.get_agent_open_symbol parameters) (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s%s" (Remanent_parameters.get_agent_close_symbol parameters) (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.UN_ALG_OP(Operator.EXP,a1),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) + | Alg_expr.UN_ALG_OP (Operator.EXP, a1), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%sexp%s" (Remanent_parameters.get_agent_open_symbol parameters) (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s" (Remanent_parameters.get_agent_close_symbol parameters) (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.UN_ALG_OP(Operator.SINUS,a1),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) + | Alg_expr.UN_ALG_OP (Operator.SINUS, a1), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%ssin%s" (Remanent_parameters.get_agent_open_symbol parameters) (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s" (Remanent_parameters.get_agent_close_symbol parameters) (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.UN_ALG_OP(Operator.COSINUS,a1),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) + | Alg_expr.UN_ALG_OP (Operator.COSINUS, a1), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%scos%s" (Remanent_parameters.get_agent_open_symbol parameters) (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s" (Remanent_parameters.get_agent_close_symbol parameters) (Remanent_parameters.get_agent_close_symbol parameters) in error - (* | Ast.UN_ALG_OP(Operator.ABS,a1),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "(abs(" in - let error = print_short_alg parameters error handler a1 in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "))" in - error *) - | Alg_expr.UN_ALG_OP(Operator.TAN,a1),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) + (* | Ast.UN_ALG_OP(Operator.ABS,a1),_ -> + let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "(abs(" in + let error = print_short_alg parameters error handler a1 in + let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "))" in + error *) + | Alg_expr.UN_ALG_OP (Operator.TAN, a1), _ -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%stan%s" (Remanent_parameters.get_agent_open_symbol parameters) (Remanent_parameters.get_agent_open_symbol parameters) in let error = print_short_alg parameters error handler a1 in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s" + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s" (Remanent_parameters.get_agent_close_symbol parameters) (Remanent_parameters.get_agent_close_symbol parameters) in error - | Alg_expr.STATE_ALG_OP Operator.TIME_VAR,_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "#TIME#" in + | Alg_expr.STATE_ALG_OP Operator.TIME_VAR, _ -> + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "#TIME#" + in error - | Alg_expr.STATE_ALG_OP Operator.EVENT_VAR,_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "#EVENT#" in + | Alg_expr.STATE_ALG_OP Operator.EVENT_VAR, _ -> + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "#EVENT#" + in error - - | Alg_expr.ALG_VAR s,_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "(OBS(%s))" s in + | Alg_expr.ALG_VAR s, _ -> + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "(OBS(%s))" s + in error - - | Alg_expr.CONST(Nbr.F(f)),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%f " f in + | Alg_expr.CONST (Nbr.F f), _ -> + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%f " f + in error - (*MOD: add print integer at compilation variables*) - | Alg_expr.CONST(Nbr.I(i)),_ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%d " i in + | Alg_expr.CONST (Nbr.I i), _ -> + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%d " i + in error - - | Alg_expr.UN_ALG_OP (Operator.UMINUS,_),_ - | Alg_expr.UN_ALG_OP (Operator.INT,_),_ - | Alg_expr.BIN_ALG_OP (Operator.MAX,_,_),_ - | Alg_expr.BIN_ALG_OP (Operator.MIN,_,_),_ - | Alg_expr.STATE_ALG_OP (Operator.NULL_EVENT_VAR - | Operator.TMAX_VAR - | Operator.EMAX_VAR - | Operator.CPUTIME - ),_ - | Alg_expr.CONST (Nbr.I64 _),_ - | Alg_expr.DIFF_TOKEN (_,_),_ - | Alg_expr.DIFF_KAPPA_INSTANCE (_,_),_ - | Alg_expr.IF _,_ - | Alg_expr.TOKEN_ID _,_ - | Alg_expr.KAPPA_INSTANCE _,_ -> (*to do*) error - (* | Ast.INFINITY _ -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "+oo" in - error *) - (* | _ -> (*to do*) - error *) + | Alg_expr.UN_ALG_OP (Operator.UMINUS, _), _ + | Alg_expr.UN_ALG_OP (Operator.INT, _), _ + | Alg_expr.BIN_ALG_OP (Operator.MAX, _, _), _ + | Alg_expr.BIN_ALG_OP (Operator.MIN, _, _), _ + | ( Alg_expr.STATE_ALG_OP + ( Operator.NULL_EVENT_VAR | Operator.TMAX_VAR | Operator.EMAX_VAR + | Operator.CPUTIME ), + _ ) + | Alg_expr.CONST (Nbr.I64 _), _ + | Alg_expr.DIFF_TOKEN (_, _), _ + | Alg_expr.DIFF_KAPPA_INSTANCE (_, _), _ + | Alg_expr.IF _, _ + | Alg_expr.TOKEN_ID _, _ + | Alg_expr.KAPPA_INSTANCE _, _ -> + (*to do*) error +(* | Ast.INFINITY _ -> + let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "+oo" in + error *) +(* | _ -> (*to do*) + error *) let print_var parameters error handler var = let s = fst var.Cckappa_sig.e_id in let _ = - if s <> "" - then Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s: " s + if s <> "" then + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s: " s in - print_short_alg - parameters error handler (Locality.dummy_annot var.Cckappa_sig.c_variable) - + print_short_alg parameters error handler + (Loc.annot_with_dummy var.Cckappa_sig.c_variable) let print_variables parameters error handler var = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.print - parameters - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.print parameters error (fun parameters error var -> - let _ = Loggers.fprintf - (Remanent_parameters.get_logger parameters) "%s" - (Remanent_parameters.get_prefix parameters) + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_prefix parameters) in let error = print_var parameters error handler var in let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in error - ) + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) var let print_signatures _parameters error _handler _signature = error let print_default_counters parameters error _handler map = - if Ckappa_sig.AgentSite_map_and_set.Map.is_empty + if Ckappa_sig.AgentSite_map_and_set.Map.is_empty map then + error + else ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s:" + (Remanent_parameters.get_prefix parameters) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + Ckappa_sig.AgentSite_map_and_set.Map.iter + (fun (a, s) state_opt -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s: %s.%s %s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_agent_name a) + (Ckappa_sig.string_of_site_name s) + (match state_opt with + | None -> "" + | Some a -> "->" ^ Ckappa_sig.string_of_state_index a) + in + Loggers.print_newline (Remanent_parameters.get_logger parameters)) map - then error - else - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s:" - (Remanent_parameters.get_prefix parameters) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in - let () = - Ckappa_sig.AgentSite_map_and_set.Map.iter - (fun (a,s) state_opt -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s: %s.%s %s" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_name a) - (Ckappa_sig.string_of_site_name s) - (match state_opt with - | None -> "" - | Some a -> "->"^(Ckappa_sig.string_of_state_index a)) - in - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - ) - map - in error + in + error + ) -let print_bond parameters relation (add1,add2) = - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s(agent_id_%s,agent_type_%s)@@site_type_%s%s(agent_id_%s,agent_type_%s)@@site_type_%s" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_id add1.Cckappa_sig.agent_index) - (Ckappa_sig.string_of_agent_name add1.Cckappa_sig.agent_type) - (Ckappa_sig.string_of_site_name add1.Cckappa_sig.site) - relation - (Ckappa_sig.string_of_agent_id add2.Cckappa_sig.agent_index) - (Ckappa_sig.string_of_agent_name add2.Cckappa_sig.agent_type) - (Ckappa_sig.string_of_site_name add2.Cckappa_sig.site) +let print_bond parameters relation (add1, add2) = + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s(agent_id_%s,agent_type_%s)@@site_type_%s%s(agent_id_%s,agent_type_%s)@@site_type_%s" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_agent_id add1.Cckappa_sig.agent_index) + (Ckappa_sig.string_of_agent_name add1.Cckappa_sig.agent_type) + (Ckappa_sig.string_of_site_name add1.Cckappa_sig.site) + relation + (Ckappa_sig.string_of_agent_id add2.Cckappa_sig.agent_index) + (Ckappa_sig.string_of_agent_name add2.Cckappa_sig.agent_type) + (Ckappa_sig.string_of_site_name add2.Cckappa_sig.site) in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () -let print_half_bond parameters _relation (add1,_) = +let print_half_bond parameters _relation (add1, _) = let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) @@ -495,21 +616,24 @@ let print_half_bond parameters _relation (add1,_) = let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () -let print_remove parameters (index,agent,list) = - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s(agent_id_%s,agent_type_%s)" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_id index) - (Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name) +let print_remove parameters (index, agent, list) = + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s(agent_id_%s,agent_type_%s)" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_agent_id index) + (Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name) in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let parameters_doc = Remanent_parameters.update_prefix parameters "documented_site:" in + let parameters_doc = + Remanent_parameters.update_prefix parameters "documented_site:" + in let () = Ckappa_sig.Site_map_and_set.Map.iter (fun site _ -> let () = - Loggers.fprintf + Loggers.fprintf (Remanent_parameters.get_logger parameters_doc) "%s(agent_id_%s,agent_type_%s)@@site_type_%s" (Remanent_parameters.get_prefix parameters_doc) @@ -517,28 +641,34 @@ let print_remove parameters (index,agent,list) = (Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name) (Ckappa_sig.string_of_site_name site) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - ()) + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + ()) agent.Cckappa_sig.agent_interface in - let parameters = Remanent_parameters.update_prefix parameters "undocumented_site:" in + let parameters = + Remanent_parameters.update_prefix parameters "undocumented_site:" + in let () = List.iter - (fun site -> + (fun site -> let () = - Loggers.fprintf + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s(agent_id_%s,agent_type_%s)@@site_type_%s" (Remanent_parameters.get_prefix parameters) (Ckappa_sig.string_of_agent_id index) (Ckappa_sig.string_of_agent_name agent.Cckappa_sig.agent_name) (Ckappa_sig.string_of_site_name site) - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - () - ) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + ()) list - in () + in + () let print_created_agent parameters (index, agent_name) = let () = @@ -558,49 +688,51 @@ let print_translate_counters parameters (site_address, action) = (Remanent_parameters.get_logger parameters) "%s(agent_id_%s,agent_type_%s,site_%s):(%s%s%s%s%s/%s%s%s%s%s,%s)" (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_id site_address.Cckappa_sig.agent_index) (Ckappa_sig.string_of_agent_name site_address.Cckappa_sig.agent_type) (Ckappa_sig.string_of_site_name site_address.Cckappa_sig.site) - (match action.Cckappa_sig.precondition.Cckappa_sig.min with - | None -> Remanent_parameters.get_open_int_interval_exclusive_symbol parameters - | Some _ -> - Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) + | None -> + Remanent_parameters.get_open_int_interval_exclusive_symbol parameters + | Some _ -> + Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) (match action.Cckappa_sig.precondition.Cckappa_sig.min with - | None -> Remanent_parameters.get_minus_infinity_symbol parameters - | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) + | None -> Remanent_parameters.get_minus_infinity_symbol parameters + | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) (Remanent_parameters.get_int_interval_separator_symbol parameters) (match action.Cckappa_sig.precondition.Cckappa_sig.max with - | None -> Remanent_parameters.get_plus_infinity_symbol parameters - | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) + | None -> Remanent_parameters.get_plus_infinity_symbol parameters + | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) (match action.Cckappa_sig.precondition.Cckappa_sig.max with - | None -> Remanent_parameters.get_open_int_interval_inclusive_symbol parameters - | Some _ -> - Remanent_parameters.get_open_int_interval_exclusive_symbol parameters) - - (match action.Cckappa_sig.postcondition.Cckappa_sig.min with - | None -> Remanent_parameters.get_open_int_interval_exclusive_symbol parameters - | Some _ -> - Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) - (match action.Cckappa_sig.postcondition.Cckappa_sig.min with - | None -> Remanent_parameters.get_minus_infinity_symbol parameters - | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) - (Remanent_parameters.get_int_interval_separator_symbol parameters) - (match action.Cckappa_sig.postcondition.Cckappa_sig.max with - | None -> Remanent_parameters.get_plus_infinity_symbol parameters - | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) - (match action.Cckappa_sig.postcondition.Cckappa_sig.max with - | None -> Remanent_parameters.get_open_int_interval_inclusive_symbol parameters - | Some _ -> - Remanent_parameters.get_open_int_interval_exclusive_symbol parameters) - (if action.Cckappa_sig.increment = 0 then "-" - else if action.Cckappa_sig.increment > 0 then - (Remanent_parameters.get_counterdeltaplus_symbol parameters)^ - (string_of_int action.Cckappa_sig.increment) - else - (Remanent_parameters.get_counterdeltaminus_symbol parameters)^ - (string_of_int (-action.Cckappa_sig.increment))) + | None -> + Remanent_parameters.get_open_int_interval_inclusive_symbol parameters + | Some _ -> + Remanent_parameters.get_open_int_interval_exclusive_symbol parameters) + (match action.Cckappa_sig.postcondition.Cckappa_sig.min with + | None -> + Remanent_parameters.get_open_int_interval_exclusive_symbol parameters + | Some _ -> + Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) + (match action.Cckappa_sig.postcondition.Cckappa_sig.min with + | None -> Remanent_parameters.get_minus_infinity_symbol parameters + | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) + (Remanent_parameters.get_int_interval_separator_symbol parameters) + (match action.Cckappa_sig.postcondition.Cckappa_sig.max with + | None -> Remanent_parameters.get_plus_infinity_symbol parameters + | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) + (match action.Cckappa_sig.postcondition.Cckappa_sig.max with + | None -> + Remanent_parameters.get_open_int_interval_inclusive_symbol parameters + | Some _ -> + Remanent_parameters.get_open_int_interval_exclusive_symbol parameters) + (if action.Cckappa_sig.increment = 0 then + "-" + else if action.Cckappa_sig.increment > 0 then + Remanent_parameters.get_counterdeltaplus_symbol parameters + ^ string_of_int action.Cckappa_sig.increment + else + Remanent_parameters.get_counterdeltaminus_symbol parameters + ^ string_of_int (-action.Cckappa_sig.increment)) in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () @@ -611,27 +743,27 @@ let print_removed_counters parameters (site_address, condition) = (Remanent_parameters.get_logger parameters) "%s(agent_id_%s,agent_type_%s,site_%s):(%s%s%s%s%s)--" (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_id site_address.Cckappa_sig.agent_index) (Ckappa_sig.string_of_agent_name site_address.Cckappa_sig.agent_type) (Ckappa_sig.string_of_site_name site_address.Cckappa_sig.site) - (match condition.Cckappa_sig.min with - | None -> Remanent_parameters.get_open_int_interval_exclusive_symbol parameters - | Some _ -> - Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) + | None -> + Remanent_parameters.get_open_int_interval_exclusive_symbol parameters + | Some _ -> + Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) (match condition.Cckappa_sig.min with - | None -> Remanent_parameters.get_minus_infinity_symbol parameters - | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) + | None -> Remanent_parameters.get_minus_infinity_symbol parameters + | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) (Remanent_parameters.get_int_interval_separator_symbol parameters) (match condition.Cckappa_sig.max with - | None -> Remanent_parameters.get_minus_infinity_symbol parameters - | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) + | None -> Remanent_parameters.get_minus_infinity_symbol parameters + | Some i -> string_of_int (Ckappa_sig.int_of_state_index i)) (match condition.Cckappa_sig.max with - | None -> Remanent_parameters.get_open_int_interval_inclusive_symbol parameters - | Some _ -> - Remanent_parameters.get_open_int_interval_exclusive_symbol parameters) - in + | None -> + Remanent_parameters.get_open_int_interval_inclusive_symbol parameters + | Some _ -> + Remanent_parameters.get_open_int_interval_exclusive_symbol parameters) + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () @@ -641,27 +773,58 @@ let print_new_counters parameters (site_address, state) = (Remanent_parameters.get_logger parameters) "%s(agent_id_%s,agent_type_%s,site_%s):(%s)++" (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_id site_address.Cckappa_sig.agent_index) (Ckappa_sig.string_of_agent_name site_address.Cckappa_sig.agent_type) (Ckappa_sig.string_of_site_name site_address.Cckappa_sig.site) - - (string_of_int (Ckappa_sig.int_of_state_index state)) + (string_of_int (Ckappa_sig.int_of_state_index state)) in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in () + let print_actions parameters error _handler actions = - let parameters_unbinding = Remanent_parameters.update_prefix parameters "unbinding:" in - let _ = List.iter (print_bond parameters_unbinding "....") (List.rev actions.Cckappa_sig.release) in - let parameters_half_unbinding = Remanent_parameters.update_prefix parameters "1/2unbinding:" in - let _ = List.iter (print_half_bond parameters_half_unbinding "....") (List.rev actions.Cckappa_sig.half_break) in - let parameters_removal = Remanent_parameters.update_prefix parameters "deletion:" in - let _ = List.iter (print_remove parameters_removal) (List.rev actions.Cckappa_sig.remove) in - let parameters_creation = Remanent_parameters.update_prefix parameters "creation:" in - let _ = List.iter (print_created_agent parameters_creation) (List.rev actions.Cckappa_sig.creation) in - let parameters_binding = Remanent_parameters.update_prefix parameters "binding:" in - let _ = List.iter (print_bond parameters_binding "----") (List.rev actions.Cckappa_sig.bind) in - let parameters_translate_counters = Remanent_parameters.update_prefix parameters "counters:" in + let parameters_unbinding = + Remanent_parameters.update_prefix parameters "unbinding:" + in + let _ = + List.iter + (print_bond parameters_unbinding "....") + (List.rev actions.Cckappa_sig.release) + in + let parameters_half_unbinding = + Remanent_parameters.update_prefix parameters "1/2unbinding:" + in + let _ = + List.iter + (print_half_bond parameters_half_unbinding "....") + (List.rev actions.Cckappa_sig.half_break) + in + let parameters_removal = + Remanent_parameters.update_prefix parameters "deletion:" + in + let _ = + List.iter + (print_remove parameters_removal) + (List.rev actions.Cckappa_sig.remove) + in + let parameters_creation = + Remanent_parameters.update_prefix parameters "creation:" + in + let _ = + List.iter + (print_created_agent parameters_creation) + (List.rev actions.Cckappa_sig.creation) + in + let parameters_binding = + Remanent_parameters.update_prefix parameters "binding:" + in + let _ = + List.iter + (print_bond parameters_binding "----") + (List.rev actions.Cckappa_sig.bind) + in + let parameters_translate_counters = + Remanent_parameters.update_prefix parameters "counters:" + in let _ = List.iter (print_translate_counters parameters_translate_counters) @@ -680,101 +843,135 @@ let print_actions parameters error _handler actions = error let print_rule parameters error handler rule = - let parameters_lhs = Remanent_parameters.update_prefix parameters "lhs:" in - let error = print_mixture parameters_lhs error handler rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs in - let parameters_rhs = Remanent_parameters.update_prefix parameters "rhs:" in - let error = print_mixture parameters_rhs error handler rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs in - let parameters_lhsdiff = Remanent_parameters.update_prefix parameters "direct:" in - let error = print_diffview parameters_lhsdiff error handler rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.diff_direct in - let parameters_rhsdiff = Remanent_parameters.update_prefix parameters "reverse:" in - let error = print_diffview parameters_rhsdiff error handler rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.diff_reverse in - let parameters_actions = Remanent_parameters.update_prefix parameters "actions:" in - let error = print_actions parameters_actions error handler rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions in + let parameters_lhs = Remanent_parameters.update_prefix parameters "lhs:" in + let error = + print_mixture parameters_lhs error handler + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs + in + let parameters_rhs = Remanent_parameters.update_prefix parameters "rhs:" in + let error = + print_mixture parameters_rhs error handler + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs + in + let parameters_lhsdiff = + Remanent_parameters.update_prefix parameters "direct:" + in + let error = + print_diffview parameters_lhsdiff error handler + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.diff_direct + in + let parameters_rhsdiff = + Remanent_parameters.update_prefix parameters "reverse:" + in + let error = + print_diffview parameters_rhsdiff error handler + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.diff_reverse + in + let parameters_actions = + Remanent_parameters.update_prefix parameters "actions:" + in + let error = + print_actions parameters_actions error handler + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions + in error let print_rules parameters error handler rules = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.print - parameters - error - (fun parameters error rule -> - print_rule parameters error handler rule) + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.print parameters error + (fun parameters error rule -> print_rule parameters error handler rule) rules let print_observables _parameters error _handler _obs = error let print_init parameters error handler init = - let parameters_rhs = Remanent_parameters.update_prefix parameters "mixture:" in - let error = print_mixture parameters_rhs error handler init.Cckappa_sig.e_init_c_mixture in + let parameters_rhs = + Remanent_parameters.update_prefix parameters "mixture:" + in + let error = + print_mixture parameters_rhs error handler init.Cckappa_sig.e_init_c_mixture + in error let print_inits parameters error handler init = - Int_storage.Nearly_inf_Imperatif.print - parameters - error - (fun parameters error init -> - print_init parameters error handler init) + Int_storage.Nearly_inf_Imperatif.print parameters error + (fun parameters error init -> print_init parameters error handler init) init let print_perturbations _parameters error _handler _perturbations = error let print_agent_annotation parameters error handler = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.iter - parameters error + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.iter parameters error (fun parameters error agent_name (agent_string, locations) -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s%i:%s:" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.int_of_agent_name agent_name) - agent_string - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in - let () = - List.iter - (fun position -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s %s" - (Remanent_parameters.get_prefix parameters) - (Locality.to_string position) - in - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - ) - locations - in - error - ) handler.Cckappa_sig.agents_annotation + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%i:%s:" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.int_of_agent_name agent_name) + agent_string + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + List.iter + (fun position -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s %s" + (Remanent_parameters.get_prefix parameters) + (Loc.to_string position) + in + Loggers.print_newline (Remanent_parameters.get_logger parameters)) + locations + in + error) + handler.Cckappa_sig.agents_annotation let print_compil parameters error handler compil = - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" - (Remanent_parameters.get_prefix parameters) + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_prefix parameters) + in + let parameters' = Remanent_parameters.update_prefix parameters "variables:" in + let error = + print_variables parameters' error handler compil.Cckappa_sig.variables + in + let parameters' = Remanent_parameters.update_prefix parameters "signature:" in + let error = + print_signatures parameters' error handler compil.Cckappa_sig.signatures + in + let parameters' = + Remanent_parameters.update_prefix parameters "agent definition:" + in + let error = print_agent_annotation parameters' error handler in + let parameters' = + Remanent_parameters.update_prefix parameters "default_counters:" in - let parameters' = Remanent_parameters.update_prefix parameters "variables:" in - let error = print_variables parameters' error handler compil.Cckappa_sig.variables in - let parameters' = Remanent_parameters.update_prefix parameters "signature:" in let error = - print_signatures - parameters' error handler compil.Cckappa_sig.signatures - in - let parameters' = Remanent_parameters.update_prefix parameters - "agent definition:" in - let error = print_agent_annotation parameters' error handler in - let parameters' = Remanent_parameters.update_prefix parameters "default_counters:" in - let error = print_default_counters parameters' error handler compil.Cckappa_sig.counter_default in - let parameters' = Remanent_parameters.update_prefix parameters "rules:" in + print_default_counters parameters' error handler + compil.Cckappa_sig.counter_default + in + let parameters' = Remanent_parameters.update_prefix parameters "rules:" in let error = print_rules parameters' error handler compil.Cckappa_sig.rules in - let parameters' = Remanent_parameters.update_prefix parameters "observables:" in - let error = print_observables parameters' error handler compil.Cckappa_sig.observables in - let parameters' = Remanent_parameters.update_prefix parameters "initial_states:" in + let parameters' = + Remanent_parameters.update_prefix parameters "observables:" + in + let error = + print_observables parameters' error handler compil.Cckappa_sig.observables + in + let parameters' = + Remanent_parameters.update_prefix parameters "initial_states:" + in let error = print_inits parameters' error handler compil.Cckappa_sig.init in - let parameters' = Remanent_parameters.update_prefix parameters "perturbations:" in - let error = print_perturbations parameters' error handler - compil.Cckappa_sig.perturbations + let parameters' = + Remanent_parameters.update_prefix parameters "perturbations:" + in + let error = + print_perturbations parameters' error handler + compil.Cckappa_sig.perturbations in error diff --git a/core/KaSa_rep/frontend/print_cckappa.mli b/core/KaSa_rep/frontend/print_cckappa.mli index 46c12c9a1a..d68543dbf1 100644 --- a/core/KaSa_rep/frontend/print_cckappa.mli +++ b/core/KaSa_rep/frontend/print_cckappa.mli @@ -1,16 +1,17 @@ -val trace: bool -val local_trace: bool +val trace : bool +val local_trace : bool +val print_kasim_site : unit -> string -val print_kasim_site: unit -> string - -val print_mixture: +val print_mixture : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> - Cckappa_sig.mixture -> Exception_without_parameter.method_handler + Cckappa_sig.mixture -> + Exception_without_parameter.method_handler -val print_compil: +val print_compil : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> - Cckappa_sig.compil -> Exception_without_parameter.method_handler + Cckappa_sig.compil -> + Exception_without_parameter.method_handler diff --git a/core/KaSa_rep/frontend/print_ckappa.ml b/core/KaSa_rep/frontend/print_ckappa.ml index 62a1fa9a8e..5c5c7f8c8a 100644 --- a/core/KaSa_rep/frontend/print_ckappa.ml +++ b/core/KaSa_rep/frontend/print_ckappa.ml @@ -15,126 +15,128 @@ let local_trace = false let print_agent_name parameter error agent_name = - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s" agent_name + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" agent_name in error let print_site_name parameter error site_name = let () = - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s" - site_name + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" site_name in error let print_internal_state parameter error internal_state = - let () = Loggers.fprintf + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" internal_state in error let print_binding_state parameter error binding_state = - match binding_state - with + match binding_state with | Ckappa_sig.Free -> error - | Ckappa_sig.Lnk_type (agent_name,site_name) -> + | Ckappa_sig.Lnk_type (agent_name, site_name) -> let binding_type_symbol = Remanent_parameters.get_btype_sep_symbol parameter in let () = - Loggers.print_binding_type (Remanent_parameters.get_logger parameter) + Loggers.print_binding_type + (Remanent_parameters.get_logger parameter) ~binding_type_symbol ~agent_name ~site_name () in error let print_link_state parameter error link = match link with - | Ckappa_sig.LNK_VALUE (agent_index,agent_name,site_name,link_index,_) -> - begin - match Remanent_parameters.get_link_mode parameter - with - | Remanent_parameters_sig.Bound_indices -> - let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s%s%s%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_bound_symbol parameter) - (Ckappa_sig.string_of_c_link_value link_index) - (Remanent_parameters.get_close_binding_state parameter) - in - error - | Remanent_parameters_sig.Site_address -> - let () = (*CHECK*) - Loggers.fprintf - (Remanent_parameters.get_logger parameter) - "%s%s(%s,%s)%s%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_bound_symbol parameter) - agent_name - (Ckappa_sig.string_of_agent_id agent_index) - (Remanent_parameters.get_at_symbol parameter) - site_name - in - error - | Remanent_parameters_sig.Bound_type -> + | Ckappa_sig.LNK_VALUE (agent_index, agent_name, site_name, link_index, _) -> + (match Remanent_parameters.get_link_mode parameter with + | Remanent_parameters_sig.Bound_indices -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s%s%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_bound_symbol parameter) + (Ckappa_sig.string_of_c_link_value link_index) + (Remanent_parameters.get_close_binding_state parameter) + in + error + | Remanent_parameters_sig.Site_address -> + let () = + (*CHECK*) + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s(%s,%s)%s%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_bound_symbol parameter) + agent_name + (Ckappa_sig.string_of_agent_id agent_index) + (Remanent_parameters.get_at_symbol parameter) + site_name + in + error + | Remanent_parameters_sig.Bound_type -> let binding_type_symbol = Remanent_parameters.get_btype_sep_symbol parameter in let s = - Public_data.string_of_binding_type - ~binding_type_symbol ~agent_name ~site_name () + Public_data.string_of_binding_type ~binding_type_symbol ~agent_name + ~site_name () in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameter) + Loggers.fprintf + (Remanent_parameters.get_logger parameter) "%s%s%s%s" (Remanent_parameters.get_open_binding_state parameter) (Remanent_parameters.get_bound_symbol parameter) s (Remanent_parameters.get_close_binding_state parameter) in - error - end + error) | Ckappa_sig.FREE -> - let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s%s%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_free_symbol parameter) - (Remanent_parameters.get_close_binding_state parameter) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_free_symbol parameter) + (Remanent_parameters.get_close_binding_state parameter) in error - | Ckappa_sig.LNK_ANY _ -> + | Ckappa_sig.LNK_ANY _ -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameter) + Loggers.fprintf + (Remanent_parameters.get_logger parameter) "%s%s%s" (Remanent_parameters.get_open_binding_state parameter) (Remanent_parameters.get_link_to_any parameter) (Remanent_parameters.get_close_binding_state parameter) in error - | Ckappa_sig.LNK_MISSING -> - error + | Ckappa_sig.LNK_MISSING -> error | Ckappa_sig.LNK_SOME _ -> let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameter) + Loggers.fprintf + (Remanent_parameters.get_logger parameter) "%s%s%s" (Remanent_parameters.get_open_binding_state parameter) (Remanent_parameters.get_link_to_some parameter) (Remanent_parameters.get_close_binding_state parameter) in error - | Ckappa_sig.LNK_TYPE ((agent_name,_),(site_name,_)) -> + | Ckappa_sig.LNK_TYPE ((agent_name, _), (site_name, _)) -> let binding_type_symbol = Remanent_parameters.get_btype_sep_symbol parameter in let s = - Public_data.string_of_binding_type - ~binding_type_symbol ~agent_name ~site_name () + Public_data.string_of_binding_type ~binding_type_symbol ~agent_name + ~site_name () in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameter) + Loggers.fprintf + (Remanent_parameters.get_logger parameter) "%s%s%s%s" (Remanent_parameters.get_open_binding_state parameter) (Remanent_parameters.get_bound_symbol parameter) @@ -145,107 +147,115 @@ let print_link_state parameter error link = let print_port parameter error port = let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s" port.Ckappa_sig.port_nme + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s" port.Ckappa_sig.port_name in let _ = List.iter (fun x -> - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s%s%s%s" - (Remanent_parameters.get_open_internal_state parameter) - (Remanent_parameters.get_internal_state_symbol parameter) - (match x with Some x -> x | None -> "#") - (Remanent_parameters.get_close_internal_state parameter) - ) port.Ckappa_sig.port_int + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s%s%s" + (Remanent_parameters.get_open_internal_state parameter) + (Remanent_parameters.get_internal_state_symbol parameter) + (match x with + | Some x -> x + | None -> "#") + (Remanent_parameters.get_close_internal_state parameter)) + port.Ckappa_sig.port_int in - let error = print_link_state parameter error port.Ckappa_sig.port_lnk in + let error = print_link_state parameter error port.Ckappa_sig.port_link in error - let print_counter parameter error counter = - let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s" counter.Ckappa_sig.count_nme - in - let _ = - match counter.Ckappa_sig.count_test with - | Some (Ckappa_sig.CEQ n) -> - Loggers.fprintf (Remanent_parameters.get_logger parameter) +let print_counter parameter error counter = + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s" counter.Ckappa_sig.counter_name + in + let _ = + match counter.Ckappa_sig.counter_test with + | Some (Ckappa_sig.CEQ n) -> + Loggers.fprintf + (Remanent_parameters.get_logger parameter) "%s%s%i%s" (Remanent_parameters.get_open_counterceq parameter) (Remanent_parameters.get_counterceq_symbol parameter) n (Remanent_parameters.get_close_counterceq parameter) + | Some (Ckappa_sig.CGTE n) -> + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s%i%s" + (Remanent_parameters.get_open_countercgte parameter) + (Remanent_parameters.get_countercgte_symbol parameter) + n + (Remanent_parameters.get_close_countercgte parameter) + | Some (Ckappa_sig.CVAR s) -> + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s%s%s" + (Remanent_parameters.get_open_countercvar parameter) + (Remanent_parameters.get_countercvar_symbol parameter) + s + (Remanent_parameters.get_close_countercvar parameter) + | Some Ckappa_sig.UNKNOWN | None -> () + in + let () = + match counter.Ckappa_sig.counter_delta with + | Some 0 | None -> () + | Some n when n > 0 -> + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s%i%s" + (Remanent_parameters.get_open_counterdelta parameter) + (Remanent_parameters.get_counterdeltaplus_symbol parameter) + n + (Remanent_parameters.get_close_counterdelta parameter) + | Some n (*when n<0*) -> + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s%i%s" + (Remanent_parameters.get_open_counterdelta parameter) + (Remanent_parameters.get_counterdeltaminus_symbol parameter) + (-n) + (Remanent_parameters.get_close_countercvar parameter) + in + error - | Some (Ckappa_sig.CGTE n) -> - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s%s%i%s" - (Remanent_parameters.get_open_countercgte parameter) - (Remanent_parameters.get_countercgte_symbol parameter) - n - (Remanent_parameters.get_close_countercgte parameter) - - | Some (Ckappa_sig.CVAR s) -> - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s%s%s%s" - (Remanent_parameters.get_open_countercvar parameter) - (Remanent_parameters.get_countercvar_symbol parameter) - s - (Remanent_parameters.get_close_countercvar parameter) - | Some Ckappa_sig.UNKNOWN - | None -> () - in - let () = - match counter.Ckappa_sig.count_delta with - | Some 0 | None -> () - | Some n when n>0 -> - Loggers.fprintf - (Remanent_parameters.get_logger parameter) - "%s%s%i%s" - (Remanent_parameters.get_open_counterdelta parameter) - (Remanent_parameters.get_counterdeltaplus_symbol parameter) - n - (Remanent_parameters.get_close_counterdelta parameter) - - | Some n (*when n<0*) -> - Loggers.fprintf - (Remanent_parameters.get_logger parameter) - "%s%s%i%s" - (Remanent_parameters.get_open_counterdelta parameter) - (Remanent_parameters.get_counterdeltaminus_symbol parameter) - (- n) - (Remanent_parameters.get_close_countercvar parameter) - in - error - -let print_interface parameter error interface = +let print_interface parameter error interface = let rec aux error bool interface = match interface with | Ckappa_sig.EMPTY_INTF -> error - | Ckappa_sig.COUNTER_SEP (counter,interface) -> - let _ = Misc_sa.print_comma parameter bool - (Remanent_parameters.get_site_sep_comma_symbol parameter) in + | Ckappa_sig.COUNTER_SEP (counter, interface) -> + let _ = + Misc_sa.print_comma parameter bool + (Remanent_parameters.get_site_sep_comma_symbol parameter) + in let error = print_counter parameter error counter in aux error true interface - | Ckappa_sig.PORT_SEP (port,interface) -> - let _ = Misc_sa.print_comma parameter bool - (Remanent_parameters.get_site_sep_comma_symbol parameter) in + | Ckappa_sig.PORT_SEP (port, interface) -> + let _ = + Misc_sa.print_comma parameter bool + (Remanent_parameters.get_site_sep_comma_symbol parameter) + in let error = print_port parameter error port in aux error true interface - in aux error false interface + in + aux error false interface let print_agent parameter error agent = let () = - Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%s%s" - agent.Ckappa_sig.ag_nme + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s%s" agent.Ckappa_sig.agent_name (Remanent_parameters.get_agent_open_symbol parameter) in - let error = - print_interface parameter error agent.Ckappa_sig.ag_intf - in + let error = print_interface parameter error agent.Ckappa_sig.ag_intf in let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameter) + Loggers.fprintf + (Remanent_parameters.get_logger parameter) "%s" (Remanent_parameters.get_agent_close_symbol parameter) in @@ -256,10 +266,11 @@ let print_mixture parameter error mixture = match mixture with | Ckappa_sig.EMPTY_MIX -> error | Ckappa_sig.SKIP mixture -> - if Remanent_parameters.get_do_we_show_ghost parameter - then - let () = Misc_sa.print_comma parameter bool - (Remanent_parameters.get_agent_sep_comma_symbol parameter) in + if Remanent_parameters.get_do_we_show_ghost parameter then ( + let () = + Misc_sa.print_comma parameter bool + (Remanent_parameters.get_agent_sep_comma_symbol parameter) + in let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) @@ -267,20 +278,18 @@ let print_mixture parameter error mixture = (Remanent_parameters.get_ghost_agent_symbol parameter) in aux error true mixture - else + ) else aux error bool mixture - | Ckappa_sig.COMMA (agent,mixture) -> - let () = Misc_sa.print_comma parameter bool + | Ckappa_sig.COMMA (agent, mixture) -> + let () = + Misc_sa.print_comma parameter bool (Remanent_parameters.get_agent_sep_comma_symbol parameter) in - let error = - print_agent parameter error agent - in + let error = print_agent parameter error agent in aux error true mixture - | Ckappa_sig.DOT (i,agent,mixture) -> + | Ckappa_sig.DOT (i, agent, mixture) -> let () = - if bool - then + if bool then Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s%s" @@ -289,10 +298,9 @@ let print_mixture parameter error mixture = in let error = print_agent parameter error agent in aux error true mixture - | Ckappa_sig.PLUS (i,agent,mixture) -> + | Ckappa_sig.PLUS (i, agent, mixture) -> let () = - if bool - then + if bool then Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s%s" @@ -301,7 +309,8 @@ let print_mixture parameter error mixture = in let error = print_agent parameter error agent in aux error true mixture - in aux error false mixture + in + aux error false mixture let get_agent_open_symbol parameter = Loggers.fprintf @@ -310,121 +319,127 @@ let get_agent_open_symbol parameter = (Remanent_parameters.get_agent_open_symbol parameter) let get_agent_close_symbol parameter = -Loggers.fprintf - (Remanent_parameters.get_logger parameter) - "%s" - (Remanent_parameters.get_agent_close_symbol parameter) + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s" + (Remanent_parameters.get_agent_close_symbol parameter) -let rec print_alg parameter (error:Exception.method_handler) alg = - match alg - with - | Alg_expr.BIN_ALG_OP (op,(alg1,_),(alg2,_)) -> +let rec print_alg parameter (error : Exception.method_handler) alg = + match alg with + | Alg_expr.BIN_ALG_OP (op, (alg1, _), (alg2, _)) -> let () = get_agent_open_symbol parameter in let error = print_alg parameter error alg1 in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "%s" - (Operator.bin_alg_op_to_string op) in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%s" + (Operator.bin_alg_op_to_string op) + in let error = print_alg parameter error alg2 in - let () = get_agent_close_symbol parameter in + let () = get_agent_close_symbol parameter in error - | Alg_expr.UN_ALG_OP (op,(alg,_)) -> + | Alg_expr.UN_ALG_OP (op, (alg, _)) -> let () = get_agent_open_symbol parameter in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "%a" - Operator.print_un_alg_op op in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%a" Operator.print_un_alg_op op + in let error = print_alg parameter error alg in let () = get_agent_close_symbol parameter in error | Alg_expr.STATE_ALG_OP state_alg_op -> - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "%a" - Operator.print_state_alg_op state_alg_op in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%a" Operator.print_state_alg_op state_alg_op + in error | Alg_expr.ALG_VAR string -> - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "%s" string - in error + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" string + in + error | Alg_expr.TOKEN_ID token -> - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "%s" token - in error - | Alg_expr.KAPPA_INSTANCE mixture -> - print_mixture parameter error mixture + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" token + in + error + | Alg_expr.KAPPA_INSTANCE mixture -> print_mixture parameter error mixture | Alg_expr.CONST t -> - let () = Loggers.fprintf + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" (Nbr.to_string t) - in error - | Alg_expr.DIFF_TOKEN ((expr,_),token) -> - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "d" in + in + error + | Alg_expr.DIFF_TOKEN ((expr, _), token) -> + let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "d" in let error = print_alg parameter error expr in let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameter) "/d%s" token - in error - | Alg_expr.DIFF_KAPPA_INSTANCE ((expr,_),pattern) -> - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "d" in + Loggers.fprintf (Remanent_parameters.get_logger parameter) "/d%s" token + in + error + | Alg_expr.DIFF_KAPPA_INSTANCE ((expr, _), pattern) -> + let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "d" in let error = print_alg parameter error expr in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "/d" in + let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "/d" in print_mixture parameter error pattern - | Alg_expr.IF (cond,(yes,_),(no,_)) -> + | Alg_expr.IF (cond, (yes, _), (no, _)) -> let () = get_agent_open_symbol parameter in let error = print_bool parameter error cond in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameter) "[?]" in + let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "[?]" in let error = print_alg parameter error yes in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "[:]" in + let () = Loggers.fprintf (Remanent_parameters.get_logger parameter) "[:]" in let error = print_alg parameter error no in let () = get_agent_close_symbol parameter in error -and print_bool parameter (error:Exception.method_handler) = function - | Alg_expr.TRUE,_ -> - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "[true]" - in error - | Alg_expr.FALSE,_ -> - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "[false]" - in error - | Alg_expr.COMPARE_OP (op,(alg1,_),(alg2,_)),_ -> + +and print_bool parameter (error : Exception.method_handler) = function + | Alg_expr.TRUE, _ -> + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "[true]" + in + error + | Alg_expr.FALSE, _ -> + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "[false]" + in + error + | Alg_expr.COMPARE_OP (op, (alg1, _), (alg2, _)), _ -> let () = get_agent_open_symbol parameter in let error = print_alg parameter error alg1 in let () = match - Loggers.formatter_of_logger - (Remanent_parameters.get_logger parameter) + Loggers.formatter_of_logger (Remanent_parameters.get_logger parameter) with | None -> () - | Some formatter -> Operator.print_compare_op formatter op in + | Some formatter -> Operator.print_compare_op formatter op + in let error = print_alg parameter error alg2 in let () = get_agent_close_symbol parameter in error - | Alg_expr.BIN_BOOL_OP (op,b1,b2),_ -> + | Alg_expr.BIN_BOOL_OP (op, b1, b2), _ -> let () = get_agent_open_symbol parameter in let error = print_bool parameter error b1 in let () = match - Loggers.formatter_of_logger - (Remanent_parameters.get_logger parameter) + Loggers.formatter_of_logger (Remanent_parameters.get_logger parameter) with | None -> () - | Some formatter -> Operator.print_bin_bool_op formatter op in + | Some formatter -> Operator.print_bin_bool_op formatter op + in let error = print_bool parameter error b2 in let () = get_agent_close_symbol parameter in error - | Alg_expr.UN_BOOL_OP (op,b1),_ -> + | Alg_expr.UN_BOOL_OP (op, b1), _ -> let () = match - Loggers.formatter_of_logger - (Remanent_parameters.get_logger parameter) + Loggers.formatter_of_logger (Remanent_parameters.get_logger parameter) with | None -> () - | Some formatter -> Operator.print_un_bool_op formatter op in + | Some formatter -> Operator.print_un_bool_op formatter op + in let () = get_agent_open_symbol parameter in let error = print_bool parameter error b1 in let () = get_agent_close_symbol parameter in @@ -432,9 +447,9 @@ and print_bool parameter (error:Exception.method_handler) = function let print_rule parameter error rule = let error = print_mixture parameter error rule.Ckappa_sig.lhs in - let arrow = - Remanent_parameters.get_uni_arrow_symbol parameter in - let _ = Loggers.fprintf - (Remanent_parameters.get_logger parameter) "%s" arrow in + let arrow = Remanent_parameters.get_uni_arrow_symbol parameter in + let _ = + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" arrow + in let error = print_mixture parameter error rule.Ckappa_sig.rhs in error diff --git a/core/KaSa_rep/frontend/print_ckappa.mli b/core/KaSa_rep/frontend/print_ckappa.mli index 5769c30484..b8d301204d 100644 --- a/core/KaSa_rep/frontend/print_ckappa.mli +++ b/core/KaSa_rep/frontend/print_ckappa.mli @@ -1,41 +1,42 @@ -val local_trace:bool +val local_trace : bool -val print_rule: +val print_rule : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - Ckappa_sig.mixture Ckappa_sig.rule -> Exception_without_parameter.method_handler + Ckappa_sig.mixture Ckappa_sig.rule -> + Exception_without_parameter.method_handler -val print_bool: +val print_bool : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> - (Ckappa_sig.mixture, string) Alg_expr.bool Locality.annot -> + (Ckappa_sig.mixture, string) Alg_expr.bool Loc.annoted -> Exception_without_parameter.method_handler -val print_alg: +val print_alg : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> (Ckappa_sig.mixture, string) Alg_expr.e -> Exception_without_parameter.method_handler -val print_binding_state: +val print_binding_state : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.binding_state -> Exception_without_parameter.method_handler -val print_internal_state: +val print_internal_state : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.internal_state -> Exception_without_parameter.method_handler -val print_site_name: +val print_site_name : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.site_name -> Exception_without_parameter.method_handler -val print_agent_name: +val print_agent_name : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Ckappa_sig.agent_name -> diff --git a/core/KaSa_rep/frontend/print_handler.ml b/core/KaSa_rep/frontend/print_handler.ml index 7bf01f4593..fab0b527d0 100644 --- a/core/KaSa_rep/frontend/print_handler.ml +++ b/core/KaSa_rep/frontend/print_handler.ml @@ -35,7 +35,7 @@ let print_state parameters state = (Remanent_parameters.get_logger parameters) "%sfree" (Remanent_parameters.get_prefix parameters) - | Ckappa_sig.Binding Ckappa_sig.C_Lnk_type (a, b) -> + | Ckappa_sig.Binding (Ckappa_sig.C_Lnk_type (a, b)) -> Loggers.fprintf (Remanent_parameters.get_logger parameters) "%sagent_type:%s@@site_type:%s" @@ -52,11 +52,11 @@ let print_site parameters site = (Remanent_parameters.get_prefix parameters) a | Ckappa_sig.Counter a -> - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s%s(counter value)" - (Remanent_parameters.get_prefix parameters) - a + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s(counter value)" + (Remanent_parameters.get_prefix parameters) + a | Ckappa_sig.Binding a -> Loggers.fprintf (Remanent_parameters.get_logger parameters) @@ -65,511 +65,496 @@ let print_site parameters site = a let string_of_site _parameters site = - match site - with - | Ckappa_sig.Internal a -> a^"(internal state)" - | Ckappa_sig.Binding a -> a^"(binding state)" - | Ckappa_sig.Counter a -> a^" (counter value)" + match site with + | Ckappa_sig.Internal a -> a ^ "(internal state)" + | Ckappa_sig.Binding a -> a ^ "(binding state)" + | Ckappa_sig.Counter a -> a ^ " (counter value)" let print_handler parameters error handler = - let log = (Remanent_parameters.get_logger parameters) in - let () = Loggers.fprintf log "%s" (Remanent_parameters.get_prefix parameters) in + let log = Remanent_parameters.get_logger parameters in + let () = + Loggers.fprintf log "%s" (Remanent_parameters.get_prefix parameters) + in let () = Loggers.print_newline log in - let parameters_agent = Remanent_parameters.update_prefix parameters "agents:" in - let () = Loggers.fprintf log "%s" (Remanent_parameters.get_prefix parameters_agent) in + let parameters_agent = + Remanent_parameters.update_prefix parameters "agents:" + in + let () = + Loggers.fprintf log "%s" (Remanent_parameters.get_prefix parameters_agent) + in let () = Loggers.print_newline log in - let print_f print_aux = - (fun parameters error i site () () -> - let parameters = Remanent_parameters.update_prefix parameters - ("site_type:" ^ - (Ckappa_sig.string_of_site_name i) ^ "->") - in - let () = print_aux parameters site in - let () = Loggers.print_newline log in - error) + let print_f print_aux parameters error i site () () = + let parameters = + Remanent_parameters.update_prefix parameters + ("site_type:" ^ Ckappa_sig.string_of_site_name i ^ "->") + in + let () = print_aux parameters site in + let () = Loggers.print_newline log in + error in - let print_state_f print_aux = - (fun parameters error i state () () -> - let parameters = Remanent_parameters.update_prefix parameters - ("state_id:" ^ - (Ckappa_sig.string_of_state_index i) ^ "->") - in - let () = print_aux parameters state in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "\n" in - error) + let print_state_f print_aux parameters error i state () () = + let parameters = + Remanent_parameters.update_prefix parameters + ("state_id:" ^ Ckappa_sig.string_of_state_index i ^ "->") + in + let () = print_aux parameters state in + let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "\n" in + error in let error = - Ckappa_sig.Dictionary_of_agents.iter - parameters_agent - error + Ckappa_sig.Dictionary_of_agents.iter parameters_agent error (fun _parameters error i agent_name () () -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_agent) - "%sagent_type:%s:%s" - (Remanent_parameters.get_prefix parameters_agent) - (Ckappa_sig.string_of_agent_name i) - agent_name - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters_agent) - in error) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_agent) + "%sagent_type:%s:%s" + (Remanent_parameters.get_prefix parameters_agent) + (Ckappa_sig.string_of_agent_name i) + agent_name + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters_agent) + in + error) handler.Cckappa_sig.agents_dic in - let parameters_sites = Remanent_parameters.update_prefix parameters "sites:" in - let () = Loggers.fprintf log "%s" (Remanent_parameters.get_prefix parameters_sites) in + let parameters_sites = + Remanent_parameters.update_prefix parameters "sites:" + in + let () = + Loggers.fprintf log "%s" (Remanent_parameters.get_prefix parameters_sites) + in let () = Loggers.print_newline log in let error = Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.print - parameters_sites - error + parameters_sites error (fun parameters error a -> - let error = - Ckappa_sig.Dictionary_of_sites.iter - parameters - error - (print_f print_site) - a - in - error) + let error = + Ckappa_sig.Dictionary_of_sites.iter parameters error + (print_f print_site) a + in + error) handler.Cckappa_sig.sites in - let parameters_states = Remanent_parameters.update_prefix parameters "states:" in - let () = Loggers.fprintf log "%s \n" (Remanent_parameters.get_prefix parameters_states) in + let parameters_states = + Remanent_parameters.update_prefix parameters "states:" + in + let () = + Loggers.fprintf log "%s \n" + (Remanent_parameters.get_prefix parameters_states) + in let error = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.print - parameters_states - error + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .print parameters_states error (fun parameters error a -> - Ckappa_sig.Dictionary_of_States.iter - parameters - error - (print_state_f print_state) - a) + Ckappa_sig.Dictionary_of_States.iter parameters error + (print_state_f print_state) + a) handler.Cckappa_sig.states_dic in - let parameters_duals = Remanent_parameters.update_prefix parameters "duals:" in - let () = Loggers.fprintf log "%s \n" (Remanent_parameters.get_prefix parameters_duals) in + let parameters_duals = + Remanent_parameters.update_prefix parameters "duals:" + in + let () = + Loggers.fprintf log "%s \n" + (Remanent_parameters.get_prefix parameters_duals) + in let error = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.print - parameters_duals - error - (fun parameters error (a, b, (c:Ckappa_sig.c_state)) -> - let _ = - Loggers.fprintf - log - "%sagent_type:%s,site_type:%s,state_id:%s\n" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_name a) - (Ckappa_sig.string_of_site_name b) - (Ckappa_sig.string_of_state_index c) - in - error) + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .print parameters_duals error + (fun parameters error (a, b, (c : Ckappa_sig.c_state)) -> + let _ = + Loggers.fprintf log "%sagent_type:%s,site_type:%s,state_id:%s\n" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_agent_name a) + (Ckappa_sig.string_of_site_name b) + (Ckappa_sig.string_of_state_index c) + in + error) handler.Cckappa_sig.dual in error -let dot_of_contact_map ?loggers parameters (error:Exception.method_handler) handler = +let dot_of_contact_map ?loggers parameters (error : Exception.method_handler) + handler = let parameters_dot = - match - loggers - with + match loggers with | None -> Remanent_parameters.open_contact_map_file parameters | Some loggers -> Remanent_parameters.set_logger parameters loggers in let _ = List.iter (fun x -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "%s%s" - Headers.dot_comment - x - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) in - ()) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "%s%s" Headers.dot_comment x + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + ()) (Headers.head parameters_dot) in let _ = List.iter - (fun x-> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "%s%s" - Headers.dot_comment - x - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in - ()) + (fun x -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "%s%s" Headers.dot_comment x + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + ()) Headers.head_contact_map_in_dot in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) "graph G{ \n" in let _ = - Ckappa_sig.Dictionary_of_agents.iter - parameters_dot - error + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "graph G{ \n" + in + let _ = + Ckappa_sig.Dictionary_of_agents.iter parameters_dot error (fun parameters_dot error i agent_name () () -> - let _ = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "subgraph cluster%s {\n" - (Ckappa_sig.string_of_agent_name i) - in - let error, site_dic = - Misc_sa.unsome - ( - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters_dot - error - i - handler.Cckappa_sig.sites) - (fun error -> - Exception.warn - parameters_dot error __POS__ - Exit (Ckappa_sig.Dictionary_of_sites.init ())) - in - let error = - Ckappa_sig.Dictionary_of_sites.iter - parameters_dot - error - (fun parameters_dot error j site () () -> - let _ = - match site with - | Ckappa_sig.Counter site_name -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "subgraph cluster%s {\n" + (Ckappa_sig.string_of_agent_name i) + in + let error, site_dic = + Misc_sa.unsome + (Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get + parameters_dot error i handler.Cckappa_sig.sites) (fun error -> + Exception.warn parameters_dot error __POS__ Exit + (Ckappa_sig.Dictionary_of_sites.init ())) + in + let error = + Ckappa_sig.Dictionary_of_sites.iter parameters_dot error + (fun parameters_dot error j site () () -> + let _ = + match site with + | Ckappa_sig.Counter site_name -> if not (Remanent_parameters.get_pure_contact parameters_dot) - then + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) - " %s.%s [style = filled label = \"%s\" %s color = %s size = \"5\"]" + " %s.%s [style = filled label = \"%s\" %s color = \ + %s size = \"5\"]" (Ckappa_sig.string_of_agent_name i) (Ckappa_sig.string_of_site_name j) site_name - (Graph_loggers.shape_in_dot (Remanent_parameters.get_counter_site_shape parameters_dot)) - (Graph_loggers.dot_color_encoding (Remanent_parameters.get_counter_site_color parameters_dot)) + (Graph_loggers.shape_in_dot + (Remanent_parameters.get_counter_site_shape + parameters_dot)) + (Graph_loggers.dot_color_encoding + (Remanent_parameters.get_counter_site_color + parameters_dot)) in - Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) - else + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + ) else () - | Ckappa_sig.Internal site_name -> - if not (Remanent_parameters.get_pure_contact parameters_dot) - then - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - " %s.%s [style = filled label = \"%s\" %s color = %s size = \"5\"]" - (Ckappa_sig.string_of_agent_name i) - (Ckappa_sig.string_of_site_name j) - site_name - (Graph_loggers.shape_in_dot - (Remanent_parameters.get_internal_site_shape parameters_dot)) - (Graph_loggers.dot_color_encoding - (Remanent_parameters.get_internal_site_color parameters_dot)) - in - Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) - else - () - | Ckappa_sig.Binding site_name -> + | Ckappa_sig.Internal site_name -> + if not (Remanent_parameters.get_pure_contact parameters_dot) + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) - " %s.%s [style = filled label = \"%s\" %s color = %s size = \"5\"]" + " %s.%s [style = filled label = \"%s\" %s color = %s \ + size = \"5\"]" (Ckappa_sig.string_of_agent_name i) (Ckappa_sig.string_of_site_name j) site_name (Graph_loggers.shape_in_dot - (Remanent_parameters.get_binding_site_shape parameters_dot)) + (Remanent_parameters.get_internal_site_shape + parameters_dot)) (Graph_loggers.dot_color_encoding - (Remanent_parameters.get_binding_site_color parameters_dot)) + (Remanent_parameters.get_internal_site_color + parameters_dot)) in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in () - in - error) - site_dic - in - let error, n_sites = - Ckappa_sig.Dictionary_of_sites.last_entry parameters_dot error site_dic - in - let () = - if Ckappa_sig.compare_site_name n_sites Ckappa_sig.dummy_site_name < 0 - then - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - " %s.0 [shape = plaintext label = \"\"]" - (Ckappa_sig.string_of_agent_name i) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in () - in - let color = - Ckappa_sig.get_agent_color - n_sites parameters_dot - in - let shape = - Ckappa_sig.get_agent_shape - n_sites - parameters_dot - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "label = \"%s\"; %s; color = %s" - agent_name - (Graph_loggers.shape_in_dot shape) - (Graph_loggers.dot_color_encoding color) - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters_dot) - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) "} ; " in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) - in - error) + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + ) else + () + | Ckappa_sig.Binding site_name -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + " %s.%s [style = filled label = \"%s\" %s color = %s \ + size = \"5\"]" + (Ckappa_sig.string_of_agent_name i) + (Ckappa_sig.string_of_site_name j) + site_name + (Graph_loggers.shape_in_dot + (Remanent_parameters.get_binding_site_shape + parameters_dot)) + (Graph_loggers.dot_color_encoding + (Remanent_parameters.get_binding_site_color + parameters_dot)) + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + in + () + in + error) + site_dic + in + let error, n_sites = + Ckappa_sig.Dictionary_of_sites.last_entry parameters_dot error + site_dic + in + let () = + if Ckappa_sig.compare_site_name n_sites Ckappa_sig.dummy_site_name < 0 + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + " %s.0 [shape = plaintext label = \"\"]" + (Ckappa_sig.string_of_agent_name i) + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters_dot) + in + () + ) + in + let color = Ckappa_sig.get_agent_color n_sites parameters_dot in + let shape = Ckappa_sig.get_agent_shape n_sites parameters_dot in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "label = \"%s\"; %s; color = %s" agent_name + (Graph_loggers.shape_in_dot shape) + (Graph_loggers.dot_color_encoding color) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) "} ; " + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in + error) handler.Cckappa_sig.agents_dic in let _ = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.iter - parameters_dot - error - (fun parameters_dot error (i,(j,_k)) (i',j',_k') -> - if i + if i < i' || (i = i' && j <= j') then ( + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "%s.%s -- %s.%s\n" + (Ckappa_sig.string_of_agent_name i) + (Ckappa_sig.string_of_site_name j) + (Ckappa_sig.string_of_agent_name i') + (Ckappa_sig.string_of_site_name j') + in + error + ) else + error) handler.Cckappa_sig.dual in let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters_dot) "}" in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) + in let () = - match - loggers - with - | None -> Loggers.close_logger (Remanent_parameters.get_logger parameters_dot) - | Some _ -> Loggers.flush_logger (Remanent_parameters.get_logger parameters_dot) + match loggers with + | None -> + Loggers.close_logger (Remanent_parameters.get_logger parameters_dot) + | Some _ -> + Loggers.flush_logger (Remanent_parameters.get_logger parameters_dot) in error let print_list_of_lines parameters list = List.iter (fun line -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s" line - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in ()) + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" line + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + ()) list - let gexf_of_contact_map ?loggers parameters (error:Exception.method_handler) handler = - let parameters_gexf = - match - loggers - with - | None -> Remanent_parameters.open_contact_map_file parameters - | Some loggers -> Remanent_parameters.set_logger parameters loggers - in - let _ = - print_list_of_lines parameters_gexf - [ - ""; - ""; - ""; - " "; - " "; - " "; - " "; - " "; - ] - in - let _ = - Ckappa_sig.Dictionary_of_agents.iter - parameters_gexf - error - (fun parameters_gexf error i agent_name () () -> - let string_name = agent_name in - let () = - print_list_of_lines parameters_gexf - [ - " "; - " "; - " "; - " "; - " "; - " "; - ] - in - let error, site_dic = - Misc_sa.unsome - ( - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters_gexf - error - i - handler.Cckappa_sig.sites) - (fun error -> - Exception.warn - parameters_gexf error __POS__ - Exit (Ckappa_sig.Dictionary_of_sites.init ())) - in - let error = - Ckappa_sig.Dictionary_of_sites.iter - parameters_gexf - error - (fun parameters_gexf error _j site () () -> - match site with - | Ckappa_sig.Counter _ - | Ckappa_sig.Internal _ -> error - | Ckappa_sig.Binding site -> - let site_name = - string_name^":"^site - in - let () = - print_list_of_lines parameters_gexf - [ - " "; - " "; - " "; - " "; - " "; - " "; - ] - in error) - site_dic - in - error) - handler.Cckappa_sig.agents_dic - in - let () = print_list_of_lines parameters_gexf [" ";" "] in - let error, counter = - Ckappa_sig.Dictionary_of_agents.fold - (fun _ ((),()) agent_name (error, counter) -> - let string_name = Ckappa_sig.string_of_agent_name agent_name in - let error, site_dic = - Misc_sa.unsome - ( - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters_gexf - error - agent_name - handler.Cckappa_sig.sites) - (fun error -> - Exception.warn - parameters_gexf error __POS__ - Exit (Ckappa_sig.Dictionary_of_sites.init ())) - in - let error, counter = - Ckappa_sig.Dictionary_of_sites.fold - (fun j ((),()) _ (error, counter) -> - match j with - | Ckappa_sig.Counter _ - | Ckappa_sig.Internal _ -> error, counter - | Ckappa_sig.Binding site -> - let site_name = - string_name^":"^site - in - let () = - print_list_of_lines parameters_gexf - [ - " "; - ] - in - error, counter+1) - site_dic - (error,counter) - in error, counter) - handler.Cckappa_sig.agents_dic - (error,0) - in - let _ = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.fold - parameters_gexf - error - (fun parameters_gexf error (i,(j,_k)) (i',j',_k') counter -> - if i - Exception.warn parameters_gexf error __POS__ Exit "" - | Ckappa_sig.Binding site_name ->error, site_name - in +let gexf_of_contact_map ?loggers parameters (error : Exception.method_handler) + handler = + let parameters_gexf = + match loggers with + | None -> Remanent_parameters.open_contact_map_file parameters + | Some loggers -> Remanent_parameters.set_logger parameters loggers + in + let _ = + print_list_of_lines parameters_gexf + [ + ""; + ""; + ""; + " "; + " "; + " "; + " "; + " "; + ] + in + let _ = + Ckappa_sig.Dictionary_of_agents.iter parameters_gexf error + (fun parameters_gexf error i agent_name () () -> + let string_name = agent_name in + let () = + print_list_of_lines parameters_gexf + [ + " "; + " "; + " "; + " "; + " "; + " "; + ] + in + let error, site_dic = + Misc_sa.unsome + (Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get + parameters_gexf error i handler.Cckappa_sig.sites) (fun error -> + Exception.warn parameters_gexf error __POS__ Exit + (Ckappa_sig.Dictionary_of_sites.init ())) + in + let error = + Ckappa_sig.Dictionary_of_sites.iter parameters_gexf error + (fun parameters_gexf error _j site () () -> + match site with + | Ckappa_sig.Counter _ | Ckappa_sig.Internal _ -> error + | Ckappa_sig.Binding site -> + let site_name = string_name ^ ":" ^ site in + let () = + print_list_of_lines parameters_gexf + [ + " "; + " "; + " "; + " "; + " "; + " "; + ] + in + error) + site_dic + in + error) + handler.Cckappa_sig.agents_dic + in + let () = + print_list_of_lines parameters_gexf [ " "; " " ] + in + let error, counter = + Ckappa_sig.Dictionary_of_agents.fold + (fun _ ((), ()) agent_name (error, counter) -> + let string_name = Ckappa_sig.string_of_agent_name agent_name in + let error, site_dic = + Misc_sa.unsome + (Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get + parameters_gexf error agent_name handler.Cckappa_sig.sites) + (fun error -> + Exception.warn parameters_gexf error __POS__ Exit + (Ckappa_sig.Dictionary_of_sites.init ())) + in + let error, counter = + Ckappa_sig.Dictionary_of_sites.fold + (fun j ((), ()) _ (error, counter) -> + match j with + | Ckappa_sig.Counter _ | Ckappa_sig.Internal _ -> error, counter + | Ckappa_sig.Binding site -> + let site_name = string_name ^ ":" ^ site in + let () = + print_list_of_lines parameters_gexf + [ + " "; + ] + in + error, counter + 1) + site_dic (error, counter) + in + error, counter) + handler.Cckappa_sig.agents_dic (error, 0) + in + let _ = + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .fold parameters_gexf error + (fun parameters_gexf error (i, (j, _k)) (i', j', _k') counter -> + if i < i' || (i = i' && j <= j') then ( + let error, agent_name = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters_gexf error handler i + in + let error, site = + Handler.translate_site parameters_gexf error handler i j + in + let error, site_name = + match site with + | Ckappa_sig.Internal _ | Ckappa_sig.Counter _ -> + Exception.warn parameters_gexf error __POS__ Exit "" + | Ckappa_sig.Binding site_name -> error, site_name + in - let error, agent_name' = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) - parameters_gexf error handler i' - in - let error, site' = - Handler.translate_site - parameters_gexf error handler i' j' - in - let error, site_name' = - match site' - with - | Ckappa_sig.Internal _ - | Ckappa_sig.Counter _ -> - Exception.warn parameters_gexf error __POS__ Exit "" - | Ckappa_sig.Binding site_name ->error, site_name - in + let error, agent_name' = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameters_gexf error handler i' + in + let error, site' = + Handler.translate_site parameters_gexf error handler i' j' + in + let error, site_name' = + match site' with + | Ckappa_sig.Internal _ | Ckappa_sig.Counter _ -> + Exception.warn parameters_gexf error __POS__ Exit "" + | Ckappa_sig.Binding site_name -> error, site_name + in - let _ = - print_list_of_lines parameters_gexf - [ - " "; - ] - in error, counter+1 - else - error,counter) - handler.Cckappa_sig.dual counter - in - let _ = print_list_of_lines parameters_gexf - [ - " "; - " "; - "" - ] - in - let () = - match - loggers - with - | None -> Loggers.close_logger (Remanent_parameters.get_logger parameters_gexf) - | Some _ -> Loggers.flush_logger (Remanent_parameters.get_logger parameters_gexf) - in - error + let _ = + print_list_of_lines parameters_gexf + [ + " "; + ] + in + error, counter + 1 + ) else + error, counter) + handler.Cckappa_sig.dual counter + in + let _ = + print_list_of_lines parameters_gexf + [ " "; " "; "" ] + in + let () = + match loggers with + | None -> + Loggers.close_logger (Remanent_parameters.get_logger parameters_gexf) + | Some _ -> + Loggers.flush_logger (Remanent_parameters.get_logger parameters_gexf) + in + error diff --git a/core/KaSa_rep/frontend/print_handler.mli b/core/KaSa_rep/frontend/print_handler.mli index 3c149f6f91..c798568d2c 100644 --- a/core/KaSa_rep/frontend/print_handler.mli +++ b/core/KaSa_rep/frontend/print_handler.mli @@ -1,25 +1,25 @@ -val local_trace:bool -val trace:bool +val local_trace : bool +val trace : bool -val gexf_of_contact_map: +val gexf_of_contact_map : ?loggers:Loggers.t -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Exception_without_parameter.method_handler -val dot_of_contact_map: +val dot_of_contact_map : ?loggers:Loggers.t -> Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Exception_without_parameter.method_handler -val print_handler: +val print_handler : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Exception_without_parameter.method_handler -val string_of_site: +val string_of_site : 'a -> (string, string, string) Ckappa_sig.site_type -> string diff --git a/core/KaSa_rep/frontend/purity.ml b/core/KaSa_rep/frontend/purity.ml index c23f9fab8f..a199b20eeb 100644 --- a/core/KaSa_rep/frontend/purity.ml +++ b/core/KaSa_rep/frontend/purity.ml @@ -12,5 +12,4 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - let local_trace = false diff --git a/core/KaSa_rep/frontend/purity.mli b/core/KaSa_rep/frontend/purity.mli index 1831a09f69..ed127e59d3 100644 --- a/core/KaSa_rep/frontend/purity.mli +++ b/core/KaSa_rep/frontend/purity.mli @@ -1 +1 @@ -val local_trace:bool +val local_trace : bool diff --git a/core/KaSa_rep/frontend/quark_type.ml b/core/KaSa_rep/frontend/quark_type.ml index d43519ce7e..758c607432 100644 --- a/core/KaSa_rep/frontend/quark_type.ml +++ b/core/KaSa_rep/frontend/quark_type.ml @@ -1,4 +1,4 @@ - (** +(** * quark.ml * openkappa * Jérôme Feret, projet Abstraction, INRIA Paris-Rocquencourt @@ -15,109 +15,109 @@ let local_trace = false module Label = Influence_labels.Int_labels - -module Labels = Influence_labels.Extensive(Label) - - +module Labels = Influence_labels.Extensive (Label) module StringMap = Mods.StringMap type agent_quark = Ckappa_sig.c_agent_name -type site_quark = (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) +type site_quark = + Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -module BoundSite = - SetMap.Make - (struct - type t = Ckappa_sig.c_rule_id * Labels.label * Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name - let compare = compare - let print _ _ = () - end) +module BoundSite = SetMap.Make (struct + type t = + Ckappa_sig.c_rule_id + * Labels.label + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + + let compare = compare + let print _ _ = () +end) module SiteMap = - Int_storage.Extend (Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif) - (Int_storage.Extend (Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif) + Int_storage.Extend + (Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif) + (Int_storage.Extend + (Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif) (Ckappa_sig.State_index_quick_nearly_Inf_Int_storage_Imperatif)) module CounterMap = Int_storage.Extend (Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif) - (Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif) + (Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif) -module DeadSiteMap= Int_storage.Extend - (Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif) - (Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif) +module DeadSiteMap = + Int_storage.Extend + (Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif) + (Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif) type agents_quarks = - Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t -type sites_quarks = Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t +type sites_quarks = + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t SiteMap.t -type counters_quarks = Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - CounterMap.t - -type quarks = - { - dead_agent: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - StringMap.t ; - dead_sites: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Cckappa_sig.KaSim_Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t ; - dead_states: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - DeadSiteMap.t; - dead_agent_plus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - StringMap.t ; - dead_sites_plus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Cckappa_sig.KaSim_Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t ; - dead_states_plus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - DeadSiteMap.t; - dead_agent_minus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - StringMap.t ; - dead_sites_minus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Cckappa_sig.KaSim_Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t ; - dead_states_minus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - DeadSiteMap.t; - agent_modif_plus: agents_quarks ; - agent_modif_minus: agents_quarks ; - agent_test: agents_quarks ; - agent_var_minus: agents_quarks ; - site_test_bound : sites_quarks ; - site_modif_bound_minus: sites_quarks ; - site_modif_bound_plus: sites_quarks ; - site_modif_minus: sites_quarks ; - site_test: sites_quarks ; - site_var_minus: sites_quarks ; - site_bound_var_minus: sites_quarks ; - site_bound_var_plus: sites_quarks ; - site_modif_plus: sites_quarks ; - agent_var_plus : agents_quarks ; - site_var_plus : sites_quarks ; - counter_test_geq: counters_quarks ; - counter_test_leq: counters_quarks ; - counter_delta_plus: counters_quarks ; - counter_delta_minus: counters_quarks ; - - } +type counters_quarks = + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + CounterMap.t + +type quarks = { + dead_agent: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + StringMap.t; + dead_sites: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Cckappa_sig.KaSim_Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + dead_states: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + DeadSiteMap.t; + dead_agent_plus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + StringMap.t; + dead_sites_plus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Cckappa_sig.KaSim_Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + dead_states_plus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + DeadSiteMap.t; + dead_agent_minus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + StringMap.t; + dead_sites_minus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Cckappa_sig.KaSim_Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + dead_states_minus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + DeadSiteMap.t; + agent_modif_plus: agents_quarks; + agent_modif_minus: agents_quarks; + agent_test: agents_quarks; + agent_var_minus: agents_quarks; + site_test_bound: sites_quarks; + site_modif_bound_minus: sites_quarks; + site_modif_bound_plus: sites_quarks; + site_modif_minus: sites_quarks; + site_test: sites_quarks; + site_var_minus: sites_quarks; + site_bound_var_minus: sites_quarks; + site_bound_var_plus: sites_quarks; + site_modif_plus: sites_quarks; + agent_var_plus: agents_quarks; + site_var_plus: sites_quarks; + counter_test_geq: counters_quarks; + counter_test_leq: counters_quarks; + counter_delta_plus: counters_quarks; + counter_delta_minus: counters_quarks; +} type influence_map = Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t -type influence_maps = - { - wake_up_map: influence_map; - influence_map: influence_map - } +type influence_maps = { + wake_up_map: influence_map; + influence_map: influence_map; +} diff --git a/core/KaSa_rep/frontend/quark_type.mli b/core/KaSa_rep/frontend/quark_type.mli index 882480a4e6..befa82d6d3 100644 --- a/core/KaSa_rep/frontend/quark_type.mli +++ b/core/KaSa_rep/frontend/quark_type.mli @@ -1,91 +1,95 @@ +val local_trace : bool -val local_trace: bool - -module StringMap: SetMap.Map with type elt=string -module Labels: Influence_labels.Label_handler with type label=int +module StringMap : SetMap.Map with type elt = string +module Labels : Influence_labels.Label_handler with type label = int type agent_quark = Ckappa_sig.c_agent_name -type site_quark = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state +type site_quark = + Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -module BoundSite: SetMap.S with type elt = Ckappa_sig.c_rule_id * int * agent_quark * Ckappa_sig.c_site_name +module BoundSite : + SetMap.S + with type elt = + Ckappa_sig.c_rule_id * int * agent_quark * Ckappa_sig.c_site_name -module SiteMap: Int_storage.Storage with type key = agent_quark * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) +module SiteMap : + Int_storage.Storage + with type key = agent_quark * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) -module CounterMap: Int_storage.Storage with type key = agent_quark * Ckappa_sig.c_site_name +module CounterMap : + Int_storage.Storage with type key = agent_quark * Ckappa_sig.c_site_name -module DeadSiteMap: Int_storage.Storage with type key = agent_quark * Ckappa_sig.c_site_name -type agents_quarks = - Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t +module DeadSiteMap : + Int_storage.Storage with type key = agent_quark * Ckappa_sig.c_site_name -type sites_quarks = Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - SiteMap.t +type agents_quarks = + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t -type counters_quarks = Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - CounterMap.t +type sites_quarks = + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + SiteMap.t -type quarks = - { - dead_agent: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - StringMap.t ; - dead_sites: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Cckappa_sig.KaSim_Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t ; - dead_states: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - DeadSiteMap.t; - dead_agent_plus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - StringMap.t ; - dead_sites_plus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Cckappa_sig.KaSim_Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t ; - dead_states_plus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - DeadSiteMap.t; - dead_agent_minus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - StringMap.t ; - dead_sites_minus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - Cckappa_sig.KaSim_Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t ; - dead_states_minus: Labels.label_set - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t - DeadSiteMap.t; - agent_modif_plus: agents_quarks ; - agent_modif_minus: agents_quarks ; - agent_test: agents_quarks ; - agent_var_minus: agents_quarks ; - site_test_bound : sites_quarks ; - site_modif_bound_minus: sites_quarks ; - site_modif_bound_plus: sites_quarks ; - site_modif_minus: sites_quarks ; - site_test: sites_quarks ; - site_var_minus: sites_quarks ; - site_bound_var_minus: sites_quarks ; - site_bound_var_plus: sites_quarks ; - site_modif_plus: sites_quarks ; - agent_var_plus : agents_quarks ; - site_var_plus : sites_quarks ; - counter_test_geq: counters_quarks ; - counter_test_leq: counters_quarks ; - counter_delta_plus: counters_quarks ; - counter_delta_minus: counters_quarks ; +type counters_quarks = + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + CounterMap.t - } +type quarks = { + dead_agent: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + StringMap.t; + dead_sites: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Cckappa_sig.KaSim_Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + dead_states: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + DeadSiteMap.t; + dead_agent_plus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + StringMap.t; + dead_sites_plus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Cckappa_sig.KaSim_Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + dead_states_plus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + DeadSiteMap.t; + dead_agent_minus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + StringMap.t; + dead_sites_minus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + Cckappa_sig.KaSim_Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + dead_states_minus: + Labels.label_set Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.t + DeadSiteMap.t; + agent_modif_plus: agents_quarks; + agent_modif_minus: agents_quarks; + agent_test: agents_quarks; + agent_var_minus: agents_quarks; + site_test_bound: sites_quarks; + site_modif_bound_minus: sites_quarks; + site_modif_bound_plus: sites_quarks; + site_modif_minus: sites_quarks; + site_test: sites_quarks; + site_var_minus: sites_quarks; + site_bound_var_minus: sites_quarks; + site_bound_var_plus: sites_quarks; + site_modif_plus: sites_quarks; + agent_var_plus: agents_quarks; + site_var_plus: sites_quarks; + counter_test_geq: counters_quarks; + counter_test_leq: counters_quarks; + counter_delta_plus: counters_quarks; + counter_delta_minus: counters_quarks; +} type influence_map = Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t -type influence_maps = - { - wake_up_map: influence_map; - influence_map: influence_map - } +type influence_maps = { + wake_up_map: influence_map; + influence_map: influence_map; +} diff --git a/core/KaSa_rep/influence_map/algebraic_construction.ml b/core/KaSa_rep/influence_map/algebraic_construction.ml index 60b3148201..2afa8ca6c7 100644 --- a/core/KaSa_rep/influence_map/algebraic_construction.ml +++ b/core/KaSa_rep/influence_map/algebraic_construction.ml @@ -15,306 +15,260 @@ exception False of Exception.method_handler let complete_interface parameters error handler proper_agent = - if proper_agent.Cckappa_sig.is_created - then + if proper_agent.Cckappa_sig.is_created then ( let site_list = Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ l -> site::l) - proper_agent.Cckappa_sig.agent_interface - [] + (fun site _ l -> site :: l) + proper_agent.Cckappa_sig.agent_interface [] in let error, missing_sites = - Handler.complementary_interface - parameters error handler + Handler.complementary_interface parameters error handler proper_agent.Cckappa_sig.agent_name (List.rev site_list) in let interface = proper_agent.Cckappa_sig.agent_interface in let error, interface = List.fold_left (fun (error, interface) site -> - let error, is_binding_site = - Handler.is_binding_site - parameters error handler proper_agent.Cckappa_sig.agent_name site - in - Ckappa_sig.Site_map_and_set.Map.add - parameters error - site - { - Cckappa_sig.site_name = site; - Cckappa_sig.site_position = - Locality.dummy; - Cckappa_sig.site_free = - if is_binding_site then Some true else None; - Cckappa_sig.site_state = - { - Cckappa_sig.min = Some Ckappa_sig.dummy_state_index; - Cckappa_sig.max = Some Ckappa_sig.dummy_state_index - }} interface) - (error, interface) - missing_sites + let error, is_binding_site = + Handler.is_binding_site parameters error handler + proper_agent.Cckappa_sig.agent_name site + in + Ckappa_sig.Site_map_and_set.Map.add parameters error site + { + Cckappa_sig.site_name = site; + Cckappa_sig.site_position = Loc.dummy; + Cckappa_sig.site_free = + (if is_binding_site then + Some true + else + None); + Cckappa_sig.site_state = + { + Cckappa_sig.min = Some Ckappa_sig.dummy_state_index; + Cckappa_sig.max = Some Ckappa_sig.dummy_state_index; + }; + } + interface) + (error, interface) missing_sites in - let proper_agent = {proper_agent with Cckappa_sig.agent_interface = interface} + let proper_agent = + { proper_agent with Cckappa_sig.agent_interface = interface } in error, proper_agent - else + ) else error, proper_agent -let check ~allow_dead_agent parameters error handler mixture1 mixture2 (i,j) = - let add (n1,n2) error to_do (inj1,inj2) = - let im1 = - Ckappa_sig.Agent_id_setmap.Map.find_option - n1 - inj1 - in - error,match im1 - with - | Some n2' when n2 = n2' -> Some (to_do, inj1, inj2) - | Some _ -> None - | None -> - begin - let im2 = - Ckappa_sig.Agent_id_setmap.Map.find_option - n2 - inj2 - in - match im2 - with Some _ -> None - | None -> - let inj1 = - Ckappa_sig.Agent_id_setmap.Map.add - n1 - n2 - inj1 - in - let inj2 = - Ckappa_sig.Agent_id_setmap.Map.add - n2 - n1 - inj2 - in - Some ((n1, n2) :: to_do, inj1, inj2) - end + +let check ~allow_dead_agent parameters error handler mixture1 mixture2 (i, j) = + let add (n1, n2) error to_do (inj1, inj2) = + let im1 = Ckappa_sig.Agent_id_setmap.Map.find_option n1 inj1 in + ( error, + match im1 with + | Some n2' when n2 = n2' -> Some (to_do, inj1, inj2) + | Some _ -> None + | None -> + let im2 = Ckappa_sig.Agent_id_setmap.Map.find_option n2 inj2 in + (match im2 with + | Some _ -> None + | None -> + let inj1 = Ckappa_sig.Agent_id_setmap.Map.add n1 n2 inj1 in + let inj2 = Ckappa_sig.Agent_id_setmap.Map.add n2 n1 inj2 in + Some ((n1, n2) :: to_do, inj1, inj2)) ) in let rec check_agent error to_do already_done = match to_do with - | [] -> error,Some already_done - | (h1,h2) :: t when Ckappa_sig.compare_agent_id h1 Ckappa_sig.dummy_agent_id < 0 - || - Ckappa_sig.compare_agent_id h2 Ckappa_sig.dummy_agent_id < 0 - -> + | [] -> error, Some already_done + | (h1, h2) :: t + when Ckappa_sig.compare_agent_id h1 Ckappa_sig.dummy_agent_id < 0 + || Ckappa_sig.compare_agent_id h2 Ckappa_sig.dummy_agent_id < 0 -> check_agent error t already_done - | (h1,h2)::t -> - begin - let error,view1 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error h1 mixture1.Cckappa_sig.views - in - let error,view2 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error h2 mixture2.Cckappa_sig.views - in - let error,bonds1 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error h1 mixture1.Cckappa_sig.bonds - in - let error,bonds2 = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error h2 mixture2.Cckappa_sig.bonds - in - check_interface error view1 view2 bonds1 bonds2 t already_done - end - - and deal_with error iter2 ag1 ag2 bonds1 bonds2 (to_do,already_done) = + | (h1, h2) :: t -> + let error, view1 = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error h1 mixture1.Cckappa_sig.views + in + let error, view2 = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error h2 mixture2.Cckappa_sig.views + in + let error, bonds1 = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error h1 mixture1.Cckappa_sig.bonds + in + let error, bonds2 = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error h2 mixture2.Cckappa_sig.bonds + in + check_interface error view1 view2 bonds1 bonds2 t already_done + and deal_with error iter2 ag1 ag2 bonds1 bonds2 (to_do, already_done) = let bonds1 = - match bonds1 with Some bonds1 -> bonds1 | None -> Ckappa_sig.Site_map_and_set.Map.empty + match bonds1 with + | Some bonds1 -> bonds1 + | None -> Ckappa_sig.Site_map_and_set.Map.empty in let bonds2 = - match bonds2 with Some bonds2 -> bonds2 | None -> Ckappa_sig.Site_map_and_set.Map.empty + match bonds2 with + | Some bonds2 -> bonds2 + | None -> Ckappa_sig.Site_map_and_set.Map.empty in - let error,bool = + let error, bool = try let error = - iter2 - parameters error + iter2 parameters error (fun _ error _ port1 port2 -> - let range1 = port1.Cckappa_sig.site_state in - let range2 = port2.Cckappa_sig.site_state in - if not (range1.Cckappa_sig.max < range2.Cckappa_sig.min || - range2.Cckappa_sig.max < range1.Cckappa_sig.min) - then error - else raise (False error)) - ag1.Cckappa_sig.agent_interface - ag2.Cckappa_sig.agent_interface - in error, true - with - False error -> error, false + let range1 = port1.Cckappa_sig.site_state in + let range2 = port2.Cckappa_sig.site_state in + if + not + (range1.Cckappa_sig.max < range2.Cckappa_sig.min + || range2.Cckappa_sig.max < range1.Cckappa_sig.min) + then + error + else + raise (False error)) + ag1.Cckappa_sig.agent_interface ag2.Cckappa_sig.agent_interface + in + error, true + with False error -> error, false in - if bool - then + if bool then ( try - let error,(to_do,already_done) = + let error, (to_do, already_done) = Ckappa_sig.Site_map_and_set.Map.fold2_sparse parameters error - (fun _ error _ port1 port2 (to_do,already_done) -> - if port1.Cckappa_sig.site = port2.Cckappa_sig.site - then - match - add - (port1.Cckappa_sig.agent_index, - port2.Cckappa_sig.agent_index) - error - to_do - already_done - with - | error,None -> raise (False error) - | error,Some (todo,inj1,inj2) -> (error,(todo,(inj1,inj2))) - else - raise (False error) - ) - bonds1 - bonds2 - (to_do,already_done) - in error,(true,(to_do,already_done)) - with - False error -> error,(false,(to_do,already_done)) - else - error,(bool,(to_do,already_done)) - + (fun _ error _ port1 port2 (to_do, already_done) -> + if port1.Cckappa_sig.site = port2.Cckappa_sig.site then ( + match + add + ( port1.Cckappa_sig.agent_index, + port2.Cckappa_sig.agent_index ) + error to_do already_done + with + | error, None -> raise (False error) + | error, Some (todo, inj1, inj2) -> error, (todo, (inj1, inj2)) + ) else + raise (False error)) + bonds1 bonds2 (to_do, already_done) + in + error, (true, (to_do, already_done)) + with False error -> error, (false, (to_do, already_done)) + ) else + error, (bool, (to_do, already_done)) and check_interface error ag1 ag2 bonds1 bonds2 to_do already_done = - let error,(bool,(to_do,already_done)) = - match - ag1,ag2 - with - | None,_ | _,None -> - Exception.warn - parameters error __POS__ - ~message:"Should not scan empty agents..." Exit (true,(to_do,already_done)) - | Some ag1,Some ag2 -> - begin - match ag1 - with - | Cckappa_sig.Ghost-> - Exception.warn - parameters error __POS__ - ~message:"Should not scan ghost agents..." Exit (true,(to_do,already_done)) - | Cckappa_sig.Unknown_agent _ -> raise (False error) - | Cckappa_sig.Dead_agent (ag1,_,l11,l12) -> - begin - if not allow_dead_agent then raise (False error) - else - let error, ag1 = complete_interface parameters error handler ag1 in - match ag2 with - | Cckappa_sig.Unknown_agent _ -> raise (False error) - | Cckappa_sig.Ghost -> - Exception.warn - parameters error __POS__ - ~message:"Should not scan ghost agents..." - Exit (true,(to_do,already_done)) - | Cckappa_sig.Dead_agent (ag2,_s2,l21,l22) -> - begin - let error, ag2 = complete_interface parameters error handler ag2 in - let error,(_bool,(to_do,already_done)) = - deal_with error - (fun parameter error -> - Ckappa_sig.Site_map_and_set.Map.iter2 - parameter error - (fun _parameter error site _ -> - if Ckappa_sig.Site_map_and_set.Map.mem site l22 || - Ckappa_sig.Site_map_and_set.Map.mem site l21 - then raise (False error) - else error) - (fun _parameter error site _ -> - if Ckappa_sig.Site_map_and_set.Map.mem site l12 || - Ckappa_sig.Site_map_and_set.Map.mem site l22 - then raise (False error) - else error)) - ag1 - ag2 - bonds1 - bonds2 - (to_do,already_done) in - (* to do check consistency of dead sites *) - error,(true,(to_do,already_done)) - end - | Cckappa_sig.Agent ag2 -> - let error, ag2 = complete_interface parameters error handler ag2 in + let error, (bool, (to_do, already_done)) = + match ag1, ag2 with + | None, _ | _, None -> + Exception.warn parameters error __POS__ + ~message:"Should not scan empty agents..." Exit + (true, (to_do, already_done)) + | Some ag1, Some ag2 -> + (match ag1 with + | Cckappa_sig.Ghost -> + Exception.warn parameters error __POS__ + ~message:"Should not scan ghost agents..." Exit + (true, (to_do, already_done)) + | Cckappa_sig.Unknown_agent _ -> raise (False error) + | Cckappa_sig.Dead_agent (ag1, _, l11, l12) -> + if not allow_dead_agent then + raise (False error) + else ( + let error, ag1 = complete_interface parameters error handler ag1 in + match ag2 with + | Cckappa_sig.Unknown_agent _ -> raise (False error) + | Cckappa_sig.Ghost -> + Exception.warn parameters error __POS__ + ~message:"Should not scan ghost agents..." Exit + (true, (to_do, already_done)) + | Cckappa_sig.Dead_agent (ag2, _s2, l21, l22) -> + let error, ag2 = + complete_interface parameters error handler ag2 + in + let error, (_bool, (to_do, already_done)) = deal_with error (fun parameter error -> - Ckappa_sig.Site_map_and_set.Map.iter2 - parameter error - (fun _ error _ _ -> error) - (fun _parameter error site _ -> - if Ckappa_sig.Site_map_and_set.Map.mem site l11 || - Ckappa_sig.Site_map_and_set.Map.mem site l12 - then raise (False error) - else error)) - ag1 - ag2 - bonds1 - bonds2 - (to_do,already_done) - - end - | Cckappa_sig.Agent ag1 -> - begin - let error, ag1 = complete_interface parameters error handler ag1 in - match ag2 with - | Cckappa_sig.Unknown_agent _ -> raise (False error) - | Cckappa_sig.Ghost -> - Exception.warn - parameters error __POS__ - ~message:"Should not scan ghost agents..." - Exit (true,(to_do,already_done)) - | Cckappa_sig.Dead_agent (ag2,_,l21,l22) -> - begin - let error, ag2 = - complete_interface parameters error handler ag2 - in - if not allow_dead_agent then raise (False error) - else - begin - deal_with error - (fun parameter error -> - Ckappa_sig.Site_map_and_set.Map.iter2 - parameter error - (fun _parameter error site _ -> - if Ckappa_sig.Site_map_and_set.Map.mem site l22 || - Ckappa_sig.Site_map_and_set.Map.mem site l21 - then raise (False error) - else error) - (fun _ error _ _ -> error)) - ag1 - ag2 - bonds1 - bonds2 - (to_do,already_done) - end - end - | Cckappa_sig.Agent ag2 -> - let error, ag2 = - complete_interface parameters error handler ag2 - in - deal_with error Ckappa_sig.Site_map_and_set.Map.iter2_sparse - ag1 ag2 bonds1 bonds2 (to_do,already_done) - end - end + Ckappa_sig.Site_map_and_set.Map.iter2 parameter error + (fun _parameter error site _ -> + if + Ckappa_sig.Site_map_and_set.Map.mem site l22 + || Ckappa_sig.Site_map_and_set.Map.mem site l21 + then + raise (False error) + else + error) + (fun _parameter error site _ -> + if + Ckappa_sig.Site_map_and_set.Map.mem site l12 + || Ckappa_sig.Site_map_and_set.Map.mem site l22 + then + raise (False error) + else + error)) + ag1 ag2 bonds1 bonds2 (to_do, already_done) + in + (* to do check consistency of dead sites *) + error, (true, (to_do, already_done)) + | Cckappa_sig.Agent ag2 -> + let error, ag2 = + complete_interface parameters error handler ag2 + in + deal_with error + (fun parameter error -> + Ckappa_sig.Site_map_and_set.Map.iter2 parameter error + (fun _ error _ _ -> error) + (fun _parameter error site _ -> + if + Ckappa_sig.Site_map_and_set.Map.mem site l11 + || Ckappa_sig.Site_map_and_set.Map.mem site l12 + then + raise (False error) + else + error)) + ag1 ag2 bonds1 bonds2 (to_do, already_done) + ) + | Cckappa_sig.Agent ag1 -> + let error, ag1 = complete_interface parameters error handler ag1 in + (match ag2 with + | Cckappa_sig.Unknown_agent _ -> raise (False error) + | Cckappa_sig.Ghost -> + Exception.warn parameters error __POS__ + ~message:"Should not scan ghost agents..." Exit + (true, (to_do, already_done)) + | Cckappa_sig.Dead_agent (ag2, _, l21, l22) -> + let error, ag2 = complete_interface parameters error handler ag2 in + if not allow_dead_agent then + raise (False error) + else + deal_with error + (fun parameter error -> + Ckappa_sig.Site_map_and_set.Map.iter2 parameter error + (fun _parameter error site _ -> + if + Ckappa_sig.Site_map_and_set.Map.mem site l22 + || Ckappa_sig.Site_map_and_set.Map.mem site l21 + then + raise (False error) + else + error) + (fun _ error _ _ -> error)) + ag1 ag2 bonds1 bonds2 (to_do, already_done) + | Cckappa_sig.Agent ag2 -> + let error, ag2 = complete_interface parameters error handler ag2 in + deal_with error Ckappa_sig.Site_map_and_set.Map.iter2_sparse ag1 ag2 + bonds1 bonds2 (to_do, already_done))) in - if bool - then + if bool then check_agent error to_do already_done else error, None in - let error,ouput = add (i,j) error [] - (Ckappa_sig.Agent_id_setmap.Map.empty, Ckappa_sig.Agent_id_setmap.Map.empty) + let error, ouput = + add (i, j) error [] + ( Ckappa_sig.Agent_id_setmap.Map.empty, + Ckappa_sig.Agent_id_setmap.Map.empty ) in - match ouput - with - None -> - Exception.warn - parameters error __POS__ - ~message:"Missing rule" - Exit None - | Some(_,inj1,inj2) -> check_agent error [i,j] (inj1,inj2) + match ouput with + | None -> + Exception.warn parameters error __POS__ ~message:"Missing rule" Exit None + | Some (_, inj1, inj2) -> check_agent error [ i, j ] (inj1, inj2) exception Pass of Exception.method_handler @@ -324,407 +278,353 @@ let is_shift_required bool rule = | Ckappa_sig.Reverse -> not bool let shift_agent_id bool rule id = - if is_shift_required bool rule && - Ckappa_sig.compare_agent_id id - (Ckappa_sig.agent_id_of_int rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.prefix) - >= 0 + if + is_shift_required bool rule + && Ckappa_sig.compare_agent_id id + (Ckappa_sig.agent_id_of_int + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.prefix) + >= 0 then - Ckappa_sig.add_agent_id - id - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.delta - else id + Ckappa_sig.add_agent_id id rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.delta + else + id let filter_influence parameters error handler compilation map bool = let nrules = Handler.nrules parameters error handler in let allow_dead_agent = true in let get_var v = - match - snd (v.Cckappa_sig.e_variable) - with - | Alg_expr.KAPPA_INSTANCE(mixture), _ -> error,mixture - | (Alg_expr.IF _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ - | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ | Alg_expr.TOKEN_ID _ - | Alg_expr.CONST _ - | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ),_ - -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:"Composite observable" + match snd v.Cckappa_sig.e_variable with + | Alg_expr.KAPPA_INSTANCE mixture, _ -> error, mixture + | ( ( Alg_expr.IF _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ | Alg_expr.TOKEN_ID _ + | Alg_expr.CONST _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.DIFF_TOKEN _ ), + _ ) -> + let error, () = + Exception.warn parameters error __POS__ ~message:"Composite observable" Exit () - in raise (Pass error) - in - let get_lhs r = - r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs + in + raise (Pass error) in - let get_rhs r = - r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs + let get_lhs r = r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs in + let get_rhs r = r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs in + let get_bool = + if bool then + get_rhs + else + get_lhs in - let get_bool = if bool then get_rhs else get_lhs in let check_influence_rule_mixt error rule1 mixt rule2_opt pos = - let updt_pos ((x:Ckappa_sig.c_agent_id), (y:Ckappa_sig.c_agent_id)) = - (shift_agent_id bool rule1 x, - match rule2_opt with - | None -> y - | Some rule2 -> shift_agent_id false rule2 y) + let updt_pos ((x : Ckappa_sig.c_agent_id), (y : Ckappa_sig.c_agent_id)) = + ( shift_agent_id bool rule1 x, + match rule2_opt with + | None -> y + | Some rule2 -> shift_agent_id false rule2 y ) in - check - ~allow_dead_agent - parameters - error - handler - (get_bool rule1) - mixt + check ~allow_dead_agent parameters error handler (get_bool rule1) mixt (updt_pos pos) in Ckappa_sig.PairRule_setmap.Map.fold - (fun (a,b) couple (error,map') -> - try - begin - let error,rule1 = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - a - compilation.Cckappa_sig.rules - in - let error,r1 = - match rule1 - with - | None -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:"Missing rule" - Exit () - in raise (Pass error) - | Some r -> error,r - in - let error,mixt,rule2_opt = - if - Ckappa_sig.compare_rule_id b (Ckappa_sig.rule_id_of_int nrules) < 0 - then - begin - let error,rule2 = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - b - compilation.Cckappa_sig.rules - in - match rule2 with - | None -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:("Missing rule"^ (Ckappa_sig.string_of_rule_id b)) - Exit () - in raise (Pass error) - | Some r -> error, get_lhs r, - Some r - end - else - begin - let error,var = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - (Ckappa_sig.sub_rule_id b nrules) - compilation.Cckappa_sig.variables - in - match var with - | None -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:("Missing var" ^(Ckappa_sig.string_of_rule_id b)) - Exit () - in raise (Pass error) - | Some v -> let error, mixt = get_var v in - error, mixt, None - end - in - let error,couple' = - try - let error,couple' = - Quark_type.Labels.filter_couple - parameters - error - handler - (fun error a b -> - match - check_influence_rule_mixt error - r1 - mixt - rule2_opt - (Ckappa_sig.agent_id_of_int a, - Ckappa_sig.agent_id_of_int b) - with - | error, Some _ -> error, true - | error, None -> error, false - ) - couple - in - error,couple' - with Exit -> error,couple - in - if Quark_type.Labels.is_empty_couple couple' - then error,map' - else error, - Ckappa_sig.PairRule_setmap.Map.add - (a,b) couple' map' - end - with Pass error -> (error,map') - ) - map (error, Ckappa_sig.PairRule_setmap.Map.empty) + (fun (a, b) couple (error, map') -> + try + let error, rule1 = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error + a compilation.Cckappa_sig.rules + in + let error, r1 = + match rule1 with + | None -> + let error, () = + Exception.warn parameters error __POS__ ~message:"Missing rule" + Exit () + in + raise (Pass error) + | Some r -> error, r + in + let error, mixt, rule2_opt = + if Ckappa_sig.compare_rule_id b (Ckappa_sig.rule_id_of_int nrules) < 0 + then ( + let error, rule2 = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters + error b compilation.Cckappa_sig.rules + in + match rule2 with + | None -> + let error, () = + Exception.warn parameters error __POS__ + ~message:("Missing rule" ^ Ckappa_sig.string_of_rule_id b) + Exit () + in + raise (Pass error) + | Some r -> error, get_lhs r, Some r + ) else ( + let error, var = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters + error + (Ckappa_sig.sub_rule_id b nrules) + compilation.Cckappa_sig.variables + in + match var with + | None -> + let error, () = + Exception.warn parameters error __POS__ + ~message:("Missing var" ^ Ckappa_sig.string_of_rule_id b) + Exit () + in + raise (Pass error) + | Some v -> + let error, mixt = get_var v in + error, mixt, None + ) + in + let error, couple' = + try + let error, couple' = + Quark_type.Labels.filter_couple parameters error handler + (fun error a b -> + match + check_influence_rule_mixt error r1 mixt rule2_opt + ( Ckappa_sig.agent_id_of_int a, + Ckappa_sig.agent_id_of_int b ) + with + | error, Some _ -> error, true + | error, None -> error, false) + couple + in + error, couple' + with Exit -> error, couple + in + if Quark_type.Labels.is_empty_couple couple' then + error, map' + else + error, Ckappa_sig.PairRule_setmap.Map.add (a, b) couple' map' + with Pass error -> error, map') + map + (error, Ckappa_sig.PairRule_setmap.Map.empty) -let filter_influence_high maybe_reachable - parameters handler error compilation - static dynamic - map bool = +let filter_influence_high maybe_reachable parameters handler error compilation + static dynamic map bool = let dynamic_ref = ref dynamic in let nrules = Handler.nrules parameters error handler in let allow_dead_agent = false in let get_var v = - match - snd (v.Cckappa_sig.e_variable) - with - | Alg_expr.KAPPA_INSTANCE(mixture), _ -> error,mixture - | (Alg_expr.IF _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ - | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ - | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.CONST _) ,_ -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:"Composite observable" + match snd v.Cckappa_sig.e_variable with + | Alg_expr.KAPPA_INSTANCE mixture, _ -> error, mixture + | ( ( Alg_expr.IF _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ + | Alg_expr.TOKEN_ID _ | Alg_expr.CONST _ ), + _ ) -> + let error, () = + Exception.warn parameters error __POS__ ~message:"Composite observable" Exit () - in raise (Pass error) - in - let get_lhs r = - r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs + in + raise (Pass error) in - let get_rhs r = - r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs + let get_lhs r = r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs in + let get_rhs r = r.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs in + let get_bool = + if bool then + get_rhs + else + get_lhs in - let get_bool = if bool then get_rhs else get_lhs in - let check_influence_rule_mixt error rule1 mixt rule2_opt pos = - let updt_pos ((x:Ckappa_sig.c_agent_id), (y:Ckappa_sig.c_agent_id)) = - (shift_agent_id bool rule1 x, - match rule2_opt with - | None -> y - | Some rule2 -> shift_agent_id false rule2 y) + let check_influence_rule_mixt error rule1 mixt rule2_opt pos = + let updt_pos ((x : Ckappa_sig.c_agent_id), (y : Ckappa_sig.c_agent_id)) = + ( shift_agent_id bool rule1 x, + match rule2_opt with + | None -> y + | Some rule2 -> shift_agent_id false rule2 y ) in - begin - try - check - ~allow_dead_agent - parameters - error - handler - (get_bool rule1) - mixt - (updt_pos pos) - with - | False error -> error, None - end + try + check ~allow_dead_agent parameters error handler (get_bool rule1) mixt + (updt_pos pos) + with False error -> error, None in Ckappa_sig.PairRule_setmap.Map.fold - (fun (a,b) couple ((error,dynamic),map') -> - try - begin - let error,rule1 = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - a - compilation.Cckappa_sig.rules - in - let error,r1 = - match rule1 - with - | None -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:"Missing rule" - Exit () - in raise (Pass error) - | Some r -> error,r - in - let error,mixt,rule2_opt = - if - Ckappa_sig.compare_rule_id b (Ckappa_sig.rule_id_of_int nrules) < 0 - then - begin - let error,rule2 = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - b - compilation.Cckappa_sig.rules - in - match rule2 with - | None -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:("Missing rule"^ (Ckappa_sig.string_of_rule_id b)) - Exit () - in raise (Pass error) - | Some r -> error, get_lhs r, Some r - end - else - begin - let error,var = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - (Ckappa_sig.sub_rule_id b nrules) - compilation.Cckappa_sig.variables - in - match var with - | None -> - let error,() = - Exception.warn - parameters error __POS__ - ~message:("Missing var" ^(Ckappa_sig.string_of_rule_id b)) - Exit () - in raise (Pass error) - | Some v -> - let error, var = get_var v in - error, var, None - end - in - let (error,dynamic),couple' = - try - let (error,dynamic),couple' = - Quark_type.Labels.filter_couple - parameters - (error, dynamic) - handler - (fun (error,dynamic) a b -> + (fun (a, b) couple ((error, dynamic), map') -> + try + let error, rule1 = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error + a compilation.Cckappa_sig.rules + in + let error, r1 = + match rule1 with + | None -> + let error, () = + Exception.warn parameters error __POS__ ~message:"Missing rule" + Exit () + in + raise (Pass error) + | Some r -> error, r + in + let error, mixt, rule2_opt = + if Ckappa_sig.compare_rule_id b (Ckappa_sig.rule_id_of_int nrules) < 0 + then ( + let error, rule2 = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters + error b compilation.Cckappa_sig.rules + in + match rule2 with + | None -> + let error, () = + Exception.warn parameters error __POS__ + ~message:("Missing rule" ^ Ckappa_sig.string_of_rule_id b) + Exit () + in + raise (Pass error) + | Some r -> error, get_lhs r, Some r + ) else ( + let error, var = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters + error + (Ckappa_sig.sub_rule_id b nrules) + compilation.Cckappa_sig.variables + in + match var with + | None -> + let error, () = + Exception.warn parameters error __POS__ + ~message:("Missing var" ^ Ckappa_sig.string_of_rule_id b) + Exit () + in + raise (Pass error) + | Some v -> + let error, var = get_var v in + error, var, None + ) + in + let (error, dynamic), couple' = + try + let (error, dynamic), couple' = + Quark_type.Labels.filter_couple parameters (error, dynamic) + handler + (fun (error, dynamic) a b -> + match + check_influence_rule_mixt error r1 mixt rule2_opt + ( Ckappa_sig.agent_id_of_int a, + Ckappa_sig.agent_id_of_int b ) + with + | error, None -> (error, dynamic), false + | error, Some (_inj1, inj2) -> + let error, n = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .fold parameters error + (fun _parameters error i _ sol -> + ( error, + if Ckappa_sig.compare_agent_id i sol < 0 then + sol + else + i )) + (get_bool r1).Cckappa_sig.views + Ckappa_sig.dummy_agent_id + in + let f _parameters error i = match - check_influence_rule_mixt error - r1 - mixt - rule2_opt - (Ckappa_sig.agent_id_of_int a, - Ckappa_sig.agent_id_of_int b) + Ckappa_sig.Agent_id_setmap.Map.find_option i inj2 with - | error, None -> (error, dynamic), false - | error, Some (_inj1,inj2) -> - let error, n = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters - error - (fun _parameters error i _ sol -> - error, - if Ckappa_sig.compare_agent_id i sol < 0 then sol else i) - (get_bool r1).Cckappa_sig.views - Ckappa_sig.dummy_agent_id - in - let f _parameters error i = - match Ckappa_sig.Agent_id_setmap.Map.find_option - i inj2 - with - | None -> - error, (Ckappa_sig.agent_id_of_int ((Ckappa_sig.int_of_agent_id - i)+ - (Ckappa_sig.int_of_agent_id n) +1)) - | Some j when Ckappa_sig.compare_agent_id j Ckappa_sig.dummy_agent_id < 0 -> (* check if we can improve in case of negative update, there should be a bond between j and this agent *) - error, (Ckappa_sig.agent_id_of_int ((Ckappa_sig.int_of_agent_id - i)+ - (Ckappa_sig.int_of_agent_id n) +1)) - | Some j -> error, j - in - let error, join = - Cckappa_sig.join_mixture - parameters error (fun _ error i -> error,i) - f (get_bool r1) mixt - in - let error, dynamic, bool = - maybe_reachable static dynamic error join - in - let () = dynamic_ref := dynamic in + | None -> + ( error, + Ckappa_sig.agent_id_of_int + (Ckappa_sig.int_of_agent_id i + + Ckappa_sig.int_of_agent_id n + + 1) ) + | Some j + when Ckappa_sig.compare_agent_id j + Ckappa_sig.dummy_agent_id + < 0 -> + (* check if we can improve in case of negative update, there should be a bond between j and this agent *) + ( error, + Ckappa_sig.agent_id_of_int + (Ckappa_sig.int_of_agent_id i + + Ckappa_sig.int_of_agent_id n + + 1) ) + | Some j -> error, j + in + let error, join = + Cckappa_sig.join_mixture parameters error + (fun _ error i -> error, i) + f (get_bool r1) mixt + in + let error, dynamic, bool = + maybe_reachable static dynamic error join + in + let () = dynamic_ref := dynamic in + let error = + if Remanent_parameters.get_trace parameters then ( let error = - if Remanent_parameters.get_trace parameters - then - let error = - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "FST:\n" - in - let error = - Print_cckappa.print_mixture parameters error - handler (get_bool r1) - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "SND:\n" - in - let error = - Print_cckappa.print_mixture parameters error - handler - mixt - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "PUSHOUT:\n" - in - let error = - Print_cckappa.print_mixture parameters error handler join - in - let () = - if bool - then - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "YES!!!\n" - else - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "NO!!!\n" - in - let error = - Print_cckappa.print_mixture parameters error - handler (get_bool r1) - in - let error = - Print_cckappa.print_mixture parameters error - handler - mixt - in - let error = - Print_cckappa.print_mixture parameters error handler join - in error - in error - else error in - (error, dynamic), bool) - couple - in - (error,dynamic),couple' - with False (error) -> - let dynamic = !dynamic_ref in - (error,dynamic),couple - in - if Quark_type.Labels.is_empty_couple couple' - then (error,dynamic),map' - else (error,dynamic), - Ckappa_sig.PairRule_setmap.Map.add - (a,b) couple' map' - end - with Pass error -> - let dynamic = !dynamic_ref in - ((error,dynamic),map') - - ) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "FST:\n" + in + let error = + Print_cckappa.print_mixture parameters error handler + (get_bool r1) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "SND:\n" + in + let error = + Print_cckappa.print_mixture parameters error handler + mixt + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "PUSHOUT:\n" + in + let error = + Print_cckappa.print_mixture parameters error handler + join + in + let () = + if bool then + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "YES!!!\n" + else + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "NO!!!\n" + in + let error = + Print_cckappa.print_mixture parameters error handler + (get_bool r1) + in + let error = + Print_cckappa.print_mixture parameters error handler + mixt + in + let error = + Print_cckappa.print_mixture parameters error handler + join + in + error + in + error + ) else + error + in + (error, dynamic), bool) + couple + in + (error, dynamic), couple' + with False error -> + let dynamic = !dynamic_ref in + (error, dynamic), couple + in + if Quark_type.Labels.is_empty_couple couple' then + (error, dynamic), map' + else + ( (error, dynamic), + Ckappa_sig.PairRule_setmap.Map.add (a, b) couple' map' ) + with Pass error -> + let dynamic = !dynamic_ref in + (error, dynamic), map') map - ((error,dynamic), - Ckappa_sig.PairRule_setmap.Map.empty - ) + ((error, dynamic), Ckappa_sig.PairRule_setmap.Map.empty) diff --git a/core/KaSa_rep/influence_map/bidirectional_influence_map.ml b/core/KaSa_rep/influence_map/bidirectional_influence_map.ml index ea98ba5ed6..973b55755a 100644 --- a/core/KaSa_rep/influence_map/bidirectional_influence_map.ml +++ b/core/KaSa_rep/influence_map/bidirectional_influence_map.ml @@ -1,155 +1,131 @@ let convert ~nrules ~nvars influence_map = let n = nrules + nvars in - let (_,pos,neg) = influence_map in + let _, pos, neg = influence_map in let bidirectional_map = { - Remanent_state.positive_influence_fwd = - Array.make n []; - Remanent_state.positive_influence_bwd = - Array.make n []; - Remanent_state.negative_influence_fwd = - Array.make n []; - Remanent_state.negative_influence_bwd = - Array.make n []; + Remanent_state.positive_influence_fwd = Array.make n []; + Remanent_state.positive_influence_bwd = Array.make n []; + Remanent_state.negative_influence_fwd = Array.make n []; + Remanent_state.negative_influence_bwd = Array.make n []; } in let f store_direct store_reverse map birectional_map = Ckappa_sig.PairRule_setmap.Map.fold - (fun (id1,id2) edge_label bidirectional_map -> - store_direct id1 id2 edge_label - (store_reverse id2 id1 edge_label bidirectional_map)) + (fun (id1, id2) edge_label bidirectional_map -> + store_direct id1 id2 edge_label + (store_reverse id2 id1 edge_label bidirectional_map)) map birectional_map in let add get set i im bidirectional_map = let old = get i bidirectional_map in - set i (im::old) bidirectional_map + set i (im :: old) bidirectional_map in let bidirectional_map = f (fun i j edge bidirectional_map -> - add - (fun i bidirectional_map -> - bidirectional_map.Remanent_state.positive_influence_fwd.(i)) - (fun i im bidirectional_map -> - let () = - bidirectional_map.Remanent_state.positive_influence_fwd.(i)<-im - in - bidirectional_map - ) - (Ckappa_sig.int_of_rule_id i) - (j,edge) - bidirectional_map) + add + (fun i bidirectional_map -> + bidirectional_map.Remanent_state.positive_influence_fwd.(i)) + (fun i im bidirectional_map -> + let () = + bidirectional_map.Remanent_state.positive_influence_fwd.(i) <- im + in + bidirectional_map) + (Ckappa_sig.int_of_rule_id i) + (j, edge) bidirectional_map) (fun i j edge bidirectional_map -> - add - (fun i bidirectional_map -> - bidirectional_map.Remanent_state.positive_influence_bwd.(i)) - (fun i im bidirectional_map -> - let () = - bidirectional_map.Remanent_state.positive_influence_bwd.(i)<-im in - bidirectional_map - ) - (Ckappa_sig.int_of_rule_id i) - (j,edge) - bidirectional_map - ) - pos - bidirectional_map + add + (fun i bidirectional_map -> + bidirectional_map.Remanent_state.positive_influence_bwd.(i)) + (fun i im bidirectional_map -> + let () = + bidirectional_map.Remanent_state.positive_influence_bwd.(i) <- im + in + bidirectional_map) + (Ckappa_sig.int_of_rule_id i) + (j, edge) bidirectional_map) + pos bidirectional_map in let bidirectional_map = f (fun i j edge bidirectional_map -> - add - (fun i bidirectional_map -> - bidirectional_map.Remanent_state.negative_influence_fwd.(i) - ) - (fun i im bidirectional_map -> - let () = - bidirectional_map.Remanent_state.negative_influence_fwd.( - i)<-im in - bidirectional_map - ) - (Ckappa_sig.int_of_rule_id i) - (j,edge) - bidirectional_map) + add + (fun i bidirectional_map -> + bidirectional_map.Remanent_state.negative_influence_fwd.(i)) + (fun i im bidirectional_map -> + let () = + bidirectional_map.Remanent_state.negative_influence_fwd.(i) <- im + in + bidirectional_map) + (Ckappa_sig.int_of_rule_id i) + (j, edge) bidirectional_map) (fun i j edge bidirectional_map -> - add - (fun i bidirectional_map -> - bidirectional_map.Remanent_state.negative_influence_bwd.(i) - ) - (fun i im bidirectional_map -> - let () = - bidirectional_map.Remanent_state.negative_influence_bwd.( - i)<-im in - bidirectional_map - ) - (Ckappa_sig.int_of_rule_id i) - (j,edge) - bidirectional_map) - neg - bidirectional_map - in bidirectional_map - + add + (fun i bidirectional_map -> + bidirectional_map.Remanent_state.negative_influence_bwd.(i)) + (fun i im bidirectional_map -> + let () = + bidirectional_map.Remanent_state.negative_influence_bwd.(i) <- im + in + bidirectional_map) + (Ckappa_sig.int_of_rule_id i) + (j, edge) bidirectional_map) + neg bidirectional_map + in + bidirectional_map let dump parameters handler error bidirectional_map = let nrules = Handler.nrules parameters error handler in let f loggers error map = Tools.array_fold_lefti (fun i error j -> - let () = Loggers.fprintf loggers " %i:" i in - let () = Loggers.print_newline loggers in - List.fold_left - (fun error (node,edge) -> - let node = Ckappa_sig.int_of_rule_id node in - let error, s3 = - let s = Buffer.create 0 in - let fmt = Format.formatter_of_buffer s in - let parameters = Remanent_parameters.set_logger parameters - (Loggers.open_logger_from_formatter fmt) in - let error = - Handler.print_labels parameters error handler edge - in - let () = Format.pp_print_flush fmt () in - let s = Buffer.contents s in - error, s - in - let () = - Loggers.fprintf loggers " %s [%s]" - (if node < nrules then - "Rule "^(string_of_int node) - else - "Var "^(string_of_int (node-nrules))) - s3 - in - let () = - Loggers.print_newline loggers + let () = Loggers.fprintf loggers " %i:" i in + let () = Loggers.print_newline loggers in + List.fold_left + (fun error (node, edge) -> + let node = Ckappa_sig.int_of_rule_id node in + let error, s3 = + let s = Buffer.create 0 in + let fmt = Format.formatter_of_buffer s in + let parameters = + Remanent_parameters.set_logger parameters + (Loggers.open_logger_from_formatter fmt) in - error - ) - error j - ) + let error = Handler.print_labels parameters error handler edge in + let () = Format.pp_print_flush fmt () in + let s = Buffer.contents s in + error, s + in + let () = + Loggers.fprintf loggers " %s [%s]" + (if node < nrules then + "Rule " ^ string_of_int node + else + "Var " ^ string_of_int (node - nrules)) + s3 + in + let () = Loggers.print_newline loggers in + error) + error j) error map in let loggers = Remanent_parameters.get_logger parameters in let () = Loggers.fprintf loggers "Direct\n" in let () = Loggers.fprintf loggers " Positive\n" in let error = - f loggers error - bidirectional_map.Remanent_state.positive_influence_fwd + f loggers error bidirectional_map.Remanent_state.positive_influence_fwd in let () = Loggers.fprintf loggers " Negative\n" in let error = - f loggers error - bidirectional_map.Remanent_state.negative_influence_fwd + f loggers error bidirectional_map.Remanent_state.negative_influence_fwd in let () = Loggers.fprintf loggers "Reverse\n" in let () = Loggers.fprintf loggers " Positive\n" in let error = - f loggers error - bidirectional_map.Remanent_state.positive_influence_bwd + f loggers error bidirectional_map.Remanent_state.positive_influence_bwd in let () = Loggers.fprintf loggers " Negative\n" in let error = - f loggers error - bidirectional_map.Remanent_state.negative_influence_bwd + f loggers error bidirectional_map.Remanent_state.negative_influence_bwd in error diff --git a/core/KaSa_rep/influence_map/dune b/core/KaSa_rep/influence_map/dune index ce5151276b..f3f50e1980 100644 --- a/core/KaSa_rep/influence_map/dune +++ b/core/KaSa_rep/influence_map/dune @@ -1,14 +1,27 @@ (library - (name kappa_influence_map) - (libraries kappa_kasa_frontend kappa_kasa_remanent_state kappa_classical_graphs kappa-library.terms) - (flags (:standard) - -open Kappa_kasa_frontend - -open Kappa_kasa_remanent_state - -open Kappa_errors - -open Kappa_parameters - -open Kappa_logging - -open Kappa_classical_graphs - -open Kappa_kasa_kastor_toolset - -open Kappa_generic_toolset - -open Kappa_terms -)) + (name kappa_influence_map) + (libraries + kappa_kasa_frontend + kappa_kasa_remanent_state + kappa_classical_graphs + kappa-library.terms) + (flags + (:standard) + -open + Kappa_kasa_frontend + -open + Kappa_kasa_remanent_state + -open + Kappa_errors + -open + Kappa_parameters + -open + Kappa_logging + -open + Kappa_classical_graphs + -open + Kappa_kasa_kastor_toolset + -open + Kappa_generic_toolset + -open + Kappa_terms)) diff --git a/core/KaSa_rep/influence_map/influence_map.ml b/core/KaSa_rep/influence_map/influence_map.ml index e18be39363..dfecf0bf0e 100644 --- a/core/KaSa_rep/influence_map/influence_map.ml +++ b/core/KaSa_rep/influence_map/influence_map.ml @@ -14,475 +14,222 @@ let local_trace = false -let generic_add fold2_common agent_diag rule_diag parameters error _handler (n:int) a b c = - fold2_common - parameters - error +let generic_add fold2_common agent_diag rule_diag parameters error _handler + (n : int) a b c = + fold2_common parameters error (fun parameters error _ a b map -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters - error - (fun parameters error (rule:Ckappa_sig.c_rule_id) a map -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters - error - (fun parameters error (rule':Ckappa_sig.c_rule_id) a' map -> - let rule' = Ckappa_sig.add_rule_id rule' n in - if (not rule_diag && rule = rule') - then - (error,map) - else - let key = rule, rule' in - let old = - Ckappa_sig.PairRule_setmap.Map.find_default - Quark_type.Labels.empty_couple - key - map - in - let error,couple = - Quark_type.Labels.add_couple - parameters - error - (agent_diag || - not (rule = rule')) - a - a' - old - in - error,if Quark_type.Labels.is_empty_couple couple - then map - else - Ckappa_sig.PairRule_setmap.Map.add - key - couple - map) - b - map) - a - map) + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun parameters error (rule : Ckappa_sig.c_rule_id) a map -> + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun parameters error (rule' : Ckappa_sig.c_rule_id) a' map -> + let rule' = Ckappa_sig.add_rule_id rule' n in + if (not rule_diag) && rule = rule' then + error, map + else ( + let key = rule, rule' in + let old = + Ckappa_sig.PairRule_setmap.Map.find_default + Quark_type.Labels.empty_couple key map + in + let error, couple = + Quark_type.Labels.add_couple parameters error + (agent_diag || not (rule = rule')) + a a' old + in + ( error, + if Quark_type.Labels.is_empty_couple couple then + map + else + Ckappa_sig.PairRule_setmap.Map.add key couple map ) + )) + b map) + a map) a b c let generic_add_counter = generic_add let compute_influence_map parameters error handler quark_maps nrules = - let wake_up_map = - Ckappa_sig.PairRule_setmap.Map.empty - in - let inhibition_map = - Ckappa_sig.PairRule_setmap.Map.empty - in - let error,wake_up_map = + let wake_up_map = Ckappa_sig.PairRule_setmap.Map.empty in + let inhibition_map = Ckappa_sig.PairRule_setmap.Map.empty in + let error, wake_up_map = generic_add Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold2_common - true - true - parameters - error - handler - 0 - quark_maps.Quark_type.agent_modif_plus - quark_maps.Quark_type.agent_test + true true parameters error handler 0 + quark_maps.Quark_type.agent_modif_plus quark_maps.Quark_type.agent_test wake_up_map in - let error,wake_up_map = + let error, wake_up_map = generic_add Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold2_common - true - true - parameters - error - handler - nrules + true true parameters error handler nrules quark_maps.Quark_type.agent_modif_plus - quark_maps.Quark_type.agent_var_plus - wake_up_map + quark_maps.Quark_type.agent_var_plus wake_up_map in - let error,inhibition_map = + let error, inhibition_map = generic_add Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold2_common - true - true - parameters - error - handler - nrules + true true parameters error handler nrules quark_maps.Quark_type.agent_modif_plus - quark_maps.Quark_type.agent_var_minus - inhibition_map + quark_maps.Quark_type.agent_var_minus inhibition_map in - let error,wake_up_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - 0 - quark_maps.Quark_type.site_modif_plus - quark_maps.Quark_type.site_test - wake_up_map + let error, wake_up_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler 0 quark_maps.Quark_type.site_modif_plus + quark_maps.Quark_type.site_test wake_up_map in - let error,wake_up_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - 0 - quark_maps.Quark_type.site_modif_bound_plus - quark_maps.Quark_type.site_test_bound - wake_up_map + let error, wake_up_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler 0 quark_maps.Quark_type.site_modif_bound_plus + quark_maps.Quark_type.site_test_bound wake_up_map in - let error,wake_up_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_plus - quark_maps.Quark_type.site_var_plus - wake_up_map + let error, wake_up_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler nrules quark_maps.Quark_type.site_modif_plus + quark_maps.Quark_type.site_var_plus wake_up_map in - let error,wake_up_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_bound_plus - quark_maps.Quark_type.site_bound_var_plus - wake_up_map + let error, wake_up_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler nrules quark_maps.Quark_type.site_modif_bound_plus + quark_maps.Quark_type.site_bound_var_plus wake_up_map in - let error,inhibition_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_plus - quark_maps.Quark_type.site_var_minus - inhibition_map + let error, inhibition_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler nrules quark_maps.Quark_type.site_modif_plus + quark_maps.Quark_type.site_var_minus inhibition_map in - let error,inhibition_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_bound_plus - quark_maps.Quark_type.site_bound_var_minus - inhibition_map + let error, inhibition_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler nrules quark_maps.Quark_type.site_modif_bound_plus + quark_maps.Quark_type.site_bound_var_minus inhibition_map in - let error,inhibition_map = + let error, inhibition_map = generic_add Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.agent_modif_minus - quark_maps.Quark_type.agent_test + false true parameters error handler 0 + quark_maps.Quark_type.agent_modif_minus quark_maps.Quark_type.agent_test inhibition_map in - let error,inhibition_map = - generic_add - Quark_type.SiteMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.site_modif_minus - quark_maps.Quark_type.site_test - inhibition_map + let error, inhibition_map = + generic_add Quark_type.SiteMap.fold2_common false true parameters error + handler 0 quark_maps.Quark_type.site_modif_minus + quark_maps.Quark_type.site_test inhibition_map in - let error,inhibition_map = - generic_add - Quark_type.SiteMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.site_modif_bound_minus - quark_maps.Quark_type.site_test_bound - inhibition_map + let error, inhibition_map = + generic_add Quark_type.SiteMap.fold2_common false true parameters error + handler 0 quark_maps.Quark_type.site_modif_bound_minus + quark_maps.Quark_type.site_test_bound inhibition_map in - let error,inhibition_map = + let error, inhibition_map = generic_add Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold2_common - false - true - parameters - error - handler - nrules + false true parameters error handler nrules quark_maps.Quark_type.agent_modif_minus - quark_maps.Quark_type.agent_var_plus - inhibition_map + quark_maps.Quark_type.agent_var_plus inhibition_map in - let error,inhibition_map = - generic_add - Quark_type.SiteMap.fold2_common - false - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_bound_minus - quark_maps.Quark_type.site_bound_var_plus - inhibition_map + let error, inhibition_map = + generic_add Quark_type.SiteMap.fold2_common false true parameters error + handler nrules quark_maps.Quark_type.site_modif_bound_minus + quark_maps.Quark_type.site_bound_var_plus inhibition_map in - let error,inhibition_map = - generic_add - Quark_type.SiteMap.fold2_common - false - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_minus - quark_maps.Quark_type.site_var_plus - inhibition_map + let error, inhibition_map = + generic_add Quark_type.SiteMap.fold2_common false true parameters error + handler nrules quark_maps.Quark_type.site_modif_minus + quark_maps.Quark_type.site_var_plus inhibition_map in - let error,wake_up_map = + let error, wake_up_map = generic_add Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold2_common - true - true - parameters - error - handler - nrules + true true parameters error handler nrules quark_maps.Quark_type.agent_modif_minus - quark_maps.Quark_type.agent_var_minus - wake_up_map + quark_maps.Quark_type.agent_var_minus wake_up_map in - let error,wake_up_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_minus - quark_maps.Quark_type.site_var_minus - wake_up_map + let error, wake_up_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler nrules quark_maps.Quark_type.site_modif_minus + quark_maps.Quark_type.site_var_minus wake_up_map in - let error,wake_up_map = - generic_add - Quark_type.SiteMap.fold2_common - true - true - parameters - error - handler - nrules - quark_maps.Quark_type.site_modif_bound_minus - quark_maps.Quark_type.site_bound_var_minus - wake_up_map + let error, wake_up_map = + generic_add Quark_type.SiteMap.fold2_common true true parameters error + handler nrules quark_maps.Quark_type.site_modif_bound_minus + quark_maps.Quark_type.site_bound_var_minus wake_up_map in - let error,inhibition_map = + let error, inhibition_map = generic_add (Quark_type.StringMap.fold2_sparse_with_logs Exception.wrap) - false - true - parameters - error - handler - nrules - quark_maps.Quark_type.dead_agent - quark_maps.Quark_type.dead_agent_plus + false true parameters error handler nrules + quark_maps.Quark_type.dead_agent quark_maps.Quark_type.dead_agent_plus inhibition_map in - let error,inhibition_map = + let error, inhibition_map = generic_add (Quark_type.StringMap.fold2_sparse_with_logs Exception.wrap) - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.dead_agent_minus - quark_maps.Quark_type.dead_agent + false true parameters error handler 0 + quark_maps.Quark_type.dead_agent_minus quark_maps.Quark_type.dead_agent inhibition_map in - let error,wake_up_map = + let error, wake_up_map = generic_add (Quark_type.StringMap.fold2_sparse_with_logs Exception.wrap) - false - true - parameters - error - handler - nrules - quark_maps.Quark_type.dead_agent - quark_maps.Quark_type.dead_agent_minus + false true parameters error handler nrules + quark_maps.Quark_type.dead_agent quark_maps.Quark_type.dead_agent_minus wake_up_map in - let fold_site parameters error f = + let fold_site parameters error f = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold2_common - parameters - error - (fun parameters error _ a b -> - Cckappa_sig.KaSim_Site_map_and_set.Map.fold2_sparse - parameters error - f - a - b ) - in - let error,inhibition_map = - generic_add - fold_site - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.dead_sites_minus - quark_maps.Quark_type.dead_sites + parameters error (fun parameters error _ a b -> + Cckappa_sig.KaSim_Site_map_and_set.Map.fold2_sparse parameters error f a + b) + in + let error, inhibition_map = + generic_add fold_site false true parameters error handler 0 + quark_maps.Quark_type.dead_sites_minus quark_maps.Quark_type.dead_sites inhibition_map in - let error,inhibition_map = - generic_add - fold_site - false - true - parameters - error - handler - nrules - quark_maps.Quark_type.dead_sites - quark_maps.Quark_type.dead_sites_plus + let error, inhibition_map = + generic_add fold_site false true parameters error handler nrules + quark_maps.Quark_type.dead_sites quark_maps.Quark_type.dead_sites_plus inhibition_map in - let error,wake_up_map = - generic_add - fold_site - false - true - parameters - error - handler - nrules - quark_maps.Quark_type.dead_sites - quark_maps.Quark_type.dead_sites_minus + let error, wake_up_map = + generic_add fold_site false true parameters error handler nrules + quark_maps.Quark_type.dead_sites quark_maps.Quark_type.dead_sites_minus wake_up_map in - let error,inhibition_map = - generic_add - Quark_type.DeadSiteMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.dead_states_minus - quark_maps.Quark_type.dead_states - inhibition_map + let error, inhibition_map = + generic_add Quark_type.DeadSiteMap.fold2_common false true parameters error + handler 0 quark_maps.Quark_type.dead_states_minus + quark_maps.Quark_type.dead_states inhibition_map in - let error,inhibition_map = - generic_add - Quark_type.DeadSiteMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.dead_states - quark_maps.Quark_type.dead_states_plus - inhibition_map + let error, inhibition_map = + generic_add Quark_type.DeadSiteMap.fold2_common false true parameters error + handler 0 quark_maps.Quark_type.dead_states + quark_maps.Quark_type.dead_states_plus inhibition_map in - let error,wake_up_map = - generic_add - Quark_type.DeadSiteMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.dead_states - quark_maps.Quark_type.dead_states_minus - wake_up_map + let error, wake_up_map = + generic_add Quark_type.DeadSiteMap.fold2_common false true parameters error + handler 0 quark_maps.Quark_type.dead_states + quark_maps.Quark_type.dead_states_minus wake_up_map in let error, wake_up_map = - generic_add_counter - Quark_type.CounterMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.counter_delta_plus - quark_maps.Quark_type.counter_test_leq - wake_up_map + generic_add_counter Quark_type.CounterMap.fold2_common false true parameters + error handler 0 quark_maps.Quark_type.counter_delta_plus + quark_maps.Quark_type.counter_test_leq wake_up_map in let error, wake_up_map = - generic_add_counter - Quark_type.CounterMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.counter_delta_minus - quark_maps.Quark_type.counter_test_geq - wake_up_map + generic_add_counter Quark_type.CounterMap.fold2_common false true parameters + error handler 0 quark_maps.Quark_type.counter_delta_minus + quark_maps.Quark_type.counter_test_geq wake_up_map in let error, inhibition_map = - generic_add_counter - Quark_type.CounterMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.counter_delta_minus - quark_maps.Quark_type.counter_test_leq - inhibition_map + generic_add_counter Quark_type.CounterMap.fold2_common false true parameters + error handler 0 quark_maps.Quark_type.counter_delta_minus + quark_maps.Quark_type.counter_test_leq inhibition_map in let error, inhibition_map = - generic_add_counter - Quark_type.CounterMap.fold2_common - false - true - parameters - error - handler - 0 - quark_maps.Quark_type.counter_delta_plus - quark_maps.Quark_type.counter_test_geq - inhibition_map + generic_add_counter Quark_type.CounterMap.fold2_common false true parameters + error handler 0 quark_maps.Quark_type.counter_delta_plus + quark_maps.Quark_type.counter_test_geq inhibition_map in - error,wake_up_map,inhibition_map + error, wake_up_map, inhibition_map diff --git a/core/KaSa_rep/influence_map/local_influence_map.ml b/core/KaSa_rep/influence_map/local_influence_map.ml index 40d0ab3dfe..0bb4e2cd2c 100644 --- a/core/KaSa_rep/influence_map/local_influence_map.ml +++ b/core/KaSa_rep/influence_map/local_influence_map.ml @@ -1,77 +1,59 @@ -type 'a cleanable_array = - { - array:'a array; - default:'a; - list:int list; - } +type 'a cleanable_array = { array: 'a array; default: 'a; list: int list } let set parameters error ~pos i im array = try - (let old = array.array.(i) in - let () = array.array.(i)<-im in - match old=array.default,im=array.default with - | true, false -> error, {array with list = i::array.list} - | _ -> error, array) - with - | err -> - Exception.warn - parameters error pos err array + let old = array.array.(i) in + let () = array.array.(i) <- im in + match old = array.default, im = array.default with + | true, false -> error, { array with list = i :: array.list } + | _ -> error, array + with err -> Exception.warn parameters error pos err array let get parameters error ~pos i array = - try - error, array.array.(i) - with - err -> - Exception.warn - parameters error pos err array.default + try error, array.array.(i) + with err -> Exception.warn parameters error pos err array.default let clean array = - List.iter (fun i -> array.array.(i)<-array.default) array.list + List.iter (fun i -> array.array.(i) <- array.default) array.list let origin = - { - Remanent_state.fwd=0; - Remanent_state.bwd=0; - Remanent_state.total=0; - } + { Remanent_state.fwd = 0; Remanent_state.bwd = 0; Remanent_state.total = 0 } let init_blackboard nrules nvars = let n = nrules + nvars in { - Remanent_state.blackboard_distance = Array.make n None; - Remanent_state.blackboard_is_done = Array.make n false; - Remanent_state.blackboard_to_be_explored = Array.make n false + Remanent_state.blackboard_distance = Array.make n None; + Remanent_state.blackboard_is_done = Array.make n false; + Remanent_state.blackboard_to_be_explored = Array.make n false; } -type remanent_state = - { - waiting_list: int list ; - next_round: int list ; - distance: Remanent_state.distance option cleanable_array ; - is_done: bool cleanable_array ; - to_be_explored: bool array ; - influence_map: Remanent_state.internal_influence_map - } +type remanent_state = { + waiting_list: int list; + next_round: int list; + distance: Remanent_state.distance option cleanable_array; + is_done: bool cleanable_array; + to_be_explored: bool array; + influence_map: Remanent_state.internal_influence_map; +} let is_empty remanent_state = - remanent_state.waiting_list=[] && remanent_state.next_round=[] + remanent_state.waiting_list = [] && remanent_state.next_round = [] let rec pop ~pos parameters error remanent_state = match remanent_state.waiting_list with - | head::tail -> - error,(head,{remanent_state with waiting_list = tail}) + | head :: tail -> error, (head, { remanent_state with waiting_list = tail }) | [] -> - begin - match remanent_state.next_round with - | [] -> - Exception.warn parameters error pos - (Invalid_argument "empty waiting list") (0,remanent_state) - | _ -> - pop ~pos parameters error - {remanent_state with waiting_list = remanent_state.next_round ; - next_round = []} - end - + (match remanent_state.next_round with + | [] -> + Exception.warn parameters error pos + (Invalid_argument "empty waiting list") (0, remanent_state) + | _ -> + pop ~pos parameters error + { + remanent_state with + waiting_list = remanent_state.next_round; + next_round = []; + }) let clean_remanent_state remanent_state = let () = clean remanent_state.distance in @@ -79,13 +61,18 @@ let clean_remanent_state remanent_state = () let go_fwd distance = - {distance with - Remanent_state.fwd = succ distance.Remanent_state.fwd ; - Remanent_state.total = succ distance.Remanent_state.total} + { + distance with + Remanent_state.fwd = succ distance.Remanent_state.fwd; + Remanent_state.total = succ distance.Remanent_state.total; + } + let go_bwd distance = - {distance with - Remanent_state.bwd = succ distance.Remanent_state.bwd ; - Remanent_state.total = succ distance.Remanent_state.total} + { + distance with + Remanent_state.bwd = succ distance.Remanent_state.bwd; + Remanent_state.total = succ distance.Remanent_state.total; + } let leq int int_ref_opt = match int_ref_opt with @@ -93,8 +80,7 @@ let leq int int_ref_opt = | Some int_ref -> compare int int_ref <= 0 let has_improved ~new_distance ~old_distance_opt = - match old_distance_opt - with + match old_distance_opt with | None -> true | Some old_distance -> new_distance.Remanent_state.fwd < old_distance.Remanent_state.fwd @@ -111,128 +97,111 @@ let best_distance new_distance old_distance_opt = Remanent_state.bwd = min new_distance.Remanent_state.bwd old_distance.Remanent_state.bwd; total = - min new_distance.Remanent_state.total old_distance.Remanent_state.total + min new_distance.Remanent_state.total old_distance.Remanent_state.total; } - let add_node source remanent_state = let nodes, pos, neg = remanent_state.influence_map in - let nodes = (Ckappa_sig.rule_id_of_int source)::nodes in + let nodes = Ckappa_sig.rule_id_of_int source :: nodes in let influence_map = nodes, pos, neg in - {remanent_state with influence_map} - + { remanent_state with influence_map } let add_influence source target label influence_map = Ckappa_sig.PairRule_setmap.Map.add - (Ckappa_sig.rule_id_of_int source, - Ckappa_sig.rule_id_of_int target) - label - influence_map + (Ckappa_sig.rule_id_of_int source, Ckappa_sig.rule_id_of_int target) + label influence_map let add_positive_influence source target label remanent_state = - let nodes,pos,neg = remanent_state.influence_map in + let nodes, pos, neg = remanent_state.influence_map in let pos = add_influence source target label pos in - let influence_map = nodes,pos,neg in - {remanent_state with influence_map} + let influence_map = nodes, pos, neg in + { remanent_state with influence_map } let add_negative_influence source target label remanent_state = - let nodes,pos,neg = remanent_state.influence_map in + let nodes, pos, neg = remanent_state.influence_map in let neg = add_influence source target label neg in - let influence_map = nodes,pos,neg in - {remanent_state with influence_map} + let influence_map = nodes, pos, neg in + { remanent_state with influence_map } let add_rev f source target label remanent_state = f target source label remanent_state -let explore_one_map - good_distance add_influence - parameters error remanent_state source is_done new_distance list - = +let explore_one_map good_distance add_influence parameters error remanent_state + source is_done new_distance list = List.fold_left - (fun (error, remanent_state) (target,label) -> - let target = Ckappa_sig.int_of_rule_id target in - let error, target_done = - get parameters error ~pos:__POS__ target remanent_state.is_done - in - let remanent_state = - match - is_done, target_done || target=source - with - | false,true -> - add_influence - source target label remanent_state - | _ -> remanent_state - in - if good_distance new_distance then - let error,old_distance_opt = - get parameters error ~pos:__POS__ target remanent_state.distance - in - let new_distance = best_distance new_distance old_distance_opt in - if good_distance new_distance && - has_improved ~new_distance ~old_distance_opt - then - let error, distance = - set - parameters error ~pos:__POS__ - target (Some new_distance) remanent_state.distance - in - let to_be_explored = remanent_state.to_be_explored in - let next_round = remanent_state.next_round in - let next_round,to_be_explored = - if to_be_explored.(target) - then - next_round, to_be_explored - else - let () = to_be_explored.(target)<-true in - target::next_round, to_be_explored - in - error, {remanent_state with - distance = distance ; - next_round = next_round ; - to_be_explored = to_be_explored } - else error, remanent_state - else - error, remanent_state) - (error, remanent_state) - list - - + (fun (error, remanent_state) (target, label) -> + let target = Ckappa_sig.int_of_rule_id target in + let error, target_done = + get parameters error ~pos:__POS__ target remanent_state.is_done + in + let remanent_state = + match is_done, target_done || target = source with + | false, true -> add_influence source target label remanent_state + | _ -> remanent_state + in + if good_distance new_distance then ( + let error, old_distance_opt = + get parameters error ~pos:__POS__ target remanent_state.distance + in + let new_distance = best_distance new_distance old_distance_opt in + if + good_distance new_distance + && has_improved ~new_distance ~old_distance_opt + then ( + let error, distance = + set parameters error ~pos:__POS__ target (Some new_distance) + remanent_state.distance + in + let to_be_explored = remanent_state.to_be_explored in + let next_round = remanent_state.next_round in + let next_round, to_be_explored = + if to_be_explored.(target) then + next_round, to_be_explored + else ( + let () = to_be_explored.(target) <- true in + target :: next_round, to_be_explored + ) + in + error, { remanent_state with distance; next_round; to_be_explored } + ) else + error, remanent_state + ) else + error, remanent_state) + (error, remanent_state) list -let visit parameters error - node distance remanent_state good_distance bidirectional_influence_map - = - let (error,is_done),pos_fwd,pos_bwd,neg_fwd,neg_bwd = - get parameters error ~pos:__POS__ node remanent_state.is_done, - bidirectional_influence_map.Remanent_state.positive_influence_fwd.(node), - bidirectional_influence_map.Remanent_state.positive_influence_bwd.(node), - bidirectional_influence_map.Remanent_state.negative_influence_fwd.(node), - bidirectional_influence_map.Remanent_state.negative_influence_bwd.(node) +let visit parameters error node distance remanent_state good_distance + bidirectional_influence_map = + let (error, is_done), pos_fwd, pos_bwd, neg_fwd, neg_bwd = + ( get parameters error ~pos:__POS__ node remanent_state.is_done, + bidirectional_influence_map.Remanent_state.positive_influence_fwd.(node), + bidirectional_influence_map.Remanent_state.positive_influence_bwd.(node), + bidirectional_influence_map.Remanent_state.negative_influence_fwd.(node), + bidirectional_influence_map.Remanent_state.negative_influence_bwd.(node) ) in let distance_next = go_fwd distance in let distance_prev = go_bwd distance in let remanent_state = - if is_done then remanent_state + if is_done then + remanent_state else add_node node remanent_state in let error, remanent_state = - explore_one_map - good_distance add_positive_influence - parameters error remanent_state node is_done distance_next pos_fwd + explore_one_map good_distance add_positive_influence parameters error + remanent_state node is_done distance_next pos_fwd in let error, remanent_state = - explore_one_map - good_distance add_negative_influence - parameters error remanent_state node is_done distance_next neg_fwd + explore_one_map good_distance add_negative_influence parameters error + remanent_state node is_done distance_next neg_fwd in let error, remanent_state = - explore_one_map - good_distance (add_rev add_positive_influence) + explore_one_map good_distance + (add_rev add_positive_influence) parameters error remanent_state node is_done distance_prev pos_bwd in let error, remanent_state = - explore_one_map - good_distance (add_rev add_negative_influence) + explore_one_map good_distance + (add_rev add_negative_influence) parameters error remanent_state node is_done distance_next neg_bwd in let error, is_done = @@ -240,57 +209,62 @@ let visit parameters error in let error, to_be_explored = try - let () = remanent_state.to_be_explored.(node)<-false in + let () = remanent_state.to_be_explored.(node) <- false in error, remanent_state.to_be_explored - with - _ -> + with _ -> Exception.warn parameters error __POS__ Exit remanent_state.to_be_explored in - error, - {remanent_state with is_done = is_done ; to_be_explored = to_be_explored} + error, { remanent_state with is_done; to_be_explored } -let explore_influence_map - ?fwd ?bwd ~total - parameters error blackboard initial_node bidirectional_influence_map = +let explore_influence_map ?fwd ?bwd ~total parameters error blackboard + initial_node bidirectional_influence_map = let initial_node = Ckappa_sig.int_of_rule_id initial_node in let n = Array.length blackboard.Remanent_state.blackboard_is_done in let influence_map = - [], - Ckappa_sig.PairRule_setmap.Map.empty, - Ckappa_sig.PairRule_setmap.Map.empty + ( [], + Ckappa_sig.PairRule_setmap.Map.empty, + Ckappa_sig.PairRule_setmap.Map.empty ) in - if initial_node < n - then + if initial_node < n then ( let good_distance d = leq d.Remanent_state.fwd fwd && leq d.Remanent_state.bwd bwd && leq d.Remanent_state.total (Some total) in let distance = - {array=blackboard.Remanent_state.blackboard_distance;list=[];default=None} + { + array = blackboard.Remanent_state.blackboard_distance; + list = []; + default = None; + } in let is_done = - {array=blackboard.Remanent_state.blackboard_is_done;list=[];default=false} + { + array = blackboard.Remanent_state.blackboard_is_done; + list = []; + default = false; + } in let error, distance = set parameters error ~pos:__POS__ initial_node (Some origin) distance in let next_round = [] in - let waiting_list = [initial_node] in + let waiting_list = [ initial_node ] in let remanent_state = { - distance=distance; - is_done=is_done; - next_round=next_round ; - to_be_explored=blackboard.Remanent_state.blackboard_to_be_explored; - waiting_list=waiting_list; - influence_map=influence_map + distance; + is_done; + next_round; + to_be_explored = blackboard.Remanent_state.blackboard_to_be_explored; + waiting_list; + influence_map; } in let rec aux parameters error remanent_state = - if is_empty remanent_state then error, remanent_state - else - let error, (node,remanent_state) = + if is_empty remanent_state then + error, remanent_state + else ( + let error, (node, remanent_state) = pop parameters error ~pos:__POS__ remanent_state in let error, distance_opt = @@ -298,26 +272,24 @@ let explore_influence_map in let error, distance = match distance_opt with - | None -> - Exception.warn - parameters error __POS__ - Exit origin + | None -> Exception.warn parameters error __POS__ Exit origin | Some distance -> error, distance in let error, remanent_state = - visit parameters error - node distance remanent_state - good_distance bidirectional_influence_map + visit parameters error node distance remanent_state good_distance + bidirectional_influence_map in aux parameters error remanent_state + ) in let error, remanent_state = aux parameters error remanent_state in let () = clean_remanent_state remanent_state in - error,remanent_state.influence_map, - { - Remanent_state.blackboard_distance = remanent_state.distance.array ; - Remanent_state.blackboard_is_done = remanent_state.is_done.array ; - Remanent_state.blackboard_to_be_explored = remanent_state.to_be_explored - } - else + ( error, + remanent_state.influence_map, + { + Remanent_state.blackboard_distance = remanent_state.distance.array; + Remanent_state.blackboard_is_done = remanent_state.is_done.array; + Remanent_state.blackboard_to_be_explored = remanent_state.to_be_explored; + } ) + ) else error, influence_map, blackboard diff --git a/core/KaSa_rep/influence_map/local_influence_map.mli b/core/KaSa_rep/influence_map/local_influence_map.mli index 46e4e5b0d7..54b9be2cc1 100644 --- a/core/KaSa_rep/influence_map/local_influence_map.mli +++ b/core/KaSa_rep/influence_map/local_influence_map.mli @@ -1,11 +1,15 @@ -val init_blackboard: int -> int -> Remanent_state.local_influence_map_blackboard +val init_blackboard : + int -> int -> Remanent_state.local_influence_map_blackboard -val explore_influence_map: - ?fwd:int -> ?bwd:int-> total:int -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> +val explore_influence_map : + ?fwd:int -> + ?bwd:int -> + total:int -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> Remanent_state.local_influence_map_blackboard -> Ckappa_sig.c_rule_id -> Remanent_state.bidirectional_influence_map -> - Exception.method_handler * - Remanent_state.internal_influence_map * - Remanent_state.local_influence_map_blackboard + Exception.method_handler + * Remanent_state.internal_influence_map + * Remanent_state.local_influence_map_blackboard diff --git a/core/KaSa_rep/influence_map/print_quarks.ml b/core/KaSa_rep/influence_map/print_quarks.ml index 55797d736a..af736f0a3b 100644 --- a/core/KaSa_rep/influence_map/print_quarks.ml +++ b/core/KaSa_rep/influence_map/print_quarks.ml @@ -20,32 +20,31 @@ let string_of_int_option_min parameters _error a = | Some a -> string_of_int a | None -> Remanent_parameters.get_minus_infinity_symbol parameters -let string_of_int_option_max parameters _error a = +let string_of_int_option_max parameters _error a = match a with | Some a -> string_of_int a | None -> Remanent_parameters.get_plus_infinity_symbol parameters let string_of_port parameters error port = - "["^(string_of_int_option_min parameters error port.Cckappa_sig.site_state.Cckappa_sig.min)^";"^ - (string_of_int_option_max parameters error port.Cckappa_sig.site_state.Cckappa_sig.max)^"]" + "[" + ^ string_of_int_option_min parameters error + port.Cckappa_sig.site_state.Cckappa_sig.min + ^ ";" + ^ string_of_int_option_max parameters error + port.Cckappa_sig.site_state.Cckappa_sig.max + ^ "]" -let string_of_rule_var - parameters error handler compilation - print_rule_dot print_var_dot - get_label_of_rule_dot get_label_of_var_dot - k - = +let string_of_rule_var parameters error handler compilation print_rule_dot + print_var_dot get_label_of_rule_dot get_label_of_var_dot k = let s = Buffer.create 0 in let fmt = Format.formatter_of_buffer s in - let parameters = Remanent_parameters.set_logger parameters - (Loggers.open_logger_from_formatter (fmt)) in - let error, bool, () = - Handler.print_rule_or_var - parameters error handler compilation - print_rule_dot print_var_dot - get_label_of_rule_dot - get_label_of_var_dot - k + let parameters = + Remanent_parameters.set_logger parameters + (Loggers.open_logger_from_formatter fmt) + in + let error, bool, () = + Handler.print_rule_or_var parameters error handler compilation + print_rule_dot print_var_dot get_label_of_rule_dot get_label_of_var_dot k in let _ = Format.pp_print_flush fmt () in let s = Buffer.contents s in @@ -53,243 +52,346 @@ let string_of_rule_var let print_agent_map parameters error handler map = let error = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter parameters error (fun parameters error key im -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error key' im' -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sagent_type:%s,rule:%s->" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_name key) - (Ckappa_sig.string_of_rule_id key') - in - let _ = Quark_type.Labels.dump parameters error handler im' in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - im) + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error key' im' -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sagent_type:%s,rule:%s->" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_agent_name key) + (Ckappa_sig.string_of_rule_id key') + in + let _ = Quark_type.Labels.dump parameters error handler im' in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) + im) map - in error + in + error let print_agent_var_map parameters error handler map = let error = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter parameters error (fun parameters error key im -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error key' im' -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sagent_type:%s,var:%s->" - (Remanent_parameters.get_prefix parameters) - (Ckappa_sig.string_of_agent_name key) - (Ckappa_sig.string_of_rule_id key') - in - let _ = Quark_type.Labels.dump parameters error handler im' in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - im) + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error key' im' -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sagent_type:%s,var:%s->" + (Remanent_parameters.get_prefix parameters) + (Ckappa_sig.string_of_agent_name key) + (Ckappa_sig.string_of_rule_id key') + in + let _ = Quark_type.Labels.dump parameters error handler im' in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) + im) map - in error + in + error let print_string_map parameters error handler map = let error = Quark_type.StringMap.fold (fun key im error -> - let error = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error key' im' -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sagent_type:%s,rule_id:%s->" - (Remanent_parameters.get_prefix parameters) - key - (Ckappa_sig.string_of_rule_id key') - in - let _ = Quark_type.Labels.dump parameters error handler im' in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - im in - error ) - map - error - in error + let error = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error key' im' -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sagent_type:%s,rule_id:%s->" + (Remanent_parameters.get_prefix parameters) + key + (Ckappa_sig.string_of_rule_id key') + in + let _ = Quark_type.Labels.dump parameters error handler im' in + let _ = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + im + in + error) + map error + in + error let print_var_string_map parameters error handler map = let error = Quark_type.StringMap.fold (fun key im error -> - let error = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error key' im' -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sagent_type:%s,var_id:%s->" - (Remanent_parameters.get_prefix parameters) - key - (Ckappa_sig.string_of_rule_id key') - in - let _ = Quark_type.Labels.dump parameters error handler im' in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - im in - error) - map - error - in error + let error = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error key' im' -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sagent_type:%s,var_id:%s->" + (Remanent_parameters.get_prefix parameters) + key + (Ckappa_sig.string_of_rule_id key') + in + let _ = Quark_type.Labels.dump parameters error handler im' in + let _ = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error) + im + in + error) + map error + in + error let print_agents parameters error handler quark = - let parameters_var = Remanent_parameters.update_prefix parameters "agent_var++**:" in - let error = print_agent_var_map parameters_var error handler quark.Quark_type.agent_var_plus in - let parameters_var = Remanent_parameters.update_prefix parameters "agent_var--**:" in - let error = print_agent_var_map parameters_var error handler quark.Quark_type.agent_var_minus in - let parameters_plus = Remanent_parameters.update_prefix parameters "agent_test**:" in - let error = print_agent_map parameters_plus error handler quark.Quark_type.agent_test in - let parameters_plus = Remanent_parameters.update_prefix parameters "agent_modif+:" in - let error = print_agent_map parameters_plus error handler quark.Quark_type.agent_modif_plus in - let parameters_minus = Remanent_parameters.update_prefix parameters "agent_modif-:" in - let error = print_agent_map parameters_minus error handler quark.Quark_type.agent_modif_minus in + let parameters_var = + Remanent_parameters.update_prefix parameters "agent_var++**:" + in + let error = + print_agent_var_map parameters_var error handler + quark.Quark_type.agent_var_plus + in + let parameters_var = + Remanent_parameters.update_prefix parameters "agent_var--**:" + in + let error = + print_agent_var_map parameters_var error handler + quark.Quark_type.agent_var_minus + in + let parameters_plus = + Remanent_parameters.update_prefix parameters "agent_test**:" + in + let error = + print_agent_map parameters_plus error handler quark.Quark_type.agent_test + in + let parameters_plus = + Remanent_parameters.update_prefix parameters "agent_modif+:" + in + let error = + print_agent_map parameters_plus error handler + quark.Quark_type.agent_modif_plus + in + let parameters_minus = + Remanent_parameters.update_prefix parameters "agent_modif-:" + in + let error = + print_agent_map parameters_minus error handler + quark.Quark_type.agent_modif_minus + in error let print_site_map parameter error handler map = - Quark_type.SiteMap.iter - parameter - error - (fun parameters error (agent_type,(site_type,state)) im -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error rule im' -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%sagent_type:%s,site_type:%s,state:%s,rule:%s->" - (Remanent_parameters.get_prefix parameter) - (Ckappa_sig.string_of_agent_name agent_type) - (Ckappa_sig.string_of_site_name site_type) - (Ckappa_sig.string_of_state_index state) - (Ckappa_sig.string_of_rule_id rule) - in - let _ = Quark_type.Labels.dump parameter error handler im' in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - im - ) map + Quark_type.SiteMap.iter parameter error + (fun parameters error (agent_type, (site_type, state)) im -> + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error rule im' -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%sagent_type:%s,site_type:%s,state:%s,rule:%s->" + (Remanent_parameters.get_prefix parameter) + (Ckappa_sig.string_of_agent_name agent_type) + (Ckappa_sig.string_of_site_name site_type) + (Ckappa_sig.string_of_state_index state) + (Ckappa_sig.string_of_rule_id rule) + in + let _ = Quark_type.Labels.dump parameter error handler im' in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) + im) + map let print_site_var_map parameter error handler map = - Quark_type.SiteMap.iter - parameter - error - (fun parameters error (agent_type,(site_type,state)) im -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters - error - (fun parameters error rule im' -> - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameter) - "%sagent_type:%s,site_type:%s,state:%s,var:%s->" - (Remanent_parameters.get_prefix parameter) - (Ckappa_sig.string_of_agent_name agent_type) - (Ckappa_sig.string_of_site_name site_type) - (Ckappa_sig.string_of_state_index state) - (Ckappa_sig.string_of_rule_id rule) - in - let _ = Quark_type.Labels.dump parameter error handler im' in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) - im - ) map + Quark_type.SiteMap.iter parameter error + (fun parameters error (agent_type, (site_type, state)) im -> + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.iter parameters + error + (fun parameters error rule im' -> + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameter) + "%sagent_type:%s,site_type:%s,state:%s,var:%s->" + (Remanent_parameters.get_prefix parameter) + (Ckappa_sig.string_of_agent_name agent_type) + (Ckappa_sig.string_of_site_name site_type) + (Ckappa_sig.string_of_state_index state) + (Ckappa_sig.string_of_rule_id rule) + in + let _ = Quark_type.Labels.dump parameter error handler im' in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) + im) + map let print_sites parameter error handler quark = - let parameter_var = Remanent_parameters.update_prefix parameter "site_vars++**:" in - let error = print_site_var_map parameter_var error handler quark.Quark_type.site_var_plus in - let parameter_var = Remanent_parameters.update_prefix parameter "site_vars--**:" in - let error = print_site_var_map parameter_var error handler quark.Quark_type.site_var_minus in - let parameter_plus = Remanent_parameters.update_prefix parameter "site_test**:" in - let error = print_site_map parameter_plus error handler quark.Quark_type.site_test in - let parameter_plus = Remanent_parameters.update_prefix parameter "site_modif+:" in - let error = print_site_map parameter_plus error handler quark.Quark_type.site_modif_plus in - let parameter_minus = Remanent_parameters.update_prefix parameter "site_modif-:" in - let error = print_site_map parameter_minus error handler quark.Quark_type.site_modif_minus in + let parameter_var = + Remanent_parameters.update_prefix parameter "site_vars++**:" + in + let error = + print_site_var_map parameter_var error handler + quark.Quark_type.site_var_plus + in + let parameter_var = + Remanent_parameters.update_prefix parameter "site_vars--**:" + in + let error = + print_site_var_map parameter_var error handler + quark.Quark_type.site_var_minus + in + let parameter_plus = + Remanent_parameters.update_prefix parameter "site_test**:" + in + let error = + print_site_map parameter_plus error handler quark.Quark_type.site_test + in + let parameter_plus = + Remanent_parameters.update_prefix parameter "site_modif+:" + in + let error = + print_site_map parameter_plus error handler quark.Quark_type.site_modif_plus + in + let parameter_minus = + Remanent_parameters.update_prefix parameter "site_modif-:" + in + let error = + print_site_map parameter_minus error handler + quark.Quark_type.site_modif_minus + in error let print_dead_agents parameter error handler quark = - let parameter_var = Remanent_parameters.update_prefix parameter "dead_agent**:" in - let error = print_string_map parameter_var error handler quark.Quark_type.dead_agent in - let parameter_var = Remanent_parameters.update_prefix parameter "dead_agent++**:" in - let error = print_var_string_map parameter_var error handler quark.Quark_type.dead_agent_plus in - let parameter_plus = Remanent_parameters.update_prefix parameter "dead_agent--**:" in - let error = print_var_string_map parameter_plus error handler quark.Quark_type.dead_agent_minus in + let parameter_var = + Remanent_parameters.update_prefix parameter "dead_agent**:" + in + let error = + print_string_map parameter_var error handler quark.Quark_type.dead_agent + in + let parameter_var = + Remanent_parameters.update_prefix parameter "dead_agent++**:" + in + let error = + print_var_string_map parameter_var error handler + quark.Quark_type.dead_agent_plus + in + let parameter_plus = + Remanent_parameters.update_prefix parameter "dead_agent--**:" + in + let error = + print_var_string_map parameter_plus error handler + quark.Quark_type.dead_agent_minus + in error -let print_quarks parameters error handler quark = +let print_quarks parameters error handler quark = let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "REMARKS: The notation [i] is a position of an agent in a rule/var. If a position is a negative number [-i], then it refers an agent that is connected to the agent at position (i-1) that is modified by side effects." in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "REMARKS: The notation [i] is a position of an agent in a rule/var. If a \ + position is a negative number [-i], then it refers an agent that is \ + connected to the agent at position (i-1) that is modified by side \ + effects." + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let error = print_agents parameters error handler quark in - let error = print_sites parameters error handler quark in + let error = print_agents parameters error handler quark in + let error = print_sites parameters error handler quark in let error = print_dead_agents parameters error handler quark in error -let print_maps ?directives:(directives=[]) parameters logger error handler - compilation print_rule print_var get_label_of_rule get_label_of_var - print_labels prefix _suffix map = - let error = +let print_maps ?(directives = []) parameters logger error handler compilation + print_rule print_var get_label_of_rule get_label_of_var print_labels prefix + _suffix map = + let error = Ckappa_sig.PairRule_setmap.Map.fold - (fun (a,b) couple error -> - let error, _bool, s1 = - string_of_rule_var parameters error handler compilation - print_rule print_var get_label_of_rule get_label_of_var a - in - let error, _bool, s2 = - string_of_rule_var parameters error handler compilation - print_rule print_var get_label_of_rule get_label_of_var b - in - let error, s3 = - let s = Buffer.create 0 in - let fmt = Format.formatter_of_buffer s in - let parameters = Remanent_parameters.set_logger parameters - (Loggers.open_logger_from_formatter fmt) in - let error = - print_labels parameters error handler couple - in - let () = Format.pp_print_flush fmt () in - let s = Buffer.contents s in - error, s - in - let directives = (Graph_loggers_sig.Label s3)::directives in - let () = Graph_loggers.print_edge logger ~directives ~prefix s1 s2 in - error - ) - map - error - in error + (fun (a, b) couple error -> + let error, _bool, s1 = + string_of_rule_var parameters error handler compilation print_rule + print_var get_label_of_rule get_label_of_var a + in + let error, _bool, s2 = + string_of_rule_var parameters error handler compilation print_rule + print_var get_label_of_rule get_label_of_var b + in + let error, s3 = + let s = Buffer.create 0 in + let fmt = Format.formatter_of_buffer s in + let parameters = + Remanent_parameters.set_logger parameters + (Loggers.open_logger_from_formatter fmt) + in + let error = print_labels parameters error handler couple in + let () = Format.pp_print_flush fmt () in + let s = Buffer.contents s in + error, s + in + let directives = Graph_loggers_sig.Label s3 :: directives in + let () = Graph_loggers.print_edge logger ~directives ~prefix s1 s2 in + error) + map error + in + error -let print_wake_up_map parameters error handler compilation print_rule print_var print_label_rule print_label_var print_labels suffix map = - let parameters = Remanent_parameters.update_prefix parameters "Wake_up_map:" in - let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "Influence_map: The notation [i -> j] means an agent at position [i] of the first rule/var has an influence to an agent at position [j] of the second rule/var." in +let print_wake_up_map parameters error handler compilation print_rule print_var + print_label_rule print_label_var print_labels suffix map = + let parameters = + Remanent_parameters.update_prefix parameters "Wake_up_map:" + in + let _ = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "Influence_map: The notation [i -> j] means an agent at position [i] of \ + the first rule/var has an influence to an agent at position [j] of the \ + second rule/var." + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in print_maps parameters (Graph_loggers_sig.extend_logger (Remanent_parameters.get_logger parameters)) - error handler compilation print_rule print_var print_label_rule print_label_var print_labels (Remanent_parameters.get_prefix parameters) suffix map + error handler compilation print_rule print_var print_label_rule + print_label_var print_labels + (Remanent_parameters.get_prefix parameters) + suffix map -let print_inhibition_map parameters error handler compilation print_rule print_var print_label_rule print_label_var print_labels suffix map = - let parameters = Remanent_parameters.update_prefix parameters "Inhibition_map:" in +let print_inhibition_map parameters error handler compilation print_rule + print_var print_label_rule print_label_var print_labels suffix map = + let parameters = + Remanent_parameters.update_prefix parameters "Inhibition_map:" + in print_maps parameters - (Graph_loggers_sig.extend_logger - (Remanent_parameters.get_logger parameters)) - error handler compilation print_rule print_var print_label_rule print_label_var print_labels (Remanent_parameters.get_prefix parameters) suffix map + (Graph_loggers_sig.extend_logger + (Remanent_parameters.get_logger parameters)) + error handler compilation print_rule print_var print_label_rule + print_label_var print_labels + (Remanent_parameters.get_prefix parameters) + suffix map -let dot_of_influence_map ?logger parameters error handler compilation (nodes,wake_up_map,inhibition_map) = +let dot_of_influence_map ?logger parameters error handler compilation + (nodes, wake_up_map, inhibition_map) = let loggers = logger in let parameters_dot = - match loggers - with + match loggers with | None -> Remanent_parameters.open_influence_map_file parameters | Some loggers -> Remanent_parameters.set_logger parameters loggers in @@ -298,119 +400,121 @@ let dot_of_influence_map ?logger parameters error handler compilation (nodes,wak (Remanent_parameters.get_logger parameters_dot) in let () = - Graph_loggers.print_graph_preamble - logger - ~header:((Headers.head parameters_dot)@(Headers.head_influence_map_in_dot)) + Graph_loggers.print_graph_preamble logger + ~header:(Headers.head parameters_dot @ Headers.head_influence_map_in_dot) "Influence_map" in let nrules = Handler.nrules parameters error handler in let error = List.fold_left (fun error k -> - if (Ckappa_sig.int_of_rule_id k) < nrules then - let error, bool, s = - string_of_rule_var parameters error handler compilation - Handler.print_rule_dot - Handler.print_var_dot - Handler.get_label_of_rule_dot - Handler.get_label_of_var_dot - k - in - let _ = - if bool - then - let _ = - Graph_loggers.print_node logger - s - ~directives: - [ - Graph_loggers_sig.Shape + if Ckappa_sig.int_of_rule_id k < nrules then ( + let error, bool, s = + string_of_rule_var parameters error handler compilation + Handler.print_rule_dot Handler.print_var_dot + Handler.get_label_of_rule_dot Handler.get_label_of_var_dot k + in + let _ = + if bool then ( + let _ = + Graph_loggers.print_node logger s + ~directives: + [ + Graph_loggers_sig.Shape (Remanent_parameters.get_rule_shape parameters_dot); - Graph_loggers_sig.FillColor (Remanent_parameters.get_rule_color parameters_dot) - ] - in - () - in - error - else + Graph_loggers_sig.FillColor + (Remanent_parameters.get_rule_color parameters_dot); + ] + in + () + ) + in + error + ) else ( let error, bool, s = string_of_rule_var parameters error handler compilation - Handler.print_rule_dot - Handler.print_var_dot - Handler.get_label_of_rule_dot - Handler.get_label_of_var_dot - k + Handler.print_rule_dot Handler.print_var_dot + Handler.get_label_of_rule_dot Handler.get_label_of_var_dot k in let () = - if Ckappa_sig.int_of_rule_id k = nrules - then + if Ckappa_sig.int_of_rule_id k = nrules then Loggers.print_newline (Graph_loggers_sig.lift logger) in let () = - if bool then + if bool then ( let _ = - Graph_loggers.print_node logger - s + Graph_loggers.print_node logger s ~directives: [ - Graph_loggers_sig.Shape (Remanent_parameters.get_variable_shape parameters_dot); - Graph_loggers_sig.FillColor (Remanent_parameters.get_variable_color parameters_dot) + Graph_loggers_sig.Shape + (Remanent_parameters.get_variable_shape parameters_dot); + Graph_loggers_sig.FillColor + (Remanent_parameters.get_variable_color parameters_dot); ] in () - in error - ) error nodes + ) + in + error + )) + error nodes in let error = - if - Ckappa_sig.PairRule_setmap.Map.is_empty - wake_up_map - then error - else + if Ckappa_sig.PairRule_setmap.Map.is_empty wake_up_map then + error + else ( let error = print_maps - ~directives:[Graph_loggers_sig.Color (Remanent_parameters.get_wake_up_color parameters_dot); - Graph_loggers_sig.ArrowHead (Remanent_parameters.get_wake_up_arrow parameters_dot); - ] - parameters_dot logger error handler compilation - Handler.print_rule_dot Handler.print_var_dot - Handler.get_label_of_rule_dot Handler.get_label_of_var_dot - Handler.print_labels - "" " ;" - wake_up_map + ~directives: + [ + Graph_loggers_sig.Color + (Remanent_parameters.get_wake_up_color parameters_dot); + Graph_loggers_sig.ArrowHead + (Remanent_parameters.get_wake_up_arrow parameters_dot); + ] + parameters_dot logger error handler compilation Handler.print_rule_dot + Handler.print_var_dot Handler.get_label_of_rule_dot + Handler.get_label_of_var_dot Handler.print_labels "" " ;" wake_up_map in error + ) in let error = - if - Ckappa_sig.PairRule_setmap.Map.is_empty - inhibition_map - then error - else - (* let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters_dot) - "edge [color=%s, arrowhead=%s];" - (Remanent_parameters.get_inhibition_color parameters_dot) - (Remanent_parameters.get_inhibition_arrow parameters_dot) - in*) + if Ckappa_sig.PairRule_setmap.Map.is_empty inhibition_map then + error + else ( + (* let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters_dot) + "edge [color=%s, arrowhead=%s];" + (Remanent_parameters.get_inhibition_color parameters_dot) + (Remanent_parameters.get_inhibition_arrow parameters_dot) + in*) (* let () = Loggers.print_newline (Remanent_parameters.get_logger parameters_dot) in*) let error = print_maps - ~directives:[Graph_loggers_sig.Color (Remanent_parameters.get_inhibition_color parameters_dot); - Graph_loggers_sig.ArrowHead (Remanent_parameters.get_inhibition_arrow parameters_dot); - ] - parameters_dot logger error handler compilation - Handler.print_rule_dot Handler.print_var_dot - Handler.get_label_of_rule_dot Handler.get_label_of_var_dot - Handler.print_labels "" " ;" inhibition_map - + ~directives: + [ + Graph_loggers_sig.Color + (Remanent_parameters.get_inhibition_color parameters_dot); + Graph_loggers_sig.ArrowHead + (Remanent_parameters.get_inhibition_arrow parameters_dot); + ] + parameters_dot logger error handler compilation Handler.print_rule_dot + Handler.print_var_dot Handler.get_label_of_rule_dot + Handler.get_label_of_var_dot Handler.print_labels "" " ;" + inhibition_map in + error + ) in let _ = Graph_loggers.print_graph_foot logger in let () = match loggers with - | None -> Loggers.close_logger (Remanent_parameters.get_logger parameters_dot) - | Some _ -> Loggers.flush_logger (Remanent_parameters.get_logger parameters_dot) - in error + | None -> + Loggers.close_logger (Remanent_parameters.get_logger parameters_dot) + | Some _ -> + Loggers.flush_logger (Remanent_parameters.get_logger parameters_dot) + in + error diff --git a/core/KaSa_rep/influence_map/quark.ml b/core/KaSa_rep/influence_map/quark.ml index 28a7df35ea..8a3c6049ca 100644 --- a/core/KaSa_rep/influence_map/quark.ml +++ b/core/KaSa_rep/influence_map/quark.ml @@ -15,701 +15,579 @@ let local_trace = false let empty_quarks parameter error handler = - let n_agents = handler.Cckappa_sig.nagents in - let error,agent_modif_plus = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key - parameter error n_agents - in - let error,agent_modif_minus = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key - parameter error n_agents - in - let error,agent_test = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key - parameter error n_agents - in - let error,site_modif_plus = - Quark_type.SiteMap.create_biggest_key - parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) - in - let error,site_modif_minus = - Quark_type.SiteMap.create_biggest_key - parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) - in - let error,site_test = - Quark_type.SiteMap.create_biggest_key - parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) - in - let error,site_modif_bound_plus = - Quark_type.SiteMap.create_biggest_key - parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) - in - let error,site_modif_bound_minus = - Quark_type.SiteMap.create_biggest_key - parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) - in - let error,site_bound_test = - Quark_type.SiteMap.create_biggest_key - parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) - in - let error,agent_var_plus = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key - parameter error n_agents - in - let error,site_var_plus = + let n_agents = handler.Cckappa_sig.nagents in + let error, agent_modif_plus = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents + in + let error, agent_modif_minus = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents + in + let error, agent_test = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents + in + let error, site_modif_plus = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) + in + let error, site_modif_minus = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) + in + let error, site_test = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) + in + let error, site_modif_bound_plus = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) + in + let error, site_modif_bound_minus = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) + in + let error, site_bound_test = Quark_type.SiteMap.create_biggest_key parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) + in + let error, agent_var_plus = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents in - let error,site_bound_var_minus = + let error, site_var_plus = Quark_type.SiteMap.create_biggest_key parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) in - let error,site_bound_var_plus = - Quark_type.SiteMap.create_biggest_key - parameter error - (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) + let error, site_bound_var_minus = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) in - let error,agent_var_minus = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key - parameter error n_agents + let error, site_bound_var_plus = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) in - let error,site_var_minus = - Quark_type.SiteMap.create_biggest_key parameter error (n_agents,(Ckappa_sig.dummy_site_name,Ckappa_sig.dummy_state_index)) + let error, agent_var_minus = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents + in + let error, site_var_minus = + Quark_type.SiteMap.create_biggest_key parameter error + (n_agents, (Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_state_index)) in let error, dead_sites_plus = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key - parameter error n_agents + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents + in + let error, dead_states_plus = + Quark_type.DeadSiteMap.create_biggest_key parameter error + (n_agents, Ckappa_sig.dummy_site_name) in - let error,dead_states_plus = Quark_type.DeadSiteMap.create_biggest_key parameter error (n_agents,Ckappa_sig.dummy_site_name) in let error, dead_sites_minus = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key parameter error n_agents + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents in - let error, dead_states_minus = Quark_type.DeadSiteMap.create_biggest_key - parameter error - (n_agents,Ckappa_sig.dummy_site_name) + let error, dead_states_minus = + Quark_type.DeadSiteMap.create_biggest_key parameter error + (n_agents, Ckappa_sig.dummy_site_name) in let error, dead_sites = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key - parameter error n_agents - in - let error,dead_states = Quark_type.DeadSiteMap.create_biggest_key - parameter error (n_agents,Ckappa_sig.dummy_site_name) in - let error, counter_test_geq = Quark_type.CounterMap.create_biggest_key - parameter error (n_agents,Ckappa_sig.dummy_site_name) in - let error, counter_test_leq = Quark_type.CounterMap.create_biggest_key - parameter error (n_agents,Ckappa_sig.dummy_site_name) in - let error, counter_delta_plus = Quark_type.CounterMap.create_biggest_key - parameter error (n_agents,Ckappa_sig.dummy_site_name) in - let error, counter_delta_minus = Quark_type.CounterMap.create_biggest_key - parameter error (n_agents,Ckappa_sig.dummy_site_name) in - error, - { - Quark_type.dead_agent_plus = Quark_type.StringMap.empty ; - Quark_type.dead_agent_minus = Quark_type.StringMap.empty ; - Quark_type.dead_sites_minus = dead_sites_minus ; - Quark_type.dead_states_minus = dead_states_minus ; - Quark_type.dead_agent = Quark_type.StringMap.empty ; - Quark_type.dead_sites = dead_sites ; - Quark_type.dead_states = dead_states ; - Quark_type.dead_sites_plus = dead_sites_plus ; - Quark_type.dead_states_plus = dead_states_plus ; - Quark_type.agent_modif_plus = agent_modif_plus; - Quark_type.agent_modif_minus = agent_modif_minus; - Quark_type.agent_test = agent_test; - Quark_type.agent_var_minus = agent_var_minus; - Quark_type.site_modif_plus = site_modif_plus; - Quark_type.site_modif_minus = site_modif_minus; - Quark_type.site_test = site_test; - Quark_type.site_modif_bound_plus = site_modif_bound_plus; - Quark_type.site_modif_bound_minus = site_modif_bound_minus; - Quark_type.site_test_bound = site_bound_test; - Quark_type.site_var_minus = site_var_minus; - Quark_type.site_bound_var_minus = site_bound_var_minus; - Quark_type.site_bound_var_plus = site_bound_var_plus; - Quark_type.agent_var_plus = agent_var_plus ; - Quark_type.site_var_plus = site_var_plus ; - Quark_type.counter_test_geq = counter_test_geq ; - Quark_type.counter_test_leq = counter_test_leq ; - Quark_type.counter_delta_plus = counter_delta_plus ; - Quark_type.counter_delta_minus = counter_delta_minus ; - } + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameter error n_agents + in + let error, dead_states = + Quark_type.DeadSiteMap.create_biggest_key parameter error + (n_agents, Ckappa_sig.dummy_site_name) + in + let error, counter_test_geq = + Quark_type.CounterMap.create_biggest_key parameter error + (n_agents, Ckappa_sig.dummy_site_name) + in + let error, counter_test_leq = + Quark_type.CounterMap.create_biggest_key parameter error + (n_agents, Ckappa_sig.dummy_site_name) + in + let error, counter_delta_plus = + Quark_type.CounterMap.create_biggest_key parameter error + (n_agents, Ckappa_sig.dummy_site_name) + in + let error, counter_delta_minus = + Quark_type.CounterMap.create_biggest_key parameter error + (n_agents, Ckappa_sig.dummy_site_name) + in + ( error, + { + Quark_type.dead_agent_plus = Quark_type.StringMap.empty; + Quark_type.dead_agent_minus = Quark_type.StringMap.empty; + Quark_type.dead_sites_minus; + Quark_type.dead_states_minus; + Quark_type.dead_agent = Quark_type.StringMap.empty; + Quark_type.dead_sites; + Quark_type.dead_states; + Quark_type.dead_sites_plus; + Quark_type.dead_states_plus; + Quark_type.agent_modif_plus; + Quark_type.agent_modif_minus; + Quark_type.agent_test; + Quark_type.agent_var_minus; + Quark_type.site_modif_plus; + Quark_type.site_modif_minus; + Quark_type.site_test; + Quark_type.site_modif_bound_plus; + Quark_type.site_modif_bound_minus; + Quark_type.site_test_bound = site_bound_test; + Quark_type.site_var_minus; + Quark_type.site_bound_var_minus; + Quark_type.site_bound_var_plus; + Quark_type.agent_var_plus; + Quark_type.site_var_plus; + Quark_type.counter_test_geq; + Quark_type.counter_test_leq; + Quark_type.counter_delta_plus; + Quark_type.counter_delta_minus; + } ) let member_generic get parameter error rule_id agent_id key map = let error, agent = match get parameter error key map with - | error,None -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create - parameter - error - 0 + | error, None -> + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create parameter + error 0 | error, Some x -> error, x in match - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameter - error - rule_id - agent + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get parameter + error rule_id agent with - | error,None -> error, false - | error,Some x -> error, Quark_type.Labels.member agent_id x - - + | error, None -> error, false + | error, Some x -> error, Quark_type.Labels.member agent_id x let member_site parameters error rule_id agent_id agent_type site_type state = - member_generic - Quark_type.SiteMap.unsafe_get - parameters - error - rule_id - agent_id + member_generic Quark_type.SiteMap.unsafe_get parameters error rule_id agent_id (agent_type, (site_type, state)) let add_generic get set parameter error rule_id agent_id key map = let error, old_agent = match get parameter error key map with - | error,None -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create - parameter - error - 0 + | error, None -> + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create parameter + error 0 | error, Some x -> error, x in - let error,old_label_set = + let error, old_label_set = match Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameter - error - rule_id - old_agent + parameter error rule_id old_agent with - | error,None -> error, Quark_type.Labels.empty - | error,Some x -> error,x + | error, None -> error, Quark_type.Labels.empty + | error, Some x -> error, x in let new_label_set = Quark_type.Labels.add_set agent_id old_label_set in - if new_label_set == old_label_set - then - error,map - else - let error,new_agent = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set - parameter - error - rule_id - new_label_set - old_agent + if new_label_set == old_label_set then + error, map + else ( + let error, new_agent = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set parameter error + rule_id new_label_set old_agent in set parameter error key new_agent map - + ) let remove_generic get set parameter error rule_id agent_id key map = let error, old_agent = match get parameter error key map with - | error,None -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create - parameter - error - 0 + | error, None -> + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create parameter + error 0 | error, Some x -> error, x in - let error,old_label_set = + let error, old_label_set = match Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameter - error - rule_id - old_agent + parameter error rule_id old_agent with - | error,None -> error, Quark_type.Labels.empty - | error,Some x -> error,x + | error, None -> error, Quark_type.Labels.empty + | error, Some x -> error, x in let new_label_set = Quark_type.Labels.remove_set agent_id old_label_set in - if new_label_set == old_label_set - then - error,map - else - let error,new_agent = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set - parameter - error - rule_id - new_label_set - old_agent + if new_label_set == old_label_set then + error, map + else ( + let error, new_agent = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set parameter error + rule_id new_label_set old_agent in set parameter error key new_agent map - + ) let add_agent parameters error rule_id agent_id agent_type = - let _ = Misc_sa.trace parameters (fun () -> "rule_id:"^ - (Ckappa_sig.string_of_rule_id rule_id)^",agent_type:"^ - (Ckappa_sig.string_of_agent_name agent_type)^"\n") + let _ = + Misc_sa.trace parameters (fun () -> + "rule_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ "\n") in add_generic Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - rule_id - agent_id - agent_type + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error rule_id agent_id agent_type let add_var parameters error var_id agent_id agent_type = - let _ = Misc_sa.trace parameters (fun () -> - "var_id:"^ (Ckappa_sig.string_of_rule_id var_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type)^"\n") + let _ = + Misc_sa.trace parameters (fun () -> + "var_id:" + ^ Ckappa_sig.string_of_rule_id var_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ "\n") in add_generic Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - var_id - agent_id - agent_type + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error var_id agent_id agent_type let add_site parameters error rule_id agent_id agent_type site_type state = - let _ = Misc_sa.trace parameters (fun () -> - "rule_id:" ^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ - ",state:" ^ - (Ckappa_sig.string_of_state_index state) ^ "\n") + let _ = + Misc_sa.trace parameters (fun () -> + "rule_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ ",state:" + ^ Ckappa_sig.string_of_state_index state + ^ "\n") in - add_generic - Quark_type.SiteMap.unsafe_get - Quark_type.SiteMap.set - parameters - error - rule_id - agent_id + add_generic Quark_type.SiteMap.unsafe_get Quark_type.SiteMap.set parameters + error rule_id agent_id (agent_type, (site_type, state)) - let add_bound_site_test parameters error rule_id agent_id agent_type site_type = - let _ = Misc_sa.trace parameters (fun () -> - "rule_id:" ^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ - ",state: Bound \n") + let _ = + Misc_sa.trace parameters (fun () -> + "rule_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ ",state: Bound \n") in - add_generic - Quark_type.SiteMap.unsafe_get - Quark_type.SiteMap.set - parameters - error - rule_id - agent_id + add_generic Quark_type.SiteMap.unsafe_get Quark_type.SiteMap.set parameters + error rule_id agent_id (agent_type, (site_type, Ckappa_sig.state_index_of_int 1)) let add_bound_site parameters error rule_id agent_id agent_type site_type set = - let _ = Misc_sa.trace parameters (fun () -> - "rule_id:" ^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ - ",state: bound\n") - in - error, Quark_type.BoundSite.Set.add (rule_id,agent_id,agent_type,site_type) set + let _ = + Misc_sa.trace parameters (fun () -> + "rule_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ ",state: bound\n") + in + ( error, + Quark_type.BoundSite.Set.add (rule_id, agent_id, agent_type, site_type) set + ) let add_site_var parameters error var_id agent_id agent_type site_type state = - let _ = Misc_sa.trace parameters (fun () -> - "var_id:" ^ - (Ckappa_sig.string_of_rule_id var_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ - ",state:" ^ - (Ckappa_sig.string_of_state_index state)^"\n") + let _ = + Misc_sa.trace parameters (fun () -> + "var_id:" + ^ Ckappa_sig.string_of_rule_id var_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ ",state:" + ^ Ckappa_sig.string_of_state_index state + ^ "\n") in - add_generic - Quark_type.SiteMap.unsafe_get - Quark_type.SiteMap.set - parameters - error - var_id - agent_id + add_generic Quark_type.SiteMap.unsafe_get Quark_type.SiteMap.set parameters + error var_id agent_id (agent_type, (site_type, state)) -let add_counter string parameters error rule_id agent_id agent_type counter - map = - let _ = Misc_sa.trace parameters (fun () -> - "rule_id:" ^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name counter) ^ - string ^ "\n") - in - add_generic - Quark_type.CounterMap.unsafe_get - Quark_type.CounterMap.set - parameters - error - rule_id - agent_id - (agent_type, counter) - map - +let add_counter string parameters error rule_id agent_id agent_type counter map + = + let _ = + Misc_sa.trace parameters (fun () -> + "rule_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name counter + ^ string ^ "\n") + in + add_generic Quark_type.CounterMap.unsafe_get Quark_type.CounterMap.set + parameters error rule_id agent_id (agent_type, counter) map -let add_half_bond_breaking parameter error handler rule_id agent_id - agent_type site k (site_modif_plus,site_modif_minus,site_bound_modif_minus) = +let add_half_bond_breaking parameter error handler rule_id agent_id agent_type + site k (site_modif_plus, site_modif_minus, site_bound_modif_minus) = match Handler.dual parameter error handler agent_type site k with - | error, None -> error,(site_modif_plus,site_modif_minus,site_bound_modif_minus) - | error,Some (agent_type2,site2,k2) -> + | error, None -> + error, (site_modif_plus, site_modif_minus, site_bound_modif_minus) + | error, Some (agent_type2, site2, k2) -> let error, site_modif_plus = - add_site parameter error rule_id agent_id agent_type2 site2 Ckappa_sig.dummy_state_index site_modif_plus + add_site parameter error rule_id agent_id agent_type2 site2 + Ckappa_sig.dummy_state_index site_modif_plus in - let error,site_modif_minus = - add_site parameter error rule_id agent_id agent_type2 site2 k2 site_modif_minus + let error, site_modif_minus = + add_site parameter error rule_id agent_id agent_type2 site2 k2 + site_modif_minus in - let error,site_bound_modif_minus = - add_bound_site parameter error rule_id agent_id agent_type2 site2 site_bound_modif_minus + let error, site_bound_modif_minus = + add_bound_site parameter error rule_id agent_id agent_type2 site2 + site_bound_modif_minus in - error,(site_modif_plus,site_modif_minus,site_bound_modif_minus) + error, (site_modif_plus, site_modif_minus, site_bound_modif_minus) -let add_dead_state s parameters error var_id agent_id agent_type site_type map map' = - let _ = Misc_sa.trace parameters (fun () -> - s ^ "_id:" ^ - (Ckappa_sig.string_of_rule_id var_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ "\n") +let add_dead_state s parameters error var_id agent_id agent_type site_type map + map' = + let _ = + Misc_sa.trace parameters (fun () -> + s ^ "_id:" + ^ Ckappa_sig.string_of_rule_id var_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ "\n") in let error, map = - add_generic - Quark_type.DeadSiteMap.unsafe_get - Quark_type.DeadSiteMap.set - parameters - error - var_id - agent_id - (agent_type, site_type) - map + add_generic Quark_type.DeadSiteMap.unsafe_get Quark_type.DeadSiteMap.set + parameters error var_id agent_id (agent_type, site_type) map in let error, map' = - add_generic - Quark_type.DeadSiteMap.unsafe_get - Quark_type.DeadSiteMap.set - parameters - error - var_id - agent_id - (agent_type, site_type) - map' + add_generic Quark_type.DeadSiteMap.unsafe_get Quark_type.DeadSiteMap.set + parameters error var_id agent_id (agent_type, site_type) map' in error, map, map' -let remove_dead_state s parameters error var_id agent_id agent_type site_type map = - let _ = Misc_sa.trace parameters (fun () -> - s ^ "_id:" ^ - (Ckappa_sig.string_of_rule_id var_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ " (REMOVE)\n") - in - remove_generic - Quark_type.DeadSiteMap.unsafe_get - Quark_type.DeadSiteMap.set - parameters - error - var_id - agent_id - (agent_type, site_type) - map - +let remove_dead_state s parameters error var_id agent_id agent_type site_type + map = + let _ = + Misc_sa.trace parameters (fun () -> + s ^ "_id:" + ^ Ckappa_sig.string_of_rule_id var_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ " (REMOVE)\n") + in + remove_generic Quark_type.DeadSiteMap.unsafe_get Quark_type.DeadSiteMap.set + parameters error var_id agent_id (agent_type, site_type) map let add_dead_agent s parameters error rule_id agent_id agent_type map map' = - let _ = Misc_sa.trace parameters (fun () -> - s ^"_id:"^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - agent_type ^ - "(Dead agent)\n") + let _ = + Misc_sa.trace parameters (fun () -> + s ^ "_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" ^ agent_type ^ "(Dead agent)\n") in let f error map = - let error,old_agent = - match Quark_type.StringMap.find_option agent_type map - with - | None -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create - parameters - error - 0 - | Some x -> error,x - in - let error,old_label_set = - match - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - rule_id - old_agent - with - | error,None -> error, Quark_type.Labels.empty - | error,Some x -> error,x + let error, old_agent = + match Quark_type.StringMap.find_option agent_type map with + | None -> + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 + | Some x -> error, x + in + let error, old_label_set = + match + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error rule_id old_agent + with + | error, None -> error, Quark_type.Labels.empty + | error, Some x -> error, x + in + let new_label_set = Quark_type.Labels.add_set agent_id old_label_set in + if new_label_set == old_label_set then + error, map + else ( + let error, new_agent = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error rule_id new_label_set old_agent in - let new_label_set = - Quark_type.Labels.add_set agent_id old_label_set in - if new_label_set == old_label_set - then - error,map - else - let error,new_agent = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - rule_id - new_label_set - old_agent - in - error, - Quark_type.StringMap.add agent_type new_agent map + error, Quark_type.StringMap.add agent_type new_agent map + ) in let error, map = f error map in let error, map' = f error map' in error, map, map' -let remove_dead_agent s parameters error rule_id agent_id agent_type map = - let _ = Misc_sa.trace parameters (fun () -> - s ^"_id:"^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - agent_type ^ - "(REMOVE Dead agent)\n") +let remove_dead_agent s parameters error rule_id agent_id agent_type map = + let _ = + Misc_sa.trace parameters (fun () -> + s ^ "_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" ^ agent_type ^ "(REMOVE Dead agent)\n") in let f error map = - let error,old_agent = - match Quark_type.StringMap.find_option agent_type map - with + let error, old_agent = + match Quark_type.StringMap.find_option agent_type map with | None -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create - parameters - error - 0 - | Some x -> error,x + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 + | Some x -> error, x in - let error,old_label_set = + let error, old_label_set = match Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - rule_id - old_agent + parameters error rule_id old_agent with - | error,None -> error, Quark_type.Labels.empty - | error,Some x -> error,x + | error, None -> error, Quark_type.Labels.empty + | error, Some x -> error, x in - let new_label_set = - Quark_type.Labels.remove_set agent_id old_label_set in - if new_label_set == old_label_set - then - error,map - else - let error,new_agent = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - rule_id - new_label_set - old_agent + let new_label_set = Quark_type.Labels.remove_set agent_id old_label_set in + if new_label_set == old_label_set then + error, map + else ( + let error, new_agent = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error rule_id new_label_set old_agent in - error, - Quark_type.StringMap.add agent_type new_agent map + error, Quark_type.StringMap.add agent_type new_agent map + ) in f error map - -let add_dead_sites s parameters error rule_id agent_id agent_type site map map' = - let _ = Misc_sa.trace parameters (fun () -> - s ^ "_id:"^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - "site: todo (Dead site)\n") +let add_dead_sites s parameters error rule_id agent_id agent_type site map map' + = + let _ = + Misc_sa.trace parameters (fun () -> + s ^ "_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ "site: todo (Dead site)\n") in let f error map = let error, old_agent = match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - map + parameters error agent_type map with - | error, None -> - error, - Cckappa_sig.KaSim_Site_map_and_set.Map.empty + | error, None -> error, Cckappa_sig.KaSim_Site_map_and_set.Map.empty | error, Some x -> error, x in let error, old_site = match Cckappa_sig.KaSim_Site_map_and_set.Map.find_option_without_logs - parameters - error - site - old_agent + parameters error site old_agent with (* this is a partial map, not associated key are implicitely associated to an empty map *) | error, None -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create - parameters - error - 0 + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 | error, Some x -> error, x in let error, old_label_set = match Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - rule_id - old_site + parameters error rule_id old_site with | error, None -> error, Quark_type.Labels.empty | error, Some x -> error, x in - let new_label_set = Quark_type.Labels.add_set agent_id - old_label_set in - if new_label_set == old_label_set - then + let new_label_set = Quark_type.Labels.add_set agent_id old_label_set in + if new_label_set == old_label_set then error, map - else - let error,new_site = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - rule_id - new_label_set - old_site + else ( + let error, new_site = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error rule_id new_label_set old_site in let error, new_agent = - Cckappa_sig.KaSim_Site_map_and_set.Map.add_or_overwrite - parameters error site new_site old_agent + Cckappa_sig.KaSim_Site_map_and_set.Map.add_or_overwrite parameters error + site new_site old_agent in Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_agent - map + parameters error agent_type new_agent map + ) in let error, map = f error map in let error, map' = f error map' in error, map, map' -let remove_dead_sites s parameters error rule_id agent_id agent_type site map = - let _ = Misc_sa.trace parameters (fun () -> - s ^ "_id:"^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - "site: todo (REMOVE Dead site)\n") +let remove_dead_sites s parameters error rule_id agent_id agent_type site map = + let _ = + Misc_sa.trace parameters (fun () -> + s ^ "_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ "site: todo (REMOVE Dead site)\n") in let f error map = let error, old_agent = match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - map + parameters error agent_type map with - | error, None -> - error, - Cckappa_sig.KaSim_Site_map_and_set.Map.empty + | error, None -> error, Cckappa_sig.KaSim_Site_map_and_set.Map.empty | error, Some x -> error, x in let error, old_site = match Cckappa_sig.KaSim_Site_map_and_set.Map.find_option_without_logs - parameters - error - site - old_agent + parameters error site old_agent with (* this is a partial map, not associated key are implicitely associated to an empty map *) | error, None -> - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create - parameters - error - 0 + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 | error, Some x -> error, x in let error, old_label_set = match Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - rule_id - old_site + parameters error rule_id old_site with | error, None -> error, Quark_type.Labels.empty | error, Some x -> error, x in - let new_label_set = Quark_type.Labels.remove_set agent_id - old_label_set in - if new_label_set == old_label_set - then + let new_label_set = Quark_type.Labels.remove_set agent_id old_label_set in + if new_label_set == old_label_set then error, map - else - let error,new_site = - Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - rule_id - new_label_set - old_site + else ( + let error, new_site = + Ckappa_sig.Rule_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error rule_id new_label_set old_site in let error, new_agent = - Cckappa_sig.KaSim_Site_map_and_set.Map.add_or_overwrite - parameters error site new_site old_agent + Cckappa_sig.KaSim_Site_map_and_set.Map.add_or_overwrite parameters error + site new_site old_agent in Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_agent - map + parameters error agent_type new_agent map + ) in f error map - -let clean_bound_modif parameter error common_prefix (map1,set1) (map2,set2) = +let clean_bound_modif parameter error common_prefix (map1, set1) (map2, set2) = let agent_id_of_label l = let n = - if l >= 0 - then l - else 1-l + if l >= 0 then + l + else + 1 - l in Ckappa_sig.agent_id_of_int n in - let filter = - Quark_type.BoundSite.Set.filter - (fun (_,agent_id,_,_) -> - Ckappa_sig.compare_agent_id - (agent_id_of_label agent_id) - common_prefix < 0) + let filter = + Quark_type.BoundSite.Set.filter (fun (_, agent_id, _, _) -> + Ckappa_sig.compare_agent_id (agent_id_of_label agent_id) common_prefix + < 0) in let set1_ = filter set1 in let set2_ = filter set2 in @@ -717,113 +595,127 @@ let clean_bound_modif parameter error common_prefix (map1,set1) (map2,set2) = let set2' = Quark_type.BoundSite.Set.minus set2 set1_ in let error, map1 = Quark_type.BoundSite.Set.fold - (fun (rule_id,agent_id,agent_type,site_type) (error, map)-> - let _ = Misc_sa.trace parameter (fun () -> - "MODIF PLUS rule_id:" ^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ - ",state: BOUND\n") - in + (fun (rule_id, agent_id, agent_type, site_type) (error, map) -> + let _ = + Misc_sa.trace parameter (fun () -> + "MODIF PLUS rule_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ ",state: BOUND\n") + in - add_site parameter error rule_id agent_id agent_type site_type (Ckappa_sig.state_index_of_int 1) map) - set1' - (error,map1) + add_site parameter error rule_id agent_id agent_type site_type + (Ckappa_sig.state_index_of_int 1) + map) + set1' (error, map1) in let error, map2 = Quark_type.BoundSite.Set.fold - (fun (rule_id,agent_id,agent_type,site_type) (error,map) -> - let _ = Misc_sa.trace parameter (fun () -> - "MODIF MOINS: rule_id:" ^ - (Ckappa_sig.string_of_rule_id rule_id) ^ - ",agent_type:" ^ - (Ckappa_sig.string_of_agent_name agent_type) ^ - ",site_type:" ^ - (Ckappa_sig.string_of_site_name site_type) ^ - ",state: BOUND\n") - in - add_site parameter error rule_id agent_id agent_type site_type (Ckappa_sig.state_index_of_int 1) map) - set2' - (error,map2) + (fun (rule_id, agent_id, agent_type, site_type) (error, map) -> + let _ = + Misc_sa.trace parameter (fun () -> + "MODIF MOINS: rule_id:" + ^ Ckappa_sig.string_of_rule_id rule_id + ^ ",agent_type:" + ^ Ckappa_sig.string_of_agent_name agent_type + ^ ",site_type:" + ^ Ckappa_sig.string_of_site_name site_type + ^ ",state: BOUND\n") + in + add_site parameter error rule_id agent_id agent_type site_type + (Ckappa_sig.state_index_of_int 1) + map) + set2' (error, map2) in error, map1, map2 let scan_mixture_in_var bool parameter error handler var_id mixture quarks = let views = mixture.Cckappa_sig.views in - let agent_var,site_var,site_bound_var,dead_agents,dead_sites,dead_states = - if bool - then - quarks.Quark_type.agent_var_plus, - quarks.Quark_type.site_var_plus, - quarks.Quark_type.site_bound_var_plus, - quarks.Quark_type.dead_agent_plus, - quarks.Quark_type.dead_sites_plus, - quarks.Quark_type.dead_states_plus + let agent_var, site_var, site_bound_var, dead_agents, dead_sites, dead_states + = + if bool then + ( quarks.Quark_type.agent_var_plus, + quarks.Quark_type.site_var_plus, + quarks.Quark_type.site_bound_var_plus, + quarks.Quark_type.dead_agent_plus, + quarks.Quark_type.dead_sites_plus, + quarks.Quark_type.dead_states_plus ) else - quarks.Quark_type.agent_var_minus, - quarks.Quark_type.site_var_minus, - quarks.Quark_type.site_bound_var_minus, - quarks.Quark_type.dead_agent_minus, - quarks.Quark_type.dead_sites_minus, - quarks.Quark_type.dead_states_minus - in - let error,(agent_var,site_var,site_bound_var,dead_agents,dead_sites,dead_states) = + ( quarks.Quark_type.agent_var_minus, + quarks.Quark_type.site_var_minus, + quarks.Quark_type.site_bound_var_minus, + quarks.Quark_type.dead_agent_minus, + quarks.Quark_type.dead_sites_minus, + quarks.Quark_type.dead_states_minus ) + in + let ( error, + ( agent_var, + site_var, + site_bound_var, + dead_agents, + dead_sites, + dead_states ) ) = (*what is tested in the mixture*) - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameter + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error (fun parameter error _agent_id agent - (agent_var, site_var, site_bound_var, dead_agents, dead_sites, dead_states) -> - let dealwith agent error (agent_var,site_var, site_bound_var) = + ( agent_var, + site_var, + site_bound_var, + dead_agents, + dead_sites, + dead_states ) -> + let dealwith agent error (agent_var, site_var, site_bound_var) = let error, kasim_id = - Quark_type.Labels.label_of_int - parameter error + Quark_type.Labels.label_of_int parameter error (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) in let agent_type = agent.Cckappa_sig.agent_name in let error, agent_var = - add_var - parameter - error - var_id - kasim_id - agent_type - agent_var + add_var parameter error var_id kasim_id agent_type agent_var in - let error,site_var,site_bound_var = + let error, site_var, site_bound_var = Ckappa_sig.Site_map_and_set.Map.fold - (fun site port (error,site_var,site_bound_var) -> - let interval = port.Cckappa_sig.site_state in - let max = interval.Cckappa_sig.max in - let min = interval.Cckappa_sig.min in - let error, binding_state = Handler.is_binding_site parameter error handler agent_type site in - if (binding_state && port.Cckappa_sig.site_free = None) (* The state is a wildcard, it should be ignored *) - || ((not binding_state) && min <> max) - then - error, site_var, site_bound_var - else - match min,max with - | Some min, Some max when min =max -> - let error, site_var = - add_site_var parameter error var_id kasim_id agent_type - site min site_var - in - error, site_var, site_bound_var - | Some _, Some _ -> - let error, site_bound_var = - add_site_var parameter error var_id kasim_id agent_type site (Ckappa_sig.state_index_of_int 1) site_bound_var - in - error, site_var, site_bound_var - | None, _ | _,None -> - let error, (site_var, site_bound_var) = - Exception.warn - parameter error __POS__ Exit - (site_var, site_bound_var) - in - error, site_var, site_bound_var - ) + (fun site port (error, site_var, site_bound_var) -> + let interval = port.Cckappa_sig.site_state in + let max = interval.Cckappa_sig.max in + let min = interval.Cckappa_sig.min in + let error, binding_state = + Handler.is_binding_site parameter error handler agent_type + site + in + if + (binding_state && port.Cckappa_sig.site_free = None) + (* The state is a wildcard, it should be ignored *) + || ((not binding_state) && min <> max) + then + error, site_var, site_bound_var + else ( + match min, max with + | Some min, Some max when min = max -> + let error, site_var = + add_site_var parameter error var_id kasim_id agent_type + site min site_var + in + error, site_var, site_bound_var + | Some _, Some _ -> + let error, site_bound_var = + add_site_var parameter error var_id kasim_id agent_type + site + (Ckappa_sig.state_index_of_int 1) + site_bound_var + in + error, site_var, site_bound_var + | None, _ | _, None -> + let error, (site_var, site_bound_var) = + Exception.warn parameter error __POS__ Exit + (site_var, site_bound_var) + in + error, site_var, site_bound_var + )) agent.Cckappa_sig.agent_interface (error, site_var, site_bound_var) in @@ -836,199 +728,165 @@ let scan_mixture_in_var bool parameter error handler var_id mixture quarks = (Ckappa_sig.int_of_agent_id id_int) in let error, dead_agents, _ = - add_dead_agent - "var" - parameter - error - var_id - kasim_id - string - dead_agents - dead_agents + add_dead_agent "var" parameter error var_id kasim_id string + dead_agents dead_agents in - error, (agent_var, site_var, site_bound_var, dead_agents, dead_sites, dead_states) + ( error, + ( agent_var, + site_var, + site_bound_var, + dead_agents, + dead_sites, + dead_states ) ) | Cckappa_sig.Ghost -> - error, (agent_var, site_var, site_bound_var, dead_agents, dead_sites, dead_states) + ( error, + ( agent_var, + site_var, + site_bound_var, + dead_agents, + dead_sites, + dead_states ) ) | Cckappa_sig.Dead_agent (agent, deadsite, deadstate, deadstate') -> let error, kasim_id = - Quark_type.Labels.label_of_int - parameter - error + Quark_type.Labels.label_of_int parameter error (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) in let error, (agent_var, site_var, site_bound_var) = - dealwith - agent - error - (agent_var, site_var,site_bound_var) + dealwith agent error (agent_var, site_var, site_bound_var) in let error, dead_sites, _ = Cckappa_sig.KaSim_Site_map_and_set.Set.fold - (fun s (error, deadsite,dead_site_) -> - add_dead_sites - "var" - parameter - error - var_id - kasim_id - agent.Cckappa_sig.agent_name - s - deadsite - dead_site_) - + (fun s (error, deadsite, dead_site_) -> + add_dead_sites "var" parameter error var_id kasim_id + agent.Cckappa_sig.agent_name s deadsite dead_site_) deadsite (error, dead_sites, dead_sites) in - let error,dead_states,_ = + let error, dead_states, _ = Ckappa_sig.Site_map_and_set.Map.fold (fun s _ (error, dead_states, dead_states_) -> - add_dead_state - "var" - parameter - error - var_id - kasim_id - agent.Cckappa_sig.agent_name - s - dead_states - dead_states_) + add_dead_state "var" parameter error var_id kasim_id + agent.Cckappa_sig.agent_name s dead_states dead_states_) deadstate (error, dead_states, dead_states) in - let error, dead_states,_ = + let error, dead_states, _ = Ckappa_sig.Site_map_and_set.Map.fold (fun s _ (error, dead_states, dead_states_) -> - add_dead_state - "var" - parameter - error - var_id - kasim_id - agent.Cckappa_sig.agent_name - s - dead_states - dead_states_) + add_dead_state "var" parameter error var_id kasim_id + agent.Cckappa_sig.agent_name s dead_states dead_states_) deadstate' (error, dead_states, dead_states) in - error, (agent_var,site_var,site_bound_var, dead_agents,dead_sites,dead_states) + ( error, + ( agent_var, + site_var, + site_bound_var, + dead_agents, + dead_sites, + dead_states ) ) | Cckappa_sig.Agent agent -> let error, (agent_var, site_var, site_bound_var) = - dealwith - agent - error - (agent_var, site_var, site_bound_var) + dealwith agent error (agent_var, site_var, site_bound_var) in - error, (agent_var, site_var, site_bound_var, dead_agents, dead_sites, dead_states) - ) + ( error, + ( agent_var, + site_var, + site_bound_var, + dead_agents, + dead_sites, + dead_states ) )) views - (agent_var, - site_var, - site_bound_var, - dead_agents, - dead_sites, - dead_states) - in - if bool - then - error, - { - quarks with - Quark_type.agent_var_plus = agent_var ; - Quark_type.site_var_plus = site_var ; - Quark_type.site_bound_var_plus = site_bound_var ; - Quark_type.dead_agent_plus = dead_agents ; - Quark_type.dead_sites_plus = dead_sites ; - Quark_type.dead_states_plus = dead_states } + (agent_var, site_var, site_bound_var, dead_agents, dead_sites, dead_states) + in + if bool then + ( error, + { + quarks with + Quark_type.agent_var_plus = agent_var; + Quark_type.site_var_plus = site_var; + Quark_type.site_bound_var_plus = site_bound_var; + Quark_type.dead_agent_plus = dead_agents; + Quark_type.dead_sites_plus = dead_sites; + Quark_type.dead_states_plus = dead_states; + } ) else - error, - { - quarks with - Quark_type.agent_var_minus = agent_var ; - Quark_type.site_var_minus = site_var ; - Quark_type.site_bound_var_minus = site_bound_var ; - Quark_type.dead_agent_minus = dead_agents ; - Quark_type.dead_sites_minus = dead_sites ; - Quark_type.dead_states_minus = dead_states } - + ( error, + { + quarks with + Quark_type.agent_var_minus = agent_var; + Quark_type.site_var_minus = site_var; + Quark_type.site_bound_var_minus = site_bound_var; + Quark_type.dead_agent_minus = dead_agents; + Quark_type.dead_sites_minus = dead_sites; + Quark_type.dead_states_minus = dead_states; + } ) let scan_pos_mixture = scan_mixture_in_var true let scan_neg_mixture = scan_mixture_in_var false let scan_var parameter error handler var_id var quarks = let aux error var list_pos list_neg = - match var - with - | Alg_expr.KAPPA_INSTANCE(mixture) -> error,mixture::list_pos,list_neg - | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ - | Alg_expr.CONST _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.STATE_ALG_OP _ - | Alg_expr.ALG_VAR _ - | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ - | Alg_expr.IF _ - -> - begin (* to do *) - error,list_pos,list_neg - end - in - let error,list_pos,list_neg = aux error var [] [] in - let error,quarks = + match var with + | Alg_expr.KAPPA_INSTANCE mixture -> error, mixture :: list_pos, list_neg + | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ | Alg_expr.CONST _ + | Alg_expr.TOKEN_ID _ | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ | Alg_expr.IF _ -> + (* to do *) + error, list_pos, list_neg + in + let error, list_pos, list_neg = aux error var [] [] in + let error, quarks = List.fold_left - (fun (error,quarks) mixture -> - scan_pos_mixture parameter error handler var_id mixture quarks) - (error,quarks) - list_pos + (fun (error, quarks) mixture -> + scan_pos_mixture parameter error handler var_id mixture quarks) + (error, quarks) list_pos in - let error,quarks = + let error, quarks = List.fold_left - (fun (error,quarks) mixture -> - scan_neg_mixture parameter error handler var_id mixture quarks) - (error, quarks) - list_neg + (fun (error, quarks) mixture -> + scan_neg_mixture parameter error handler var_id mixture quarks) + (error, quarks) list_neg in error, quarks let is_tested_and_not_question_mark parameter error agent_id site views = let error, agent_opt = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameter error agent_id views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameter + error agent_id views in match agent_opt with | None | Some Cckappa_sig.Ghost - | Some Cckappa_sig.Dead_agent _ - | Some Cckappa_sig.Unknown_agent _ - -> error, false - | Some Cckappa_sig.Agent agent -> + | Some (Cckappa_sig.Dead_agent _) + | Some (Cckappa_sig.Unknown_agent _) -> + error, false + | Some (Cckappa_sig.Agent agent) -> let error, port_opt = - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameter error site agent.Cckappa_sig.agent_interface + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameter error + site agent.Cckappa_sig.agent_interface in - match port_opt with + (match port_opt with | None -> error, false | Some port -> let interval = port.Cckappa_sig.site_state in - match interval.Cckappa_sig.min, interval.Cckappa_sig.max with + (match interval.Cckappa_sig.min, interval.Cckappa_sig.max with | Some min, Some max -> - let min = Ckappa_sig.int_of_state_index min in - let max = Ckappa_sig.int_of_state_index max in - if max = 0 || min > 0 - then error, true - else error, false - | None, Some _ | Some _ , None -> + let min = Ckappa_sig.int_of_state_index min in + let max = Ckappa_sig.int_of_state_index max in + if max = 0 || min > 0 then + error, true + else + error, false + | None, Some _ | Some _, None -> Exception.warn parameter error __POS__ Exit true - | None, None -> - Exception.warn parameter error __POS__ Exit false + | None, None -> Exception.warn parameter error __POS__ Exit false)) let scan_rule parameter error handler rule_id rule quarks = - let common_prefix = - Ckappa_sig.agent_id_of_int rule.Cckappa_sig.prefix - in + let common_prefix = Ckappa_sig.agent_id_of_int rule.Cckappa_sig.prefix in let viewslhs = rule.Cckappa_sig.rule_lhs.Cckappa_sig.views in let viewsrhs = rule.Cckappa_sig.rule_rhs.Cckappa_sig.views in - let agent_test = quarks.Quark_type.agent_test in + let agent_test = quarks.Quark_type.agent_test in let site_test = quarks.Quark_type.site_test in let site_bound_test = quarks.Quark_type.site_test_bound in let dead_agents_test = quarks.Quark_type.dead_agent in @@ -1049,593 +907,692 @@ let scan_rule parameter error handler rule_id rule quarks = let counter_delta_minus = quarks.Quark_type.counter_delta_minus in let _ = Misc_sa.trace parameter (fun () -> "TEST\n") in - let error,(agent_test,site_test,_site_bound_test,_dead_agents,_dead_sites,_dead_states,dead_agents_minus,dead_sites_minus,dead_states_minus) = (*what is tested in the lhs*) - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameter + let ( error, + ( agent_test, + site_test, + _site_bound_test, + _dead_agents, + _dead_sites, + _dead_states, + dead_agents_minus, + dead_sites_minus, + dead_states_minus ) ) = + (*what is tested in the lhs*) + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error - (fun parameter error _agent_id agent (agent_test,site_test,site_bound_test,dead_agents,dead_sites,dead_states,dead_agents_minus,dead_sites_minus,dead_states_minus) -> - let dealwith agent error (agent_test,site_test,site_bound_test) = - let error,kasim_id = - Quark_type.Labels.label_of_int - parameter error - (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) - in - let agent_type = agent.Cckappa_sig.agent_name in - let error,agent_test = add_agent parameter error rule_id kasim_id agent_type agent_test in - let error,site_test, site_bound_test = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site port (error,site_test,site_bound_test) -> - let error, b = - Handler.is_counter - parameter error handler - agent_type site + (fun parameter error _agent_id agent + ( agent_test, + site_test, + site_bound_test, + dead_agents, + dead_sites, + dead_states, + dead_agents_minus, + dead_sites_minus, + dead_states_minus ) -> + let dealwith agent error (agent_test, site_test, site_bound_test) = + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + let agent_type = agent.Cckappa_sig.agent_name in + let error, agent_test = + add_agent parameter error rule_id kasim_id agent_type agent_test + in + let error, site_test, site_bound_test = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site port (error, site_test, site_bound_test) -> + let error, b = + Handler.is_counter parameter error handler agent_type site + in + if b then + error, site_test, site_bound_test + else ( + let interval = port.Cckappa_sig.site_state in + let max = interval.Cckappa_sig.max in + let min = interval.Cckappa_sig.min in + let error, binding_state = + Handler.is_binding_site parameter error handler agent_type + site in - if b then (error,site_test,site_bound_test) - else - let interval = - port.Cckappa_sig.site_state - in - let max = interval.Cckappa_sig.max in - let min = interval.Cckappa_sig.min in - let error, binding_state = - Handler.is_binding_site - parameter error handler agent_type site - in - match min,max with - | Some min, Some max -> - if (binding_state && port.Cckappa_sig.site_free = None) (* The state is a wildcard, it should be ignored *) + match min, max with + | Some min, Some max -> + if + (binding_state && port.Cckappa_sig.site_free = None) + (* The state is a wildcard, it should be ignored *) || ((not binding_state) && min <> max) - then - error, site_test, site_bound_test - else - if min = max - then - let error, site_test = - add_site parameter error rule_id kasim_id agent_type site min site_test - in - error, site_test, site_bound_test - else - let error, site_bound_test = - add_bound_site_test parameter - error rule_id kasim_id agent_type site site_bound_test - in - error, site_test, site_bound_test - | None, _ | _,None -> - let error, (site_test,site_bound_test) = - Exception.warn parameter error __POS__ Exit (site_test, site_bound_test) - in error, site_test, site_bound_test - - ) - agent.Cckappa_sig.agent_interface - (error,site_test,site_bound_test) - in - error,(agent_test,site_test,site_bound_test) - in - match agent with - | Cckappa_sig.Unknown_agent (string,id_int) -> - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id id_int) - in - let error,dead_agents,dead_agents_minus = add_dead_agent "rule" parameter error rule_id kasim_id string dead_agents dead_agents_minus in - - error,(agent_test,site_test,site_bound_test,dead_agents,dead_sites,dead_states,dead_agents_minus,dead_sites_minus,dead_states_minus) - - | Cckappa_sig.Ghost -> error,(agent_test,site_test,site_bound_test,dead_agents,dead_sites,dead_states,dead_agents_minus,dead_sites_minus,dead_states_minus) - | Cckappa_sig.Dead_agent (agent,deadsite,deadstate,deadstate') -> - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) - in - let error,(agent_test,site_test,site_bound_test) = dealwith agent error (agent_test,site_test,site_bound_test) in - let error,dead_sites,dead_sites_minus = - Cckappa_sig.KaSim_Site_map_and_set.Set.fold - (fun s (error,deadsite,deadsite_minus) -> - add_dead_sites "rule" parameter error rule_id kasim_id agent.Cckappa_sig.agent_name s deadsite deadsite_minus) - deadsite - (error,dead_sites,dead_sites_minus) - in - let error,dead_states,dead_states_minus = - Ckappa_sig.Site_map_and_set.Map.fold - (fun s _ (error,dead_states,dead_states_minus) -> - add_dead_state "rule" parameter error rule_id kasim_id agent.Cckappa_sig.agent_name s dead_states dead_states_minus) - deadstate - (error,dead_states,dead_states_minus) - in - let error,dead_states, dead_states_minus = - Ckappa_sig.Site_map_and_set.Map.fold - (fun s _ (error,dead_states,dead_states_minus) -> - add_dead_state "rule" parameter error rule_id kasim_id agent.Cckappa_sig.agent_name s dead_states dead_states_minus) - deadstate' - (error,dead_states,dead_states_minus) - in - error,(agent_test,site_test,site_bound_test,dead_agents, - dead_sites,dead_states,dead_agents_minus,dead_sites_minus,dead_states_minus) - | Cckappa_sig.Agent agent -> - let error,(agent_test,site_test,site_bound_test) = dealwith agent error (agent_test,site_test,site_bound_test) in - error,(agent_test,site_test,site_bound_test,dead_agents,dead_sites,dead_states,dead_agents_minus,dead_sites_minus,dead_states_minus) + then + error, site_test, site_bound_test + else if min = max then ( + let error, site_test = + add_site parameter error rule_id kasim_id agent_type + site min site_test + in + error, site_test, site_bound_test + ) else ( + let error, site_bound_test = + add_bound_site_test parameter error rule_id kasim_id + agent_type site site_bound_test + in + error, site_test, site_bound_test + ) + | None, _ | _, None -> + let error, (site_test, site_bound_test) = + Exception.warn parameter error __POS__ Exit + (site_test, site_bound_test) + in + error, site_test, site_bound_test + )) + agent.Cckappa_sig.agent_interface + (error, site_test, site_bound_test) + in + error, (agent_test, site_test, site_bound_test) + in + match agent with + | Cckappa_sig.Unknown_agent (string, id_int) -> + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id id_int) + in + let error, dead_agents, dead_agents_minus = + add_dead_agent "rule" parameter error rule_id kasim_id string + dead_agents dead_agents_minus + in - ) + ( error, + ( agent_test, + site_test, + site_bound_test, + dead_agents, + dead_sites, + dead_states, + dead_agents_minus, + dead_sites_minus, + dead_states_minus ) ) + | Cckappa_sig.Ghost -> + ( error, + ( agent_test, + site_test, + site_bound_test, + dead_agents, + dead_sites, + dead_states, + dead_agents_minus, + dead_sites_minus, + dead_states_minus ) ) + | Cckappa_sig.Dead_agent (agent, deadsite, deadstate, deadstate') -> + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + let error, (agent_test, site_test, site_bound_test) = + dealwith agent error (agent_test, site_test, site_bound_test) + in + let error, dead_sites, dead_sites_minus = + Cckappa_sig.KaSim_Site_map_and_set.Set.fold + (fun s (error, deadsite, deadsite_minus) -> + add_dead_sites "rule" parameter error rule_id kasim_id + agent.Cckappa_sig.agent_name s deadsite deadsite_minus) + deadsite + (error, dead_sites, dead_sites_minus) + in + let error, dead_states, dead_states_minus = + Ckappa_sig.Site_map_and_set.Map.fold + (fun s _ (error, dead_states, dead_states_minus) -> + add_dead_state "rule" parameter error rule_id kasim_id + agent.Cckappa_sig.agent_name s dead_states dead_states_minus) + deadstate + (error, dead_states, dead_states_minus) + in + let error, dead_states, dead_states_minus = + Ckappa_sig.Site_map_and_set.Map.fold + (fun s _ (error, dead_states, dead_states_minus) -> + add_dead_state "rule" parameter error rule_id kasim_id + agent.Cckappa_sig.agent_name s dead_states dead_states_minus) + deadstate' + (error, dead_states, dead_states_minus) + in + ( error, + ( agent_test, + site_test, + site_bound_test, + dead_agents, + dead_sites, + dead_states, + dead_agents_minus, + dead_sites_minus, + dead_states_minus ) ) + | Cckappa_sig.Agent agent -> + let error, (agent_test, site_test, site_bound_test) = + dealwith agent error (agent_test, site_test, site_bound_test) + in + ( error, + ( agent_test, + site_test, + site_bound_test, + dead_agents, + dead_sites, + dead_states, + dead_agents_minus, + dead_sites_minus, + dead_states_minus ) )) viewslhs - (agent_test,site_test,site_bound_test,dead_agents_test,dead_sites_test,dead_states_test ,dead_agents_minus,dead_sites_minus,dead_states_minus) + ( agent_test, + site_test, + site_bound_test, + dead_agents_test, + dead_sites_test, + dead_states_test, + dead_agents_minus, + dead_sites_minus, + dead_states_minus ) + in + let _ = + Misc_sa.trace parameter (fun () -> "CLEANING QUARKS FOR DEAD AGENTS\n") in - let _ = Misc_sa.trace parameter (fun () ->"CLEANING QUARKS FOR DEAD AGENTS\n") in - let error,(dead_agents_minus,dead_sites_minus,dead_states_minus) = (*what is dead in the rhs*) - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameter + let error, (dead_agents_minus, dead_sites_minus, dead_states_minus) = + (*what is dead in the rhs*) + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error - (fun parameter error _agent_id agent (dead_agents_minus,dead_sites_minus,dead_states_minus) - -> - match agent with - | Cckappa_sig.Unknown_agent (string,id_int) -> - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id id_int) - in - let error,dead_agents_minus = remove_dead_agent "rule" parameter error rule_id kasim_id string dead_agents_minus in - error,(dead_agents_minus,dead_sites_minus,dead_states_minus) - - | Cckappa_sig.Ghost -> error,(dead_agents_minus,dead_sites_minus,dead_states_minus) - | Cckappa_sig.Dead_agent (agent,deadsite,deadstate,deadstate') -> - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) - in - let error,dead_sites_minus = - Cckappa_sig.KaSim_Site_map_and_set.Set.fold - (fun s (error,deadsite_minus) -> - remove_dead_sites "rule" parameter error rule_id kasim_id agent.Cckappa_sig.agent_name s deadsite_minus) - deadsite - (error,dead_sites_minus) - in - let error,dead_states_minus = - Ckappa_sig.Site_map_and_set.Map.fold - (fun s _ (error,dead_states_minus) -> - remove_dead_state "rule" parameter error rule_id kasim_id agent.Cckappa_sig.agent_name s dead_states_minus) - deadstate - (error,dead_states_minus) - in - let error,dead_states_minus = - Ckappa_sig.Site_map_and_set.Map.fold - (fun s _ (error,dead_states_minus) -> - remove_dead_state "rule" parameter error rule_id kasim_id agent.Cckappa_sig.agent_name s dead_states_minus) - deadstate' - (error,dead_states_minus) - in - error,(dead_agents_minus,dead_sites_minus,dead_states_minus) - | Cckappa_sig.Agent _ -> - error,(dead_agents_minus,dead_sites_minus,dead_states_minus) - - ) + (fun parameter error _agent_id agent + (dead_agents_minus, dead_sites_minus, dead_states_minus) -> + match agent with + | Cckappa_sig.Unknown_agent (string, id_int) -> + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id id_int) + in + let error, dead_agents_minus = + remove_dead_agent "rule" parameter error rule_id kasim_id string + dead_agents_minus + in + error, (dead_agents_minus, dead_sites_minus, dead_states_minus) + | Cckappa_sig.Ghost -> + error, (dead_agents_minus, dead_sites_minus, dead_states_minus) + | Cckappa_sig.Dead_agent (agent, deadsite, deadstate, deadstate') -> + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + let error, dead_sites_minus = + Cckappa_sig.KaSim_Site_map_and_set.Set.fold + (fun s (error, deadsite_minus) -> + remove_dead_sites "rule" parameter error rule_id kasim_id + agent.Cckappa_sig.agent_name s deadsite_minus) + deadsite (error, dead_sites_minus) + in + let error, dead_states_minus = + Ckappa_sig.Site_map_and_set.Map.fold + (fun s _ (error, dead_states_minus) -> + remove_dead_state "rule" parameter error rule_id kasim_id + agent.Cckappa_sig.agent_name s dead_states_minus) + deadstate (error, dead_states_minus) + in + let error, dead_states_minus = + Ckappa_sig.Site_map_and_set.Map.fold + (fun s _ (error, dead_states_minus) -> + remove_dead_state "rule" parameter error rule_id kasim_id + agent.Cckappa_sig.agent_name s dead_states_minus) + deadstate' (error, dead_states_minus) + in + error, (dead_agents_minus, dead_sites_minus, dead_states_minus) + | Cckappa_sig.Agent _ -> + error, (dead_agents_minus, dead_sites_minus, dead_states_minus)) viewsrhs - (dead_agents_minus,dead_sites_minus,dead_states_minus) + (dead_agents_minus, dead_sites_minus, dead_states_minus) in - let _ = Misc_sa.trace parameter (fun () ->"CREATION\n") in - let error,agent_modif_plus = (*the agents that are created*) + let _ = Misc_sa.trace parameter (fun () -> "CREATION\n") in + let error, agent_modif_plus = + (*the agents that are created*) List.fold_left - (fun (error,agent_modif_plus) (agent_id,agent_type) -> - let error,agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameter error agent_id viewsrhs - in - match agent with - | None -> - Exception.warn parameter error __POS__ Exit agent_modif_plus - | Some Cckappa_sig.Unknown_agent _ | Some Cckappa_sig.Ghost -> error,agent_modif_plus - | Some Cckappa_sig.Dead_agent (agent,_,_,_) | Some Cckappa_sig.Agent agent -> - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) - in - add_agent parameter error rule_id kasim_id agent_type agent_modif_plus) - (error,agent_modif_plus) - rule.Cckappa_sig.actions.Cckappa_sig.creation + (fun (error, agent_modif_plus) (agent_id, agent_type) -> + let error, agent = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameter error agent_id viewsrhs + in + match agent with + | None -> Exception.warn parameter error __POS__ Exit agent_modif_plus + | Some (Cckappa_sig.Unknown_agent _) | Some Cckappa_sig.Ghost -> + error, agent_modif_plus + | Some (Cckappa_sig.Dead_agent (agent, _, _, _)) + | Some (Cckappa_sig.Agent agent) -> + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + add_agent parameter error rule_id kasim_id agent_type agent_modif_plus) + (error, agent_modif_plus) rule.Cckappa_sig.actions.Cckappa_sig.creation in let _ = Misc_sa.trace parameter (fun () -> "REMOVAL\n") in - let error,(agent_modif_minus,site_modif_plus,site_modif_minus,site_bound_modif_minus) = (*the agents that are removed *) + let ( error, + ( agent_modif_minus, + site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) ) = + (*the agents that are removed *) List.fold_left - (fun (error,(agent_modif_minus,site_modif_plus,site_modif_minus,site_bound_modif_minus)) (agent_id,agent,list) -> - let agent_type = agent.Cckappa_sig.agent_name in - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) - in - let error, mkasim_id = - Quark_type.Labels.label_of_int parameter error - (-1 - Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id - ) - in - let error,agent_modif_minus = add_agent parameter error rule_id kasim_id agent_type agent_modif_minus in - let error,(site_modif_plus,site_modif_minus,site_bound_modif_minus) = - List.fold_left - (fun (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) site -> - let error,is_binding = - Handler.is_binding_site - parameter error handler agent_type site + (fun ( error, + ( agent_modif_minus, + site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) ) (agent_id, agent, list) -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + let error, mkasim_id = + Quark_type.Labels.label_of_int parameter error + (-1 - Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + let error, agent_modif_minus = + add_agent parameter error rule_id kasim_id agent_type + agent_modif_minus + in + let error, (site_modif_plus, site_modif_minus, site_bound_modif_minus) = + List.fold_left + (fun ( error, + (site_modif_plus, site_modif_minus, site_bound_modif_minus) + ) site -> + let error, is_binding = + Handler.is_binding_site parameter error handler agent_type site + in + if is_binding then ( + let error, is_tested_and_not_question_mark = + is_tested_and_not_question_mark parameter error agent_id site + viewslhs in - if is_binding - then - begin - let error, is_tested_and_not_question_mark = - is_tested_and_not_question_mark - parameter error agent_id site viewslhs - in - if not is_tested_and_not_question_mark - then - let error,state_dic = - Misc_sa.unsome - ( - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameter - error - (agent_type, site) - handler.Cckappa_sig.states_dic) - (fun error -> - Exception.warn parameter error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init ())) - in - let error,last_entry = Ckappa_sig.Dictionary_of_States.last_entry parameter error state_dic in - let rec aux k (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) = - if k > last_entry - then - (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) - else - let error,(site_modif_plus,site_modif_minus,site_bound_modif_minus) = - add_half_bond_breaking - parameter error handler rule_id mkasim_id agent_type site k - (site_modif_plus,site_modif_minus,site_bound_modif_minus) - in - aux (Ckappa_sig.next_state_index k) - (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) + if not is_tested_and_not_question_mark then ( + let error, state_dic = + Misc_sa.unsome + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameter error (agent_type, site) + handler.Cckappa_sig.states_dic) + (fun error -> + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) + in + let error, last_entry = + Ckappa_sig.Dictionary_of_States.last_entry parameter error + state_dic + in + let rec aux k + ( error, + ( site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) ) = + if k > last_entry then + ( error, + ( site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) ) + else ( + let ( error, + ( site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) ) = + add_half_bond_breaking parameter error handler rule_id + mkasim_id agent_type site k + ( site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) in - aux (Ckappa_sig.dummy_state_index_1) (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) - else - error,(site_modif_plus,site_modif_minus,site_bound_modif_minus) - end - else - error, - (site_modif_plus,site_modif_minus,site_bound_modif_minus) - ) - (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) - list - in - error,(agent_modif_minus,site_modif_plus,site_modif_minus,site_bound_modif_minus)) - (error,(agent_modif_minus,site_modif_plus,site_modif_minus,site_bound_modif_minus)) + aux + (Ckappa_sig.next_state_index k) + ( error, + ( site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) ) + ) + in + aux Ckappa_sig.dummy_state_index_1 + ( error, + (site_modif_plus, site_modif_minus, site_bound_modif_minus) + ) + ) else + ( error, + (site_modif_plus, site_modif_minus, site_bound_modif_minus) + ) + ) else + ( error, + (site_modif_plus, site_modif_minus, site_bound_modif_minus) )) + (error, (site_modif_plus, site_modif_minus, site_bound_modif_minus)) + list + in + ( error, + ( agent_modif_minus, + site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) )) + ( error, + ( agent_modif_minus, + site_modif_plus, + site_modif_minus, + site_bound_modif_minus ) ) rule.Cckappa_sig.actions.Cckappa_sig.remove in let _ = Misc_sa.trace parameter (fun () -> "MODIFICATION+\n") in - let error,(site_modif_plus,site_bound_modif_plus) = (*the sites that are directly modified (excluding side-effects)*) - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameter + let error, (site_modif_plus, site_bound_modif_plus) = + (*the sites that are directly modified (excluding side-effects)*) + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error - (fun parameter error _agent_id agent (site_modif_plus,site_bound_modif_plus) -> - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) - in - let agent_type = agent.Cckappa_sig.agent_name in - Ckappa_sig.Site_map_and_set.Map.fold - (fun site port (error,(site_modif_plus, site_bound_modif_plus)) -> - let error, b = - Handler.is_counter parameter error handler agent_type site + (fun parameter error _agent_id agent + (site_modif_plus, site_bound_modif_plus) -> + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + let agent_type = agent.Cckappa_sig.agent_name in + Ckappa_sig.Site_map_and_set.Map.fold + (fun site port (error, (site_modif_plus, site_bound_modif_plus)) -> + let error, b = + Handler.is_counter parameter error handler agent_type site + in + if b then + error, (site_modif_plus, site_bound_modif_plus) + else ( + let interval = port.Cckappa_sig.site_state in + let max = interval.Cckappa_sig.max in + let min = interval.Cckappa_sig.min in + let error, binding_state = + Handler.is_binding_site parameter error handler agent_type site in - if b then error, (site_modif_plus, site_bound_modif_plus) - else - let interval = port.Cckappa_sig.site_state in - let max = interval.Cckappa_sig.max in - let min = interval.Cckappa_sig.min in - let error, binding_state = Handler.is_binding_site parameter error handler agent_type site in - let error, site_bound_modif_plus = - match min,max with - Some min, Some _max -> - if binding_state - && - Ckappa_sig.compare_state_index - min Ckappa_sig.dummy_state_index > 0 - then - add_bound_site parameter error rule_id kasim_id - agent_type site site_bound_modif_plus - else - error, site_bound_modif_plus - | None, _ | _,None -> + let error, site_bound_modif_plus = + match min, max with + | Some min, Some _max -> + if + binding_state + && Ckappa_sig.compare_state_index min + Ckappa_sig.dummy_state_index + > 0 + then + add_bound_site parameter error rule_id kasim_id agent_type + site site_bound_modif_plus + else + error, site_bound_modif_plus + | None, _ | _, None -> Exception.warn parameter error __POS__ Exit site_bound_modif_plus + in + match min, max with + | Some min, Some max -> + let rec aux k (error, site_modif_plus) = + if k > max then + error, site_modif_plus + else + aux + (Ckappa_sig.next_state_index k) + (add_site parameter error rule_id kasim_id agent_type site + k site_modif_plus) in - match min,max with - | Some min, Some max -> - - - let rec aux k (error,site_modif_plus) = - if k>max - then - error,site_modif_plus - else - aux - (Ckappa_sig.next_state_index k) - (add_site parameter error rule_id kasim_id agent_type - site k site_modif_plus) - in - let error, site_modif_plus = - aux min (error,site_modif_plus) - in - error, (site_modif_plus, site_bound_modif_plus) - | None, _ | _,None -> - Exception.warn parameter error __POS__ Exit - (site_modif_plus, site_bound_modif_plus) - - ) - agent.Cckappa_sig.agent_interface - (error,(site_modif_plus,site_bound_modif_plus)) - ) + let error, site_modif_plus = aux min (error, site_modif_plus) in + error, (site_modif_plus, site_bound_modif_plus) + | None, _ | _, None -> + Exception.warn parameter error __POS__ Exit + (site_modif_plus, site_bound_modif_plus) + )) + agent.Cckappa_sig.agent_interface + (error, (site_modif_plus, site_bound_modif_plus))) rule.Cckappa_sig.diff_direct (site_modif_plus, site_bound_modif_plus) in let _ = Misc_sa.trace parameter (fun () -> "MODIFICATION-\n") in - let error,(site_modif_minus,site_bound_modif_minus) = (*the sites that are directly modified (excluding side-effects)*) - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameter + let error, (site_modif_minus, site_bound_modif_minus) = + (*the sites that are directly modified (excluding side-effects)*) + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error - (fun parameter error agent_id agent (site_modif_minus,site_bound_modif_minus) -> - let error,kasim_id = - Quark_type.Labels.label_of_int parameter error - (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) - in - let is_in_common_prefix = - Ckappa_sig.compare_agent_id - agent_id - (Ckappa_sig.agent_id_of_int rule.Cckappa_sig.prefix) - < 0 - in - let agent_type = agent.Cckappa_sig.agent_name in - Ckappa_sig.Site_map_and_set.Map.fold - (fun site port (error,(site_modif_minus,site_bound_modif_minus)) -> - let error, b = - Handler.is_counter parameter error handler agent_type site - in - if b then error, (site_modif_minus, site_bound_modif_minus) - else - let interval = port.Cckappa_sig.site_state in - let max = interval.Cckappa_sig.max in - let min = interval.Cckappa_sig.min in - match min,max with - | Some min, Some max -> - let error, binding_state = - Handler.is_binding_site parameter - error handler agent_type site - in - let error, site_bound_modif_minus = - if binding_state && - Ckappa_sig.compare_state_index - min Ckappa_sig.dummy_state_index > 0 - then - add_bound_site - parameter error rule_id kasim_id agent_type site site_bound_modif_minus - else - error, site_bound_modif_minus - in - let rec aux k (error,site_modif_minus) = - if k>max - then - (error,site_modif_minus) - else - let site_modif_minus = - if is_in_common_prefix - then - match - member_site parameter error rule_id kasim_id - agent_type site k site_modif_plus - with - | error, true -> error, site_modif_minus - | error, false -> - add_site - parameter error - rule_id kasim_id agent_type site k site_modif_minus - else - add_site - parameter error - rule_id kasim_id agent_type site k - site_modif_minus - in - aux - (Ckappa_sig.next_state_index k) - site_modif_minus - in - let error, modif = aux min (error,site_modif_minus) in - error, (modif, site_bound_modif_minus) - | None,_ | _,None -> - Exception.warn - parameter error __POS__ Exit (site_modif_minus,site_bound_modif_minus) - - ) - agent.Cckappa_sig.agent_interface - (error, - (site_modif_minus, - site_bound_modif_minus + (fun parameter error agent_id agent + (site_modif_minus, site_bound_modif_minus) -> + let error, kasim_id = + Quark_type.Labels.label_of_int parameter error + (Ckappa_sig.int_of_agent_id agent.Cckappa_sig.agent_kasim_id) + in + let is_in_common_prefix = + Ckappa_sig.compare_agent_id agent_id + (Ckappa_sig.agent_id_of_int rule.Cckappa_sig.prefix) + < 0 + in + let agent_type = agent.Cckappa_sig.agent_name in + Ckappa_sig.Site_map_and_set.Map.fold + (fun site port (error, (site_modif_minus, site_bound_modif_minus)) -> + let error, b = + Handler.is_counter parameter error handler agent_type site + in + if b then + error, (site_modif_minus, site_bound_modif_minus) + else ( + let interval = port.Cckappa_sig.site_state in + let max = interval.Cckappa_sig.max in + let min = interval.Cckappa_sig.min in + match min, max with + | Some min, Some max -> + let error, binding_state = + Handler.is_binding_site parameter error handler agent_type + site + in + let error, site_bound_modif_minus = + if + binding_state + && Ckappa_sig.compare_state_index min + Ckappa_sig.dummy_state_index + > 0 + then + add_bound_site parameter error rule_id kasim_id agent_type + site site_bound_modif_minus + else + error, site_bound_modif_minus + in + let rec aux k (error, site_modif_minus) = + if k > max then + error, site_modif_minus + else ( + let site_modif_minus = + if is_in_common_prefix then ( + match + member_site parameter error rule_id kasim_id + agent_type site k site_modif_plus + with + | error, true -> error, site_modif_minus + | error, false -> + add_site parameter error rule_id kasim_id agent_type + site k site_modif_minus + ) else + add_site parameter error rule_id kasim_id agent_type + site k site_modif_minus + in + aux (Ckappa_sig.next_state_index k) site_modif_minus + ) + in + let error, modif = aux min (error, site_modif_minus) in + error, (modif, site_bound_modif_minus) + | None, _ | _, None -> + Exception.warn parameter error __POS__ Exit + (site_modif_minus, site_bound_modif_minus) )) - - ) + agent.Cckappa_sig.agent_interface + (error, (site_modif_minus, site_bound_modif_minus))) rule.Cckappa_sig.diff_reverse - (site_modif_minus,site_bound_modif_minus) + (site_modif_minus, site_bound_modif_minus) in - let error,(site_modif_plus,site_modif_minus,site_bound_modif_minus) = (*the sites that are released via half bond breaking*) + let error, (site_modif_plus, site_modif_minus, site_bound_modif_minus) = + (*the sites that are released via half bond breaking*) let _ = Misc_sa.trace parameter (fun () -> "HALF BOND BREAKING\n") in List.fold_left - (fun (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) (add,state) -> - let agent_index = add.Cckappa_sig.agent_index in - let error,mkasim_id = - Quark_type.Labels.label_of_int parameter error - (-1 - Ckappa_sig.int_of_agent_id agent_index) - in - let agent_type = add.Cckappa_sig.agent_type in - let site = add.Cckappa_sig.site in - let error,(min,max) = - match state - with - | None -> - begin - let error,state_dic = - Misc_sa.unsome - ( - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameter - error - (agent_type, site) - handler.Cckappa_sig.states_dic) - (fun error -> - Exception.warn parameter error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init ())) - in - let error,last_entry = Ckappa_sig.Dictionary_of_States.last_entry parameter error state_dic in - error,(Ckappa_sig.dummy_state_index_1,last_entry) - end - | Some interval -> - begin - match interval.Cckappa_sig.min,interval.Cckappa_sig.max - with - | Some min, Some max -> - error,(min,max) - | None, _ | _,None -> - Exception.warn parameter error __POS__ Exit - (Ckappa_sig.dummy_state_index, - Ckappa_sig.dummy_state_index) - end - in - let rec aux k (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) = - if Ckappa_sig.compare_state_index k max > 0 - then - (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) - else - let error,(site_modif_plus,site_modif_minus,site_bound_modif_minus) = - add_half_bond_breaking parameter error - handler rule_id mkasim_id agent_type site k (site_modif_plus,site_modif_minus,site_bound_modif_minus) - in - aux (Ckappa_sig.next_state_index k) (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) - in - aux min - (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) - ) - (error,(site_modif_plus,site_modif_minus,site_bound_modif_minus)) + (fun (error, (site_modif_plus, site_modif_minus, site_bound_modif_minus)) + (add, state) -> + let agent_index = add.Cckappa_sig.agent_index in + let error, mkasim_id = + Quark_type.Labels.label_of_int parameter error + (-1 - Ckappa_sig.int_of_agent_id agent_index) + in + let agent_type = add.Cckappa_sig.agent_type in + let site = add.Cckappa_sig.site in + let error, (min, max) = + match state with + | None -> + let error, state_dic = + Misc_sa.unsome + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameter error (agent_type, site) + handler.Cckappa_sig.states_dic) + (fun error -> + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) + in + let error, last_entry = + Ckappa_sig.Dictionary_of_States.last_entry parameter error + state_dic + in + error, (Ckappa_sig.dummy_state_index_1, last_entry) + | Some interval -> + (match interval.Cckappa_sig.min, interval.Cckappa_sig.max with + | Some min, Some max -> error, (min, max) + | None, _ | _, None -> + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.dummy_state_index, Ckappa_sig.dummy_state_index)) + in + let rec aux k + (error, (site_modif_plus, site_modif_minus, site_bound_modif_minus)) + = + if Ckappa_sig.compare_state_index k max > 0 then + error, (site_modif_plus, site_modif_minus, site_bound_modif_minus) + else ( + let ( error, + (site_modif_plus, site_modif_minus, site_bound_modif_minus) ) + = + add_half_bond_breaking parameter error handler rule_id mkasim_id + agent_type site k + (site_modif_plus, site_modif_minus, site_bound_modif_minus) + in + aux + (Ckappa_sig.next_state_index k) + ( error, + (site_modif_plus, site_modif_minus, site_bound_modif_minus) ) + ) + in + aux min + (error, (site_modif_plus, site_modif_minus, site_bound_modif_minus))) + (error, (site_modif_plus, site_modif_minus, site_bound_modif_minus)) rule.Cckappa_sig.actions.Cckappa_sig.half_break in - let error, site_bound_modif_plus, site_bound_modif_minus = (* if a quark appers in both, remove them *) + let error, site_bound_modif_plus, site_bound_modif_minus = + (* if a quark appers in both, remove them *) clean_bound_modif parameter error common_prefix - (quarks.Quark_type.site_modif_bound_plus,site_bound_modif_plus) - (quarks.Quark_type.site_modif_bound_minus,site_bound_modif_minus) + (quarks.Quark_type.site_modif_bound_plus, site_bound_modif_plus) + (quarks.Quark_type.site_modif_bound_minus, site_bound_modif_minus) in - let error, counter_test_geq, counter_test_leq, counter_delta_plus, counter_delta_minus = + let ( error, + counter_test_geq, + counter_test_leq, + counter_delta_plus, + counter_delta_minus ) = List.fold_left - (fun - (error, counter_test_geq, counter_test_leq, counter_delta_plus, counter_delta_minus) - (site, action) -> + (fun ( error, + counter_test_geq, + counter_test_leq, + counter_delta_plus, + counter_delta_minus ) (site, action) -> let pre = action.Cckappa_sig.precondition in let delta = action.Cckappa_sig.increment in let error, counter_test_geq = match pre.Cckappa_sig.max with | None -> error, counter_test_geq | Some _ -> - add_counter ">=" - parameter error - rule_id - (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) site.Cckappa_sig.agent_type site.Cckappa_sig.site - counter_test_geq + add_counter ">=" parameter error rule_id + (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) + site.Cckappa_sig.agent_type site.Cckappa_sig.site counter_test_geq in let error, counter_test_leq = match pre.Cckappa_sig.min with | None -> error, counter_test_leq | Some _ -> - add_counter "<=" - parameter error - rule_id - (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) site.Cckappa_sig.agent_type site.Cckappa_sig.site - counter_test_leq + add_counter "<=" parameter error rule_id + (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) + site.Cckappa_sig.agent_type site.Cckappa_sig.site counter_test_leq in let error, counter_delta_minus = - if delta < 0 - then - add_counter "-=" - parameter error - rule_id - (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) site.Cckappa_sig.agent_type site.Cckappa_sig.site + if delta < 0 then + add_counter "-=" parameter error rule_id + (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) + site.Cckappa_sig.agent_type site.Cckappa_sig.site counter_delta_minus else error, counter_delta_minus in let error, counter_delta_plus = - if delta > 0 - then - add_counter "+=" - parameter error - rule_id - (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) site.Cckappa_sig.agent_type site.Cckappa_sig.site + if delta > 0 then + add_counter "+=" parameter error rule_id + (Ckappa_sig.int_of_agent_id site.Cckappa_sig.agent_index) + site.Cckappa_sig.agent_type site.Cckappa_sig.site counter_delta_plus else error, counter_delta_plus in - (error, counter_test_geq, counter_test_leq, counter_delta_plus, counter_delta_minus)) - (error, counter_test_geq, counter_test_leq, counter_delta_plus, counter_delta_minus) + ( error, + counter_test_geq, + counter_test_leq, + counter_delta_plus, + counter_delta_minus )) + ( error, + counter_test_geq, + counter_test_leq, + counter_delta_plus, + counter_delta_minus ) rule.Cckappa_sig.actions.Cckappa_sig.translate_counters - - in - error, - {quarks with - Quark_type.agent_test = agent_test ; - Quark_type.site_test = site_test ; - Quark_type.dead_agent = dead_agents_test; - Quark_type.dead_sites = dead_sites_test; - Quark_type.dead_states = dead_states_test; - Quark_type.dead_agent_minus = dead_agents_minus; - Quark_type.dead_sites_minus = dead_sites_minus; - Quark_type.dead_states_minus = dead_states_minus; - Quark_type.agent_modif_plus = agent_modif_plus ; - Quark_type.site_modif_plus = site_modif_plus ; - Quark_type.agent_modif_minus = agent_modif_minus ; - Quark_type.site_modif_minus = site_modif_minus ; - Quark_type.site_modif_bound_plus = site_bound_modif_plus ; - Quark_type.site_modif_bound_minus = site_bound_modif_minus ; - Quark_type.counter_test_geq = counter_test_geq ; - Quark_type.counter_test_leq = counter_test_leq ; - Quark_type.counter_delta_plus = counter_delta_plus ; - Quark_type.counter_delta_minus = counter_delta_minus ; - } + ( error, + { + quarks with + Quark_type.agent_test; + Quark_type.site_test; + Quark_type.dead_agent = dead_agents_test; + Quark_type.dead_sites = dead_sites_test; + Quark_type.dead_states = dead_states_test; + Quark_type.dead_agent_minus = dead_agents_minus; + Quark_type.dead_sites_minus; + Quark_type.dead_states_minus; + Quark_type.agent_modif_plus; + Quark_type.site_modif_plus; + Quark_type.agent_modif_minus; + Quark_type.site_modif_minus; + Quark_type.site_modif_bound_plus = site_bound_modif_plus; + Quark_type.site_modif_bound_minus = site_bound_modif_minus; + Quark_type.counter_test_geq; + Quark_type.counter_test_leq; + Quark_type.counter_delta_plus; + Quark_type.counter_delta_minus; + } ) let scan_rule_set parameter error handler rules = - let error,init = empty_quarks parameter error handler in - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameter - error + let error, init = empty_quarks parameter error handler in + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameter error (fun parameter error rule_id rule quark_maps -> - let _ = Misc_sa.trace parameter (fun () -> "Rule "^ Ckappa_sig.string_of_rule_id rule_id^"\n") in - scan_rule - parameter - error - handler - rule_id - rule.Cckappa_sig.e_rule_c_rule - quark_maps) - rules - init + let _ = + Misc_sa.trace parameter (fun () -> + "Rule " ^ Ckappa_sig.string_of_rule_id rule_id ^ "\n") + in + scan_rule parameter error handler rule_id rule.Cckappa_sig.e_rule_c_rule + quark_maps) + rules init let scan_var_set parameter error handler vars quarks = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameter - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameter error (fun parameter error var_id var quark_maps -> - let (_,(var,_))=var.Cckappa_sig.e_variable in - let _ = Misc_sa.trace parameter (fun () -> "Var "^ Ckappa_sig.string_of_rule_id var_id^"\n") in - scan_var - parameter - error - handler - var_id - var - quark_maps) - vars - quarks + let _, (var, _) = var.Cckappa_sig.e_variable in + let _ = + Misc_sa.trace parameter (fun () -> + "Var " ^ Ckappa_sig.string_of_rule_id var_id ^ "\n") + in + scan_var parameter error handler var_id var quark_maps) + vars quarks let quarkify parameters error handler cc_compil = let _ = Misc_sa.trace parameters (fun () -> "Quarkify\n") in - let error,quarks = scan_rule_set parameters error handler cc_compil.Cckappa_sig.rules in - scan_var_set parameters error handler cc_compil.Cckappa_sig.variables quarks + let error, quarks = + scan_rule_set parameters error handler cc_compil.Cckappa_sig.rules + in + scan_var_set parameters error handler cc_compil.Cckappa_sig.variables quarks diff --git a/core/KaSa_rep/main/KaSa.ml b/core/KaSa_rep/main/KaSa.ml index 9878126f26..d8c389ebe1 100644 --- a/core/KaSa_rep/main/KaSa.ml +++ b/core/KaSa_rep/main/KaSa.ml @@ -17,20 +17,18 @@ let main () = let _, parameters, _ = Get_option.get_option errors in let module A = (val Domain_selection.select_domain - ~reachability_parameters: - (Remanent_parameters.get_reachability_analysis_parameters parameters) - ()) + ~reachability_parameters: + (Remanent_parameters.get_reachability_analysis_parameters + parameters) + ()) in let export_to_kasa = - (module Export_to_KaSa.Export(A) : Export_to_KaSa.Type) - in - let module Export_to_KaSa = - (val export_to_kasa : Export_to_KaSa.Type) + (module Export_to_KaSa.Export (A) : Export_to_KaSa.Type) in + let module Export_to_KaSa = (val export_to_kasa : Export_to_KaSa.Type) in let state = Export_to_KaSa.init () in let state = - if (Remanent_parameters.get_compute_symmetries parameters) - then + if Remanent_parameters.get_compute_symmetries parameters then fst (Export_to_KaSa.get_env state) else state @@ -39,164 +37,142 @@ let main () = (*-----------------------------------------------------------------------*) (*WORK IN PROCESS:*) let state = - if Remanent_parameters.get_do_scc parameters - then + if Remanent_parameters.get_do_scc parameters then ( let accuracy_level_cm = - match - Remanent_parameters.get_contact_map_accuracy_level parameters - with + match Remanent_parameters.get_contact_map_accuracy_level parameters with | Remanent_parameters_sig.None -> Public_data.Low | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.Full + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + Public_data.Full in let accuracy_level_scc = - match - Remanent_parameters.get_scc_accuracy_level parameters - with - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.High + match Remanent_parameters.get_scc_accuracy_level parameters with + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> + Public_data.Low + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + Public_data.High in let state = - Export_to_KaSa.output_scc_decomposition - ~accuracy_level_cm ~accuracy_level_scc state + Export_to_KaSa.output_scc_decomposition ~accuracy_level_cm + ~accuracy_level_scc state in - state - else + state + ) else state in (*--------------------------------------------------------------------*) let state = - let bool, state = - if (Remanent_parameters.get_do_contact_map parameters) - then - match Remanent_parameters.get_contact_map_accuracy_level parameters - with - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> - true, - Export_to_KaSa.output_internal_contact_map - ~accuracy_level:Public_data.Low state - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> false, state - else false, state + let bool, state = + if Remanent_parameters.get_do_contact_map parameters then ( + match Remanent_parameters.get_contact_map_accuracy_level parameters with + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> + ( true, + Export_to_KaSa.output_internal_contact_map + ~accuracy_level:Public_data.Low state ) + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + false, state + ) else + false, state in - if bool then state - else - if Remanent_parameters.get_trace parameters || Print_cckappa.trace - then + if bool then + state + else if Remanent_parameters.get_trace parameters || Print_cckappa.trace then ( let state, c_compil = Export_to_KaSa.get_c_compilation state in let parameters' = - Remanent_parameters.update_prefix parameters "Compilation:" in + Remanent_parameters.update_prefix parameters "Compilation:" + in let state = Export_to_KaSa.set_parameters parameters' state in let state = Export_to_KaSa.dump_c_compil state c_compil in let state = Export_to_KaSa.set_parameters parameters state in state - else + ) else state in let error = Export_to_KaSa.get_errors state in let state = Export_to_KaSa.set_errors error state in - - -(*-----------------------------------------------------------------------*) + (*-----------------------------------------------------------------------*) let state = - if Remanent_parameters.get_do_influence_map parameters - then + if Remanent_parameters.get_do_influence_map parameters then ( let state = Export_to_KaSa.output_influence_map ~accuracy_level: (match Remanent_parameters.get_influence_map_accuracy_level parameters with - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium -> Public_data.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.High) + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> + Public_data.Low + | Remanent_parameters_sig.Medium -> Public_data.Medium + | Remanent_parameters_sig.High | Remanent_parameters_sig.Full -> + Public_data.High) state in state - else + ) else state in (*-----------------------------------------------------------------------*) let state = - if Remanent_parameters.get_do_reachability_analysis parameters - || Remanent_parameters.get_compute_separating_transitions parameters + if + Remanent_parameters.get_do_reachability_analysis parameters + || Remanent_parameters.get_compute_separating_transitions parameters then if Remanent_parameters.get_trace parameters then Export_to_KaSa.output_constraints_list state else fst (Export_to_KaSa.get_reachability_analysis state) - else + else state in let state = - if (Remanent_parameters.get_do_contact_map parameters) - then - match Remanent_parameters.get_contact_map_accuracy_level parameters - with - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High + if Remanent_parameters.get_do_contact_map parameters then ( + match Remanent_parameters.get_contact_map_accuracy_level parameters with + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High | Remanent_parameters_sig.Full -> Export_to_KaSa.output_internal_contact_map - ~accuracy_level:Public_data.Medium - state - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> state - else state + ~accuracy_level:Public_data.Medium state + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> state + ) else + state in let state = - if (Remanent_parameters.get_compute_symmetries parameters) - then - match Remanent_parameters.get_contact_map_accuracy_level parameters - with - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> - Export_to_KaSa.output_symmetries - ~accuracy_level:Public_data.Medium - state - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> - Export_to_KaSa.output_symmetries - ~accuracy_level:Public_data.Low - state - else + if Remanent_parameters.get_compute_symmetries parameters then ( + match Remanent_parameters.get_contact_map_accuracy_level parameters with + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + Export_to_KaSa.output_symmetries ~accuracy_level:Public_data.Medium + state + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> + Export_to_KaSa.output_symmetries ~accuracy_level:Public_data.Low state + ) else state in (*-----------------------------------------------------------------------*) (*Stochastic flow of information*) let state, _stochastic_flow_opt = - if Remanent_parameters.get_do_stochastic_flow_of_information parameters - then + if Remanent_parameters.get_do_stochastic_flow_of_information parameters then ( let state, output = Export_to_KaSa.get_ctmc_flow state in state, Some output - else + ) else state, None in let state, _ode_flow_opt = - if Remanent_parameters.get_do_ODE_flow_of_information parameters - then + if Remanent_parameters.get_do_ODE_flow_of_information parameters then ( let state, output = Export_to_KaSa.get_ode_flow state in state, Some output - else + ) else state, None in let _ = Exception.print parameters (Export_to_KaSa.get_errors state) in let () = - if Remanent_parameters.get_print_efficiency parameters - then + if Remanent_parameters.get_print_efficiency parameters then ( let end_time = Sys.time () in let cpu_time = end_time -. start_time in - let handler, dead_rules, separating_transitions, transition_system_length = + let handler, dead_rules, separating_transitions, transition_system_length + = Export_to_KaSa.get_data state in let () = @@ -205,363 +181,319 @@ let main () = "CPU time: %g s." cpu_time in let () = - match - handler - with + match handler with | None -> () | Some l -> - Loggers.fprintf + Loggers.fprintf (Remanent_parameters.get_logger parameters) - "; rules: %i" - l.Cckappa_sig.nrules - in + "; rules: %i" l.Cckappa_sig.nrules + in let () = - match - dead_rules - with + match dead_rules with | None -> () | Some l -> Loggers.fprintf (Remanent_parameters.get_logger parameters) - "; dead rules: %i" - (List.length l) + "; dead rules: %i" (List.length l) in let () = - match - separating_transitions - with + match separating_transitions with | None -> () | Some l -> let json = Public_data.separating_transitions_to_json l in let l = Public_data.separating_transitions_of_json json in - let nr,nt = + let nr, nt = List.fold_left - (fun (nr,nt) (_,l) -> - nr+1, - nt+List.length l) - (0,0) l + (fun (nr, nt) (_, l) -> nr + 1, nt + List.length l) + (0, 0) l in Loggers.fprintf (Remanent_parameters.get_logger parameters) - "; separating transitions: %i in %i rules ;" - nt nr + "; separating transitions: %i in %i rules ;" nt nr in let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) in let _ = - match - transition_system_length - with + match transition_system_length with | None -> () | Some l -> let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "transition system lengths: %a" - (fun fmt -> - List.iter (Format.fprintf fmt "%i;")) l + (fun fmt -> List.iter (Format.fprintf fmt "%i;")) + l in let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let sum,nbr,longest = + let sum, nbr, longest = List.fold_left - (fun (sum,nbr,longest) i -> - sum+i, - succ nbr, - max longest i) - (0,0,0) l + (fun (sum, nbr, longest) i -> sum + i, succ nbr, max longest i) + (0, 0, 0) l in let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "Total: %i; Average: %i; Longest: %i" - sum - (int_of_float (ceil ((float_of_int sum)/.(float_of_int nbr)))) + "Total: %i; Average: %i; Longest: %i" sum + (int_of_float (ceil (float_of_int sum /. float_of_int nbr))) longest in let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) in () in let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "." + Loggers.fprintf (Remanent_parameters.get_logger parameters) "." in let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) in () + ) in let () = if - (Remanent_parameters.get_backdoor_nbr_of_scc parameters - || - Remanent_parameters.get_backdoor_average_size_of_scc parameters - || - Remanent_parameters.get_backdoor_nbr_of_dead_rules parameters - || - Remanent_parameters.get_backdoor_nbr_of_non_weakly_reversible_transitions parameters - || - Remanent_parameters.get_backdoor_timing parameters - || - Remanent_parameters.get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions parameters - || - Remanent_parameters.get_backdoor_nbr_of_rules parameters - || - Remanent_parameters.get_backdoor_nbr_of_constraints parameters - || - Remanent_parameters.get_backdoor_nbr_of_nr_constraints parameters - || - Remanent_parameters.get_backdoor_nbr_of_influences parameters - ) - then - let handler, dead_rules, separating_transitions, - _ = + Remanent_parameters.get_backdoor_nbr_of_scc parameters + || Remanent_parameters.get_backdoor_average_size_of_scc parameters + || Remanent_parameters.get_backdoor_nbr_of_dead_rules parameters + || Remanent_parameters + .get_backdoor_nbr_of_non_weakly_reversible_transitions parameters + || Remanent_parameters.get_backdoor_timing parameters + || Remanent_parameters + .get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions + parameters + || Remanent_parameters.get_backdoor_nbr_of_rules parameters + || Remanent_parameters.get_backdoor_nbr_of_constraints parameters + || Remanent_parameters.get_backdoor_nbr_of_nr_constraints parameters + || Remanent_parameters.get_backdoor_nbr_of_influences parameters + then ( + let handler, dead_rules, separating_transitions, _ = Export_to_KaSa.get_data state in let () = - if - Remanent_parameters.get_backdoor_nbr_of_dead_rules parameters - then + if Remanent_parameters.get_backdoor_nbr_of_dead_rules parameters then ( let () = - match - dead_rules - with + match dead_rules with | None -> () | Some dead_rules -> Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%i" (List.length dead_rules) - in () + in + () + ) in let () = - if - Remanent_parameters.get_backdoor_nbr_of_rules parameters - then + if Remanent_parameters.get_backdoor_nbr_of_rules parameters then ( let () = - match - handler - with - | None -> () + match handler with + | None -> () | Some l -> Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%i" l.Cckappa_sig.nrules - in () + in + () + ) in let () = if - Remanent_parameters.get_backdoor_nbr_of_non_weakly_reversible_transitions parameters - then + Remanent_parameters + .get_backdoor_nbr_of_non_weakly_reversible_transitions parameters + then ( let () = - match - separating_transitions - with + match separating_transitions with | None -> () | Some l -> - let nt = - List.fold_left - (fun nt (_,l) -> - nt+List.length l) - (0) l - in - Loggers.fprintf - (Remanent_parameters.get_logger_backdoor parameters) - "%i" nt + let nt = + List.fold_left (fun nt (_, l) -> nt + List.length l) 0 l + in + Loggers.fprintf + (Remanent_parameters.get_logger_backdoor parameters) + "%i" nt in () + ) in let () = if - Remanent_parameters.get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions parameters - then + Remanent_parameters + .get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions + parameters + then ( let () = - match - separating_transitions - with + match separating_transitions with | None -> () | Some l -> - let nt = List.length l in - Loggers.fprintf - (Remanent_parameters.get_logger_backdoor parameters) - "%i" nt + let nt = List.length l in + Loggers.fprintf + (Remanent_parameters.get_logger_backdoor parameters) + "%i" nt in () + ) in let () = - if Remanent_parameters.get_backdoor_nbr_of_constraints parameters - then - let _,constraints = Export_to_KaSa.get_constraints_list state in + if Remanent_parameters.get_backdoor_nbr_of_constraints parameters then ( + let _, constraints = Export_to_KaSa.get_constraints_list state in let n_constraints = - List.fold_left - (fun n (_,l) -> n+List.length l) - 0 constraints + List.fold_left (fun n (_, l) -> n + List.length l) 0 constraints in Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%i" n_constraints + ) in let () = if Remanent_parameters.get_backdoor_nbr_of_nr_constraints parameters - then - let _,constraints = Export_to_KaSa.get_constraints_list state in + then ( + let _, constraints = Export_to_KaSa.get_constraints_list state in let n_constraints = List.fold_left - (fun n (x,l) -> - if x = "nr" - then n+List.length l - else n) + (fun n (x, l) -> + if x <> "Views domain - non relational properties" then + n + List.length l + else + n) 0 constraints in Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%i" n_constraints + ) in let () = - if Remanent_parameters.get_backdoor_nbr_of_influences parameters - then - let _,(_,influence_plus, influence_minus) = + if Remanent_parameters.get_backdoor_nbr_of_influences parameters then ( + let _, (_, influence_plus, influence_minus) = Export_to_KaSa.get_influence_map ~accuracy_level: (match - Remanent_parameters.get_influence_map_accuracy_level parameters + Remanent_parameters.get_influence_map_accuracy_level + parameters with - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium -> Public_data.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.High) + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> + Public_data.Low + | Remanent_parameters_sig.Medium -> Public_data.Medium + | Remanent_parameters_sig.High | Remanent_parameters_sig.Full -> + Public_data.High) state in let n_constraints = Ckappa_sig.PairRule_setmap.Map.fold - (fun _ _ n -> 1+n) + (fun _ _ n -> 1 + n) influence_plus (Ckappa_sig.PairRule_setmap.Map.fold - (fun _ _ n -> 1+n) + (fun _ _ n -> 1 + n) influence_minus 0) in Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%i" n_constraints + ) in let () = - if Remanent_parameters.get_backdoor_nbr_of_scc parameters - then - let accuracy_level_cm = - match - Remanent_parameters.get_contact_map_accuracy_level parameters - with - | Remanent_parameters_sig.None -> Public_data.Low - | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.Full - in - let accuracy_level_scc = - match - Remanent_parameters.get_scc_accuracy_level parameters - with - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.High - in - let _,scc = - Export_to_KaSa.get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc state + if Remanent_parameters.get_backdoor_nbr_of_scc parameters then ( + let accuracy_level_cm = + match + Remanent_parameters.get_contact_map_accuracy_level parameters + with + | Remanent_parameters_sig.None -> Public_data.Low + | Remanent_parameters_sig.Low -> Public_data.Low + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + Public_data.Full + in + let accuracy_level_scc = + match Remanent_parameters.get_scc_accuracy_level parameters with + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> + Public_data.Low + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + Public_data.High + in + let _, scc = + Export_to_KaSa.get_scc_decomposition ~accuracy_level_cm + ~accuracy_level_scc state in let n_constraints = List.length scc in Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%i" n_constraints + ) in let () = - if Remanent_parameters.get_backdoor_average_size_of_scc parameters - then - let accuracy_level_cm = - match - Remanent_parameters.get_contact_map_accuracy_level parameters - with - | Remanent_parameters_sig.None -> Public_data.Low - | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.Full - in - let accuracy_level_scc = - match - Remanent_parameters.get_scc_accuracy_level parameters - with - | Remanent_parameters_sig.None - | Remanent_parameters_sig.Low -> Public_data.Low - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Full -> Public_data.High - in - let _,scc = - Export_to_KaSa.get_scc_decomposition ~accuracy_level_cm ~accuracy_level_scc state + if Remanent_parameters.get_backdoor_average_size_of_scc parameters then ( + let accuracy_level_cm = + match + Remanent_parameters.get_contact_map_accuracy_level parameters + with + | Remanent_parameters_sig.None -> Public_data.Low + | Remanent_parameters_sig.Low -> Public_data.Low + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + Public_data.Full + in + let accuracy_level_scc = + match Remanent_parameters.get_scc_accuracy_level parameters with + | Remanent_parameters_sig.None | Remanent_parameters_sig.Low -> + Public_data.Low + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + Public_data.High + in + let _, scc = + Export_to_KaSa.get_scc_decomposition ~accuracy_level_cm + ~accuracy_level_scc state in let n_scc = List.length scc in - if n_scc > 0 - then + if n_scc > 0 then ( let n_constraints = - List.fold_left - (fun n l -> n+List.length l) - 0 - scc + List.fold_left (fun n l -> n + List.length l) 0 scc in let n_constraints = n_constraints / n_scc in Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%i" n_constraints - else - Loggers.fprintf - (Remanent_parameters.get_logger_backdoor parameters) - "N/A" - in - let () = - if Remanent_parameters.get_backdoor_timing parameters - then - let end_time = Sys.time () in - let cpu_time = end_time -. start_time in - let () = - - - if cpu_time <= 1. then - Loggers.fprintf - (Remanent_parameters.get_logger_backdoor parameters) - "%0.3f" cpu_time - else if cpu_time <= 10. - then - Loggers.fprintf - (Remanent_parameters.get_logger_backdoor parameters) - "%.2f" cpu_time - else if cpu_time <= 1000. - then + ) else Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) - "%3.0f" cpu_time - else + "N/A" + ) + in + let () = + if Remanent_parameters.get_backdoor_timing parameters then ( + let end_time = Sys.time () in + let cpu_time = end_time -. start_time in + let () = + if cpu_time <= 1. then + Loggers.fprintf + (Remanent_parameters.get_logger_backdoor parameters) + "%0.3f" cpu_time + else if cpu_time <= 10. then + Loggers.fprintf + (Remanent_parameters.get_logger_backdoor parameters) + "%.2f" cpu_time + else if cpu_time <= 1000. then + Loggers.fprintf + (Remanent_parameters.get_logger_backdoor parameters) + "%3.0f" cpu_time + else Loggers.fprintf (Remanent_parameters.get_logger_backdoor parameters) "%3.0g" cpu_time - in - () + in + () + ) in let () = Loggers.flush_logger (Remanent_parameters.get_logger_backdoor parameters) in () + ) in () diff --git a/core/KaSa_rep/main/KaSa_json.ml b/core/KaSa_rep/main/KaSa_json.ml index 00165b4736..a8bcd27dd4 100644 --- a/core/KaSa_rep/main/KaSa_json.ml +++ b/core/KaSa_rep/main/KaSa_json.ml @@ -13,25 +13,26 @@ let main () = let errors = Exception.empty_error_handler in - let _, parameters, _ = Get_option.get_option errors in + let _, parameters, _ = Get_option.get_option errors in let module A = (val Domain_selection.select_domain - ~reachability_parameters:(Remanent_parameters.get_reachability_analysis_parameters parameters) ()) + ~reachability_parameters: + (Remanent_parameters.get_reachability_analysis_parameters + parameters) + ()) in let export_to_json = - (module Export_to_json.Export(A) : Export_to_json.Type) - in - let module Export_to_json = - (val export_to_json : Export_to_json.Type) + (module Export_to_json.Export (A) : Export_to_json.Type) in + let module Export_to_json = (val export_to_json : Export_to_json.Type) in let state = Export_to_json.init () in - let state,cm = Export_to_json.get_contact_map state in + let state, cm = Export_to_json.get_contact_map state in let _ = Public_data.contact_map_of_json cm in - let state,im = Export_to_json.get_influence_map state in + let state, im = Export_to_json.get_influence_map state in let _ = Public_data.influence_map_of_json im in - let state,dr = Export_to_json.get_dead_rules state in + let state, dr = Export_to_json.get_dead_rules state in let _ = Public_data.dead_rules_of_json dr in - let state,constraints = Export_to_json.get_constraints_list state in + let state, constraints = Export_to_json.get_constraints_list state in let _ = Remanent_state.lemmas_list_of_json constraints in let errors = Export_to_json.get_errors state in let error_json = Exception_without_parameter.to_json errors in diff --git a/core/KaSa_rep/main/dune b/core/KaSa_rep/main/dune index 7bc33e1009..4b83362bb0 100644 --- a/core/KaSa_rep/main/dune +++ b/core/KaSa_rep/main/dune @@ -1,46 +1,85 @@ (library - (name kappa_staticanalyses) - (libraries unix kappa_species_count_enumeration kappa_reachability kappa_influence_map kappa_kasa_export) - (modules (:standard \ KaSa)) - (flags (:standard -w @a - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms - -open Kappa_runtime - -open Kappa_grammar - -open Kappa_cli - -open Kappa_profiling - -open Kappa_logging - -open Kappa_errors - -open Kappa_version - -open Kappa_kasa_kastor_toolset - -open Kappa_symmetries - -open Kappa_parameters - -open Kappa_reachability - -open Kappa_flow_analysis - -open Kappa_kasa_remanent_state - -open Kappa_mvbdu - -open Kappa_kasa_frontend - -open Kappa_kasa_site_graphs - -open Kappa_kasa_backend - -open Kappa_influence_map - -open Kappa_kasa_export - -open Kappa_kasa_type_interface - ))) - + (name kappa_staticanalyses) + (libraries + unix + kappa_species_count_enumeration + kappa_reachability + kappa_influence_map + kappa_kasa_export) + (modules + (:standard \ KaSa)) + (flags + (:standard + -w + @a + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms + -open + Kappa_runtime + -open + Kappa_grammar + -open + Kappa_cli + -open + Kappa_profiling + -open + Kappa_logging + -open + Kappa_errors + -open + Kappa_version + -open + Kappa_kasa_kastor_toolset + -open + Kappa_symmetries + -open + Kappa_parameters + -open + Kappa_reachability + -open + Kappa_flow_analysis + -open + Kappa_kasa_remanent_state + -open + Kappa_mvbdu + -open + Kappa_kasa_frontend + -open + Kappa_kasa_site_graphs + -open + Kappa_kasa_backend + -open + Kappa_influence_map + -open + Kappa_kasa_export + -open + Kappa_kasa_type_interface))) (executable - (name KaSa) - (libraries num yojson str kappa_staticanalyses kappa_kasa_frontend) - (modules KaSa) - (public_name KaSa) - (package kappa-binaries) - (flags (:standard - -open Kappa_logging - -open Kappa_errors - -open Kappa_parameters - -open Kappa_reachability - -open Kappa_staticanalyses - -open Kappa_kasa_frontend - -open Kappa_kasa_export - -open Kappa_kasa_type_interface))) + (name KaSa) + (libraries num yojson str kappa_staticanalyses kappa_kasa_frontend) + (modules KaSa) + (public_name KaSa) + (package kappa-binaries) + (flags + (:standard + -open + Kappa_logging + -open + Kappa_errors + -open + Kappa_parameters + -open + Kappa_reachability + -open + Kappa_staticanalyses + -open + Kappa_kasa_frontend + -open + Kappa_kasa_export + -open + Kappa_kasa_type_interface))) diff --git a/core/KaSa_rep/more_datastructures/dictionary.ml b/core/KaSa_rep/more_datastructures/dictionary.ml index 4d7e663a03..96ecce36ae 100644 --- a/core/KaSa_rep/more_datastructures/dictionary.ml +++ b/core/KaSa_rep/more_datastructures/dictionary.ml @@ -15,240 +15,264 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Dictionary = -sig +module type Dictionary = sig type key type value - type ('a,'b) dictionary - - val init: unit -> ('a,'b) dictionary - val member: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - value -> ('a,'b) dictionary -> Exception.method_handler * bool - val allocate: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a -> 'a -> key) -> value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (key * 'a * 'b * ('a,'b) dictionary) option - val allocate_uniquely: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a -> 'a -> key) -> value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (key * 'a * 'b * ('a,'b) dictionary) option + type ('a, 'b) dictionary + + val init : unit -> ('a, 'b) dictionary + + val member : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + value -> + ('a, 'b) dictionary -> + Exception.method_handler * bool + + val allocate : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> key) -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler * (key * 'a * 'b * ('a, 'b) dictionary) option + + val allocate_uniquely : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> key) -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler * (key * 'a * 'b * ('a, 'b) dictionary) option + (* val allocate_f_id: Exception.method_handler -> ('a -> 'a -> int) -> value -> (int -> 'a) -> 'a dictionary -> Exception.method_handler * (int * 'a * 'a dictionary) option*) - val allocate_bool: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a -> 'a -> key) -> value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (bool * (key * 'a * 'b * ('a,'b) dictionary) option) - - val unsafe_allocate: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (key * 'a * 'b * ('a,'b) dictionary) - val translate: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - key -> ('a,'b) dictionary -> + val allocate_bool : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> key) -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler + * (bool * (key * 'a * 'b * ('a, 'b) dictionary) option) + + val unsafe_allocate : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler * (key * 'a * 'b * ('a, 'b) dictionary) + + val translate : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + ('a, 'b) dictionary -> Exception.method_handler * (value * 'a * 'b) option - val stabilize: ('a,'b) dictionary -> ('a,'b) dictionary - val iter: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> - key -> value -> 'a -> 'b -> Exception.method_handler) -> - ('a,'b) dictionary -> Exception.method_handler - val last_entry: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a,'b) dictionary -> Exception.method_handler * key + + val stabilize : ('a, 'b) dictionary -> ('a, 'b) dictionary + + val iter : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + value -> + 'a -> + 'b -> + Exception.method_handler) -> + ('a, 'b) dictionary -> + Exception.method_handler + + val last_entry : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a, 'b) dictionary -> + Exception.method_handler * key + val fold : (value -> 'a * 'b -> key -> 'c -> 'c) -> ('a, 'b) dictionary -> 'c -> 'c end -exception Association_is_existing_with_the_same_value_in_a_different_location_memory +exception + Association_is_existing_with_the_same_value_in_a_different_location_memory + exception Association_is_not_defined module Dictionary = - (functor (Hash:Hash.Hash) -> - (struct - type key = int - type value = Hash.key - - type ('a,'b) in_construction = - { - hash_table:('a*'b) Hash.hash; - fresh:int - } - - type ('a,'b) stabilized = (value * 'a * 'b) option array - - type ('a,'b) dictionary = - { - is_stabilized: bool; - stabilized:('a,'b) stabilized; - in_construction:('a,'b) in_construction - } - - let invalid x parameters mh __POS__ message exn = - Exception.warn parameters mh __POS__ ~message exn x - - let invalid_arg = invalid None - - let invalid_arg_bool = invalid (false, None) - - - let preinit () = - { - hash_table = Hash.create 1; - fresh = 0 - } - - let premember parameters error value in_construction = - let error , output = - Hash.find_option_without_logs - (* indeed, this function is used to test whether or not there is an association *) - parameters error value in_construction.hash_table in - error,output != None - - let pretranslate parameters error key stabilized = - if key>=0 && key error, Some a - | None -> - invalid_arg - parameters error __POS__ - "missing entry" Association_is_not_defined - else - if key<0 then - invalid_arg - parameters error __POS__ - "negative key are not allowed" Association_is_not_defined - else - invalid_arg - parameters error __POS__ - "missing entry" Association_is_not_defined - - let prestabilize in_construction = - let array = Array.make in_construction.fresh None in - let () = - Hash.iter - (fun a (asso,asso') i -> array.(i)<-Some (a,asso,asso')) - in_construction.hash_table - in - array - - let init () = - { - in_construction = (preinit ()); - stabilized = Array.make 0 None; - is_stabilized = true - } - - let member parameters error value dictionary = - premember parameters error value dictionary.in_construction - - let stabilize dictionary = - if dictionary.is_stabilized then dictionary - else - { - in_construction = dictionary.in_construction; - is_stabilized = true; - stabilized = prestabilize dictionary.in_construction - } - - let translate parameters error key dictionary = - let dictionary = stabilize dictionary in - pretranslate parameters error key dictionary.stabilized - - let allocate_uniquely_or_not - uniquely parameters error compare (value:value) asso build dictionary = - let in_construction = dictionary.in_construction in - match - Hash.find_option_without_logs - (* indeed, this function is used to check that either there is no association, or that this is the same association *) - parameters error value in_construction.hash_table - with - | error,None -> - let fresh = in_construction.fresh in - let asso_id = build fresh in - let error, hash_table = - Hash.add parameters error value (asso,asso_id) fresh - in_construction.hash_table in - let hash = - { - hash_table = hash_table; - fresh = fresh + 1 - } - in - let dictionary = - if dictionary.is_stabilized - then {dictionary with is_stabilized = false} - else dictionary - in - let dictionary = - { - dictionary with in_construction = hash - } - in - error, (true, Some (fresh, asso, asso_id, dictionary)) - | error, Some (i, (asso', asso'_id)) when asso'== asso -> - error, (false, Some (i, asso', asso'_id, dictionary)) - | error, Some (i, (asso', asso'_id)) when compare asso asso' = 0 -> - if uniquely - then - invalid_arg_bool - parameters error __POS__ - "wrong association (the image is not uniquely described in memory)" - Association_is_existing_with_the_same_value_in_a_different_location_memory - else - error, (false, Some (i, asso', asso'_id, dictionary)) - | error, Some _ -> - invalid_arg_bool - parameters error __POS__ - "wrong association (several images for the same key)" - Association_is_existing_with_the_same_value_in_a_different_location_memory - - let allocate aa e x v a d f = - let a,(_,c) = allocate_uniquely_or_not false aa e x v a d f in a,c - let allocate_uniquely aa e x v a d f = - let a,(_,c) = allocate_uniquely_or_not true aa e x v a d f in a,c - let allocate_bool aa e = allocate_uniquely_or_not false aa e - - let unsafe_allocate parameters error value asso build dictionary = - let in_construction = dictionary.in_construction in - let fresh = in_construction.fresh in - let asso_id = build fresh in - let error,hash_table = - Hash.add_or_overwrite parameters error value (asso,asso_id) - fresh in_construction.hash_table in - let hash = - { - hash_table = hash_table; - fresh = fresh + 1 - } - in - let dictionary = - { - dictionary with in_construction = hash - } - in - error,(fresh,asso,asso_id,dictionary) - - let iter parameters error f dic = - let dic' = stabilize dic in - let g key error = function - | None -> error - | Some (value, a, b) -> f parameters error key value a b in - (* if dic.is_stabilized - then*) Tools.array_fold_lefti g error dic'.stabilized - (*else Hash.fold - (fun value (a,b) key error -> f parameters error key value a b) - dic.in_construction.hash_table error*) - - let fold f dictionary = - let in_construction = dictionary.in_construction in - Hash.fold f in_construction.hash_table - - let last_entry _parameters error dic = error, dic.in_construction.fresh - 1 - - end: Dictionary with type key = int and type value = Hash.key)) +functor + (Hash : Hash.Hash) + -> + ( + struct + type key = int + type value = Hash.key + + type ('a, 'b) in_construction = { + hash_table: ('a * 'b) Hash.hash; + fresh: int; + } + + type ('a, 'b) stabilized = (value * 'a * 'b) option array + + type ('a, 'b) dictionary = { + is_stabilized: bool; + stabilized: ('a, 'b) stabilized; + in_construction: ('a, 'b) in_construction; + } + + let invalid x parameters mh __POS__ message exn = + Exception.warn parameters mh __POS__ ~message exn x + + let invalid_arg = invalid None + let invalid_arg_bool = invalid (false, None) + let preinit () = { hash_table = Hash.create 1; fresh = 0 } + + let premember parameters error value in_construction = + let error, output = + Hash.find_option_without_logs + (* indeed, this function is used to test whether or not there is an association *) + parameters error value in_construction.hash_table + in + error, output != None + + let pretranslate parameters error key stabilized = + if key >= 0 && key < Array.length stabilized then ( + match stabilized.(key) with + | Some a -> error, Some a + | None -> + invalid_arg parameters error __POS__ "missing entry" + Association_is_not_defined + ) else if key < 0 then + invalid_arg parameters error __POS__ "negative key are not allowed" + Association_is_not_defined + else + invalid_arg parameters error __POS__ "missing entry" + Association_is_not_defined + + let prestabilize in_construction = + let array = Array.make in_construction.fresh None in + let () = + Hash.iter + (fun a (asso, asso') i -> array.(i) <- Some (a, asso, asso')) + in_construction.hash_table + in + array + + let init () = + { + in_construction = preinit (); + stabilized = Array.make 0 None; + is_stabilized = true; + } + + let member parameters error value dictionary = + premember parameters error value dictionary.in_construction + + let stabilize dictionary = + if dictionary.is_stabilized then + dictionary + else + { + in_construction = dictionary.in_construction; + is_stabilized = true; + stabilized = prestabilize dictionary.in_construction; + } + + let translate parameters error key dictionary = + let dictionary = stabilize dictionary in + pretranslate parameters error key dictionary.stabilized + + let allocate_uniquely_or_not uniquely parameters error compare + (value : value) asso build dictionary = + let in_construction = dictionary.in_construction in + match + Hash.find_option_without_logs + (* indeed, this function is used to check that either there is no association, or that this is the same association *) + parameters error value in_construction.hash_table + with + | error, None -> + let fresh = in_construction.fresh in + let asso_id = build fresh in + let error, hash_table = + Hash.add parameters error value (asso, asso_id) fresh + in_construction.hash_table + in + let hash = { hash_table; fresh = fresh + 1 } in + let dictionary = + if dictionary.is_stabilized then + { dictionary with is_stabilized = false } + else + dictionary + in + let dictionary = { dictionary with in_construction = hash } in + error, (true, Some (fresh, asso, asso_id, dictionary)) + | error, Some (i, (asso', asso'_id)) when asso' == asso -> + error, (false, Some (i, asso', asso'_id, dictionary)) + | error, Some (i, (asso', asso'_id)) when compare asso asso' = 0 -> + if uniquely then + invalid_arg_bool parameters error __POS__ + "wrong association (the image is not uniquely described in \ + memory)" + Association_is_existing_with_the_same_value_in_a_different_location_memory + else + error, (false, Some (i, asso', asso'_id, dictionary)) + | error, Some _ -> + invalid_arg_bool parameters error __POS__ + "wrong association (several images for the same key)" + Association_is_existing_with_the_same_value_in_a_different_location_memory + + let allocate aa e x v a d f = + let a, (_, c) = allocate_uniquely_or_not false aa e x v a d f in + a, c + + let allocate_uniquely aa e x v a d f = + let a, (_, c) = allocate_uniquely_or_not true aa e x v a d f in + a, c + + let allocate_bool aa e = allocate_uniquely_or_not false aa e + + let unsafe_allocate parameters error value asso build dictionary = + let in_construction = dictionary.in_construction in + let fresh = in_construction.fresh in + let asso_id = build fresh in + let error, hash_table = + Hash.add_or_overwrite parameters error value (asso, asso_id) fresh + in_construction.hash_table + in + let hash = { hash_table; fresh = fresh + 1 } in + let dictionary = { dictionary with in_construction = hash } in + error, (fresh, asso, asso_id, dictionary) + + let iter parameters error f dic = + let dic' = stabilize dic in + let g key error = function + | None -> error + | Some (value, a, b) -> f parameters error key value a b + in + (* if dic.is_stabilized + then*) + Tools.array_fold_lefti g error dic'.stabilized + (*else Hash.fold + (fun value (a,b) key error -> f parameters error key value a b) + dic.in_construction.hash_table error*) + + let fold f dictionary = + let in_construction = dictionary.in_construction in + Hash.fold f in_construction.hash_table + + let last_entry _parameters error dic = + error, dic.in_construction.fresh - 1 + end : + Dictionary with type key = int and type value = Hash.key) module Dictionary_of_Ord = - (functor (O:SetMap.OrderedType) -> Dictionary (Hash.Hash_of_Ord(O))) +functor (O : SetMap.OrderedType) -> Dictionary (Hash.Hash_of_Ord (O)) diff --git a/core/KaSa_rep/more_datastructures/dictionary.mli b/core/KaSa_rep/more_datastructures/dictionary.mli index 9af34c9683..0b922dc953 100644 --- a/core/KaSa_rep/more_datastructures/dictionary.mli +++ b/core/KaSa_rep/more_datastructures/dictionary.mli @@ -1,47 +1,89 @@ -module type Dictionary = -sig +module type Dictionary = sig type key type value - type ('a,'b) dictionary - - val init: unit -> ('a,'b) dictionary - val member: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - value -> ('a,'b) dictionary -> Exception.method_handler * bool - val allocate: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a -> 'a -> key) -> value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (key * 'a * 'b * ('a,'b) dictionary) option - val allocate_uniquely: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a -> 'a -> key) -> value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (key * 'a * 'b * ('a,'b) dictionary) option + type ('a, 'b) dictionary + + val init : unit -> ('a, 'b) dictionary + + val member : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + value -> + ('a, 'b) dictionary -> + Exception.method_handler * bool + + val allocate : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> key) -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler * (key * 'a * 'b * ('a, 'b) dictionary) option + + val allocate_uniquely : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> key) -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler * (key * 'a * 'b * ('a, 'b) dictionary) option + (* val allocate_f_id: Exception.method_handler -> ('a -> 'a -> int) -> value -> (int -> 'a) -> 'a dictionary -> Exception.method_handler * (int * 'a * 'a dictionary) option*) - val allocate_bool: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a -> 'a -> key) -> value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (bool * (key * 'a * 'b * ('a,'b) dictionary) option) - - val unsafe_allocate: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - value -> 'a -> (key -> 'b) -> ('a,'b) dictionary -> - Exception.method_handler * (key * 'a * 'b * ('a,'b) dictionary) - val translate: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - key -> ('a,'b) dictionary -> + val allocate_bool : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> key) -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler + * (bool * (key * 'a * 'b * ('a, 'b) dictionary) option) + + val unsafe_allocate : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + value -> + 'a -> + (key -> 'b) -> + ('a, 'b) dictionary -> + Exception.method_handler * (key * 'a * 'b * ('a, 'b) dictionary) + + val translate : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + ('a, 'b) dictionary -> Exception.method_handler * (value * 'a * 'b) option - val stabilize: ('a,'b) dictionary -> ('a,'b) dictionary - val iter: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> - key -> value -> 'a -> 'b -> Exception.method_handler) -> - ('a,'b) dictionary -> Exception.method_handler - val last_entry: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - ('a,'b) dictionary -> Exception.method_handler * key + + val stabilize : ('a, 'b) dictionary -> ('a, 'b) dictionary + + val iter : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + value -> + 'a -> + 'b -> + Exception.method_handler) -> + ('a, 'b) dictionary -> + Exception.method_handler + + val last_entry : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a, 'b) dictionary -> + Exception.method_handler * key + val fold : (value -> 'a * 'b -> key -> 'c -> 'c) -> ('a, 'b) dictionary -> 'c -> 'c end -module Dictionary_of_Ord: -functor (O:SetMap.OrderedType) -> Dictionary with type key = int and type value = O.t +module Dictionary_of_Ord : functor (O : SetMap.OrderedType) -> + Dictionary with type key = int and type value = O.t diff --git a/core/KaSa_rep/more_datastructures/dune b/core/KaSa_rep/more_datastructures/dune index 45a5cc84ac..e27524c3a1 100644 --- a/core/KaSa_rep/more_datastructures/dune +++ b/core/KaSa_rep/more_datastructures/dune @@ -1,8 +1,22 @@ (library - (name kappa_kasa_kastor_toolset) - (libraries str yojson result kappa_logging kappa_parameters kappa_errors kappa-library.generic) - (flags (:standard -w @a - -open Kappa_logging - -open Kappa_parameters - -open Kappa_errors - -open Kappa_generic_toolset))) + (name kappa_kasa_kastor_toolset) + (libraries + str + yojson + result + kappa_logging + kappa_parameters + kappa_errors + kappa-library.generic) + (flags + (:standard + -w + @a + -open + Kappa_logging + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_generic_toolset))) diff --git a/core/KaSa_rep/more_datastructures/graphs.ml b/core/KaSa_rep/more_datastructures/graphs.ml index 21d89f7f60..d3ebf5a510 100644 --- a/core/KaSa_rep/more_datastructures/graphs.ml +++ b/core/KaSa_rep/more_datastructures/graphs.ml @@ -3,152 +3,125 @@ let local_trace = false type node = int let node_of_int x = x -let int_of_node (x:node) = (x:int) +let int_of_node (x : node) : int = x + +module NodeSetMap = SetMap.Make (struct + type t = node + + let compare = compare + let print = Format.pp_print_int +end) -module NodeSetMap = - (SetMap.Make - (struct - type t = node - let compare = compare - let print = Format.pp_print_int - end - )) module NodeMap = NodeSetMap.Map -module Fixed_size_array = - ( - Int_storage.Quick_key_list(Int_storage.Int_storage_imperatif) : - Int_storage.Storage - with type key = node - and type dimension = int - ) +module Fixed_size_array : + Int_storage.Storage with type key = node and type dimension = int = + Int_storage.Quick_key_list (Int_storage.Int_storage_imperatif) -module Nodearray = - ( - Int_storage.Nearly_inf_Imperatif : - Int_storage.Storage - with type key = node - and type dimension = int - ) +module Nodearray : + Int_storage.Storage with type key = node and type dimension = int = + Int_storage.Nearly_inf_Imperatif -type ('node_labels,'edge_labels) graph = - { - node_labels: 'node_labels Fixed_size_array.t ; - edges: (node * 'edge_labels) list Fixed_size_array.t ; - } +type ('node_labels, 'edge_labels) graph = { + node_labels: 'node_labels Fixed_size_array.t; + edges: (node * 'edge_labels) list Fixed_size_array.t; +} let create parameters error node_of_node_label node_list edge_list = let max_node = - List.fold_left - (fun m i -> max m (int_of_node i)) - 0 node_list + List.fold_left (fun m i -> max m (int_of_node i)) 0 node_list in - let error, nodes = Fixed_size_array.create parameters error max_node in + let error, nodes = Fixed_size_array.create parameters error max_node in let error, nodes = List.fold_left (fun (error, nodes) i -> - Fixed_size_array.set parameters error (i:node) (node_of_node_label i) nodes) - (error, nodes) - (List.rev node_list) + Fixed_size_array.set parameters error + (i : node) + (node_of_node_label i) nodes) + (error, nodes) (List.rev node_list) in let error, edges = Fixed_size_array.create parameters error max_node in - let add_edge parameters error (n1,label,n2) edges = - let error, old = + let add_edge parameters error (n1, label, n2) edges = + let error, old = match Fixed_size_array.unsafe_get parameters error n1 edges with | error, None -> error, [] | error, Some a -> error, a in - Fixed_size_array.set parameters error n1 ((n2,label)::old) edges + Fixed_size_array.set parameters error n1 ((n2, label) :: old) edges in let error, edges = List.fold_left - (fun (error,edges) edge -> - add_edge parameters error edge edges) - (error, edges) - edge_list + (fun (error, edges) edge -> add_edge parameters error edge edges) + (error, edges) edge_list in - error, - { - node_labels = nodes ; - edges = edges ; - } + error, { node_labels = nodes; edges } let get parameters error i t = - match Nodearray.unsafe_get parameters error i t - with error, Some i -> error, i - | error, None -> error, -1 + match Nodearray.unsafe_get parameters error i t with + | error, Some i -> error, i + | error, None -> error, -1 let get_b parameters error i t = - match Nodearray.unsafe_get parameters error i t - with error, Some i -> error, i - | error, None -> error, false + match Nodearray.unsafe_get parameters error i t with + | error, Some i -> error, i + | error, None -> error, false -let compute_scc - ?low ?pre ?on_stack - parameters error n_to_string graph = +let compute_scc ?low ?pre ?on_stack parameters error n_to_string graph = let error = - if local_trace || Remanent_parameters.get_trace parameters - then + if local_trace || Remanent_parameters.get_trace parameters then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "COMPUTE BRIDGE: \n Graph: \n Nodes: \n" in let error = - Fixed_size_array.iter - parameters error + Fixed_size_array.iter parameters error (fun parameters error i j -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%i %s;\n" - i (n_to_string j) in - error) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%i %s;\n" i (n_to_string j) + in + error) graph.node_labels in let error = - Fixed_size_array.iter - parameters error + Fixed_size_array.iter parameters error (fun parameters error i l -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%i:" i - in - let error = - List.fold_left - (fun error (j,_) -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%i," j - in - error) - error - l - in - let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in - error) + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%i:" i + in + let error = + List.fold_left + (fun error (j, _) -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%i," j + in + error) + error l + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) graph.edges in error - else + ) else error in let error, low, pre, on_stack = match low, pre, on_stack with - | Some low, Some pre, Some on_stack -> - error, low, pre, on_stack - | None, _, _| _, None, _| _, _, None -> + | Some low, Some pre, Some on_stack -> error, low, pre, on_stack + | None, _, _ | _, None, _ | _, _, None -> let error, _max_node = - Fixed_size_array.fold - parameters error + Fixed_size_array.fold parameters error (fun _parameter error i _ j -> error, max (int_of_node i) j) - graph.node_labels - 0 + graph.node_labels 0 in let error, low = match low with @@ -168,54 +141,43 @@ let compute_scc error, low, pre, on_stack in let rec aux parameters error pre low on_stack scc_list stack counter v = - let error, pre = - Nodearray.set parameters error v counter pre - in - let error, low = - Nodearray.set parameters error v counter low - in - let stack = v::stack in - let error, on_stack = - Nodearray.set parameters error v true on_stack - in + let error, pre = Nodearray.set parameters error v counter pre in + let error, low = Nodearray.set parameters error v counter low in + let stack = v :: stack in + let error, on_stack = Nodearray.set parameters error v true on_stack in let counter = succ counter in let error, edges_v = match Fixed_size_array.unsafe_get parameters error v graph.edges with - | error, None -> - error, [] - | error, Some a -> - error, a + | error, None -> error, [] + | error, Some a -> error, a in let error, (pre, low, counter, on_stack, scc_list, stack) = List.fold_left - (fun - (error, (pre, low, counter, on_stack, scc_list, stack)) - (w,_) -> + (fun (error, (pre, low, counter, on_stack, scc_list, stack)) (w, _) -> let error, pre_w = get parameters error w pre in let error, (pre, low, counter, on_stack, scc_list, stack) = - if pre_w = -1 - then + if pre_w = -1 then ( let error, (pre, low, counter, on_stack, scc_list, stack) = aux parameters error pre low on_stack scc_list stack counter w in let error, low_v = get parameters error v low in let error, low_w = get parameters error w low in let error, low = - Nodearray.set parameters error v - (min low_v low_w) low + Nodearray.set parameters error v (min low_v low_w) low in error, (pre, low, counter, on_stack, scc_list, stack) - else - let error, b = get_b parameters error w on_stack in - if b then + ) else ( + let error, b = get_b parameters error w on_stack in + if b then ( let error, low_v = get parameters error v low in let error, pre_w = get parameters error w pre in let error, low = Nodearray.set parameters error v (min low_v pre_w) low in error, (pre, low, counter, on_stack, scc_list, stack) - else + ) else error, (pre, low, counter, on_stack, scc_list, stack) + ) in error, (pre, low, counter, on_stack, scc_list, stack)) (error, (pre, low, counter, on_stack, scc_list, stack)) @@ -223,163 +185,140 @@ let compute_scc in let error, low_v = get parameters error v low in let error, pre_v = get parameters error v pre in - if low_v = pre_v - then + if low_v = pre_v then ( let rec aux2 parameters error pre low on_stack scc_list stack counter cc v - = + = match stack with - | w'::stack -> + | w' :: stack -> let error, on_stack = Nodearray.set parameters error w' false on_stack in - let cc = w'::cc in - if v=w' then - error, (pre, low, counter, on_stack, cc::scc_list, stack) + let cc = w' :: cc in + if v = w' then + error, (pre, low, counter, on_stack, cc :: scc_list, stack) else - aux2 - parameters error pre low on_stack scc_list stack counter cc - v + aux2 parameters error pre low on_stack scc_list stack counter cc v | [] -> assert false in aux2 parameters error pre low on_stack scc_list stack counter [] v - else + ) else error, (pre, low, counter, on_stack, scc_list, stack) in let error, (pre, low, _counter, on_stack, scc_list, _stack) = - Fixed_size_array.fold - parameters error - (fun parameters error v _ ( pre, low, counter, on_stack, scc_list, stack) -> - let error, pre_v = get parameters error v pre in - if pre_v = -1 then - aux parameters error pre low on_stack scc_list stack counter v - else - error, (pre, low, counter, on_stack, scc_list, stack)) + Fixed_size_array.fold parameters error + (fun parameters error v _ (pre, low, counter, on_stack, scc_list, stack) -> + let error, pre_v = get parameters error v pre in + if pre_v = -1 then + aux parameters error pre low on_stack scc_list stack counter v + else + error, (pre, low, counter, on_stack, scc_list, stack)) graph.node_labels (pre, low, 1, on_stack, [], []) in let () = - if local_trace || - Remanent_parameters.get_trace parameters - then + if local_trace || Remanent_parameters.get_trace parameters then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "SCC" in let _ = List.iter - (fun list -> - let () = - List.iter - (Loggers.fprintf + (fun list -> + let () = + List.iter + (Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i;") - list in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "\n" - in - ()) + list + in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "\n" + in + ()) scc_list in - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) in let error, pre = Nodearray.free_all parameters error pre in let error, low = Nodearray.free_all parameters error low in let error, on_stack = Nodearray.free_all parameters error on_stack in error, pre, low, on_stack, scc_list -let detect_bridges - parameters error - add graph string_of_n string_of_e scc bridges = - Fixed_size_array.fold - parameters - error +let detect_bridges parameters error add graph string_of_n string_of_e scc + bridges = + Fixed_size_array.fold parameters error (fun parameters error ni l bridges -> - let error, scci = - match Nodearray.get parameters error ni scc - with - | error, Some scci -> error, scci - | error, None -> - Exception.warn parameters error __POS__ Exit (-1) - in - List.fold_left - (fun (error, bridges) (nj,label) -> - let error, sccj = - match Nodearray.get parameters error nj scc - with - | error, Some sccj -> error, sccj - | error, None -> - Exception.warn parameters error __POS__ Exit (-2) - in - if scci=sccj - then error, bridges - else - match - Fixed_size_array.get parameters error ni graph.node_labels - with + let error, scci = + match Nodearray.get parameters error ni scc with + | error, Some scci -> error, scci + | error, None -> Exception.warn parameters error __POS__ Exit (-1) + in + List.fold_left + (fun (error, bridges) (nj, label) -> + let error, sccj = + match Nodearray.get parameters error nj scc with + | error, Some sccj -> error, sccj + | error, None -> Exception.warn parameters error __POS__ Exit (-2) + in + if scci = sccj then + error, bridges + else ( + match + Fixed_size_array.get parameters error ni graph.node_labels + with + | error, None -> + Exception.warn parameters error __POS__ Exit bridges + | error, Some nstringi -> + (match + Fixed_size_array.get parameters error nj graph.node_labels + with | error, None -> Exception.warn parameters error __POS__ Exit bridges - | error, Some nstringi -> - begin - match - Fixed_size_array.get parameters error nj graph.node_labels - with - | error, None -> - Exception.warn parameters error __POS__ Exit bridges - | error, Some nstringj -> + | error, Some nstringj -> + let () = + if Remanent_parameters.get_trace parameters || local_trace + then ( let () = - if Remanent_parameters.get_trace parameters || local_trace - then - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s %s %s" - (string_of_n nstringi) - (string_of_e label) - (string_of_n nstringj) - in - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s %s %s" (string_of_n nstringi) (string_of_e label) + (string_of_n nstringj) in - error,add (nstringi,label,nstringj) bridges - end) - (error, bridges) l) - graph.edges - bridges + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + ) + in + error, add (nstringi, label, nstringj) bridges) + )) + (error, bridges) l) + graph.edges bridges -let add_bridges - ?low ?pre ?on_stack ?scc - add parameters error string_of_n string_of_e graph bridges - = +let add_bridges ?low ?pre ?on_stack ?scc add parameters error string_of_n + string_of_e graph bridges = let error, scc = match scc with | Some scc -> error, scc | None -> Nodearray.create parameters error 1 in let error, pre, low, on_stack, scc_list = - compute_scc - ?low ?pre ?on_stack - parameters error string_of_n graph + compute_scc ?low ?pre ?on_stack parameters error string_of_n graph in - let error, _,scc = + let error, _, scc = List.fold_left (fun (error, n, scc) cc -> - let error, n, scc = - List.fold_left - (fun (error, n, scc) node -> - let error, scc = Nodearray.set parameters error node n scc in - error, n, scc) - (error, n, scc) - cc - in - error, n+1, scc) + let error, n, scc = + List.fold_left + (fun (error, n, scc) node -> + let error, scc = Nodearray.set parameters error node n scc in + error, n, scc) + (error, n, scc) cc + in + error, n + 1, scc) (error, 1, scc) scc_list in let error, bridges = - detect_bridges parameters error add graph string_of_n string_of_e scc bridges - in - let error, scc = - Nodearray.free_all parameters error scc + detect_bridges parameters error add graph string_of_n string_of_e scc + bridges in + let error, scc = Nodearray.free_all parameters error scc in error, low, pre, on_stack, scc, bridges diff --git a/core/KaSa_rep/more_datastructures/graphs.mli b/core/KaSa_rep/more_datastructures/graphs.mli index f54f05dbff..2e9c2a40f8 100644 --- a/core/KaSa_rep/more_datastructures/graphs.mli +++ b/core/KaSa_rep/more_datastructures/graphs.mli @@ -1,40 +1,41 @@ type node -val node_of_int: int -> node +val node_of_int : int -> node val int_of_node : node -> int -module NodeMap: SetMap.Map with type elt = node +module NodeMap : SetMap.Map with type elt = node module Nodearray : - Int_storage.Storage - with type key = node - and type dimension = int + Int_storage.Storage with type key = node and type dimension = int -type ('node_label,'edge_label) graph +type ('node_label, 'edge_label) graph -val create: +val create : Remanent_parameters_sig.parameters -> Exception.method_handler -> - (node -> 'node_label) -> node list -> + (node -> 'node_label) -> + node list -> (node * 'edge_label * node) list -> - Exception.method_handler * - ('node_label, 'edge_label) graph + Exception.method_handler * ('node_label, 'edge_label) graph -val add_bridges: +val add_bridges : ?low:int Nodearray.t -> ?pre:int Nodearray.t -> ?on_stack:bool Nodearray.t -> ?scc:int Nodearray.t -> - (('a*'b*'a) -> 'c -> 'c) -> + ('a * 'b * 'a -> 'c -> 'c) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> ('a -> string) -> ('b -> string) -> ('a, 'b) graph -> 'c -> - Exception.method_handler * - int Nodearray.t * int Nodearray.t * bool Nodearray.t * int Nodearray.t * - 'c + Exception.method_handler + * int Nodearray.t + * int Nodearray.t + * bool Nodearray.t + * int Nodearray.t + * 'c val compute_scc : ?low:int Nodearray.t -> @@ -44,5 +45,8 @@ val compute_scc : Exception.method_handler -> ('a -> string) -> ('a, 'b) graph -> - Exception.method_handler * int Nodearray.t * int Nodearray.t * - bool Nodearray.t * Nodearray.key list list + Exception.method_handler + * int Nodearray.t + * int Nodearray.t + * bool Nodearray.t + * Nodearray.key list list diff --git a/core/KaSa_rep/more_datastructures/hash.ml b/core/KaSa_rep/more_datastructures/hash.ml index 7a30ed14be..87037d32e7 100644 --- a/core/KaSa_rep/more_datastructures/hash.ml +++ b/core/KaSa_rep/more_datastructures/hash.ml @@ -12,60 +12,96 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Hash = -sig +module type Hash = sig type key type 'a hash - val create: int -> 'a hash - - val add: Remanent_parameters_sig.parameters ->Exception.method_handler -> key -> 'a -> int -> 'a hash -> Exception.method_handler * 'a hash - - val overwrite: Remanent_parameters_sig.parameters ->Exception.method_handler -> key -> 'a -> int -> 'a hash -> Exception.method_handler * 'a hash - - val add_or_overwrite:Remanent_parameters_sig.parameters ->Exception.method_handler -> key -> 'a -> int -> 'a hash -> Exception.method_handler * 'a hash - - val find_option: Remanent_parameters_sig.parameters -> Exception.method_handler -> key -> 'a hash -> Exception.method_handler * (int*'a) option - - val find_option_without_logs: Remanent_parameters_sig.parameters -> Exception.method_handler -> key -> 'a hash -> Exception.method_handler * (int*'a) option - - val find_option_log_on_the_fly: key -> 'a hash -> (int*'a) option - - val iter: (key -> 'a -> int -> unit) -> 'a hash -> unit - - val fold: (key -> 'b -> int -> 'a -> 'a) -> 'b hash -> 'a -> 'a + val create : int -> 'a hash + + val add : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a -> + int -> + 'a hash -> + Exception.method_handler * 'a hash + + val overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a -> + int -> + 'a hash -> + Exception.method_handler * 'a hash + + val add_or_overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a -> + int -> + 'a hash -> + Exception.method_handler * 'a hash + + val find_option : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a hash -> + Exception.method_handler * (int * 'a) option + + val find_option_without_logs : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a hash -> + Exception.method_handler * (int * 'a) option + + val find_option_log_on_the_fly : key -> 'a hash -> (int * 'a) option + val iter : (key -> 'a -> int -> unit) -> 'a hash -> unit + val fold : (key -> 'b -> int -> 'a -> 'a) -> 'b hash -> 'a -> 'a end module Hash = - (functor (Map:Map_wrapper.S_with_logs) -> - (struct - type key = Map.elt - type 'a hash = (int*'a) Map.Map.t - - let create _ = Map.Map.empty - - let add parameter error key asso int = Map.Map.add parameter error key (int,asso) - - let overwrite parameter error key asso int = Map.Map.overwrite parameter error key (int,asso) - - let add_or_overwrite parameter error key asso int = Map.Map.add_or_overwrite parameter error key (int,asso) - - let find_option parameter error a b = - let error',output = Map.Map.find_option parameter error a b in - if error==error' then error',output - else - Exception.warn - parameter error' __POS__ - ~message:"attempt to read an unexisting association" Not_found output - - let find_option_without_logs = Map.Map.find_option_without_logs - - let find_option_log_on_the_fly a b = Lift_error_logs.lift_with_on_the_fly_logging_binary find_option a b - - - let iter f = Map.Map.iter (fun (a:key) (b,c) -> f a c b) - let fold f = Map.Map.fold (fun a (b,c) d -> f a c b d) - - end:Hash with type key = Map.elt)) - -module Hash_of_Ord = (functor (O:SetMap.OrderedType) -> Hash(Map_wrapper.Make(SetMap.Make(O)))) +functor + (Map : Map_wrapper.S_with_logs) + -> + ( + struct + type key = Map.elt + type 'a hash = (int * 'a) Map.Map.t + + let create _ = Map.Map.empty + + let add parameter error key asso int = + Map.Map.add parameter error key (int, asso) + + let overwrite parameter error key asso int = + Map.Map.overwrite parameter error key (int, asso) + + let add_or_overwrite parameter error key asso int = + Map.Map.add_or_overwrite parameter error key (int, asso) + + let find_option parameter error a b = + let error', output = Map.Map.find_option parameter error a b in + if error == error' then + error', output + else + Exception.warn parameter error' __POS__ + ~message:"attempt to read an unexisting association" Not_found + output + + let find_option_without_logs = Map.Map.find_option_without_logs + + let find_option_log_on_the_fly a b = + Lift_error_logs.lift_with_on_the_fly_logging_binary find_option a b + + let iter f = Map.Map.iter (fun (a : key) (b, c) -> f a c b) + let fold f = Map.Map.fold (fun a (b, c) d -> f a c b d) + end : + Hash with type key = Map.elt) + +module Hash_of_Ord = +functor (O : SetMap.OrderedType) -> Hash (Map_wrapper.Make (SetMap.Make (O))) diff --git a/core/KaSa_rep/more_datastructures/hash.mli b/core/KaSa_rep/more_datastructures/hash.mli index 6764f04231..a79eeba2eb 100644 --- a/core/KaSa_rep/more_datastructures/hash.mli +++ b/core/KaSa_rep/more_datastructures/hash.mli @@ -1,27 +1,54 @@ -module type Hash = -sig +module type Hash = sig type key type 'a hash - val create: int -> 'a hash - - val add: Remanent_parameters_sig.parameters ->Exception.method_handler -> key -> 'a -> int -> 'a hash -> Exception.method_handler * 'a hash - - val overwrite: Remanent_parameters_sig.parameters ->Exception.method_handler -> key -> 'a -> int -> 'a hash -> Exception.method_handler * 'a hash - - val add_or_overwrite:Remanent_parameters_sig.parameters ->Exception.method_handler -> key -> 'a -> int -> 'a hash -> Exception.method_handler * 'a hash - - val find_option: Remanent_parameters_sig.parameters -> Exception.method_handler -> key -> 'a hash -> Exception.method_handler * (int*'a) option - - val find_option_without_logs: Remanent_parameters_sig.parameters -> Exception.method_handler -> key -> 'a hash -> Exception.method_handler * (int*'a) option - - val find_option_log_on_the_fly: key -> 'a hash -> (int*'a) option - - val iter: (key -> 'a -> int -> unit) -> 'a hash -> unit - - val fold: (key -> 'b -> int -> 'a -> 'a) -> 'b hash -> 'a -> 'a + val create : int -> 'a hash + + val add : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a -> + int -> + 'a hash -> + Exception.method_handler * 'a hash + + val overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a -> + int -> + 'a hash -> + Exception.method_handler * 'a hash + + val add_or_overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a -> + int -> + 'a hash -> + Exception.method_handler * 'a hash + + val find_option : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a hash -> + Exception.method_handler * (int * 'a) option + + val find_option_without_logs : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + 'a hash -> + Exception.method_handler * (int * 'a) option + + val find_option_log_on_the_fly : key -> 'a hash -> (int * 'a) option + val iter : (key -> 'a -> int -> unit) -> 'a hash -> unit + val fold : (key -> 'b -> int -> 'a -> 'a) -> 'b hash -> 'a -> 'a end - -module Hash_of_Ord: - functor (O:SetMap.OrderedType) -> Hash with type key= O.t +module Hash_of_Ord : functor (O : SetMap.OrderedType) -> + Hash with type key = O.t diff --git a/core/KaSa_rep/more_datastructures/int_storage.ml b/core/KaSa_rep/more_datastructures/int_storage.ml index 6432541ef9..70cd847dff 100644 --- a/core/KaSa_rep/more_datastructures/int_storage.ml +++ b/core/KaSa_rep/more_datastructures/int_storage.ml @@ -15,294 +15,355 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type ('a,'b) unary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> Exception.method_handler * 'b -type ('a,'b,'c) binary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler * 'c -type ('a,'b,'c,'d) ternary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> 'c -> Exception.method_handler * 'd -type ('a,'b,'c,'d,'e) quaternary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> 'c -> 'd -> Exception.method_handler * 'e -type ('a,'b,'c,'d,'e,'f,'g) sexternary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> Exception.method_handler * 'g - -type 'a unary_no_output = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> Exception.method_handler -type ('a,'b) binary_no_output = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler - -module type Storage = -sig +type ('a, 'b) unary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + Exception.method_handler * 'b + +type ('a, 'b, 'c) binary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * 'c + +type ('a, 'b, 'c, 'd) ternary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'd + +type ('a, 'b, 'c, 'd, 'e) quaternary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + 'd -> + Exception.method_handler * 'e + +type ('a, 'b, 'c, 'd, 'e, 'f, 'g) sexternary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + 'd -> + 'e -> + 'f -> + Exception.method_handler * 'g + +type 'a unary_no_output = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + Exception.method_handler + +type ('a, 'b) binary_no_output = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler + +module type Storage = sig type 'a t type key type dimension - val create: (dimension,'a t) unary - val create_biggest_key: (key, 'a t) unary - val expand_and_copy: ('a t,dimension,'a t) binary - val init: (dimension, (key, 'a) unary, 'a t) binary - val set: (key,'a,'a t,'a t) ternary - val free: (key,'a t,'a t) binary - val get: (key,'a t,'a option) binary - val unsafe_get: (key,'a t,'a option) binary - val dimension: ('a t, dimension) unary - val print: ('a unary_no_output,'a t) binary_no_output - val key_list: ('a t, key list) unary - val iter:((key,'a) binary_no_output, 'a t) binary_no_output - val fold_with_interruption: ((key,'a,'b,'b) ternary,'a t,'b,'b) ternary - val fold: ((key,'a,'b,'b) ternary,'a t,'b,'b) ternary - val fold2: ((key,'a,'c,'c) ternary,(key,'b,'c,'c) ternary, - (key,'a,'b,'c,'c) quaternary,'a t,'b t, 'c, 'c) sexternary - val fold2_common: ((key,'a,'b,'c,'c) quaternary,'a t,'b t, 'c, 'c) quaternary - val for_all: ((key,'a,bool) binary,'a t,bool) binary - - val free_all: ('a t,'a t) unary + val create : (dimension, 'a t) unary + val create_biggest_key : (key, 'a t) unary + val expand_and_copy : ('a t, dimension, 'a t) binary + val init : (dimension, (key, 'a) unary, 'a t) binary + val set : (key, 'a, 'a t, 'a t) ternary + val free : (key, 'a t, 'a t) binary + val get : (key, 'a t, 'a option) binary + val unsafe_get : (key, 'a t, 'a option) binary + val dimension : ('a t, dimension) unary + val print : ('a unary_no_output, 'a t) binary_no_output + val key_list : ('a t, key list) unary + val iter : ((key, 'a) binary_no_output, 'a t) binary_no_output + val fold_with_interruption : ((key, 'a, 'b, 'b) ternary, 'a t, 'b, 'b) ternary + val fold : ((key, 'a, 'b, 'b) ternary, 'a t, 'b, 'b) ternary + + val fold2 : + ( (key, 'a, 'c, 'c) ternary, + (key, 'b, 'c, 'c) ternary, + (key, 'a, 'b, 'c, 'c) quaternary, + 'a t, + 'b t, + 'c, + 'c ) + sexternary + + val fold2_common : + ((key, 'a, 'b, 'c, 'c) quaternary, 'a t, 'b t, 'c, 'c) quaternary + + val for_all : ((key, 'a, bool) binary, 'a t, bool) binary + val free_all : ('a t, 'a t) unary end -let invalid_arg parameters mh pos exn value = +let invalid_arg parameters mh pos exn value = Exception.warn parameters mh pos exn value -module Int_storage_imperatif = - (struct - type key = int - type dimension = int - type 'a t = - { - array:('a option) array ; - size:int ; - } - - let dimension _ error a = error, a.size - - let key_list _paremeters error t = - let size = t.size in - let array = t.array in - let rec aux k sol = - if k<0 then error,sol - else - match array.(k) with - | None -> aux (k-1) sol - | Some _ -> aux (k-1) (k::sol) - in aux size [] - - let rec create parameters error size = - if size < 0 - then - let error,array = create parameters error 0 in - invalid_arg parameters error __POS__ Exit array - else - error, - { - array = Array.make (size+1) None; - size = size; - } - - let create_biggest_key parameters error x = create parameters error x - - let expand_and_copy parameters error array size = - let error,dimension = dimension parameters error array in - if dimension < size - then - let error,array' = create parameters error size in - let _ = Array.blit array.array 0 array'.array 0 dimension in - error,array' - else - error,{array = Array.sub array.array 0 size ; size = size} - - let set parameters error key value array = - if key>array.size || key<0 - then - let () = Printf.fprintf stdout "%i %i" key array.size in - invalid_arg parameters error __POS__ Exit array - else - let _ = array.array.(key)<-Some value in - error, array - - let init parameters error size f = - if size < 0 - then - let error, array = create parameters error 0 in - invalid_arg parameters error __POS__ Exit array - else - let error, array = create parameters error size in - let rec aux k error array = - if k>size then error,array - else - let error, value = f parameters error k in - let error, array = set parameters error k value array in - aux (k+1) error array - in - aux 0 error array - - let get parameters error key array = - if key>array.size || key<0 then +module Int_storage_imperatif : + Storage with type key = int and type dimension = int = struct + type key = int + type dimension = int + type 'a t = { array: 'a option array; size: int } + + let dimension _ error a = error, a.size + + let key_list _paremeters error t = + let size = t.size in + let array = t.array in + let rec aux k sol = + if k < 0 then + error, sol + else ( + match array.(k) with + | None -> aux (k - 1) sol + | Some _ -> aux (k - 1) (k :: sol) + ) + in + aux size [] + + let rec create parameters error size = + if size < 0 then ( + let error, array = create parameters error 0 in + invalid_arg parameters error __POS__ Exit array + ) else + error, { array = Array.make (size + 1) None; size } + + let create_biggest_key parameters error x = create parameters error x + + let expand_and_copy parameters error array size = + let error, dimension = dimension parameters error array in + if dimension < size then ( + let error, array' = create parameters error size in + let _ = Array.blit array.array 0 array'.array 0 dimension in + error, array' + ) else + error, { array = Array.sub array.array 0 size; size } + + let set parameters error key value array = + if key > array.size || key < 0 then ( + let () = Printf.fprintf stdout "%i %i" key array.size in + invalid_arg parameters error __POS__ Exit array + ) else ( + let _ = array.array.(key) <- Some value in + error, array + ) + + let init parameters error size f = + if size < 0 then ( + let error, array = create parameters error 0 in + invalid_arg parameters error __POS__ Exit array + ) else ( + let error, array = create parameters error size in + let rec aux k error array = + if k > size then + error, array + else ( + let error, value = f parameters error k in + let error, array = set parameters error k value array in + aux (k + 1) error array + ) + in + aux 0 error array + ) + + let get parameters error key array = + if key > array.size || key < 0 then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "130:%i\n" key + in + invalid_arg parameters error __POS__ Exit None + ) else ( + match array.array.(key) with + | None -> let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "130:%i\n" key + "133:%i\n" key in invalid_arg parameters error __POS__ Exit None - else - match array.array.(key) with - | None -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "133:%i\n" key - in invalid_arg parameters error __POS__ Exit None - | a -> error,a - - let free parameters error key array = - if key>array.size || key<0 then - let error, _ = invalid_arg parameters error __POS__ Exit None in - error, array - else + | a -> error, a + ) + + let free parameters error key array = + if key > array.size || key < 0 then ( + let error, _ = invalid_arg parameters error __POS__ Exit None in + error, array + ) else ( match array.array.(key) with | None -> let error, _ = invalid_arg parameters error __POS__ Exit None in error, array | _ -> - let () = array.array.(key)<-None in + let () = array.array.(key) <- None in error, array - - - let unsafe_get _parameters error key array = - if key>array.size || key<0 then - error,None - else - error,array.array.(key) - - let print parameters error print_elt array = - let rec aux i error = - if i>array.size then error - else - let error = - match array.array.(i) with - | None -> error - | Some elt -> - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s%d:" (Remanent_parameters.get_prefix parameters) i in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let parameters = Remanent_parameters.update_prefix parameters - ((string_of_int i)^":") in - let error = print_elt parameters error elt in - error - in aux (i+1) error - in aux 0 error - - let iter parameter error f t = - let size = t.size in - let array = t.array in - let rec aux k error = - if k>size then error - else - match array.(k) with - | None -> - aux (k+1) error - | Some x -> - aux (k+1) (f parameter error k x) - in - aux 0 error - - let fold parameter error f t init = - let size = t.size in - let array = t.array in - let rec aux k remanent = - if k>size then remanent - else - match array.(k) with - | None -> - aux (k+1) remanent - | Some x -> - let error,sol = remanent in - aux (k+1) (f parameter error k x sol) - in - aux 0 (error,init) - - let for_all parameter error f t = - let size = t.size in - let array = t.array in - let rec aux k error = - if k>size then error, true - else - match array.(k) with - | None -> - aux (k+1) error - | Some x -> - let error, bool = f parameter error k x in - if bool - then - aux (k+1) error - else - error, false - in - aux 0 error - - let fold_with_interruption parameter error f t init = - let size = t.size in - let array = t.array in - let rec aux k remanent = - if k>size then remanent - else - match array.(k) with - | None -> - aux (k+1) remanent - | Some x -> - let error,sol = remanent in - let output_opt = - try - Some (f parameter error k x sol) - with - Sys.Break -> None + ) + + let unsafe_get _parameters error key array = + if key > array.size || key < 0 then + error, None + else + error, array.array.(key) + + let print parameters error print_elt array = + let rec aux i error = + if i > array.size then + error + else ( + let error = + match array.array.(i) with + | None -> error + | Some elt -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%d:" + (Remanent_parameters.get_prefix parameters) + i in - match - output_opt - with - | None -> remanent - | Some a -> aux (k+1) a - in - aux 0 (error,init) - - let fold2_common parameter error f t1 t2 init = - let size = min t1.size t2.size in - let array1 = t1.array in - let array2 = t2.array in - let rec aux k remanent = - if k>size then remanent - else - match array1.(k),array2.(k) with - | None,_ | _,None -> aux (k+1) remanent - | Some x1,Some x2 -> - let error,sol = remanent in - aux (k+1) (f parameter error k x1 x2 sol) - in - aux 0 (error,init) - - let fold2 - parameter error f g h t1 t2 init = - let size = min t1.size t2.size in - let array1 = t1.array in - let array2 = t2.array in - let rec aux k remanent = - if k>size then remanent - else - let error,sol = remanent in - match array1.(k),array2.(k) with - | Some x1,None -> aux (k+1) (f parameter error k x1 sol) - | None,Some x2 -> aux (k+1) (g parameter error k x2 sol) - | Some x1,Some x2 -> - aux (k+1) (h parameter error k x1 x2 sol) - | None, None -> aux (k+1) (error, sol) - in - aux 0 (error,init) - - let free_all parameter error t = - fold parameter error - (fun parameter error a _ t -> free parameter error a t) - t t - - - end:Storage with type key = int and type dimension = int) + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let parameters = + Remanent_parameters.update_prefix parameters + (string_of_int i ^ ":") + in + let error = print_elt parameters error elt in + error + in + aux (i + 1) error + ) + in + aux 0 error + + let iter parameter error f t = + let size = t.size in + let array = t.array in + let rec aux k error = + if k > size then + error + else ( + match array.(k) with + | None -> aux (k + 1) error + | Some x -> aux (k + 1) (f parameter error k x) + ) + in + aux 0 error + + let fold parameter error f t init = + let size = t.size in + let array = t.array in + let rec aux k remanent = + if k > size then + remanent + else ( + match array.(k) with + | None -> aux (k + 1) remanent + | Some x -> + let error, sol = remanent in + aux (k + 1) (f parameter error k x sol) + ) + in + aux 0 (error, init) + + let for_all parameter error f t = + let size = t.size in + let array = t.array in + let rec aux k error = + if k > size then + error, true + else ( + match array.(k) with + | None -> aux (k + 1) error + | Some x -> + let error, bool = f parameter error k x in + if bool then + aux (k + 1) error + else + error, false + ) + in + aux 0 error + + let fold_with_interruption parameter error f t init = + let size = t.size in + let array = t.array in + let rec aux k remanent = + if k > size then + remanent + else ( + match array.(k) with + | None -> aux (k + 1) remanent + | Some x -> + let error, sol = remanent in + let output_opt = + try Some (f parameter error k x sol) with Sys.Break -> None + in + (match output_opt with + | None -> remanent + | Some a -> aux (k + 1) a) + ) + in + aux 0 (error, init) + + let fold2_common parameter error f t1 t2 init = + let size = min t1.size t2.size in + let array1 = t1.array in + let array2 = t2.array in + let rec aux k remanent = + if k > size then + remanent + else ( + match array1.(k), array2.(k) with + | None, _ | _, None -> aux (k + 1) remanent + | Some x1, Some x2 -> + let error, sol = remanent in + aux (k + 1) (f parameter error k x1 x2 sol) + ) + in + aux 0 (error, init) + + let fold2 parameter error f g h t1 t2 init = + let size = min t1.size t2.size in + let array1 = t1.array in + let array2 = t2.array in + let rec aux k remanent = + if k > size then + remanent + else ( + let error, sol = remanent in + match array1.(k), array2.(k) with + | Some x1, None -> aux (k + 1) (f parameter error k x1 sol) + | None, Some x2 -> aux (k + 1) (g parameter error k x2 sol) + | Some x1, Some x2 -> aux (k + 1) (h parameter error k x1 x2 sol) + | None, None -> aux (k + 1) (error, sol) + ) + in + aux 0 (error, init) + + let free_all parameter error t = + fold parameter error + (fun parameter error a _ t -> free parameter error a t) + t t +end module Nearly_infinite_arrays = - functor (Basic:Storage with type dimension = int and type key = int) -> - (struct +functor + (Basic : Storage with type dimension = int and type key = int) + -> + ( + struct type dimension = Basic.dimension type key = Basic.key type 'a t = 'a Basic.t @@ -313,35 +374,34 @@ module Nearly_infinite_arrays = let key_list = Basic.key_list let expand parameters error array = - let error,old_dimension = dimension parameters error array in - if old_dimension = Sys.max_array_length - then + let error, old_dimension = dimension parameters error array in + if old_dimension = Sys.max_array_length then invalid_arg parameters error __POS__ Exit array else Basic.expand_and_copy parameters error array - (max 1 (min Sys.max_array_length (2*old_dimension))) + (max 1 (min Sys.max_array_length (2 * old_dimension))) let get = Basic.get let unsafe_get = Basic.unsafe_get let expand_and_copy = Basic.expand_and_copy let init = Basic.init let free = Basic.free + let rec set parameters error key value array = - let error,dimension = dimension parameters error array in - if key>=dimension - then - let error,array' = expand parameters error array in - if array == array' - then + let error, dimension = dimension parameters error array in + if key >= dimension then ( + let error, array' = expand parameters error array in + if array == array' then invalid_arg parameters error __POS__ Exit array else set parameters error key value array' - else + ) else Basic.set parameters error key value array let print = Basic.print - (* let print_var_f = Basic.print_var_f - let print_site_f = Basic.print_site_f*) + + (* let print_var_f = Basic.print_var_f + let print_site_f = Basic.print_site_f*) let iter = Basic.iter let fold = Basic.fold let fold2 = Basic.fold2 @@ -349,265 +409,246 @@ module Nearly_infinite_arrays = let fold2_common = Basic.fold2_common let for_all = Basic.for_all let free_all = Basic.free_all - end:Storage with type key = int and type dimension = int) + end : + Storage with type key = int and type dimension = int) module Extend = - functor (Extension:Storage) -> - functor (Underlying:Storage) -> - (struct - +functor + (Extension : Storage) + (Underlying : Storage) + -> + ( + struct type dimension = Extension.dimension * Underlying.dimension - type key = Extension.key * Underlying.key - - type 'a t = - { - matrix : 'a Underlying.t Extension.t ; - dimension : dimension; - } + type 'a t = { matrix: 'a Underlying.t Extension.t; dimension: dimension } let create parameters error dimension = - let error,matrix = Extension.create parameters error (fst dimension) in - error, - { - matrix = matrix; - dimension = dimension ; - } + let error, matrix = Extension.create parameters error (fst dimension) in + error, { matrix; dimension } let create_biggest_key parameters error key = - let error,matrix = Extension.create_biggest_key parameters error (fst key) in - let error,matrix' = Underlying.create_biggest_key parameters error (snd key) in - let error,dimension = Extension.dimension parameters error matrix in - let error,dimension' = Underlying.dimension parameters error matrix' in - error, - {matrix = matrix; - dimension = (dimension,dimension')} + let error, matrix = + Extension.create_biggest_key parameters error (fst key) + in + let error, matrix' = + Underlying.create_biggest_key parameters error (snd key) + in + let error, dimension = Extension.dimension parameters error matrix in + let error, dimension' = Underlying.dimension parameters error matrix' in + error, { matrix; dimension = dimension, dimension' } let key_list parameters error t = - let error,ext_list = Extension.key_list parameters error t.matrix in + let error, ext_list = Extension.key_list parameters error t.matrix in List.fold_left - (fun (error,list) key -> - let error,t2 = Extension.get parameters error key t.matrix in - match t2 with - | None -> invalid_arg parameters error __POS__ Exit list - | Some t2 -> - let error,l2 = Underlying.key_list parameters error t2 in - error, - List.fold_left - (fun list key2 -> (key,key2)::list) - list - (List.rev l2)) - (error,[]) - (List.rev ext_list) + (fun (error, list) key -> + let error, t2 = Extension.get parameters error key t.matrix in + match t2 with + | None -> invalid_arg parameters error __POS__ Exit list + | Some t2 -> + let error, l2 = Underlying.key_list parameters error t2 in + ( error, + List.fold_left + (fun list key2 -> (key, key2) :: list) + list (List.rev l2) )) + (error, []) (List.rev ext_list) let expand_and_copy parameters error array _dimension = invalid_arg parameters error __POS__ Exit array - let init parameters error dim f = + let init parameters error dim f = let error, array = - Extension.init parameters error (fst dim) - (fun p e i -> - Underlying.init p e (snd dim) (fun p' e' j -> f p' e' (i,j))) + Extension.init parameters error (fst dim) (fun p e i -> + Underlying.init p e (snd dim) (fun p' e' j -> f p' e' (i, j))) in - error, - { - matrix = array; - dimension = dim - } - - let set parameters error (i,j) value array = - let error,old_underlying = Extension.unsafe_get parameters error i array.matrix in - let error,old_underlying = + error, { matrix = array; dimension = dim } + + let set parameters error (i, j) value array = + let error, old_underlying = + Extension.unsafe_get parameters error i array.matrix + in + let error, old_underlying = match old_underlying with - | Some old_underlying -> error,old_underlying + | Some old_underlying -> error, old_underlying | None -> Underlying.create parameters error (snd array.dimension) in - let error,new_underlying = Underlying.set parameters error j value old_underlying in - let error,new_matrix = Extension.set parameters error i new_underlying array.matrix in + let error, new_underlying = + Underlying.set parameters error j value old_underlying + in + let error, new_matrix = + Extension.set parameters error i new_underlying array.matrix + in (* let ordered = ordered && Extension.ordered new_matrix in*) - error,{array with matrix = new_matrix} + error, { array with matrix = new_matrix } - let get parameters error (i,j) array = - let error,underlying = Extension.get parameters error i array.matrix in + let get parameters error (i, j) array = + let error, underlying = Extension.get parameters error i array.matrix in match underlying with | Some underlying -> Underlying.get parameters error j underlying - | None -> invalid_arg parameters error __POS__ Exit None + | None -> invalid_arg parameters error __POS__ Exit None - let unsafe_get parameters error (i,j) array = - let error,underlying = Extension.unsafe_get parameters error i array.matrix in + let unsafe_get parameters error (i, j) array = + let error, underlying = + Extension.unsafe_get parameters error i array.matrix + in match underlying with | Some underlying -> Underlying.unsafe_get parameters error j underlying - | _ -> error,None - - let free parameters error (i,j) array = - let error,old_underlying = Extension.unsafe_get parameters error i array.matrix in + | _ -> error, None - match old_underlying with - | None -> - let error, _ = invalid_arg parameters error __POS__ Exit None in - error, array - | Some old_underlying -> - let error,new_underlying = Underlying.free parameters error j old_underlying in - let error,new_matrix = Extension.set parameters error i - new_underlying array.matrix in - error,{array with matrix = new_matrix} - - let dimension _ error a = error,a.dimension + let free parameters error (i, j) array = + let error, old_underlying = + Extension.unsafe_get parameters error i array.matrix + in + match old_underlying with + | None -> + let error, _ = invalid_arg parameters error __POS__ Exit None in + error, array + | Some old_underlying -> + let error, new_underlying = + Underlying.free parameters error j old_underlying + in + let error, new_matrix = + Extension.set parameters error i new_underlying array.matrix + in + error, { array with matrix = new_matrix } + + let dimension _ error a = error, a.dimension let print parameters error print_of a = - Extension.print - parameters - error + Extension.print parameters error (fun p error -> Underlying.print p error print_of) a.matrix - (* let print_var_f error print_of parameters a = - Extension.print error - (fun error -> Underlying.print error print_of) - parameters - a.matrix + (* let print_var_f error print_of parameters a = + Extension.print error + (fun error -> Underlying.print error print_of) + parameters + a.matrix - let print_site_f error print_of parameters a = - Extension.print error - (fun error -> Underlying.print error print_of) - parameters - a.matrix*) + let print_site_f error print_of parameters a = + Extension.print error + (fun error -> Underlying.print error print_of) + parameters + a.matrix*) let iter parameter error f a = - Extension.iter - parameter - error + Extension.iter parameter error (fun parameter error k a -> - Underlying.iter - parameter - error - (fun parameter error k' a' -> f parameter error (k,k') a') - a - ) + Underlying.iter parameter error + (fun parameter error k' a' -> f parameter error (k, k') a') + a) a.matrix let for_all parameter error f a = - Extension.for_all - parameter error + Extension.for_all parameter error (fun parameter error k a -> - Underlying.for_all - parameter error - (fun parameter error k' a' -> - f parameter error (k,k') a') - a) + Underlying.for_all parameter error + (fun parameter error k' a' -> f parameter error (k, k') a') + a) a.matrix - let fold_gen fold1 fold2 parameter error f a b = - fold1 - parameter - error + let fold_gen fold1 fold2 parameter error f a b = + fold1 parameter error (fun parameter error k a b -> - fold2 - parameter - error - (fun parameter error k' a' b -> f parameter error (k,k') a' b) - a - b - ) - a.matrix - b + fold2 parameter error + (fun parameter error k' a' b -> f parameter error (k, k') a' b) + a b) + a.matrix b + + let fold parameter error f a b = + fold_gen Extension.fold Underlying.fold parameter error f a b - let fold parameter error f a b = fold_gen Extension.fold Underlying.fold parameter error f a b - let fold_with_interruption parameter error f a b = fold_gen Extension.fold_with_interruption Underlying.fold_with_interruption parameter error f a b + let fold_with_interruption parameter error f a b = + fold_gen Extension.fold_with_interruption + Underlying.fold_with_interruption parameter error f a b let fold2_common parameter error f a b c = - fold - parameter - error + fold parameter error (fun parameter error k a c -> - let error,get = unsafe_get parameter error k b in - match get with - | None -> (error,c) - | Some b -> f parameter error k a b c) - a - c + let error, get = unsafe_get parameter error k b in + match get with + | None -> error, c + | Some b -> f parameter error k a b c) + a c let fold2 parameter error f g h a b c = let error, c = - fold - parameter - error + fold parameter error (fun parameter error k a c -> - let error,get = unsafe_get parameter error k b in - match get with - | None -> f parameter error k a c - | Some b -> h parameter error k a b c) - a - c + let error, get = unsafe_get parameter error k b in + match get with + | None -> f parameter error k a c + | Some b -> h parameter error k a b c) + a c in - fold - parameter - error + fold parameter error (fun parameter error k b c -> - let error,get = unsafe_get parameter error k a in - match get with - | None -> g parameter error k b c - | Some _ -> error, c) - b - c + let error, get = unsafe_get parameter error k a in + match get with + | None -> g parameter error k b c + | Some _ -> error, c) + b c let free_all parameter error t = fold parameter error (fun parameter error a _ t -> free parameter error a t) t t - - end:Storage with type key = Extension.key * Underlying.key and type dimension = Extension.dimension * Underlying.dimension ) - + end : + Storage + with type key = Extension.key * Underlying.key + and type dimension = Extension.dimension * Underlying.dimension) module Quick_key_list = - functor (Basic:Storage) -> - (struct +functor + (Basic : Storage) + -> + ( + struct type dimension = Basic.dimension type key = Basic.key - type 'a t = - { - basic: 'a Basic.t ; - keys: key list - } + type 'a t = { basic: 'a Basic.t; keys: key list } let create parameters error i = - let error,basic = Basic.create parameters error i in - error,{basic = basic ; keys = []} + let error, basic = Basic.create parameters error i in + error, { basic; keys = [] } let create_biggest_key parameters error key = - let error,basic = Basic.create_biggest_key parameters error key in - error,{basic = basic ; keys = []} + let error, basic = Basic.create_biggest_key parameters error key in + error, { basic; keys = [] } - let key_list _parameters error t = error,t.keys + let key_list _parameters error t = error, t.keys let expand_and_copy parameters error array j = - let error, basic = Basic.expand_and_copy parameters error array.basic j in - error,{basic = basic ; keys = array.keys} + let error, basic = + Basic.expand_and_copy parameters error array.basic j + in + error, { basic; keys = array.keys } let init parameters error n f = let error, basic = Basic.init parameters error n f in let error, keys = Basic.fold parameters error - (fun _ e k _ list -> e,k::list) + (fun _ e k _ list -> e, k :: list) basic [] in - error, {basic = basic; keys = keys} + error, { basic; keys } let set parameters error key value array = - let error,old = Basic.unsafe_get parameters error key array.basic in + let error, old = Basic.unsafe_get parameters error key array.basic in let new_array = match old with | Some _ -> array - | None -> {array with keys = key::array.keys} + | None -> { array with keys = key :: array.keys } + in + let error, new_basic = + Basic.set parameters error key value new_array.basic in - let error,new_basic = Basic.set parameters error key value new_array.basic in - error, {new_array with basic = new_basic} + error, { new_array with basic = new_basic } let free parameters error key array = let error, basic = Basic.free parameters error key array.basic in - error, {array with basic = basic} - + error, { array with basic } let get parameters error key array = Basic.get parameters error key array.basic @@ -615,143 +656,126 @@ module Quick_key_list = let unsafe_get parameters error key array = Basic.unsafe_get parameters error key array.basic - let dimension parameters error a = Basic.dimension parameters error a.basic + let dimension parameters error a = + Basic.dimension parameters error a.basic let print error f parameters a = Basic.print error f parameters a.basic - (* let print_var_f error f parameters a = - Basic.print_var_f error f parameters a.basic + (* let print_var_f error f parameters a = + Basic.print_var_f error f parameters a.basic - let print_site_f error f parameters a = - Basic.print_site_f error f parameters a.basic*) + let print_site_f error f parameters a = + Basic.print_site_f error f parameters a.basic*) let iter parameters error f a = - let error,list = key_list parameters error a in + let error, list = key_list parameters error a in List.fold_left (fun error k -> - let error,im = get parameters error k a in - match im with - | None -> - let error,_ = invalid_arg parameters error __POS__ - Exit () in error - | Some im -> f parameters error k im) + let error, im = get parameters error k a in + match im with + | None -> + let error, _ = invalid_arg parameters error __POS__ Exit () in + error + | Some im -> f parameters error k im) error (List.rev list) let fold parameters error f a b = - let error,list = key_list parameters error a in + let error, list = key_list parameters error a in List.fold_left - (fun (error,b) k -> - let error,im = get parameters error k a in - match im with - | None -> invalid_arg parameters error __POS__ Exit b - | Some im -> f parameters error k im b) - (error,b) - (List.rev list) + (fun (error, b) k -> + let error, im = get parameters error k a in + match im with + | None -> invalid_arg parameters error __POS__ Exit b + | Some im -> f parameters error k im b) + (error, b) (List.rev list) let for_all parameters error f a = - let error,list = key_list parameters error a in + let error, list = key_list parameters error a in let rec aux l error = match l with | [] -> error, true - | h::t -> - begin - match - get parameters error h a - with - | error, None -> - let error, () = Exception.warn parameters error __POS__ Exit () in + | h :: t -> + (match get parameters error h a with + | error, None -> + let error, () = Exception.warn parameters error __POS__ Exit () in + aux t error + | error, Some data -> + let error, bool = f parameters error h data in + if bool then aux t error - | error, Some data -> - let error, bool = f parameters error h data in - if bool then - aux t error - else - error, false - end + else + error, false) in aux list error let free_all parameter error t = let error, t = fold parameter error - (fun parameter error a _ t -> free parameter error a t) - t t + (fun parameter error a _ t -> free parameter error a t) + t t in - error, {t with keys = []} + error, { t with keys = [] } let fold_with_interruption parameters error f a b = - let error,list = key_list parameters error a in + let error, list = key_list parameters error a in let rec aux list output = - match - list - with + match list with | [] -> output - | head::tail -> + | head :: tail -> let output_opt = try - let error,im = get parameters error head a in + let error, im = get parameters error head a in let b = snd output in match im with - | None -> - Some (invalid_arg parameters error __POS__ Exit b) + | None -> Some (invalid_arg parameters error __POS__ Exit b) | Some im -> Some (f parameters error head im b) with Sys.Break -> None in - match - output_opt - with + (match output_opt with | None -> output - | Some output -> aux tail output - in aux list (error,b) + | Some output -> aux tail output) + in + aux list (error, b) let fold2_common parameter error f a b c = - fold - parameter - error + fold parameter error (fun parameter error k a c -> - let error,get = unsafe_get parameter error k b in - match get with - | None -> (error,c) - | Some b -> f parameter error k a b c) - a - c + let error, get = unsafe_get parameter error k b in + match get with + | None -> error, c + | Some b -> f parameter error k a b c) + a c let fold2 parameter error f g h a b c = let error, c = - fold - parameter - error + fold parameter error (fun parameter error k a c -> - let error,get = unsafe_get parameter error k b in - match get with - | None -> f parameter error k a c - | Some b -> h parameter error k a b c) - a - c + let error, get = unsafe_get parameter error k b in + match get with + | None -> f parameter error k a c + | Some b -> h parameter error k a b c) + a c in - fold - parameter - error + fold parameter error (fun parameter error k b c -> - let error,get = unsafe_get parameter error k a in - match get with - | None -> g parameter error k b c - | Some _ -> error, c) - b - c - - end:Storage with type key = Basic.key and type dimension = Basic.dimension) + let error, get = unsafe_get parameter error k a in + match get with + | None -> g parameter error k b c + | Some _ -> error, c) + b c + end : + Storage with type key = Basic.key and type dimension = Basic.dimension) module Nearly_inf_Imperatif = Nearly_infinite_arrays (Int_storage_imperatif) - module Quick_Nearly_inf_Imperatif = Quick_key_list (Nearly_inf_Imperatif) module Int_Int_storage_Imperatif_Imperatif = - Extend (Int_storage_imperatif)(Int_storage_imperatif) + Extend (Int_storage_imperatif) (Int_storage_imperatif) module Nearly_Inf_Int_Int_storage_Imperatif_Imperatif = - Extend (Quick_Nearly_inf_Imperatif)(Quick_Nearly_inf_Imperatif) + Extend (Quick_Nearly_inf_Imperatif) (Quick_Nearly_inf_Imperatif) module Nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif = - Extend (Quick_Nearly_inf_Imperatif) - (Extend (Quick_Nearly_inf_Imperatif)(Quick_Nearly_inf_Imperatif)) + Extend + (Quick_Nearly_inf_Imperatif) + (Extend (Quick_Nearly_inf_Imperatif) (Quick_Nearly_inf_Imperatif)) diff --git a/core/KaSa_rep/more_datastructures/int_storage.mli b/core/KaSa_rep/more_datastructures/int_storage.mli index 6badf64ba3..dfdc78a202 100644 --- a/core/KaSa_rep/more_datastructures/int_storage.mli +++ b/core/KaSa_rep/more_datastructures/int_storage.mli @@ -15,97 +15,134 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type ('a,'b) unary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> Exception.method_handler * 'b -type ('a,'b,'c) binary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler * 'c -type ('a,'b,'c,'d) ternary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> 'c -> Exception.method_handler * 'd -type ('a,'b,'c,'d,'e) quaternary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> 'c -> 'd -> Exception.method_handler * 'e -type ('a,'b,'c,'d,'e,'f,'g) sexternary = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> Exception.method_handler * 'g - -type 'a unary_no_output = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> Exception.method_handler -type ('a,'b) binary_no_output = Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler - - -module type Storage = -sig +type ('a, 'b) unary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + Exception.method_handler * 'b + +type ('a, 'b, 'c) binary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * 'c + +type ('a, 'b, 'c, 'd) ternary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'd + +type ('a, 'b, 'c, 'd, 'e) quaternary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + 'd -> + Exception.method_handler * 'e + +type ('a, 'b, 'c, 'd, 'e, 'f, 'g) sexternary = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + 'd -> + 'e -> + 'f -> + Exception.method_handler * 'g + +type 'a unary_no_output = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + Exception.method_handler + +type ('a, 'b) binary_no_output = + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler + +module type Storage = sig type 'a t type key type dimension - val create: (dimension,'a t) unary - val create_biggest_key: (key,'a t) unary - - val expand_and_copy: ('a t,dimension,'a t) binary - val init: (dimension, (key, 'a) unary, 'a t) binary - val set: (key,'a,'a t,'a t) ternary - val free: (key,'a t,'a t) binary - val get: (key,'a t,'a option) binary - val unsafe_get: (key,'a t,'a option) binary - val dimension: ('a t, dimension) unary - val print: ('a unary_no_output,'a t) binary_no_output - val key_list: ('a t, key list) unary - val iter:((key,'a) binary_no_output, 'a t) binary_no_output - val fold_with_interruption: ((key,'a,'b,'b) ternary,'a t,'b,'b) ternary - val fold: ((key,'a,'b,'b) ternary,'a t,'b,'b) ternary - val fold2: ((key,'a,'c,'c) ternary,(key,'b,'c,'c) ternary, - (key,'a,'b,'c,'c) quaternary,'a t,'b t, 'c, 'c) sexternary - val fold2_common: ((key,'a,'b,'c,'c) quaternary,'a t,'b t, 'c, 'c) quaternary - - val for_all: ((key,'a,bool) binary,'a t,bool) binary - val free_all: ('a t,'a t) unary + val create : (dimension, 'a t) unary + val create_biggest_key : (key, 'a t) unary + val expand_and_copy : ('a t, dimension, 'a t) binary + val init : (dimension, (key, 'a) unary, 'a t) binary + val set : (key, 'a, 'a t, 'a t) ternary + val free : (key, 'a t, 'a t) binary + val get : (key, 'a t, 'a option) binary + val unsafe_get : (key, 'a t, 'a option) binary + val dimension : ('a t, dimension) unary + val print : ('a unary_no_output, 'a t) binary_no_output + val key_list : ('a t, key list) unary + val iter : ((key, 'a) binary_no_output, 'a t) binary_no_output + val fold_with_interruption : ((key, 'a, 'b, 'b) ternary, 'a t, 'b, 'b) ternary + val fold : ((key, 'a, 'b, 'b) ternary, 'a t, 'b, 'b) ternary + + val fold2 : + ( (key, 'a, 'c, 'c) ternary, + (key, 'b, 'c, 'c) ternary, + (key, 'a, 'b, 'c, 'c) quaternary, + 'a t, + 'b t, + 'c, + 'c ) + sexternary + + val fold2_common : + ((key, 'a, 'b, 'c, 'c) quaternary, 'a t, 'b t, 'c, 'c) quaternary + + val for_all : ((key, 'a, bool) binary, 'a t, bool) binary + val free_all : ('a t, 'a t) unary end (** Cartesian product *) -module Extend - (Extension:Storage) - (Underlying:Storage) : +module Extend (Extension : Storage) (Underlying : Storage) : Storage - with type key = Extension.key * Underlying.key - and type dimension = Extension.dimension * Underlying.dimension + with type key = Extension.key * Underlying.key + and type dimension = Extension.dimension * Underlying.dimension (** also record the list of key, for more efficient fold/iter *) -module Quick_key_list - (Basic:Storage) : - Storage - with type key = Basic.key - and type dimension = Basic.dimension +module Quick_key_list (Basic : Storage) : + Storage with type key = Basic.key and type dimension = Basic.dimension (** simple array implementation *) -module Int_storage_imperatif: +module Int_storage_imperatif : Storage with type key = int and type dimension = int (** expandable arrays (the size is still limited by max_int *) -module Nearly_infinite_arrays : - (Storage with type dimension = int and type key = int) -> - Storage with type key = int and type dimension = int - - +module Nearly_infinite_arrays : functor + (_ : Storage with type dimension = int and type key = int) + -> Storage with type key = int and type dimension = int (** expandable 1-dim array *) -module Nearly_inf_Imperatif: - Storage - with type key = int - and type dimension = int +module Nearly_inf_Imperatif : + Storage with type key = int and type dimension = int (** expandable 1-dim array with sparse fold/iter *) -module Quick_Nearly_inf_Imperatif: - Storage - with type key = int - and type dimension = int +module Quick_Nearly_inf_Imperatif : + Storage with type key = int and type dimension = int (** 2-dim matrices with sparse fold/iter *) -module Int_Int_storage_Imperatif_Imperatif: - Storage - with type key = int * int - and type dimension = int * int +module Int_Int_storage_Imperatif_Imperatif : + Storage with type key = int * int and type dimension = int * int (** 2-dim expandable matrices *) -module Nearly_Inf_Int_Int_storage_Imperatif_Imperatif: - Storage - with type key = int * int - and type dimension = int * int +module Nearly_Inf_Int_Int_storage_Imperatif_Imperatif : + Storage with type key = int * int and type dimension = int * int (** 3-dim expandable matrices *) -module Nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif: +module Nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif : Storage - with type key = int * (int * int) - and type dimension = int * (int * int) + with type key = int * (int * int) + and type dimension = int * (int * int) diff --git a/core/KaSa_rep/more_datastructures/map_wrapper.ml b/core/KaSa_rep/more_datastructures/map_wrapper.ml index ba28922e25..7e06807057 100644 --- a/core/KaSa_rep/more_datastructures/map_wrapper.ml +++ b/core/KaSa_rep/more_datastructures/map_wrapper.ml @@ -2,261 +2,523 @@ Time-stamp: *) -module type Set_with_logs = -sig +module type Set_with_logs = sig type elt type t - val empty: t - val is_empty: t -> bool - val singleton: elt -> t - val is_singleton: t -> bool - - - val add: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - val add_when_not_in: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - - val remove: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - - val minus: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val union: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val disjoint_union: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val inter: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val diff: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val cardinal: t -> int - - val mem: elt -> t -> bool - val exists: (elt -> bool) -> t -> bool - val filter: (elt -> bool) -> t -> t - val for_all: (elt -> bool) -> t -> bool - val partition: (elt -> bool) -> t -> t * t - - val compare: t -> t -> int - val equal: t -> t -> bool - val subset: t -> t -> bool - - val iter: (elt -> unit) -> t -> unit - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - val fold_inv: (elt -> 'a -> 'a) -> t -> 'a -> 'a - - val elements: t -> elt list - - val choose: t -> elt option - val min_elt: t -> elt option - val max_elt: t -> elt option + val empty : t + val is_empty : t -> bool + val singleton : elt -> t + val is_singleton : t -> bool + + val add : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val add_when_not_in : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val remove : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val minus : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val disjoint_union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val inter : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val diff : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val cardinal : t -> int + val mem : elt -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val for_all : (elt -> bool) -> t -> bool + val partition : (elt -> bool) -> t -> t * t + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val fold_inv : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val elements : t -> elt list + val choose : t -> elt option + val min_elt : t -> elt option + val max_elt : t -> elt option end -module type Map_with_logs = -sig +module type Map_with_logs = sig type elt type set type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val min_elt: 'a t -> (elt * 'a) option - val mem: (elt -> 'a t -> bool) - - val find_option: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a option - val find_default: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> elt -> 'a t -> Exception.method_handler * 'a - val find_default_without_logs: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> elt -> 'a t -> Exception.method_handler * 'a - val find_option_without_logs: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a option - - val add: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'a t -> Exception.method_handler * 'a t - val overwrite: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'a t -> Exception.method_handler * 'a t - val add_or_overwrite: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'a t -> Exception.method_handler * 'a t - - val remove: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a t - val remove_or_not: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a t - - val update: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t - - val map2: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler * 'c) -> 'a t -> 'b t -> Exception.method_handler * 'c t - val map2z: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'a -> Exception.method_handler * 'a) -> 'a t -> 'a t -> Exception.method_handler * 'a t - - val fold2z: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> 'c -> (Exception.method_handler * 'c)) -> 'a t -> 'b t -> 'c -> Exception.method_handler * 'c - - val fold2: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'c -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'b -> 'c -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> 'c -> Exception.method_handler * 'c) -> 'a t -> 'b t -> 'c -> Exception.method_handler * 'c - - val fold2_sparse: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> 'c -> (Exception.method_handler * 'c)) -> 'a t -> 'b t -> 'c -> Exception.method_handler * 'c - - val iter2_sparse: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> Exception.method_handler )-> 'a t -> 'b t -> Exception.method_handler - - val diff: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t * 'a t - val diff_pred: Remanent_parameters_sig.parameters -> Exception.method_handler -> ('a -> 'a -> bool) -> 'a t -> 'a t -> Exception.method_handler * 'a t * 'a t - - val merge: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t - - val union: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t - - val fold_restriction: Remanent_parameters_sig.parameters -> Exception.method_handler -> (elt -> 'a -> (Exception.method_handler * 'b) -> (Exception.method_handler * 'b)) -> set -> 'a t -> 'b -> Exception.method_handler * 'b - val fold_restriction_with_missing_associations: Remanent_parameters_sig.parameters -> Exception.method_handler -> (elt -> 'a -> (Exception.method_handler * 'b) -> (Exception.method_handler * 'b)) -> (elt -> (Exception.method_handler * 'b) -> (Exception.method_handler * 'b)) -> set -> 'a t -> 'b -> Exception.method_handler * 'b - - val iter: (elt -> 'a -> unit) -> 'a t -> unit - - val iter2: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> Exception.method_handler ) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'b -> Exception.method_handler ) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> Exception.method_handler )-> 'a t -> 'b t -> Exception.method_handler - - val fold: (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val mapi: (elt -> 'a -> 'b) -> 'a t -> 'b t - - val map: ('a -> 'b) -> 'a t -> 'b t - - val for_all: (elt -> 'a -> bool) -> 'a t -> bool - - val filter_one: (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option - - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - + val empty : 'a t + val is_empty : 'a t -> bool + val min_elt : 'a t -> (elt * 'a) option + val mem : elt -> 'a t -> bool + + val find_option : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a option + + val find_default : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + elt -> + 'a t -> + Exception.method_handler * 'a + + val find_default_without_logs : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + elt -> + 'a t -> + Exception.method_handler * 'a + + val find_option_without_logs : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a option + + val add : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'a t -> + Exception.method_handler * 'a t + + val overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'a t -> + Exception.method_handler * 'a t + + val add_or_overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'a t -> + Exception.method_handler * 'a t + + val remove : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a t + + val remove_or_not : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a t + + val update : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val map2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + Exception.method_handler * 'c t + + val map2z : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'a -> + Exception.method_handler * 'a) -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val fold2z : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + Exception.method_handler * 'c + + val fold2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'c -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + Exception.method_handler * 'c + + val fold2_sparse : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + Exception.method_handler * 'c + + val iter2_sparse : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + Exception.method_handler) -> + 'a t -> + 'b t -> + Exception.method_handler + + val diff : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t * 'a t + + val diff_pred : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> bool) -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t * 'a t + + val merge : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val fold_restriction : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (elt -> + 'a -> + Exception.method_handler * 'b -> + Exception.method_handler * 'b) -> + set -> + 'a t -> + 'b -> + Exception.method_handler * 'b + + val fold_restriction_with_missing_associations : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (elt -> + 'a -> + Exception.method_handler * 'b -> + Exception.method_handler * 'b) -> + (elt -> Exception.method_handler * 'b -> Exception.method_handler * 'b) -> + set -> + 'a t -> + 'b -> + Exception.method_handler * 'b + + val iter : (elt -> 'a -> unit) -> 'a t -> unit + + val iter2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + Exception.method_handler) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'b -> + Exception.method_handler) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + Exception.method_handler) -> + 'a t -> + 'b t -> + Exception.method_handler + + val fold : (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val mapi : (elt -> 'a -> 'b) -> 'a t -> 'b t + val map : ('a -> 'b) -> 'a t -> 'b t + val for_all : (elt -> 'a -> bool) -> 'a t -> bool + val filter_one : (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val bindings : 'a t -> (elt * 'a) list - val of_json: - ?lab_key:string -> ?lab_value:string -> ?error_msg:string -> + val of_json : + ?lab_key:string -> + ?lab_value:string -> + ?error_msg:string -> (Yojson.Basic.t -> elt) -> (Yojson.Basic.t -> 'value) -> - Yojson.Basic.t -> 'value t + Yojson.Basic.t -> + 'value t - val to_json: - ?lab_key:string -> ?lab_value:string -> + val to_json : + ?lab_key:string -> + ?lab_value:string -> (elt -> Yojson.Basic.t) -> ('value -> Yojson.Basic.t) -> - 'value t -> Yojson.Basic.t - + 'value t -> + Yojson.Basic.t end module type S_with_logs = sig type elt + module Set : Set_with_logs with type elt = elt module Map : Map_with_logs with type elt = elt and type set = Set.t end let lift f = f Exception.wrap -module Make (S_both: (SetMap.S)): S_with_logs - with type elt = S_both.elt - and type 'a Map.t= 'a S_both.Map.t - and type Set.t = S_both.Set.t = - (struct - type elt = S_both.elt +module Make (S_both : SetMap.S) : + S_with_logs + with type elt = S_both.elt + and type 'a Map.t = 'a S_both.Map.t + and type Set.t = S_both.Set.t = struct + type elt = S_both.elt - module Set = - (struct - type elt=S_both.elt - type t=S_both.Set.t - let empty = S_both.Set.empty - let is_empty = S_both.Set.is_empty - let singleton = S_both.Set.singleton - let is_singleton = S_both.Set.is_singleton - let add = lift S_both.Set.add_with_logs - let add_when_not_in p e x s = - let e,_,s = (lift S_both.Set.add_while_testing_freshness) p e x s in - e,s - let remove = lift S_both.Set.remove_with_logs - let union = lift S_both.Set.union_with_logs - let disjoint_union = lift S_both.Set.disjoint_union_with_logs - let inter = lift S_both.Set.inter_with_logs - let diff = lift S_both.Set.diff_with_logs - let minus = lift S_both.Set.minus_with_logs - let cardinal = S_both.Set.size - let mem = S_both.Set.mem - let exists = S_both.Set.exists - let filter = S_both.Set.filter - let for_all = S_both.Set.for_all - let partition = S_both.Set.partition - let compare = S_both.Set.compare - let equal = S_both.Set.equal - let subset = S_both.Set.subset - let iter = S_both.Set.iter - let fold = S_both.Set.fold - let fold_inv = S_both.Set.fold_inv - let elements = S_both.Set.elements - let choose = S_both.Set.choose - let min_elt = S_both.Set.min_elt - let max_elt = S_both.Set.max_elt - end:Set_with_logs with type elt = S_both.elt and type t = S_both.Set.t) - - module Map= - (struct - type elt=S_both.elt - type set=S_both.Set.t - type +'data t = 'data S_both.Map.t - - let empty = S_both.Map.empty - let is_empty = S_both.Map.is_empty - let min_elt = S_both.Map.min_elt - let mem = S_both.Map.mem - let find_option a b c d = lift S_both.Map.find_option_with_logs a b c d - let find_default a b c d = lift S_both.Map.find_default_with_logs a b c d - let find_option_without_logs _a b c d = b,S_both.Map.find_option c d - let find_default_without_logs _a b c d e = b,S_both.Map.find_default c d e - let add a b c d = lift S_both.Map.add_with_logs a b c d - let overwrite parameter error c d e = - let error, bool, map = - lift S_both.Map.add_while_testing_freshness parameter error c d e - in - if bool - then - Exception.warn - parameter error __POS__ - ~message:"attempt to overwrite an association that does not exist" - (Failure "Attempt to overwrite an association that does not exist") - map - else - error, map - let add_or_overwrite a b c d e = - let error, _, map = lift S_both.Map.add_while_testing_freshness a b c d e in - error, map - - let remove a b c d = lift S_both.Map.remove_with_logs a b c d - let remove_or_not a b c d = - let error, _, map = lift S_both.Map.remove_while_testing_existence a b c d in - error,map - - - let update a b c = lift S_both.Map.update_with_logs a b c - let map2 a b c = lift S_both.Map.map2_with_logs a b c - let map2z a b c = lift S_both.Map.map2z_with_logs a b c - let fold2z a b c = lift S_both.Map.fold2z_with_logs a b c - let fold2 a b c = lift S_both.Map.fold2_with_logs a b c - let iter2 parameter error f g h mapf mapg = - fst (S_both.Map.fold2_with_logs - Exception.wrap - parameter error - (fun a b c d () -> f a b c d,()) - (fun a b c d () -> g a b c d,()) - (fun a b c d e () -> h a b c d e,()) - - mapf mapg ()) - - let fold2_sparse a b c = lift S_both.Map.fold2_sparse_with_logs a b c - let iter2_sparse a b c = lift S_both.Map.iter2_sparse_with_logs a b c - let diff a b c = lift S_both.Map.diff_with_logs a b c - let diff_pred a b c = lift S_both.Map.diff_pred_with_logs a b c - let merge a b c = lift S_both.Map.merge_with_logs a b c - let union a b c = lift S_both.Map.union_with_logs a b c - let fold_restriction a b c = lift S_both.Map.fold_restriction_with_logs a b c - let fold_restriction_with_missing_associations a b c = - lift S_both.Map.fold_restriction_with_missing_associations_with_logs a b c - let iter = S_both.Map.iter - let fold = S_both.Map.fold - let mapi = S_both.Map.mapi - let map = S_both.Map.map - let for_all = S_both.Map.for_all - let filter_one = S_both.Map.filter_one - let compare = S_both.Map.compare - let equal = S_both.Map.equal - let bindings = S_both.Map.bindings - let to_json = S_both.Map.to_json - let of_json = S_both.Map.of_json - - end:Map_with_logs + module Set : + Set_with_logs with type elt = S_both.elt and type t = S_both.Set.t = struct + type elt = S_both.elt + type t = S_both.Set.t + + let empty = S_both.Set.empty + let is_empty = S_both.Set.is_empty + let singleton = S_both.Set.singleton + let is_singleton = S_both.Set.is_singleton + let add = lift S_both.Set.add_with_logs + + let add_when_not_in p e x s = + let e, _, s = (lift S_both.Set.add_while_testing_freshness) p e x s in + e, s + + let remove = lift S_both.Set.remove_with_logs + let union = lift S_both.Set.union_with_logs + let disjoint_union = lift S_both.Set.disjoint_union_with_logs + let inter = lift S_both.Set.inter_with_logs + let diff = lift S_both.Set.diff_with_logs + let minus = lift S_both.Set.minus_with_logs + let cardinal = S_both.Set.size + let mem = S_both.Set.mem + let exists = S_both.Set.exists + let filter = S_both.Set.filter + let for_all = S_both.Set.for_all + let partition = S_both.Set.partition + let compare = S_both.Set.compare + let equal = S_both.Set.equal + let subset = S_both.Set.subset + let iter = S_both.Set.iter + let fold = S_both.Set.fold + let fold_inv = S_both.Set.fold_inv + let elements = S_both.Set.elements + let choose = S_both.Set.choose + let min_elt = S_both.Set.min_elt + let max_elt = S_both.Set.max_elt + end + + module Map : + Map_with_logs with type elt = S_both.elt and type 'a t = 'a S_both.Map.t and type set = S_both.Set.t - and type set = Set.t) - end) + and type set = Set.t = struct + type elt = S_both.elt + type set = S_both.Set.t + type +'data t = 'data S_both.Map.t + + let empty = S_both.Map.empty + let is_empty = S_both.Map.is_empty + let min_elt = S_both.Map.min_elt + let mem = S_both.Map.mem + let find_option a b c d = lift S_both.Map.find_option_with_logs a b c d + let find_default a b c d = lift S_both.Map.find_default_with_logs a b c d + let find_option_without_logs _a b c d = b, S_both.Map.find_option c d + let find_default_without_logs _a b c d e = b, S_both.Map.find_default c d e + let add a b c d = lift S_both.Map.add_with_logs a b c d + + let overwrite parameter error c d e = + let error, bool, map = + lift S_both.Map.add_while_testing_freshness parameter error c d e + in + if bool then + Exception.warn parameter error __POS__ + ~message:"attempt to overwrite an association that does not exist" + (Failure "Attempt to overwrite an association that does not exist") + map + else + error, map + + let add_or_overwrite a b c d e = + let error, _, map = + lift S_both.Map.add_while_testing_freshness a b c d e + in + error, map + + let remove a b c d = lift S_both.Map.remove_with_logs a b c d + + let remove_or_not a b c d = + let error, _, map = + lift S_both.Map.remove_while_testing_existence a b c d + in + error, map + + let update a b c = lift S_both.Map.update_with_logs a b c + let map2 a b c = lift S_both.Map.map2_with_logs a b c + let map2z a b c = lift S_both.Map.map2z_with_logs a b c + let fold2z a b c = lift S_both.Map.fold2z_with_logs a b c + let fold2 a b c = lift S_both.Map.fold2_with_logs a b c + + let iter2 parameter error f g h mapf mapg = + fst + (S_both.Map.fold2_with_logs Exception.wrap parameter error + (fun a b c d () -> f a b c d, ()) + (fun a b c d () -> g a b c d, ()) + (fun a b c d e () -> h a b c d e, ()) + mapf mapg ()) + + let fold2_sparse a b c = lift S_both.Map.fold2_sparse_with_logs a b c + let iter2_sparse a b c = lift S_both.Map.iter2_sparse_with_logs a b c + let diff a b c = lift S_both.Map.diff_with_logs a b c + let diff_pred a b c = lift S_both.Map.diff_pred_with_logs a b c + let merge a b c = lift S_both.Map.merge_with_logs a b c + let union a b c = lift S_both.Map.union_with_logs a b c + + let fold_restriction a b c = + lift S_both.Map.fold_restriction_with_logs a b c + + let fold_restriction_with_missing_associations a b c = + lift S_both.Map.fold_restriction_with_missing_associations_with_logs a b c + + let iter = S_both.Map.iter + let fold = S_both.Map.fold + let mapi = S_both.Map.mapi + let map = S_both.Map.map + let for_all = S_both.Map.for_all + let filter_one = S_both.Map.filter_one + let compare = S_both.Map.compare + let equal = S_both.Map.equal + let bindings = S_both.Map.bindings + let to_json = S_both.Map.to_json + let of_json = S_both.Map.of_json + end +end module type Projection = sig type elt_a @@ -266,153 +528,172 @@ module type Projection = sig type set_a type set_b - - val proj_map: + val proj_map : (elt_a -> elt_b) -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> 'b -> ('b -> 'a -> 'b) -> 'a map_a -> Exception.method_handler * 'b map_b - val monadic_proj_map: - (Remanent_parameters_sig.parameters -> Exception.method_handler -> - elt_a -> Exception.method_handler * elt_b) -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> + val monadic_proj_map : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> 'b -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> 'a -> - Exception.method_handler * 'b) -> - 'a map_a -> Exception.method_handler * 'b map_b - - val monadic_proj_map_i: - (Remanent_parameters_sig.parameters -> Exception.method_handler -> - elt_a -> Exception.method_handler * elt_b) -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> 'b -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> elt_a -> 'a -> - Exception.method_handler * 'b) -> - 'a map_a -> Exception.method_handler * 'b map_b - - - val proj_set: - (elt_a -> elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_b - - val monadic_proj_set: - (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt_a -> Exception.method_handler * elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_b - - val partition_set: - (elt_a -> elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_a map_b + 'a -> + Exception.method_handler * 'b) -> + 'a map_a -> + Exception.method_handler * 'b map_b - val monadic_partition_set: - (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt_a -> Exception.method_handler * elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_a map_b + val monadic_proj_map_i : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + elt_a -> + 'a -> + Exception.method_handler * 'b) -> + 'a map_a -> + Exception.method_handler * 'b map_b + val proj_set : + (elt_a -> elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_b + + val monadic_proj_set : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_b + + val partition_set : + (elt_a -> elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_a map_b + + val monadic_partition_set : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_a map_b end -module Proj(A:S_with_logs)(B:S_with_logs) = - (struct - module MA=A.Map - module MB=B.Map - module SA=A.Set - module SB=B.Set - type elt_a = MA.elt - type elt_b = MB.elt - type set_a = SA.t - type set_b = SB.t - type 'a map_a = 'a MA.t - type 'a map_b = 'a MB.t - - let proj_map f parameter error identity_elt merge map = - MA.fold - (fun key_a data_a (error,map_b) -> - let key_b = f key_a in - match - MB.find_option_without_logs parameter error key_b map_b - with - | error,None -> MB.add_or_overwrite parameter error key_b (merge identity_elt data_a) map_b - | error,Some old -> MB.add_or_overwrite parameter error key_b (merge old data_a) map_b - ) - map - (error,MB.empty) - - let monadic_proj_map_i f parameter error identity_elt merge map = - MA.fold - (fun key_a data_a (error,map_b) -> - let error,key_b = f parameter error key_a in - match - MB.find_option_without_logs parameter error key_b map_b - with - | error,None -> - let error,data' = merge parameter error identity_elt key_a data_a in - MB.add_or_overwrite parameter error key_b data' map_b - | error,Some old -> - let error,data' = merge parameter error old key_a data_a in - MB.add_or_overwrite parameter error key_b data' map_b - ) - map - (error,MB.empty) - - let monadic_proj_map f parameter error identity_elt merge map = - monadic_proj_map_i f parameter error identity_elt - (fun parameter error old _ data_a -> - merge parameter error old data_a) - map - - let partition_set f parameter error set = - SA.fold - (fun key_a (error,map_b) -> - let key_b = f key_a in - match - MB.find_option_without_logs parameter error key_b map_b - with - | error,None -> - MB.add_or_overwrite parameter error key_b (SA.singleton key_a) map_b - | error,Some old -> - let error, newset = SA.add parameter error key_a old in - MB.add_or_overwrite parameter error key_b newset map_b - ) - set - (error,MB.empty) - - let monadic_partition_set f parameter error set = - SA.fold - (fun key_a (error,map_b) -> - let error,key_b = f parameter error key_a in - match - MB.find_option_without_logs parameter error key_b map_b - with - | error,None -> - let error,data' = error, SA.singleton key_a in - MB.add_or_overwrite parameter error key_b data' map_b - | error,Some old -> - let error,data' = SA.add_when_not_in parameter error key_a old in - MB.add_or_overwrite parameter error key_b data' map_b - ) - set - (error,MB.empty) - - let proj_set f parameter error set_a = - SA.fold - (fun key_a (error,set_b) -> - SB.add_when_not_in parameter error - (f key_a) set_b) - set_a - (error, SB.empty) - - let monadic_proj_set f parameter error set_a = - SA.fold - (fun key_a (error,set_b) -> - let error, key_b = f parameter error key_a in - SB.add_when_not_in parameter error key_b set_b) - set_a - (error, SB.empty) - - end: Projection - with type elt_a = A.elt - and type elt_b = B.elt - and type 'a map_a = 'a A.Map.t - and type 'a map_b = 'a B.Map.t - and type set_a = A.Set.t - and type set_b = B.Set.t) +module Proj (A : S_with_logs) (B : S_with_logs) : + Projection + with type elt_a = A.elt + and type elt_b = B.elt + and type 'a map_a = 'a A.Map.t + and type 'a map_b = 'a B.Map.t + and type set_a = A.Set.t + and type set_b = B.Set.t = struct + module MA = A.Map + module MB = B.Map + module SA = A.Set + module SB = B.Set + + type elt_a = MA.elt + type elt_b = MB.elt + type set_a = SA.t + type set_b = SB.t + type 'a map_a = 'a MA.t + type 'a map_b = 'a MB.t + + let proj_map f parameter error identity_elt merge map = + MA.fold + (fun key_a data_a (error, map_b) -> + let key_b = f key_a in + match MB.find_option_without_logs parameter error key_b map_b with + | error, None -> + MB.add_or_overwrite parameter error key_b + (merge identity_elt data_a) + map_b + | error, Some old -> + MB.add_or_overwrite parameter error key_b (merge old data_a) map_b) + map (error, MB.empty) + + let monadic_proj_map_i f parameter error identity_elt merge map = + MA.fold + (fun key_a data_a (error, map_b) -> + let error, key_b = f parameter error key_a in + match MB.find_option_without_logs parameter error key_b map_b with + | error, None -> + let error, data' = merge parameter error identity_elt key_a data_a in + MB.add_or_overwrite parameter error key_b data' map_b + | error, Some old -> + let error, data' = merge parameter error old key_a data_a in + MB.add_or_overwrite parameter error key_b data' map_b) + map (error, MB.empty) + + let monadic_proj_map f parameter error identity_elt merge map = + monadic_proj_map_i f parameter error identity_elt + (fun parameter error old _ data_a -> merge parameter error old data_a) + map + + let partition_set f parameter error set = + SA.fold + (fun key_a (error, map_b) -> + let key_b = f key_a in + match MB.find_option_without_logs parameter error key_b map_b with + | error, None -> + MB.add_or_overwrite parameter error key_b (SA.singleton key_a) map_b + | error, Some old -> + let error, newset = SA.add parameter error key_a old in + MB.add_or_overwrite parameter error key_b newset map_b) + set (error, MB.empty) + + let monadic_partition_set f parameter error set = + SA.fold + (fun key_a (error, map_b) -> + let error, key_b = f parameter error key_a in + match MB.find_option_without_logs parameter error key_b map_b with + | error, None -> + let error, data' = error, SA.singleton key_a in + MB.add_or_overwrite parameter error key_b data' map_b + | error, Some old -> + let error, data' = SA.add_when_not_in parameter error key_a old in + MB.add_or_overwrite parameter error key_b data' map_b) + set (error, MB.empty) + + let proj_set f parameter error set_a = + SA.fold + (fun key_a (error, set_b) -> + SB.add_when_not_in parameter error (f key_a) set_b) + set_a (error, SB.empty) + + let monadic_proj_set f parameter error set_a = + SA.fold + (fun key_a (error, set_b) -> + let error, key_b = f parameter error key_a in + SB.add_when_not_in parameter error key_b set_b) + set_a (error, SB.empty) +end module type Projection2 = sig type elt_a @@ -422,91 +703,95 @@ module type Projection2 = sig type 'a map_b type 'a map_c - val proj2: - Remanent_parameters_sig.parameters -> Exception.method_handler -> + val proj2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> (elt_a -> elt_b) -> (elt_a -> elt_c) -> 'b -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> 'a -> 'b) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + 'a -> + 'b) -> 'a map_a -> Exception.method_handler * 'b map_c map_b - val proj2_monadic: - Remanent_parameters_sig.parameters -> Exception.method_handler -> + val proj2_monadic : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> 'mvbdu_handler -> (elt_a -> elt_b) -> (elt_a -> elt_c) -> 'b -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'mvbdu_handler -> 'b -> 'a -> - Exception.method_handler * 'mvbdu_handler * 'b) -> - 'a map_a -> Exception.method_handler * 'mvbdu_handler * 'b map_c map_b + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'mvbdu_handler -> + 'b -> + 'a -> + Exception.method_handler * 'mvbdu_handler * 'b) -> + 'a map_a -> + Exception.method_handler * 'mvbdu_handler * 'b map_c map_b end -module Proj2(A:S_with_logs)(B:S_with_logs)(C:S_with_logs) = - (struct - module MA=A.Map - module MB=B.Map - module MC=C.Map - type elt_a = MA.elt - type elt_b = MB.elt - type elt_c = MC.elt - type 'a map_a = 'a MA.t - type 'a map_b = 'a MB.t - type 'a map_c = 'a MC.t - - let proj2 parameter error f g identity_elt merge map = - MA.fold - (fun key_a data_a (error, map_b) -> - let key_b = f key_a in - let key_c = g key_a in - let error, submap = - MB.find_default_without_logs parameter error MC.empty key_b map_b - in - let error, find_default = - MC.find_default_without_logs parameter error identity_elt - key_c submap - in - let error, submap = - MC.add parameter error - key_c - (merge parameter error find_default - data_a) - submap - in - MB.add_or_overwrite parameter error key_b submap map_b - ) - map - (error, MB.empty) - - let proj2_monadic parameter handler mvbdu_handler f g identity_elt merge map = - MA.fold - (fun key_a data_a (handler, mvbdu_handler, map_b) -> - let key_b = f key_a in - let key_c = g key_a in - let handler, submap = - MB.find_default_without_logs parameter handler MC.empty key_b map_b - in - let handler, find_default = - MC.find_default_without_logs parameter handler identity_elt key_c submap - in - let handler, mvbdu_handler, data' = - merge parameter handler mvbdu_handler - find_default - data_a - in - let handler, submap = MC.add parameter handler key_c data' submap - in - let handler, add = - MB.add_or_overwrite parameter handler key_b submap map_b - in - handler, mvbdu_handler, add) - map - (handler, mvbdu_handler, MB.empty) - - end: Projection2 - with type elt_a = A.elt - and type elt_b = B.elt - and type elt_c = C.elt - and type 'a map_a = 'a A.Map.t - and type 'a map_b = 'a B.Map.t - and type 'a map_c = 'a C.Map.t) +module Proj2 (A : S_with_logs) (B : S_with_logs) (C : S_with_logs) : + Projection2 + with type elt_a = A.elt + and type elt_b = B.elt + and type elt_c = C.elt + and type 'a map_a = 'a A.Map.t + and type 'a map_b = 'a B.Map.t + and type 'a map_c = 'a C.Map.t = struct + module MA = A.Map + module MB = B.Map + module MC = C.Map + + type elt_a = MA.elt + type elt_b = MB.elt + type elt_c = MC.elt + type 'a map_a = 'a MA.t + type 'a map_b = 'a MB.t + type 'a map_c = 'a MC.t + + let proj2 parameter error f g identity_elt merge map = + MA.fold + (fun key_a data_a (error, map_b) -> + let key_b = f key_a in + let key_c = g key_a in + let error, submap = + MB.find_default_without_logs parameter error MC.empty key_b map_b + in + let error, find_default = + MC.find_default_without_logs parameter error identity_elt key_c submap + in + let error, submap = + MC.add parameter error key_c + (merge parameter error find_default data_a) + submap + in + MB.add_or_overwrite parameter error key_b submap map_b) + map (error, MB.empty) + + let proj2_monadic parameter handler mvbdu_handler f g identity_elt merge map = + MA.fold + (fun key_a data_a (handler, mvbdu_handler, map_b) -> + let key_b = f key_a in + let key_c = g key_a in + let handler, submap = + MB.find_default_without_logs parameter handler MC.empty key_b map_b + in + let handler, find_default = + MC.find_default_without_logs parameter handler identity_elt key_c + submap + in + let handler, mvbdu_handler, data' = + merge parameter handler mvbdu_handler find_default data_a + in + let handler, submap = MC.add parameter handler key_c data' submap in + let handler, add = + MB.add_or_overwrite parameter handler key_b submap map_b + in + handler, mvbdu_handler, add) + map + (handler, mvbdu_handler, MB.empty) +end diff --git a/core/KaSa_rep/more_datastructures/map_wrapper.mli b/core/KaSa_rep/more_datastructures/map_wrapper.mli index bbf222ed25..1bc3c44cab 100644 --- a/core/KaSa_rep/more_datastructures/map_wrapper.mli +++ b/core/KaSa_rep/more_datastructures/map_wrapper.mli @@ -2,120 +2,398 @@ Time-stamp: *) -module type Set_with_logs = -sig +module type Set_with_logs = sig type elt type t - val empty: t - val is_empty: t -> bool - val singleton: elt -> t - val is_singleton: t -> bool - - - val add: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - val add_when_not_in: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - val remove: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - - val minus: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val union: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val disjoint_union: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val inter: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val diff: Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> t -> Exception.method_handler * t - val cardinal: t -> int - - val mem: elt -> t -> bool - val exists: (elt -> bool) -> t -> bool - val filter: (elt -> bool) -> t -> t - val for_all: (elt -> bool) -> t -> bool - val partition: (elt -> bool) -> t -> t * t - - val compare: t -> t -> int - val equal: t -> t -> bool - val subset: t -> t -> bool - - val iter: (elt -> unit) -> t -> unit - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - val fold_inv: (elt -> 'a -> 'a) -> t -> 'a -> 'a - - val elements: t -> elt list - - val choose: t -> elt option - val min_elt: t -> elt option - val max_elt: t -> elt option + val empty : t + val is_empty : t -> bool + val singleton : elt -> t + val is_singleton : t -> bool + + val add : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val add_when_not_in : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val remove : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val minus : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val disjoint_union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val inter : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val diff : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + t -> + Exception.method_handler * t + + val cardinal : t -> int + val mem : elt -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val for_all : (elt -> bool) -> t -> bool + val partition : (elt -> bool) -> t -> t * t + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val fold_inv : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val elements : t -> elt list + val choose : t -> elt option + val min_elt : t -> elt option + val max_elt : t -> elt option end -module type Map_with_logs = -sig +module type Map_with_logs = sig type elt type set type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val min_elt: 'a t -> (elt * 'a) option - val mem: elt -> 'a t -> bool - val find_option: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a option - val find_default: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> elt -> 'a t -> Exception.method_handler * 'a - val find_default_without_logs: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> elt -> 'a t -> Exception.method_handler * 'a - val find_option_without_logs: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a option - val add: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'a t -> Exception.method_handler * 'a t - val overwrite: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'a t -> Exception.method_handler * 'a t - val add_or_overwrite: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'a t -> Exception.method_handler * 'a t - val remove: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a t - val remove_or_not: Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a t -> Exception.method_handler * 'a t - val update: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t - val map2: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler * 'c) -> 'a t -> 'b t -> Exception.method_handler * 'c t - val map2z: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a -> 'a -> Exception.method_handler * 'a) -> 'a t -> 'a t -> Exception.method_handler * 'a t - val fold2z: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> 'c -> (Exception.method_handler * 'c)) -> 'a t -> 'b t -> 'c -> Exception.method_handler * 'c - val fold2: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'c -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'b -> 'c -> Exception.method_handler * 'c) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> 'c -> Exception.method_handler * 'c) -> 'a t -> 'b t -> 'c -> Exception.method_handler * 'c - - val fold2_sparse: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> 'c -> (Exception.method_handler * 'c)) -> 'a t -> 'b t -> 'c -> Exception.method_handler * 'c - val iter2_sparse: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> Exception.method_handler )-> 'a t -> 'b t -> Exception.method_handler - val diff: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t * 'a t - val diff_pred: Remanent_parameters_sig.parameters -> Exception.method_handler -> ('a -> 'a -> bool) -> 'a t -> 'a t -> Exception.method_handler * 'a t * 'a t - val merge: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t - val union: Remanent_parameters_sig.parameters -> Exception.method_handler -> 'a t -> 'a t -> Exception.method_handler * 'a t - val fold_restriction: Remanent_parameters_sig.parameters -> Exception.method_handler -> (elt -> 'a -> (Exception.method_handler * 'b) -> (Exception.method_handler * 'b)) -> set -> 'a t -> 'b -> Exception.method_handler * 'b - val fold_restriction_with_missing_associations: Remanent_parameters_sig.parameters -> Exception.method_handler -> (elt -> 'a -> (Exception.method_handler * 'b) -> (Exception.method_handler * 'b)) -> (elt -> (Exception.method_handler * 'b) -> (Exception.method_handler * 'b)) -> set -> 'a t -> 'b -> Exception.method_handler * 'b - val iter: (elt -> 'a -> unit) -> 'a t -> unit - val iter2: Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> Exception.method_handler ) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'b -> Exception.method_handler ) -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> 'a -> 'b -> Exception.method_handler )-> 'a t -> 'b t -> Exception.method_handler - val fold: (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val mapi: (elt -> 'a -> 'b) -> 'a t -> 'b t - val map: ('a -> 'b) -> 'a t -> 'b t - val for_all: (elt -> 'a -> bool) -> 'a t -> bool - val filter_one: (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val empty : 'a t + val is_empty : 'a t -> bool + val min_elt : 'a t -> (elt * 'a) option + val mem : elt -> 'a t -> bool + + val find_option : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a option + + val find_default : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + elt -> + 'a t -> + Exception.method_handler * 'a + + val find_default_without_logs : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + elt -> + 'a t -> + Exception.method_handler * 'a + + val find_option_without_logs : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a option + + val add : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'a t -> + Exception.method_handler * 'a t + + val overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'a t -> + Exception.method_handler * 'a t + + val add_or_overwrite : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'a t -> + Exception.method_handler * 'a t + + val remove : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a t + + val remove_or_not : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a t -> + Exception.method_handler * 'a t + + val update : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val map2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + Exception.method_handler * 'c t + + val map2z : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a -> + 'a -> + Exception.method_handler * 'a) -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val fold2z : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + Exception.method_handler * 'c + + val fold2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'c -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + Exception.method_handler * 'c + + val fold2_sparse : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + Exception.method_handler * 'c + + val iter2_sparse : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + Exception.method_handler) -> + 'a t -> + 'b t -> + Exception.method_handler + + val diff : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t * 'a t + + val diff_pred : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + ('a -> 'a -> bool) -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t * 'a t + + val merge : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val union : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'a t -> + 'a t -> + Exception.method_handler * 'a t + + val fold_restriction : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (elt -> + 'a -> + Exception.method_handler * 'b -> + Exception.method_handler * 'b) -> + set -> + 'a t -> + 'b -> + Exception.method_handler * 'b + + val fold_restriction_with_missing_associations : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (elt -> + 'a -> + Exception.method_handler * 'b -> + Exception.method_handler * 'b) -> + (elt -> Exception.method_handler * 'b -> Exception.method_handler * 'b) -> + set -> + 'a t -> + 'b -> + Exception.method_handler * 'b + + val iter : (elt -> 'a -> unit) -> 'a t -> unit + + val iter2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + Exception.method_handler) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'b -> + Exception.method_handler) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + 'a -> + 'b -> + Exception.method_handler) -> + 'a t -> + 'b t -> + Exception.method_handler + + val fold : (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val mapi : (elt -> 'a -> 'b) -> 'a t -> 'b t + val map : ('a -> 'b) -> 'a t -> 'b t + val for_all : (elt -> 'a -> bool) -> 'a t -> bool + val filter_one : (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val bindings : 'a t -> (elt * 'a) list - val of_json: - ?lab_key:string -> ?lab_value:string -> ?error_msg:string -> + + val of_json : + ?lab_key:string -> + ?lab_value:string -> + ?error_msg:string -> (Yojson.Basic.t -> elt) -> (Yojson.Basic.t -> 'value) -> - Yojson.Basic.t -> 'value t + Yojson.Basic.t -> + 'value t - val to_json: - ?lab_key:string -> ?lab_value:string -> + val to_json : + ?lab_key:string -> + ?lab_value:string -> (elt -> Yojson.Basic.t) -> ('value -> Yojson.Basic.t) -> - 'value t -> Yojson.Basic.t + 'value t -> + Yojson.Basic.t end module type S_with_logs = sig type elt + module Set : Set_with_logs with type elt = elt module Map : Map_with_logs with type elt = elt and type set = Set.t end -module Make(S_both:SetMap.S): S_with_logs - with type elt = S_both.elt - and type 'a Map.t = 'a S_both.Map.t - and type Set.t = S_both.Set.t - and type Map.elt = S_both.elt - and type Set.elt = S_both.elt +module Make (S_both : SetMap.S) : + S_with_logs + with type elt = S_both.elt + and type 'a Map.t = 'a S_both.Map.t + and type Set.t = S_both.Set.t + and type Map.elt = S_both.elt + and type Set.elt = S_both.elt module type Projection = sig - type elt_a type elt_b type set_a @@ -123,42 +401,98 @@ module type Projection = sig type 'a map_a type 'a map_b - + val proj_map : + (elt_a -> elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + ('b -> 'a -> 'b) -> + 'a map_a -> + Exception.method_handler * 'b map_b (** proj_map f init merge map is a map mapping each element b to the result of the itteration of the function merge over the image in map of the element a in f such that f(a)=b, starting with the element init. *) - val proj_map: (elt_a -> elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> ('b -> 'a -> 'b) -> 'a map_a -> Exception.method_handler * 'b map_b - - val monadic_proj_map: (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt_a -> Exception.method_handler * elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> 'a -> Exception.method_handler * 'b) -> 'a map_a -> Exception.method_handler * 'b map_b - val monadic_proj_map_i: (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt_a -> Exception.method_handler * elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> elt_a -> 'a -> Exception.method_handler * 'b) -> 'a map_a -> Exception.method_handler * 'b map_b + val monadic_proj_map : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + 'a -> + Exception.method_handler * 'b) -> + 'a map_a -> + Exception.method_handler * 'b map_b + + val monadic_proj_map_i : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + elt_a -> + 'a -> + Exception.method_handler * 'b) -> + 'a map_a -> + Exception.method_handler * 'b map_b + val proj_set : + (elt_a -> elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_b (** proj_set f set is the set \{f(a) | a\in S\} *) - val proj_set: - (elt_a -> elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_b - - val monadic_proj_set: - (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt_a -> Exception.method_handler * elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_b + val monadic_proj_set : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_b + + val partition_set : + (elt_a -> elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_a map_b (** partition_set f set is the map mapping any element b with an antecedent for f in the set set, into the set of its antecedents, ie to the set \{a\in set | f(a)=b\}. *) - val partition_set: - (elt_a -> elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_a map_b - - val monadic_partition_set: - (Remanent_parameters_sig.parameters -> Exception.method_handler -> elt_a -> Exception.method_handler * elt_b) -> Remanent_parameters_sig.parameters -> Exception.method_handler -> set_a -> Exception.method_handler * set_a map_b + val monadic_partition_set : + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt_a -> + Exception.method_handler * elt_b) -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + set_a -> + Exception.method_handler * set_a map_b end -module Proj(A:S_with_logs)(B:S_with_logs) : Projection - with type elt_a = A.elt - and type elt_b = B.elt - and type set_a = A.Set.t - and type set_b = B.Set.t - and type 'a map_a = 'a A.Map.t - and type 'a map_b = 'a B.Map.t +module Proj (A : S_with_logs) (B : S_with_logs) : + Projection + with type elt_a = A.elt + and type elt_b = B.elt + and type set_a = A.Set.t + and type set_b = B.Set.t + and type 'a map_a = 'a A.Map.t + and type 'a map_b = 'a B.Map.t -module type Projection2 = -sig +module type Projection2 = sig type elt_a type elt_b type elt_c @@ -166,29 +500,42 @@ sig type 'a map_b type 'a map_c - val proj2: - Remanent_parameters_sig.parameters -> Exception.method_handler -> + val proj2 : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> (elt_a -> elt_b) -> (elt_a -> elt_c) -> 'b -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'b -> 'a -> 'b) -> + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'b -> + 'a -> + 'b) -> 'a map_a -> Exception.method_handler * 'b map_c map_b - val proj2_monadic: - Remanent_parameters_sig.parameters -> Exception.method_handler -> 'mvbdu_handler -> + val proj2_monadic : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'mvbdu_handler -> (elt_a -> elt_b) -> (elt_a -> elt_c) -> 'b -> - (Remanent_parameters_sig.parameters -> Exception.method_handler -> 'mvbdu_handler -> 'b -> 'a -> - Exception.method_handler * 'mvbdu_handler * 'b) -> - 'a map_a -> Exception.method_handler * 'mvbdu_handler * 'b map_c map_b + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + 'mvbdu_handler -> + 'b -> + 'a -> + Exception.method_handler * 'mvbdu_handler * 'b) -> + 'a map_a -> + Exception.method_handler * 'mvbdu_handler * 'b map_c map_b end -module Proj2 (A:S_with_logs)(B:S_with_logs)(C:S_with_logs) : Projection2 - with type elt_a = A.elt - and type elt_b = B.elt - and type elt_c = C.elt - and type 'a map_a = 'a A.Map.t - and type 'a map_b = 'a B.Map.t - and type 'a map_c = 'a C.Map.t +module Proj2 (A : S_with_logs) (B : S_with_logs) (C : S_with_logs) : + Projection2 + with type elt_a = A.elt + and type elt_b = B.elt + and type elt_c = C.elt + and type 'a map_a = 'a A.Map.t + and type 'a map_b = 'a B.Map.t + and type 'a map_c = 'a C.Map.t diff --git a/core/KaSa_rep/more_datastructures/misc_sa.ml b/core/KaSa_rep/more_datastructures/misc_sa.ml index 1c6abeb7c2..1d0858a2ab 100644 --- a/core/KaSa_rep/more_datastructures/misc_sa.ml +++ b/core/KaSa_rep/more_datastructures/misc_sa.ml @@ -20,62 +20,67 @@ let array_of_list create set parameters error list = let rec aux l k a = match l with | [] -> a - | t::q -> - begin - aux q (k+1) (set parameters (fst a) k t (snd a)) - end - in aux list 0 a + | t :: q -> aux q (k + 1) (set parameters (fst a) k t (snd a)) + in + aux list 0 a -let unsome (error,x) f = +let unsome (error, x) f = match x with | None -> f error - | Some x -> error,x + | Some x -> error, x let rev_inter_list compare l1 l2 = let rec aux l1 l2 rep = - match l1,l2 with - | [],_ | _,[] -> List.rev rep - | a::b,c::d -> - begin - if compare a c = 0 - then aux b d (a::rep) - else if compare a c < 0 - then aux b l2 rep - else aux l1 d rep - end - in aux l1 l2 [] + match l1, l2 with + | [], _ | _, [] -> List.rev rep + | a :: b, c :: d -> + if compare a c = 0 then + aux b d (a :: rep) + else if compare a c < 0 then + aux b l2 rep + else + aux l1 d rep + in + aux l1 l2 [] let trace parameters string = - if parameters.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.trace + if + parameters.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.trace then - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s" parameters.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.prefix (string ()) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s" + parameters.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.prefix (string ()) let inter_list compare l1 l2 = List.rev (rev_inter_list compare l1 l2) let list_0_n k = let rec aux k sol = - if k<0 then sol - else aux (k-1) (k::sol) - in aux k [] + if k < 0 then + sol + else + aux (k - 1) (k :: sol) + in + aux k [] let list_minus l1 l2 = let rec aux l1 l2 rep = - match l1,l2 with - | t1::q1,t2::q2 when t1=t2 -> aux q1 q2 rep - | t1::q1,_ -> aux q1 l2 (t1::rep) - | [],_ -> rep - in List.rev (aux l1 l2 []) + match l1, l2 with + | t1 :: q1, t2 :: q2 when t1 = t2 -> aux q1 q2 rep + | t1 :: q1, _ -> aux q1 l2 (t1 :: rep) + | [], _ -> rep + in + List.rev (aux l1 l2 []) let print_comma parameter bool comma = - if bool then Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" comma + if bool then + Loggers.fprintf (Remanent_parameters.get_logger parameter) "%s" comma let fetch_array i array def = try - begin - match array.(i) - with - | None -> def - | Some i -> i - end - with - | _ -> def + match array.(i) with + | None -> def + | Some i -> i + with _ -> def diff --git a/core/KaSa_rep/more_datastructures/misc_sa.mli b/core/KaSa_rep/more_datastructures/misc_sa.mli index 75af5e782c..9d8aa5e6cf 100644 --- a/core/KaSa_rep/more_datastructures/misc_sa.mli +++ b/core/KaSa_rep/more_datastructures/misc_sa.mli @@ -1,13 +1,17 @@ -val const_unit: 'a -> unit -val array_of_list: -('a -> 'b -> int -> 'c * 'd) -> - ('a -> 'c -> int -> 'e -> 'd -> 'c * 'd) -> - 'a -> 'b -> 'e list -> 'c * 'd +val const_unit : 'a -> unit -val unsome: 'a * 'b option -> ('a -> 'a * 'b) -> 'a * 'b -val trace: Remanent_parameters_sig.parameters -> (unit -> string) -> unit -val inter_list: ('a -> 'b -> int) -> 'a list -> 'b list -> 'a list -val list_0_n: int -> int list -val list_minus: 'a list -> 'a list -> 'a list -val print_comma: Remanent_parameters_sig.parameters -> bool -> string -> unit -val fetch_array: int -> 'a option array -> 'a -> 'a +val array_of_list : + ('a -> 'b -> int -> 'c * 'd) -> + ('a -> 'c -> int -> 'e -> 'd -> 'c * 'd) -> + 'a -> + 'b -> + 'e list -> + 'c * 'd + +val unsome : 'a * 'b option -> ('a -> 'a * 'b) -> 'a * 'b +val trace : Remanent_parameters_sig.parameters -> (unit -> string) -> unit +val inter_list : ('a -> 'b -> int) -> 'a list -> 'b list -> 'a list +val list_0_n : int -> int list +val list_minus : 'a list -> 'a list -> 'a list +val print_comma : Remanent_parameters_sig.parameters -> bool -> string -> unit +val fetch_array : int -> 'a option array -> 'a -> 'a diff --git a/core/KaSa_rep/more_datastructures/tools_kasa.ml b/core/KaSa_rep/more_datastructures/tools_kasa.ml index cef4bd26e4..31e6f69841 100644 --- a/core/KaSa_rep/more_datastructures/tools_kasa.ml +++ b/core/KaSa_rep/more_datastructures/tools_kasa.ml @@ -1,84 +1,74 @@ - let fst_option x = - match x - with - | Some (x,_) -> Some x + match x with + | Some (x, _) -> Some x | _ -> None let snd_option x = - match x - with - | Some (_,x) -> Some x + match x with + | Some (_, x) -> Some x | _ -> None +(* OCaml manual: In particular, if you want a regular expression that + matches a single backslash character, you need to quote it in the + argument to regexp (according to the last item of the list above) by + adding a second backslash. Then you need to quote both backslashes + (according to the syntax of string constants in OCaml) by doubling + them again, so you need to write four backslash characters: Str.regexp + "\\\\". *) (** dot output*) -(* OCaml manual: In particular, if you want a regular expression that -matches a single backslash character, you need to quote it in the -argument to regexp (according to the last item of the list above) by -adding a second backslash. Then you need to quote both backslashes -(according to the syntax of string constants in OCaml) by doubling -them again, so you need to write four backslash characters: Str.regexp -"\\\\". *) let escape_label_in_dot s = Str.global_substitute (Str.regexp "[\\\"\\\\]") - (fun x -> match Str.matched_string x with - | "\"" -> "\\\"" - | "\\" -> "\\\\" - | _ -> assert false) s + (fun x -> + match Str.matched_string x with + | "\"" -> "\\\"" + | "\\" -> "\\\\" + | _ -> assert false) + s let make_id_compatible_with_dot_format parameters error string = let tab = Remanent_parameters.get_make_labels_compatible_with_dot parameters in let rec aux pos l = - if pos<0 - then l - else + if pos < 0 then + l + else ( let char = String.get string pos in match Remanent_parameters_sig.CharMap.find_option char tab with | Some liste_char -> - aux (pos-1) - begin - List.fold_left - (fun list char -> char::list) - l - (List.rev liste_char) - end - | None -> - aux (pos-1) (char::l) + aux (pos - 1) + (List.fold_left + (fun list char -> char :: list) + l (List.rev liste_char)) + | None -> aux (pos - 1) (char :: l) + ) in - let l = aux (String.length string -1) [] in - error, - String.concat "" (List.rev_map (String.make 1) (List.rev l)) - + let l = aux (String.length string - 1) [] in + error, String.concat "" (List.rev_map (String.make 1) (List.rev l)) let sorted_parts_of_list n list = let list = List.sort (fun a b -> compare b a) list in let rec aux k list suffix output = - if k=0 - then - suffix::output - else - match list - with - | h::t -> - aux k t suffix (aux (k-1) t (h::suffix) output) + if k = 0 then + suffix :: output + else ( + match list with + | h :: t -> aux k t suffix (aux (k - 1) t (h :: suffix) output) | [] -> output - in aux n list [] [] + ) + in + aux n list [] [] let sort_list key parameter error list = let error, refined_list = List.fold_left (fun (error, refined_list) a -> - let error, key = - key parameter error a - in - error, (key,a)::refined_list) - (error, []) - list + let error, key = key parameter error a in + error, (key, a) :: refined_list) + (error, []) list in let refined_sorted_list = - List.sort (fun (a,_) (b,_) -> compare b a) refined_list + List.sort (fun (a, _) (b, _) -> compare b a) refined_list in error, List.rev_map snd refined_sorted_list diff --git a/core/KaSa_rep/more_datastructures/tools_kasa.mli b/core/KaSa_rep/more_datastructures/tools_kasa.mli index 14e701147c..89526cfcad 100644 --- a/core/KaSa_rep/more_datastructures/tools_kasa.mli +++ b/core/KaSa_rep/more_datastructures/tools_kasa.mli @@ -1,7 +1,11 @@ -val fst_option: ('a * 'b) option -> 'a option -val snd_option: ('a * 'b) option -> 'b option -val escape_label_in_dot: string -> string -val make_id_compatible_with_dot_format: Remanent_parameters_sig.parameters -> 'a -> string -> 'a * string -val sorted_parts_of_list: int -> 'a list -> 'a list list -val sort_list: ('a -> 'b -> 'c -> 'b * 'd) -> - 'a -> 'b -> 'c list -> 'b * 'c list +val fst_option : ('a * 'b) option -> 'a option +val snd_option : ('a * 'b) option -> 'b option +val escape_label_in_dot : string -> string + +val make_id_compatible_with_dot_format : + Remanent_parameters_sig.parameters -> 'a -> string -> 'a * string + +val sorted_parts_of_list : int -> 'a list -> 'a list list + +val sort_list : + ('a -> 'b -> 'c -> 'b * 'd) -> 'a -> 'b -> 'c list -> 'b * 'c list diff --git a/core/KaSa_rep/more_datastructures/union_find.ml b/core/KaSa_rep/more_datastructures/union_find.ml index 46f07308b9..0da2980715 100644 --- a/core/KaSa_rep/more_datastructures/union_find.ml +++ b/core/KaSa_rep/more_datastructures/union_find.ml @@ -13,52 +13,56 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Union_find = -sig +module type Union_find = sig type key type dimension type t - val create: + + val create : Remanent_parameters_sig.parameters -> Exception.method_handler -> dimension -> Exception.method_handler * t - val union_list: + val union_list : Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> key list -> Exception.method_handler * t - val iteri: + val iteri : Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - key -> key -> Exception.method_handler) -> - t -> Exception.method_handler - - val get_representent: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - key -> - t -> - Exception.method_handler * t * key + Exception.method_handler -> + key -> + key -> + Exception.method_handler) -> + t -> + Exception.method_handler + + val get_representent : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + t -> + Exception.method_handler * t * key end module Make = - functor (Storage:Int_storage.Storage) -> - (* functor (Map: Map_wrapper.Map_with_logs) ->*) - (struct - +functor + (Storage : Int_storage.Storage) + -> + (* functor (Map: Map_wrapper.Map_with_logs) ->*) + ( + struct type key = Storage.key type t = key Storage.t type dimension = Storage.dimension let create parameters error n = - Storage.init parameters error n (fun _ e x -> e,x) - + Storage.init parameters error n (fun _ e x -> e, x) (************************************************************************************) (* findSet(e): which return a pointer to the representative of the set @@ -69,27 +73,19 @@ module Make = let findSet parameter error e t = let pointToRoot parameter error root l t = List.fold_left - (fun (error, t) i -> - Storage.set parameter error i root t) - (error, t) - l + (fun (error, t) i -> Storage.set parameter error i root t) + (error, t) l in let rec helper parameter error e l t = - let error, parent = - Storage.unsafe_get parameter error e t - in - match parent - with - | None -> error, (t,e) - | Some p when p <> e -> - helper parameter error p (e::l) t + let error, parent = Storage.unsafe_get parameter error e t in + match parent with + | None -> error, (t, e) + | Some p when p <> e -> helper parameter error p (e :: l) t | Some p -> - begin - (* base case: we hit the root node make all collected nodes on the - path point to the root. And return the root afterwards *) - let error, t = pointToRoot parameter error p l t in - error, (t, p) - end + (* base case: we hit the root node make all collected nodes on the + path point to the root. And return the root afterwards *) + let error, t = pointToRoot parameter error p l t in + error, (t, p) in helper parameter error e [] t @@ -102,9 +98,7 @@ module Make = let union parameter error x y t = let error, (t, root_x) = findSet parameter error x t in let error, (t, root_y) = findSet parameter error y t in - Storage.set parameter error root_x root_y t - - + Storage.set parameter error root_x root_y t (*let eq_classes_map parameter error a = (* let classes = Cckappa_sig.Site_map_and_set.Map.empty in*) @@ -163,7 +157,7 @@ module Make = (************************************************************************************) (* compute union-find in a list*) - let union_list parameter error a (list: key list) = + let union_list parameter error a (list : key list) = match list with | [] -> error, a | t :: q -> @@ -173,10 +167,12 @@ module Make = | t' :: q' -> let error, union_array = union parameter error t t' a in aux parameter q' error union_array - in aux parameter q error a + in + aux parameter q error a let iteri = Storage.iter - - end: Union_find with type key = Storage.key - and type t = Storage.key Storage.t - and type dimension = Storage.dimension) + end : + Union_find + with type key = Storage.key + and type t = Storage.key Storage.t + and type dimension = Storage.dimension) diff --git a/core/KaSa_rep/more_datastructures/union_find.mli b/core/KaSa_rep/more_datastructures/union_find.mli index ca3dc99057..bb43ef9c66 100644 --- a/core/KaSa_rep/more_datastructures/union_find.mli +++ b/core/KaSa_rep/more_datastructures/union_find.mli @@ -1,39 +1,42 @@ -module type Union_find = -sig +module type Union_find = sig type key type dimension type t - val create: + + val create : Remanent_parameters_sig.parameters -> Exception.method_handler -> dimension -> Exception.method_handler * t - val union_list: + val union_list : Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> key list -> Exception.method_handler * t - val iteri: + val iteri : Remanent_parameters_sig.parameters -> Exception.method_handler -> (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - key -> key -> Exception.method_handler) -> - t -> Exception.method_handler + Exception.method_handler -> + key -> + key -> + Exception.method_handler) -> + t -> + Exception.method_handler - val get_representent: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - key -> - t -> - Exception.method_handler * t * key + val get_representent : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + key -> + t -> + Exception.method_handler * t * key end -module Make: - functor (Storage:Int_storage.Storage) -> - Union_find with type key = Storage.key - and type t = Storage.key Storage.t - and type dimension = Storage.dimension +module Make : functor (Storage : Int_storage.Storage) -> + Union_find + with type key = Storage.key + and type t = Storage.key Storage.t + and type dimension = Storage.dimension diff --git a/core/KaSa_rep/more_datastructures/working_list.ml b/core/KaSa_rep/more_datastructures/working_list.ml index 406226fa4d..78d7108e39 100644 --- a/core/KaSa_rep/more_datastructures/working_list.ml +++ b/core/KaSa_rep/more_datastructures/working_list.ml @@ -16,106 +16,116 @@ open SetMap let local_trace = false -module type Work_list = -sig +module type Work_list = sig type elt type t val empty : t val is_empty : t -> bool - val push : Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - val pop : Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> Exception.method_handler * (elt option * t) + + val push : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val pop : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + Exception.method_handler * (elt option * t) + val fold_left : ('a -> elt -> 'a) -> 'a -> t -> 'a val print_wl : Remanent_parameters_sig.parameters -> t -> unit end -module WlMake (Ord: OrderedType with type t = int) = - (struct - - module WSetMap = Map_wrapper.Make (SetMap.Make (Ord)) - module WSet = WSetMap.Set - - type elt = Ord.t - type t = elt list * elt list * WSet.t - - let empty = [], [], WSet.empty - - let is_empty x = - let _, _, pool = x in - WSet.is_empty pool - - let push parameter error e x = - let in_list, out_list, pool = x in - if WSet.mem e pool - then - error, x - else - let error', add_elt = WSet.add parameter error e pool in - let error = Exception.check_point Exception.warn parameter error error' __POS__ Exit in - error, ((e :: in_list), out_list, add_elt) - - let fold_left f acc x = - let in_list, out_list, _ = x in - List.fold_left f (List.fold_left f acc out_list) (List.rev in_list) - - let print_wl parameters wl = - (*let _ = fold_left - (fun () a -> Printf.fprintf (Remanent_parameters.get_log parameters) "%i " a) - () wl - in - (*print_newline()*) - let _ = print_newline () in*) - let _, _, set = wl in - WSet.iter (fun i -> - Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i " i) set; - Loggers.fprintf (Remanent_parameters.get_logger parameters) "\n" - - let rec pop parameter error x = - let in_list, out_list, pool = x in - if is_empty x - then - error, (None, x) - else - begin - match out_list with - | [] -> pop parameter error ([], (List.rev in_list), pool) - | h :: tl -> - let error,remove_elt = WSet.remove parameter error h pool in - error, ((Some h), (in_list, tl, remove_elt)) - end - - (*for debug*) - (* let rec pop parameter error x = - let in_list, out_list, pool = x in - if is_empty x - then - error, (None, x) - else - begin - match out_list with - | [] -> pop parameter error ([], (List.rev in_list), pool) - | h :: tl -> - let _ = Printf.fprintf (Remanent_parameters.get_log parameter) - "BEFORE REMOVE %i " h in - let _ = WSet.iter (fun i -> - Printf.fprintf (Remanent_parameters.get_log parameter) "%i " i) pool in - let error,remove_elt = WSet.remove parameter error h pool in - let _ = WSet.iter (fun i -> - Printf.fprintf (Remanent_parameters.get_log parameter) "%i " i) remove_elt - in - error, ((Some h), (in_list, tl, remove_elt)) - end*) - - (*for debug*) - (*let push p e f x = - let _ = Printf.fprintf (Remanent_parameters.get_log p) "BEFORE PUUSH %i\n " f in - let _ = print_wl p x in - let error,wl = push p e f x in - let _ = Printf.fprintf (Remanent_parameters.get_log p) "OUTPUT\n" in - let _ = print_wl p wl in - let _ = Printf.fprintf (Remanent_parameters.get_log p) "\n" in - error,wl *) - - end) +module WlMake (Ord : OrderedType with type t = int) = struct + module WSetMap = Map_wrapper.Make (SetMap.Make (Ord)) + module WSet = WSetMap.Set + + type elt = Ord.t + type t = elt list * elt list * WSet.t + + let empty = [], [], WSet.empty + + let is_empty x = + let _, _, pool = x in + WSet.is_empty pool + + let push parameter error e x = + let in_list, out_list, pool = x in + if WSet.mem e pool then + error, x + else ( + let error', add_elt = WSet.add parameter error e pool in + let error = + Exception.check_point Exception.warn parameter error error' __POS__ Exit + in + error, (e :: in_list, out_list, add_elt) + ) + + let fold_left f acc x = + let in_list, out_list, _ = x in + List.fold_left f (List.fold_left f acc out_list) (List.rev in_list) + + let print_wl parameters wl = + (*let _ = fold_left + (fun () a -> Printf.fprintf (Remanent_parameters.get_log parameters) "%i " a) + () wl + in + (*print_newline()*) + let _ = print_newline () in*) + let _, _, set = wl in + WSet.iter + (fun i -> + Loggers.fprintf (Remanent_parameters.get_logger parameters) "%i " i) + set; + Loggers.fprintf (Remanent_parameters.get_logger parameters) "\n" + + let rec pop parameter error x = + let in_list, out_list, pool = x in + if is_empty x then + error, (None, x) + else ( + match out_list with + | [] -> pop parameter error ([], List.rev in_list, pool) + | h :: tl -> + let error, remove_elt = WSet.remove parameter error h pool in + error, (Some h, (in_list, tl, remove_elt)) + ) + + (*for debug*) + (* let rec pop parameter error x = + let in_list, out_list, pool = x in + if is_empty x + then + error, (None, x) + else + begin + match out_list with + | [] -> pop parameter error ([], (List.rev in_list), pool) + | h :: tl -> + let _ = Printf.fprintf (Remanent_parameters.get_log parameter) + "BEFORE REMOVE %i " h in + let _ = WSet.iter (fun i -> + Printf.fprintf (Remanent_parameters.get_log parameter) "%i " i) pool in + let error,remove_elt = WSet.remove parameter error h pool in + let _ = WSet.iter (fun i -> + Printf.fprintf (Remanent_parameters.get_log parameter) "%i " i) remove_elt + in + error, ((Some h), (in_list, tl, remove_elt)) + end*) + + (*for debug*) + (*let push p e f x = + let _ = Printf.fprintf (Remanent_parameters.get_log p) "BEFORE PUUSH %i\n " f in + let _ = print_wl p x in + let error,wl = push p e f x in + let _ = Printf.fprintf (Remanent_parameters.get_log p) "OUTPUT\n" in + let _ = print_wl p wl in + let _ = Printf.fprintf (Remanent_parameters.get_log p) "\n" in + error,wl *) +end module IntWL = Mods.IntMap diff --git a/core/KaSa_rep/more_datastructures/working_list.mli b/core/KaSa_rep/more_datastructures/working_list.mli index 212d85fbfe..15c5f39496 100644 --- a/core/KaSa_rep/more_datastructures/working_list.mli +++ b/core/KaSa_rep/more_datastructures/working_list.mli @@ -1,20 +1,30 @@ -val local_trace:bool +val local_trace : bool module IntWL = Mods.IntMap -module type Work_list = -sig +module type Work_list = sig type elt type t val empty : t val is_empty : t -> bool - val push : Remanent_parameters_sig.parameters -> Exception.method_handler -> elt -> t -> Exception.method_handler * t - val pop : Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> Exception.method_handler * (elt option * t) + + val push : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + elt -> + t -> + Exception.method_handler * t + + val pop : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + t -> + Exception.method_handler * (elt option * t) + val fold_left : ('a -> elt -> 'a) -> 'a -> t -> 'a val print_wl : Remanent_parameters_sig.parameters -> t -> unit end -module WlMake: -functor (O: SetMap.OrderedType with type t = int) -> -Work_list with type elt=O.t +module WlMake : functor (O : SetMap.OrderedType with type t = int) -> + Work_list with type elt = O.t diff --git a/core/KaSa_rep/more_datastructures/wrapped_modules.ml b/core/KaSa_rep/more_datastructures/wrapped_modules.ml index 19bd8a4bbb..09c02d9a72 100644 --- a/core/KaSa_rep/more_datastructures/wrapped_modules.ml +++ b/core/KaSa_rep/more_datastructures/wrapped_modules.ml @@ -1,13 +1,14 @@ -(** Time-stamp: *) (* versions of the module with logging primitives *) (* type are shared among both versions *) -module LoggedStringSetMap = Map_wrapper.Make(Mods.StringSetMap) +module LoggedStringSetMap = Map_wrapper.Make (Mods.StringSetMap) +(** Time-stamp: *) + module LoggedStringSet = LoggedStringSetMap.Set module LoggedStringMap = LoggedStringSetMap.Map -module LoggedIntSetMap = Map_wrapper.Make(Mods.IntSetMap) +module LoggedIntSetMap = Map_wrapper.Make (Mods.IntSetMap) module LoggedIntSet = LoggedIntSetMap.Set module LoggedIntMap = LoggedIntSetMap.Map -module LoggedInt2SetMap = Map_wrapper.Make(Mods.Int2SetMap) +module LoggedInt2SetMap = Map_wrapper.Make (Mods.Int2SetMap) module LoggedInt2Set = LoggedInt2SetMap.Set module LoggedInt2Map = LoggedInt2SetMap.Map module LoggedCharSetMap = Map_wrapper.Make (Mods.CharSetMap) @@ -19,8 +20,7 @@ module LoggedCharMap = LoggedCharSetMap.Map module ParanoStringSetMap = Map_wrapper.Make (Mods.StringSetMap) module ParanoStringSet = ParanoStringSetMap.Set module ParanoStringMap = ParanoStringSetMap.Map -module ParanoIntSetMap = - Map_wrapper.Make (Mods.IntSetMap) +module ParanoIntSetMap = Map_wrapper.Make (Mods.IntSetMap) module ParanoIntSet = ParanoIntSetMap.Set module ParanoIntMap = ParanoIntSetMap.Map module ParanoInt2SetMap = Map_wrapper.Make (Mods.Int2SetMap) diff --git a/core/KaSa_rep/polymer_detection/contact_map_scc.ml b/core/KaSa_rep/polymer_detection/contact_map_scc.ml index 1543d453dc..2a63c2b985 100644 --- a/core/KaSa_rep/polymer_detection/contact_map_scc.ml +++ b/core/KaSa_rep/polymer_detection/contact_map_scc.ml @@ -54,90 +54,73 @@ and conversely, the pair from the id. *) type site = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name - type node = site * site - type edge = node * node type converted_contact_map = node list Ckappa_sig.PairAgentSite_map_and_set.Map.t -let add_edges - parameters error - (agent_name, site_name, agent_name', site_name') +let add_edges parameters error (agent_name, site_name, agent_name', site_name') site_name_list graph = - let edge = ((agent_name, site_name), (agent_name', site_name')) in + let edge = (agent_name, site_name), (agent_name', site_name') in let error, old = Ckappa_sig.PairAgentSite_map_and_set.Map.find_default_without_logs - parameters - error - [] - edge - graph + parameters error [] edge graph in let internal_scc_decomposition = - List.fold_left (fun old (site_name'', partners) -> - List.fold_left (fun old (agent_name''', site_name''') -> + List.fold_left + (fun old (site_name'', partners) -> + List.fold_left + (fun old (agent_name''', site_name''') -> let edge = - ((agent_name', site_name''), (agent_name''', site_name''')) + (agent_name', site_name''), (agent_name''', site_name''') in - edge :: old - ) old partners - ) old site_name_list + edge :: old) + old partners) + old site_name_list in - Ckappa_sig.PairAgentSite_map_and_set.Map.add_or_overwrite - parameters error - edge - internal_scc_decomposition - graph + Ckappa_sig.PairAgentSite_map_and_set.Map.add_or_overwrite parameters error + edge internal_scc_decomposition graph let convert_contact_map parameters error contact_map = let graph = Ckappa_sig.PairAgentSite_map_and_set.Map.empty in - Ckappa_sig.Agent_map_and_set.Map.fold + Ckappa_sig.Agent_map_and_set.Map.fold (fun agent_name interface (error, graph) -> - Ckappa_sig.Site_map_and_set.Map.fold - (fun site_name (_, partners) (error, graph) -> - List.fold_left - (fun (error, graph) (agent_name', site_name') -> - let error, pair_opt = - Ckappa_sig.Agent_map_and_set.Map.find_option - parameters error - agent_name' - contact_map - in - match pair_opt with - | None -> Exception.warn parameters error __POS__ Exit graph - | Some interface' -> - let error, others = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site_name (_, partners) (error, others) -> - error, - if partners = [] || site_name = site_name' - then - others - else - (site_name, partners) :: others - ) interface' (error,[]) - in - add_edges - parameters error - (agent_name, site_name, agent_name', site_name') - others - graph - ) (error, graph) partners - ) interface (error, graph) - ) contact_map (error,graph) + Ckappa_sig.Site_map_and_set.Map.fold + (fun site_name (_, partners) (error, graph) -> + List.fold_left + (fun (error, graph) (agent_name', site_name') -> + let error, pair_opt = + Ckappa_sig.Agent_map_and_set.Map.find_option parameters error + agent_name' contact_map + in + match pair_opt with + | None -> Exception.warn parameters error __POS__ Exit graph + | Some interface' -> + let error, others = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site_name (_, partners) (error, others) -> + ( error, + if partners = [] || site_name = site_name' then + others + else + (site_name, partners) :: others )) + interface' (error, []) + in + add_edges parameters error + (agent_name, site_name, agent_name', site_name') + others graph) + (error, graph) partners) + interface (error, graph)) + contact_map (error, graph) -let mixture_of_edge - parameters error handler - (((ag, st), (ag', st')), - ((ag'', st''), (ag''', st'''))) = +let mixture_of_edge parameters error handler + (((ag, st), (ag', st')), ((ag'', st''), (ag''', st'''))) = let _ = ag, ag''', st, st''' in - if ag'<> ag'' || st' = st'' - then + if ag' <> ag'' || st' = st'' then ( let error, mixture = Preprocess.empty_mixture parameters error in Exception.warn parameters error __POS__ Exit mixture - else + ) else ( (* build the pattern: A(x!1), B(x!1, y!2), C(x!2) ag(st!1), ag'(st'!1, st''!2), ag'''(st'''!2) @@ -174,13 +157,11 @@ let mixture_of_edge Build_graph.add_link parameters error ag_id' st'' ag_id'' st''' mixture in error, Build_graph.export mixture + ) -let filter_edges_in_converted_contact_map - parameters error handler static dynamic - is_reachable - converted_contact_map - = -(* Take care of propagating memoisation table, and error stream *) +let filter_edges_in_converted_contact_map parameters error handler static + dynamic is_reachable converted_contact_map = + (* Take care of propagating memoisation table, and error stream *) (* In the converted site-graph, edges are of the form: ((A,s),(A’,s’)),((A’,s’’),(A’’,s’’’)). @@ -194,55 +175,45 @@ let filter_edges_in_converted_contact_map let error, dynamic, converted_contact_map = Ckappa_sig.PairAgentSite_map_and_set.Map.fold (fun node1 potential_sites (error, dynamic, map) -> - begin - let error, dynamic, potential_sites' = - let error, dynamic, potential_sites' = - List.fold_left - (fun (error, dynamic, potential_sites') node2 -> - let ((ag,st),(ag',st')) = node1 in - let ((ag'',st''),(ag''',st''')) = node2 in - let pattern = - (((ag,st),(ag',st')), - ((ag'',st''),(ag''',st'''))) - in - let error, mixture = - mixture_of_edge - parameters error handler - pattern - in - let error, dynamic, bool = - is_reachable parameters error - static dynamic - mixture - in - let error, potential_sites' = - if bool - then - error, node2 :: potential_sites' - else - error, potential_sites' - in - error, dynamic, potential_sites' - ) (error, dynamic, []) potential_sites - in - error, dynamic, potential_sites' - in - if potential_sites' <> [] - then - let error', map = - Ckappa_sig.PairAgentSite_map_and_set.Map.add - parameters error - node1 - potential_sites' - map - in - let error = - Exception.check_point Exception.warn parameters error error' __POS__ Exit - in - error, dynamic, map - else error, dynamic, map - end - ) converted_contact_map + let error, dynamic, potential_sites' = + let error, dynamic, potential_sites' = + List.fold_left + (fun (error, dynamic, potential_sites') node2 -> + let (ag, st), (ag', st') = node1 in + let (ag'', st''), (ag''', st''') = node2 in + let pattern = + ((ag, st), (ag', st')), ((ag'', st''), (ag''', st''')) + in + let error, mixture = + mixture_of_edge parameters error handler pattern + in + let error, dynamic, bool = + is_reachable parameters error static dynamic mixture + in + let error, potential_sites' = + if bool then + error, node2 :: potential_sites' + else + error, potential_sites' + in + error, dynamic, potential_sites') + (error, dynamic, []) potential_sites + in + error, dynamic, potential_sites' + in + if potential_sites' <> [] then ( + let error', map = + Ckappa_sig.PairAgentSite_map_and_set.Map.add parameters error node1 + potential_sites' map + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, dynamic, map + ) else + error, dynamic, map) + converted_contact_map (error, dynamic, Ckappa_sig.PairAgentSite_map_and_set.Map.empty) in error, dynamic, converted_contact_map @@ -250,115 +221,101 @@ let filter_edges_in_converted_contact_map let keep_list parameters error self l = match l with | [] -> error, false - | [x] -> - begin - match Graphs.Nodearray.unsafe_get - parameters error x self - with + | [ x ] -> + (match Graphs.Nodearray.unsafe_get parameters error x self with | error, Some true -> error, true - | error, (Some _ | None) -> error, false - end - | _::_::_ -> error, true + | error, (Some _ | None) -> error, false) + | _ :: _ :: _ -> error, true let compute_graph_scc parameters error contact_map_converted = let error, (nodes, edges_list) = - Ckappa_sig.PairAgentSite_map_and_set.Map.fold - (fun node1 potential_sites (error, (nodes, edges)) -> - let error, nodes = - Ckappa_sig.PairAgentSite_map_and_set.Set.add_when_not_in parameters error node1 nodes in - let error, (nodes,edges) = - List.fold_left (fun (error, (nodes,edges)) node2 -> - let error, nodes = - Ckappa_sig.PairAgentSite_map_and_set.Set.add_when_not_in parameters error node2 nodes - in - error, (nodes, - (node1, node2) :: edges) - ) (error, (nodes,edges)) potential_sites - in - error, (nodes,edges) - ) contact_map_converted (error, (Ckappa_sig.PairAgentSite_map_and_set.Set.empty, [])) + Ckappa_sig.PairAgentSite_map_and_set.Map.fold + (fun node1 potential_sites (error, (nodes, edges)) -> + let error, nodes = + Ckappa_sig.PairAgentSite_map_and_set.Set.add_when_not_in parameters + error node1 nodes + in + let error, (nodes, edges) = + List.fold_left + (fun (error, (nodes, edges)) node2 -> + let error, nodes = + Ckappa_sig.PairAgentSite_map_and_set.Set.add_when_not_in + parameters error node2 nodes + in + error, (nodes, (node1, node2) :: edges)) + (error, (nodes, edges)) + potential_sites + in + error, (nodes, edges)) + contact_map_converted + (error, (Ckappa_sig.PairAgentSite_map_and_set.Set.empty, [])) in let nodes = Ckappa_sig.PairAgentSite_map_and_set.Set.elements nodes in let n_nodes = List.length nodes in let nodes_array = Array.make n_nodes - ((Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_site_name), - (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_site_name)) - in - let error, self = - Graphs.Nodearray.create - parameters error - n_nodes + ( (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_site_name), + (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_site_name) ) in + let error, self = Graphs.Nodearray.create parameters error n_nodes in let nodes_map = Ckappa_sig.PairAgentSite_map_and_set.Map.empty in let _, nodes, (error, nodes_map) = List.fold_left (fun (i, nodes_list, (error, map)) node -> - nodes_array.(i) <- node; - i+1, - (Graphs.node_of_int i) :: nodes_list, - Ckappa_sig.PairAgentSite_map_and_set.Map.add - parameters error - node - (Graphs.node_of_int i) - map - ) (0, [], (error, nodes_map)) nodes + nodes_array.(i) <- node; + ( i + 1, + Graphs.node_of_int i :: nodes_list, + Ckappa_sig.PairAgentSite_map_and_set.Map.add parameters error node + (Graphs.node_of_int i) map )) + (0, [], (error, nodes_map)) + nodes in - let error, (edges,self) = + let error, (edges, self) = List.fold_left - (fun (error, (l,self)) (a,b) -> - let error, node_opt = - Ckappa_sig.PairAgentSite_map_and_set.Map.find_option - parameters error - a - nodes_map - in - let error, node_opt' = - Ckappa_sig.PairAgentSite_map_and_set.Map.find_option - parameters error - b - nodes_map - in - match node_opt,node_opt' with - | None, _ | _, None -> - Exception.warn parameters error __POS__ Exit (l,self) - | Some a, Some b -> - let error, set = - if a = b then - Graphs.Nodearray.set parameters error a true self - else - error, self - in - error, - ((a, (), b) :: l, set)) - (error, ([], self)) edges_list + (fun (error, (l, self)) (a, b) -> + let error, node_opt = + Ckappa_sig.PairAgentSite_map_and_set.Map.find_option parameters error + a nodes_map + in + let error, node_opt' = + Ckappa_sig.PairAgentSite_map_and_set.Map.find_option parameters error + b nodes_map + in + match node_opt, node_opt' with + | None, _ | _, None -> + Exception.warn parameters error __POS__ Exit (l, self) + | Some a, Some b -> + let error, set = + if a = b then + Graphs.Nodearray.set parameters error a true self + else + error, self + in + error, ((a, (), b) :: l, set)) + (error, ([], self)) + edges_list in (*build a graph_scc*) - let error, graph = - Graphs.create parameters error - (fun _ -> ()) - nodes - edges - in + let error, graph = Graphs.create parameters error (fun _ -> ()) nodes edges in (*compute scc*) let error, _low, _pre, _on_stack, scc = - Graphs.compute_scc parameters error - (fun () -> "") - graph + Graphs.compute_scc parameters error (fun () -> "") graph in let error, scc = List.fold_left - (fun (error,l) a -> - let error, bool = keep_list parameters error self a in - error, if bool then a::l else l) - (error,[]) (List.rev scc) + (fun (error, l) a -> + let error, bool = keep_list parameters error self a in + ( error, + if bool then + a :: l + else + l )) + (error, []) (List.rev scc) in let scc = List.rev_map (fun a -> - List.rev_map - (fun b -> nodes_array.(Graphs.int_of_node b)) - (List.rev a)) - (List.rev scc ) + List.rev_map (fun b -> nodes_array.(Graphs.int_of_node b)) (List.rev a)) + (List.rev scc) in error, scc diff --git a/core/KaSa_rep/polymer_detection/contact_map_scc.mli b/core/KaSa_rep/polymer_detection/contact_map_scc.mli index 55e2092c84..a0211f54e0 100644 --- a/core/KaSa_rep/polymer_detection/contact_map_scc.mli +++ b/core/KaSa_rep/polymer_detection/contact_map_scc.mli @@ -16,34 +16,35 @@ type edge type converted_contact_map -val convert_contact_map: +val convert_contact_map : Remanent_parameters_sig.parameters -> Exception.method_handler -> Remanent_state.internal_contact_map -> Exception.method_handler * converted_contact_map -val mixture_of_edge: +val mixture_of_edge : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> - edge -> Exception.method_handler * Cckappa_sig.mixture + edge -> + Exception.method_handler * Cckappa_sig.mixture -val filter_edges_in_converted_contact_map: +val filter_edges_in_converted_contact_map : Remanent_parameters_sig.parameters -> Exception.method_handler -> - Cckappa_sig.kappa_handler -> + Cckappa_sig.kappa_handler -> 'static -> 'dynamic -> (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - 'static -> - 'dynamic -> - Cckappa_sig.mixture -> - Exception.method_handler * 'dynamic * bool) -> + Exception.method_handler -> + 'static -> + 'dynamic -> + Cckappa_sig.mixture -> + Exception.method_handler * 'dynamic * bool) -> converted_contact_map -> Exception.method_handler * 'dynamic * converted_contact_map -val compute_graph_scc: +val compute_graph_scc : Remanent_parameters_sig.parameters -> Exception.method_handler -> converted_contact_map -> diff --git a/core/KaSa_rep/polymer_detection/dune b/core/KaSa_rep/polymer_detection/dune index 8c6f747ebc..21787d0f35 100644 --- a/core/KaSa_rep/polymer_detection/dune +++ b/core/KaSa_rep/polymer_detection/dune @@ -1,11 +1,17 @@ (library - (name kappa_polymers_analysis) - (libraries kappa_kasa_remanent_state) - (flags (:standard) - -open Kappa_parameters - -open Kappa_errors - -open Kappa_kasa_remanent_state - -open Kappa_kasa_frontend - -open Kappa_logging - -open Kappa_kasa_kastor_toolset -)) + (name kappa_polymers_analysis) + (libraries kappa_kasa_remanent_state) + (flags + (:standard) + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_kasa_remanent_state + -open + Kappa_kasa_frontend + -open + Kappa_logging + -open + Kappa_kasa_kastor_toolset)) diff --git a/core/KaSa_rep/reachability_analysis/agent_trace.ml b/core/KaSa_rep/reachability_analysis/agent_trace.ml index c799e50eef..ad76cb4b5c 100644 --- a/core/KaSa_rep/reachability_analysis/agent_trace.ml +++ b/core/KaSa_rep/reachability_analysis/agent_trace.ml @@ -15,701 +15,581 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type fst_label = - | Rule of Ckappa_sig.c_rule_id - | Init of int - +type fst_label = Rule of Ckappa_sig.c_rule_id | Init of int type label = fst_label * Ckappa_sig.c_agent_id * int let int_of_fst_label i = match i with | Rule r -> Ckappa_sig.int_of_rule_id r - | Init i -> -(i+1) + | Init i -> -(i + 1) + +let int_pair_of_label (i, j, _) = + int_of_fst_label i, Ckappa_sig.int_of_agent_id j -let int_pair_of_label (i,j,_) = int_of_fst_label i, Ckappa_sig.int_of_agent_id j +module Label = Map_wrapper.Make (SetMap.Make (struct + type t = label -module Label = - Map_wrapper.Make - (SetMap.Make - (struct - type t = label - let compare = compare - let print _ _ = () - end)) + let compare = compare + let print _ _ = () +end)) module LabelMap = Label.Map module LabelSet = Label.Set -module Site = - Map_wrapper.Make - (SetMap.Make - (struct - type t = Ckappa_sig.c_site_name - let compare = compare - let print _ _ = () - end)) + +module Site = Map_wrapper.Make (SetMap.Make (struct + type t = Ckappa_sig.c_site_name + + let compare = compare + let print _ _ = () +end)) module SiteMap = Site.Map module SiteSet = Site.Set -module SitePair = - Map_wrapper.Make - (SetMap.Make - (struct - type t = Ckappa_sig.c_site_name * Ckappa_sig.c_site_name - let compare = compare - let print _ _ = () - end)) -module SitePairSet = SitePair.Set +module SitePair = Map_wrapper.Make (SetMap.Make (struct + type t = Ckappa_sig.c_site_name * Ckappa_sig.c_site_name -type extensional_representation = - { - title: string; - agent_type: Ckappa_sig.c_agent_name; - agent_string: string; - nodes: Ckappa_sig.Views_intbdu.mvbdu list; - edges: (Ckappa_sig.Views_intbdu.mvbdu * label * Ckappa_sig.Views_intbdu.mvbdu) list ; - nodes_creation: (Ckappa_sig.Views_intbdu.mvbdu * label) list ; - nodes_degradation: (Ckappa_sig.Views_intbdu.mvbdu * label) list ; - subframe: Mods.IntSet.t Mods.IntMap.t ; - nodes_in_bdu: Mods.IntSet.t - } + let compare = compare + let print _ _ = () +end)) -let mvbdu_of_association_list_gen gen asso_list = +module SitePairSet = SitePair.Set + +type extensional_representation = { + title: string; + agent_type: Ckappa_sig.c_agent_name; + agent_string: string; + nodes: Ckappa_sig.Views_intbdu.mvbdu list; + edges: + (Ckappa_sig.Views_intbdu.mvbdu * label * Ckappa_sig.Views_intbdu.mvbdu) list; + nodes_creation: (Ckappa_sig.Views_intbdu.mvbdu * label) list; + nodes_degradation: (Ckappa_sig.Views_intbdu.mvbdu * label) list; + subframe: Mods.IntSet.t Mods.IntMap.t; + nodes_in_bdu: Mods.IntSet.t; +} + +let mvbdu_of_association_list_gen gen asso_list = let hconsed_list = gen asso_list in let mvbdu_true = Ckappa_sig.Views_intbdu.mvbdu_true () in Ckappa_sig.Views_intbdu.mvbdu_redefine mvbdu_true hconsed_list let mvbdu_of_association_list asso = - mvbdu_of_association_list_gen - Ckappa_sig.Views_intbdu.build_association_list + mvbdu_of_association_list_gen Ckappa_sig.Views_intbdu.build_association_list asso let mvbdu_of_reverse_order_association_list asso = mvbdu_of_association_list_gen - Ckappa_sig.Views_intbdu.build_reverse_sorted_association_list - asso + Ckappa_sig.Views_intbdu.build_reverse_sorted_association_list asso let empty_transition_system title agent_string agent_name = { - title = title; + title; agent_type = agent_name; - agent_string = agent_string; + agent_string; edges = []; nodes_creation = []; nodes_degradation = []; - nodes = [] ; + nodes = []; subframe = Mods.IntMap.empty; - nodes_in_bdu = Mods.IntSet.empty + nodes_in_bdu = Mods.IntSet.empty; } let hash_of_association_list list = - let hconsed_list = - Ckappa_sig.Views_intbdu.build_association_list list - in + let hconsed_list = Ckappa_sig.Views_intbdu.build_association_list list in let hash = Ckappa_sig.Views_intbdu.hash_of_association_list hconsed_list in hash let build_asso_of_mvbdu parameters error mvbdu = - let list = - Ckappa_sig.Views_intbdu.extensional_of_mvbdu mvbdu - in - match list - with - | [list] -> - begin - error, list - end + let list = Ckappa_sig.Views_intbdu.extensional_of_mvbdu mvbdu in + match list with + | [ list ] -> error, list | _ -> - let error, list = - Exception.warn parameters error __POS__ Exit [] - in + let error, list = Exception.warn parameters error __POS__ Exit [] in error, list let hash_of_mvbdu parameters error mvbdu = - let error, asso = - build_asso_of_mvbdu parameters error mvbdu - in + let error, asso = build_asso_of_mvbdu parameters error mvbdu in error, hash_of_association_list asso let add_node parameters error q transition_system = let bdu_set = transition_system.nodes_in_bdu in let error, hash = hash_of_mvbdu parameters error q in - if - Mods.IntSet.mem hash bdu_set - then + if Mods.IntSet.mem hash bdu_set then error, transition_system else - error, - { - transition_system - with - nodes = q::transition_system.nodes; - nodes_in_bdu = Mods.IntSet.add hash bdu_set - } + ( error, + { + transition_system with + nodes = q :: transition_system.nodes; + nodes_in_bdu = Mods.IntSet.add hash bdu_set; + } ) let add_edge q q' label transition_system = - {transition_system with edges = (q,label,q')::transition_system.edges} + { transition_system with edges = (q, label, q') :: transition_system.edges } -let convert_label (r,a) = - Ckappa_sig.state_index_of_int (int_of_fst_label r), - Ckappa_sig.state_index_of_int (Ckappa_sig.int_of_agent_id a) +let convert_label (r, a) = + ( Ckappa_sig.state_index_of_int (int_of_fst_label r), + Ckappa_sig.state_index_of_int (Ckappa_sig.int_of_agent_id a) ) let add_creation parameters error r_id ag_id mvbdu transition_system = let error, transition_system = add_node parameters error mvbdu transition_system in - error, - {transition_system - with - nodes_creation = (mvbdu,(r_id,ag_id,0))::transition_system.nodes_creation - } + ( error, + { + transition_system with + nodes_creation = + (mvbdu, (r_id, ag_id, 0)) :: transition_system.nodes_creation; + } ) let dump_edge logger parameters error compil key key' label = let error, rule_name = - if Remanent_parameters.get_show_rule_names_in_local_traces parameters - then - Handler.string_of_rule ~with_loc:false ~with_rule:false ~with_ast:false parameters error compil (fst label) - else error,"" + if Remanent_parameters.get_show_rule_names_in_local_traces parameters then + Handler.string_of_rule ~with_loc:false ~with_rule:false ~with_ast:false + parameters error compil (fst label) + else + error, "" in let () = - Graph_loggers.print_edge logger - ("Node_"^key) ("Node_"^key') ~directives:[Graph_loggers_sig.Label rule_name] in + Graph_loggers.print_edge logger ("Node_" ^ key) ("Node_" ^ key') + ~directives:[ Graph_loggers_sig.Label rule_name ] + in error - let string_key_of_asso list = let hash = hash_of_association_list list in Printf.sprintf "Node_%i" hash let string_label_of_asso parameters error handler_kappa transition_system list = - let string = transition_system.agent_string^"(" in - let error,string,_ = + let string = transition_system.agent_string ^ "(" in + let error, string, _ = List.fold_left - (fun (error,string,bool) (site_type, state) -> - let string = - if bool - then - string^"," - else - string - in - let error', site_string = - Handler.string_of_site parameters error handler_kappa - ~state transition_system.agent_type site_type - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error, - string^site_string, - true - ) - (error,string,false) list + (fun (error, string, bool) (site_type, state) -> + let string = + if bool then + string ^ "," + else + string + in + let error', site_string = + Handler.string_of_site parameters error handler_kappa ~state + transition_system.agent_type site_type + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, string ^ site_string, true) + (error, string, false) list in - error, string^")" + error, string ^ ")" let dump_mvbdu logger parameters error handler_kappa transition_system mvbdu = let error, list = build_asso_of_mvbdu parameters error mvbdu in let key = string_key_of_asso list in - let error,label = string_label_of_asso parameters error handler_kappa transition_system list in - let () = Graph_loggers.print_node logger key - ~directives:([Graph_loggers_sig.Label label]) + let error, label = + string_label_of_asso parameters error handler_kappa transition_system list + in + let () = + Graph_loggers.print_node logger key + ~directives:[ Graph_loggers_sig.Label label ] in error -let add_node_from_mvbdu _parameters _handler_kappa error _agent_type _agent_string mvbdu transition_system = - error, - { - transition_system - with - nodes = mvbdu::transition_system.nodes} +let add_node_from_mvbdu _parameters _handler_kappa error _agent_type + _agent_string mvbdu transition_system = + error, { transition_system with nodes = mvbdu :: transition_system.nodes } let bdu_of_view parameters error test = let mvbdu_false = Ckappa_sig.Views_intbdu.mvbdu_false () in let mvbdu_true = Ckappa_sig.Views_intbdu.mvbdu_true () in List.fold_left - (fun (error, mvbdu) (site,state) -> - let error,lub = - match - state.Cckappa_sig.site_state.Cckappa_sig.min - with - | Some a -> error, Ckappa_sig.int_of_state_index a - | None -> - Exception.warn parameters error __POS__ Exit - 0 - in - let error, glb = - match - state.Cckappa_sig.site_state.Cckappa_sig.max - with - | Some a -> error, Ckappa_sig.int_of_state_index a - | None -> - Exception.warn parameters error __POS__ Exit - 0 - in - let rec aux k mvbdu = - if k>glb then mvbdu - else - let mvbdu' = - mvbdu_of_association_list - [site,Ckappa_sig.state_index_of_int k] in - aux (k+1) (Ckappa_sig.Views_intbdu.mvbdu_or mvbdu mvbdu') - in - let mvbdu' = aux lub mvbdu_false in - error, Ckappa_sig.Views_intbdu.mvbdu_and mvbdu mvbdu' - ) - (error, mvbdu_true) - test + (fun (error, mvbdu) (site, state) -> + let error, lub = + match state.Cckappa_sig.site_state.Cckappa_sig.min with + | Some a -> error, Ckappa_sig.int_of_state_index a + | None -> Exception.warn parameters error __POS__ Exit 0 + in + let error, glb = + match state.Cckappa_sig.site_state.Cckappa_sig.max with + | Some a -> error, Ckappa_sig.int_of_state_index a + | None -> Exception.warn parameters error __POS__ Exit 0 + in + let rec aux k mvbdu = + if k > glb then + mvbdu + else ( + let mvbdu' = + mvbdu_of_association_list [ site, Ckappa_sig.state_index_of_int k ] + in + aux (k + 1) (Ckappa_sig.Views_intbdu.mvbdu_or mvbdu mvbdu') + ) + in + let mvbdu' = aux lub mvbdu_false in + error, Ckappa_sig.Views_intbdu.mvbdu_and mvbdu mvbdu') + (error, mvbdu_true) test let asso_of_view_in_list parameters error view = let error, list = List.fold_left - (fun (error,list) (site,state) -> - let error,lub = - match - state.Cckappa_sig.site_state.Cckappa_sig.min - with - | Some a -> error, a - | None -> - Exception.warn parameters error __POS__ Exit - (Ckappa_sig.state_index_of_int 0) - in - let error, glb = - match - state.Cckappa_sig.site_state.Cckappa_sig.max - with - | Some a -> error, a - | None -> - Exception.warn parameters error __POS__ Exit - (Ckappa_sig.state_index_of_int 0) - in - if lub = glb - then - error, (site,lub)::list - else - Exception.warn parameters error __POS__ Exit list - ) - (error, []) - view + (fun (error, list) (site, state) -> + let error, lub = + match state.Cckappa_sig.site_state.Cckappa_sig.min with + | Some a -> error, a + | None -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.state_index_of_int 0) + in + let error, glb = + match state.Cckappa_sig.site_state.Cckappa_sig.max with + | Some a -> error, a + | None -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.state_index_of_int 0) + in + if lub = glb then + error, (site, lub) :: list + else + Exception.warn parameters error __POS__ Exit list) + (error, []) view in error, Ckappa_sig.Views_intbdu.build_association_list list let asso_of_view_in_map parameters error map = asso_of_view_in_list parameters error (Ckappa_sig.Site_map_and_set.Map.fold - (fun site state list -> (site,state)::list) - map - [] - ) - + (fun site state list -> (site, state) :: list) + map []) let restrict_asso asso set = - let asso = - Ckappa_sig.Views_intbdu.extensional_of_association_list - asso - in - let asso = List.filter (fun (a,_) -> SiteSet.mem a set) asso in + let asso = Ckappa_sig.Views_intbdu.extensional_of_association_list asso in + let asso = List.filter (fun (a, _) -> SiteSet.mem a set) asso in Ckappa_sig.Views_intbdu.build_association_list asso - type compute_full_support_output = - | Mod of (Ckappa_sig.c_agent_name * SiteSet.t * Ckappa_sig.Views_bdu.mvbdu * SiteSet.t * Ckappa_sig.Views_intbdu.hconsed_association_list) - | Creation of (Ckappa_sig.c_agent_name * SiteSet.t * Ckappa_sig.Views_intbdu.hconsed_association_list) - | Degradation of (Ckappa_sig.c_agent_name * SiteSet.t * Ckappa_sig.Views_bdu.mvbdu) + | Mod of + (Ckappa_sig.c_agent_name + * SiteSet.t + * Ckappa_sig.Views_bdu.mvbdu + * SiteSet.t + * Ckappa_sig.Views_intbdu.hconsed_association_list) + | Creation of + (Ckappa_sig.c_agent_name + * SiteSet.t + * Ckappa_sig.Views_intbdu.hconsed_association_list) + | Degradation of + (Ckappa_sig.c_agent_name * SiteSet.t * Ckappa_sig.Views_bdu.mvbdu) | Nil let compute_full_support parameters error handler ag_id rule = let test = rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs in let diff = rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.diff_direct in let error', agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - ag_id - test.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters + error ag_id test.Cckappa_sig.views in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let view = - match - agent - with + match agent with | None | Some Cckappa_sig.Ghost | Some (Cckappa_sig.Dead_agent _) | Some (Cckappa_sig.Unknown_agent _) -> None - | Some (Cckappa_sig.Agent ag) -> - Some ag + | Some (Cckappa_sig.Agent ag) -> Some ag in let parse error v = - match - v - with + match v with | Some v -> - begin - let error, list, list' = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site state (error,list,list') -> - let error, b_counter = - Handler.is_counter parameters error handler - v.Cckappa_sig.agent_name site - in - if not b_counter - then - let error', list = SiteSet.add parameters error site list in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - error, list,(site,state)::list' - else - error, list, list') - v.Cckappa_sig.agent_interface - (error, SiteSet.empty,[]) - in - error,Some v.Cckappa_sig.agent_name, - Some (list,list') - end - | None -> - begin - error, None, None - end + let error, list, list' = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site state (error, list, list') -> + let error, b_counter = + Handler.is_counter parameters error handler + v.Cckappa_sig.agent_name site + in + if not b_counter then ( + let error', list = SiteSet.add parameters error site list in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + error, list, (site, state) :: list' + ) else + error, list, list') + v.Cckappa_sig.agent_interface (error, SiteSet.empty, []) + in + error, Some v.Cckappa_sig.agent_name, Some (list, list') + | None -> error, None, None in let error, agent = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters error ag_id diff in let error = - Exception.check_point - Exception.warn parameters error error' ~message:(string_of_int (Ckappa_sig.int_of_agent_id ag_id)) __POS__ Exit + Exception.check_point Exception.warn parameters error error' + ~message:(string_of_int (Ckappa_sig.int_of_agent_id ag_id)) + __POS__ Exit in let error, name', test_opt = parse error view in let error, name'', diff = parse error agent in let error, name = match name', name'' with - | Some a , Some a' when a=a' -> error, a + | Some a, Some a' when a = a' -> error, a | Some a, None | None, Some a -> error, a - | Some _, Some _ - | None, None -> + | Some _, Some _ | None, None -> Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_agent_name in - match diff - with + match diff with | None -> - begin - match test_opt with - | None -> - Exception.warn - parameters error __POS__ - Exit Nil - | Some (list,list') -> - let error, list' = bdu_of_view parameters error list' in - error, Degradation (name, list, list') - end - | Some (list'',list''') -> - begin - let error, list''' = - asso_of_view_in_list parameters error list''' - in - match test_opt with - | None -> error, Creation (name,list'',list''') - | Some (list,list') -> - let error, list' = bdu_of_view parameters error list' in - error, Mod (name,list,list',list'',list''') - end - -let empty_hs parameters error hand_side = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun _parameters error _ agent b -> - match - agent - with - | Cckappa_sig.Ghost -> error, b - | Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Agent _ -> error, false ) - hand_side.Cckappa_sig.views true + (match test_opt with + | None -> Exception.warn parameters error __POS__ Exit Nil + | Some (list, list') -> + let error, list' = bdu_of_view parameters error list' in + error, Degradation (name, list, list')) + | Some (list'', list''') -> + let error, list''' = asso_of_view_in_list parameters error list''' in + (match test_opt with + | None -> error, Creation (name, list'', list''') + | Some (list, list') -> + let error, list' = bdu_of_view parameters error list' in + error, Mod (name, list, list', list'', list''')) + +let empty_hs parameters error hand_side = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun _parameters error _ agent b -> + match agent with + | Cckappa_sig.Ghost -> error, b + | Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Agent _ -> + error, false) + hand_side.Cckappa_sig.views true let empty_rule parameters error _r_id rule = - let error, b = - empty_hs - parameters error rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs - in - if b then - empty_hs - parameters error rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs - else error, b + let error, b = + empty_hs parameters error + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs + in + if b then + empty_hs parameters error + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs + else + error, b let build_support parameters error handler rules dead_rules = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error r_id rule (map, creation, degradation) -> - let error, b = dead_rules parameters error r_id in - let error, b' = empty_rule parameters error r_id rule in - if b || b' then error, (map, creation, degradation) - else - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error ag_id _ (map, creation, degradation) -> - match - compute_full_support parameters error handler ag_id rule - with - | error, Nil-> - error, (map, creation, degradation) - | error, Creation (agent_name, _, asso) -> - let error', old_list = - Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs - parameters error [] agent_name creation - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let error, creation = - Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite - parameters error agent_name - (((Rule r_id,ag_id),asso)::old_list) creation - in - error, (map, creation, degradation) - | error, Degradation (agent_name, _, mvbdu) -> - let error', old_map = - Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs - parameters error LabelMap.empty agent_name degradation - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let error', new_map = - LabelMap.add - parameters error - (Rule r_id,ag_id,0) mvbdu old_map - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let error, degradation = - Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite - parameters error agent_name new_map degradation - in - error, (map, creation, degradation) - | error, - Mod (agent_name, set_test, asso_test, set_mod, asso_mod) -> + let error, b = dead_rules parameters error r_id in + let error, b' = empty_rule parameters error r_id rule in + if b || b' then + error, (map, creation, degradation) + else + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold + parameters error + (fun parameters error ag_id _ (map, creation, degradation) -> + match compute_full_support parameters error handler ag_id rule with + | error, Nil -> error, (map, creation, degradation) + | error, Creation (agent_name, _, asso) -> + let error', old_list = + Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs + parameters error [] agent_name creation + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, creation = + Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite parameters + error agent_name + (((Rule r_id, ag_id), asso) :: old_list) + creation + in + error, (map, creation, degradation) + | error, Degradation (agent_name, _, mvbdu) -> + let error', old_map = + Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs + parameters error LabelMap.empty agent_name degradation + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error', new_map = + LabelMap.add parameters error (Rule r_id, ag_id, 0) mvbdu + old_map + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, degradation = + Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite parameters + error agent_name new_map degradation + in + error, (map, creation, degradation) + | error, Mod (agent_name, set_test, asso_test, set_mod, asso_mod) -> let error', old_map = Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs parameters error LabelMap.empty agent_name map in let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in let error', new_map = - LabelMap.add - parameters error - (Rule r_id,ag_id,0) (set_test, asso_test, set_mod, asso_mod) + LabelMap.add parameters error (Rule r_id, ag_id, 0) + (set_test, asso_test, set_mod, asso_mod) old_map in let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in - let error, map = Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite - parameters error agent_name new_map map + let error, map = + Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite parameters + error agent_name new_map map in error, (map, creation, degradation)) - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - (map, creation, degradation) - ) + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views + (map, creation, degradation)) rules - (Ckappa_sig.Agent_map_and_set.Map.empty, Ckappa_sig.Agent_map_and_set.Map.empty, - Ckappa_sig.Agent_map_and_set.Map.empty) + ( Ckappa_sig.Agent_map_and_set.Map.empty, + Ckappa_sig.Agent_map_and_set.Map.empty, + Ckappa_sig.Agent_map_and_set.Map.empty ) let pw parameters error list = let error, map = List.fold_left - (fun (error, acc) (_,(a,b)) -> - let error, old = - SiteMap.find_default_without_logs - parameters error [] a - acc in - SiteMap.add_or_overwrite parameters error a (b::old) acc) - (error, SiteMap.empty) - list + (fun (error, acc) (_, (a, b)) -> + let error, old = + SiteMap.find_default_without_logs parameters error [] a acc + in + SiteMap.add_or_overwrite parameters error a (b :: old) acc) + (error, SiteMap.empty) list in - error, SiteMap.fold - (fun a l acc -> - List.fold_left - (fun acc list -> - List.fold_left - (fun acc b -> - ((a,b)::list)::acc) - acc l) - acc acc) - map [[]] + ( error, + SiteMap.fold + (fun a l acc -> + List.fold_left + (fun acc list -> + List.fold_left (fun acc b -> ((a, b) :: list) :: acc) acc l) + acc acc) + map [ [] ] ) let smash_side_effect parameters error static dead_rules = let error, init = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in Ckappa_sig.AgentRule_map_and_set.Map.fold - (fun (agent_name,rule_id) _ (error,map) -> - let error, b = dead_rules parameters error rule_id in - if b then error, map - else - let error, old_asso = - match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - agent_name map - with - | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty - | error, Some set -> error, set - in - let error, new_asso = - Ckappa_sig.Rule_map_and_set.Set.add - parameters error rule_id old_asso - in - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters error - agent_name - new_asso - map) + (fun (agent_name, rule_id) _ (error, map) -> + let error, b = dead_rules parameters error rule_id in + if b then + error, map + else ( + let error, old_asso = + match + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error agent_name map + with + | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty + | error, Some set -> error, set + in + let error, new_asso = + Ckappa_sig.Rule_map_and_set.Set.add parameters error rule_id old_asso + in + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_name new_asso map + )) (Analyzer_headers.get_potential_side_effects static) (error, init) -let build_side_effect - parameters error static agent_name site_set smashed_map = - let error, init = Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - let error, ruleset = +let build_side_effect parameters error static agent_name site_set smashed_map = + let error, init = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + in + let error, ruleset = match Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - agent_name smashed_map + parameters error agent_name smashed_map with | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty | error, Some set -> error, set in Ckappa_sig.Rule_map_and_set.Set.fold - (fun r_id (error,map) -> - let error', list = - Ckappa_sig.AgentRule_map_and_set.Map.find_default_without_logs - parameters - error - [] - (agent_name,r_id) - (Analyzer_headers.get_potential_side_effects static) - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let list = - List.filter (fun (_, (a,_)) -> SiteSet.mem a site_set) list in - (* TO DO Better *) - let error, list = pw parameters error list in - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set - parameters error r_id list map) - ruleset - (error, init) - - + (fun r_id (error, map) -> + let error', list = + Ckappa_sig.AgentRule_map_and_set.Map.find_default_without_logs + parameters error [] (agent_name, r_id) + (Analyzer_headers.get_potential_side_effects static) + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let list = List.filter (fun (_, (a, _)) -> SiteSet.mem a site_set) list in + (* TO DO Better *) + let error, list = pw parameters error list in + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set parameters error r_id + list map) + ruleset (error, init) let commute parameters error label1 label2 support = let error, opt1 = LabelMap.find_option parameters error label1 support in let error, opt2 = LabelMap.find_option parameters error label2 support in - match opt1,opt2 with - | None, _ | _,None -> error, true - | Some (test1,_, act1,_), Some (test2, _, act2, _) -> + match opt1, opt2 with + | None, _ | _, None -> error, true + | Some (test1, _, act1, _), Some (test2, _, act2, _) -> let error, inter1 = SiteSet.inter parameters error test1 act2 in - if SiteSet.is_empty inter1 - then + if SiteSet.is_empty inter1 then ( let error, inter2 = SiteSet.inter parameters error test2 act1 in - if SiteSet.is_empty inter2 - then + if SiteSet.is_empty inter2 then error, true else error, false - else + ) else error, false - let cannot_be_concurrent mvbdu mvbdu1 mvbdu2 = - let mvbdu_and = - Ckappa_sig.Views_intbdu.mvbdu_and mvbdu1 mvbdu2 - in - let mvbdu = - Ckappa_sig.Views_intbdu.mvbdu_and mvbdu_and mvbdu - in - let mvbdu_false = - Ckappa_sig.Views_intbdu.mvbdu_false () - in + let mvbdu_and = Ckappa_sig.Views_intbdu.mvbdu_and mvbdu1 mvbdu2 in + let mvbdu = Ckappa_sig.Views_intbdu.mvbdu_and mvbdu_and mvbdu in + let mvbdu_false = Ckappa_sig.Views_intbdu.mvbdu_false () in Ckappa_sig.Views_intbdu.equal mvbdu_false mvbdu let concurrent_sites parameters error mvbdu support = LabelMap.fold - (fun label (_test,asso,_act,_asso_modif) (error, map')-> - let error, sites_in_conflict = - LabelMap.fold - (fun label' (_test,asso',act,_asso_modif') (error, accu) -> - let error, is_commute = commute parameters error label label' support in - if is_commute - then - if - cannot_be_concurrent mvbdu asso asso' - then - error, accu - else - let error, accu = SiteSet.union parameters error accu act in - error, accu - else - error, accu) - support - (error,SiteSet.empty) - in - let ext_list = SiteSet.elements sites_in_conflict in - let hconsed = - Ckappa_sig.Views_intbdu.build_variables_list ext_list - in - let error', map' = - LabelMap.add parameters error label (sites_in_conflict,hconsed) map' - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - error, map') - support - (error, LabelMap.empty) + (fun label (_test, asso, _act, _asso_modif) (error, map') -> + let error, sites_in_conflict = + LabelMap.fold + (fun label' (_test, asso', act, _asso_modif') (error, accu) -> + let error, is_commute = + commute parameters error label label' support + in + if is_commute then + if cannot_be_concurrent mvbdu asso asso' then + error, accu + else ( + let error, accu = SiteSet.union parameters error accu act in + error, accu + ) + else + error, accu) + support (error, SiteSet.empty) + in + let ext_list = SiteSet.elements sites_in_conflict in + let hconsed = Ckappa_sig.Views_intbdu.build_variables_list ext_list in + let error', map' = + LabelMap.add parameters error label (sites_in_conflict, hconsed) map' + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, map') + support (error, LabelMap.empty) let trivial_concurrent_sites _ error _ support = let hconsed = Ckappa_sig.Views_intbdu.build_variables_list [] in @@ -718,40 +598,37 @@ let trivial_concurrent_sites _ error _ support = let compute_var_set transition_system = List.fold_left (fun (map_interface, map_domain) mvbdu -> - let varlist = Ckappa_sig.Views_intbdu.variables_list_of_mvbdu mvbdu in - let hash = Ckappa_sig.Views_intbdu.hash_of_variables_list varlist in - let map_interface = Mods.IntMap.add hash varlist map_interface in - let old_list = Mods.IntMap.find_default [] hash map_domain in - let map_domain = Mods.IntMap.add hash (mvbdu::old_list) map_domain in - map_interface, map_domain) + let varlist = Ckappa_sig.Views_intbdu.variables_list_of_mvbdu mvbdu in + let hash = Ckappa_sig.Views_intbdu.hash_of_variables_list varlist in + let map_interface = Mods.IntMap.add hash varlist map_interface in + let old_list = Mods.IntMap.find_default [] hash map_domain in + let map_domain = Mods.IntMap.add hash (mvbdu :: old_list) map_domain in + map_interface, map_domain) (Mods.IntMap.empty, Mods.IntMap.empty) transition_system.nodes let distrib_list list1 list2 = let rec aux list1 list2 list12 list1wo2 list2wo1 = - match - list1,list2 - with - | [],_ -> List.rev list12,List.rev list1wo2,(List.rev list2wo1)@list2 - | _,[] -> List.rev list12,(List.rev list1wo2)@list1,List.rev list2wo1 - | h::q,h'::q' -> - if h=h' - then - aux q q' (h::list12) list1wo2 list2wo1 + match list1, list2 with + | [], _ -> List.rev list12, List.rev list1wo2, List.rev list2wo1 @ list2 + | _, [] -> List.rev list12, List.rev list1wo2 @ list1, List.rev list2wo1 + | h :: q, h' :: q' -> + if h = h' then + aux q q' (h :: list12) list1wo2 list2wo1 + else if h < h' then + aux q list2 list12 (h :: list1wo2) list2wo1 else - if h Printf.fprintf stdout "%i;" (Ckappa_sig.int_of_site_name s)) list + List.iter + (fun s -> Printf.fprintf stdout "%i;" (Ckappa_sig.int_of_site_name s)) + list in let () = Printf.fprintf stdout "\n" in () @@ -763,255 +640,250 @@ let distrib_list list1 list2 = let () = f listb in let () = f listc in let () = Printf.fprintf stdout "\n" in - lista,listb,listc + lista, listb, listc -let powerset map_interface = +let powerset map_interface = let list = Mods.IntMap.fold - (fun hash hconsed list -> - (hash,hconsed)::list - ) - map_interface - [] + (fun hash hconsed list -> (hash, hconsed) :: list) + map_interface [] in let list = List.sort - (fun (_,b) (_,d) -> - compare - (Ckappa_sig.Views_intbdu.nbr_variables d) (Ckappa_sig.Views_intbdu.nbr_variables b) - ) + (fun (_, b) (_, d) -> + compare + (Ckappa_sig.Views_intbdu.nbr_variables d) + (Ckappa_sig.Views_intbdu.nbr_variables b)) list in let rec aux to_use already_built = - match - to_use - with + match to_use with | [] -> already_built - | (hash,hconsed)::tail -> - begin - let already_built = - List.fold_left - (fun list (hash',hconsed',proof) -> - let hconsed'' = - Ckappa_sig.Views_intbdu.merge_variables_lists hconsed hconsed' - in - let hash'' = Ckappa_sig.Views_intbdu.hash_of_variables_list hconsed'' in - if hash'<>hash'' - then - (hash'',hconsed'',(hash,hconsed)::proof)::(hash',hconsed',proof)::list - else - (hash',hconsed',proof)::list) - [] - already_built - in - aux tail already_built - end + | (hash, hconsed) :: tail -> + let already_built = + List.fold_left + (fun list (hash', hconsed', proof) -> + let hconsed'' = + Ckappa_sig.Views_intbdu.merge_variables_lists hconsed hconsed' + in + let hash'' = + Ckappa_sig.Views_intbdu.hash_of_variables_list hconsed'' + in + if hash' <> hash'' then + (hash'', hconsed'', (hash, hconsed) :: proof) + :: (hash', hconsed', proof) :: list + else + (hash', hconsed', proof) :: list) + [] already_built + in + aux tail already_built in let hconsed = Ckappa_sig.Views_intbdu.build_variables_list [] in let hash = Ckappa_sig.Views_intbdu.hash_of_variables_list hconsed in - let list = aux list [hash,hconsed,[]] in + let list = aux list [ hash, hconsed, [] ] in let extended_map = List.fold_left - (fun extended_map (hash,_hconsed,proof) -> - let old_list = Mods.IntMap.find_default [] hash extended_map in - let new_list = - match proof with - | [] | [_] -> old_list - | _ -> proof::old_list - in - Mods.IntMap.add hash new_list extended_map) - Mods.IntMap.empty - list + (fun extended_map (hash, _hconsed, proof) -> + let old_list = Mods.IntMap.find_default [] hash extended_map in + let new_list = + match proof with + | [] | [ _ ] -> old_list + | _ -> proof :: old_list + in + Mods.IntMap.add hash new_list extended_map) + Mods.IntMap.empty list in Mods.IntMap.fold (fun hash list map -> - let list = - List.filter - (fun l -> not (List.exists (fun (a,_) -> a=hash) l)) - list - in - match list with - | [] | [_] -> map - | _ -> Mods.IntMap.add hash list map) - extended_map - Mods.IntMap.empty + let list = + List.filter (fun l -> not (List.exists (fun (a, _) -> a = hash) l)) list + in + match list with + | [] | [ _ ] -> map + | _ -> Mods.IntMap.add hash list map) + extended_map Mods.IntMap.empty let add_singular parameters error transition_system = - let map1,map2 = compute_var_set transition_system in + let map1, map2 = compute_var_set transition_system in let ambiguous_node = powerset map1 in Mods.IntMap.fold (fun _ proof_list (error, transition_system) -> - let rec aux map2 proof_list (error, transition_system)= - match proof_list with - | [] -> error, transition_system - | proof::tail -> - let error, transition_system = - List.fold_left - (fun (error, transition_system) proof' -> - let gen map2 proof = - List.fold_left - (fun mvbdu (hashvarlist,_) -> - let mvbdu' = - List.fold_left - (fun mvbdu'' mvbdu''' -> - Ckappa_sig.Views_intbdu.mvbdu_or mvbdu'' mvbdu''' - ) - (Ckappa_sig.Views_intbdu.mvbdu_false ()) - (Mods.IntMap.find_default [] hashvarlist map2) - in - Ckappa_sig.Views_intbdu.mvbdu_and - mvbdu' - mvbdu) - (Ckappa_sig.Views_intbdu.mvbdu_true ()) - proof - in - let mvbdu = - Ckappa_sig.Views_intbdu.mvbdu_and - (gen map2 proof) - (gen map2 proof') - in - let error, transition_system = - if - Remanent_parameters.get_add_singular_microstates - parameters - || Remanent_parameters.get_compute_separating_transitions parameters - then - let mvbdu_list = - Ckappa_sig.Views_intbdu.extensional_of_mvbdu mvbdu + let rec aux map2 proof_list (error, transition_system) = + match proof_list with + | [] -> error, transition_system + | proof :: tail -> + let error, transition_system = + List.fold_left + (fun (error, transition_system) proof' -> + let gen map2 proof = + List.fold_left + (fun mvbdu (hashvarlist, _) -> + let mvbdu' = + List.fold_left + (fun mvbdu'' mvbdu''' -> + Ckappa_sig.Views_intbdu.mvbdu_or mvbdu'' mvbdu''') + (Ckappa_sig.Views_intbdu.mvbdu_false ()) + (Mods.IntMap.find_default [] hashvarlist map2) in - List.fold_left - (fun (error, transition_system) asso -> - add_node parameters error - (Ckappa_sig.Views_intbdu.mvbdu_of_association_list - asso) - transition_system - ) - (error, transition_system) - mvbdu_list - else - error, transition_system - in - let error, transition_system = - if - Remanent_parameters.get_add_singular_macrostates - parameters - || Remanent_parameters.get_compute_separating_transitions parameters - then - List.fold_left - (fun (error, transition_system) (_,hconsed) -> - let length = Ckappa_sig.Views_intbdu.nbr_variables hconsed in - let list_var = Ckappa_sig.Views_intbdu.extensional_of_variables_list hconsed in - List.fold_left - (fun (error, transition_system) (_,hconsed') -> - let length' = Ckappa_sig.Views_intbdu.nbr_variables hconsed' in - let hconsed'' = - Ckappa_sig.Views_intbdu.merge_variables_lists hconsed hconsed' - in - let length'' = - Ckappa_sig.Views_intbdu.nbr_variables hconsed'' - in - if length' = length'' || length = length'' - then - (error, transition_system) - else - let list_var' = Ckappa_sig.Views_intbdu.extensional_of_variables_list hconsed' in - let lista,listb,listc = distrib_list list_var list_var' in + Ckappa_sig.Views_intbdu.mvbdu_and mvbdu' mvbdu) + (Ckappa_sig.Views_intbdu.mvbdu_true ()) + proof + in + let mvbdu = + Ckappa_sig.Views_intbdu.mvbdu_and (gen map2 proof) + (gen map2 proof') + in + let error, transition_system = + if + Remanent_parameters.get_add_singular_microstates parameters + || Remanent_parameters.get_compute_separating_transitions + parameters + then ( + let mvbdu_list = + Ckappa_sig.Views_intbdu.extensional_of_mvbdu mvbdu + in + List.fold_left + (fun (error, transition_system) asso -> + add_node parameters error + (Ckappa_sig.Views_intbdu.mvbdu_of_association_list + asso) + transition_system) + (error, transition_system) mvbdu_list + ) else + error, transition_system + in + let error, transition_system = + if + Remanent_parameters.get_add_singular_macrostates parameters + || Remanent_parameters.get_compute_separating_transitions + parameters + then + List.fold_left + (fun (error, transition_system) (_, hconsed) -> + let length = + Ckappa_sig.Views_intbdu.nbr_variables hconsed + in + let list_var = + Ckappa_sig.Views_intbdu.extensional_of_variables_list + hconsed + in + List.fold_left + (fun (error, transition_system) (_, hconsed') -> + let length' = + Ckappa_sig.Views_intbdu.nbr_variables hconsed' + in + let hconsed'' = + Ckappa_sig.Views_intbdu.merge_variables_lists + hconsed hconsed' + in + let length'' = + Ckappa_sig.Views_intbdu.nbr_variables hconsed'' + in + if length' = length'' || length = length'' then + error, transition_system + else ( + let list_var' = + Ckappa_sig.Views_intbdu + .extensional_of_variables_list hconsed' + in + let lista, listb, listc = + distrib_list list_var list_var' + in + List.fold_left + (fun (error, transition_system) list_var -> + let hconsed = + Ckappa_sig.Views_intbdu.build_variables_list + list_var + in + let restricted_mvbdu = + Ckappa_sig.Views_intbdu + .mvbdu_project_keep_only mvbdu hconsed + in + let mvbdu_list = + Ckappa_sig.Views_intbdu.extensional_of_mvbdu + restricted_mvbdu + in List.fold_left - (fun (error, transition_system) list_var -> - let hconsed = Ckappa_sig.Views_intbdu.build_variables_list list_var in - let restricted_mvbdu = Ckappa_sig.Views_intbdu.mvbdu_project_keep_only mvbdu hconsed in - let mvbdu_list = - Ckappa_sig.Views_intbdu.extensional_of_mvbdu restricted_mvbdu - in - List.fold_left - (fun (error, transition_system) asso -> - add_node parameters - error - (Ckappa_sig.Views_intbdu.mvbdu_of_association_list asso) - transition_system - ) - (error, transition_system) - mvbdu_list) - (error, transition_system) - [lista;listb;listc] - - ) - (error, transition_system) - proof - ) - (error, transition_system) - proof' - else - error, transition_system - in - error, transition_system - ) - (error, transition_system) tail - in - aux map2 tail (error, transition_system) - in - aux map2 proof_list (error, transition_system)) - ambiguous_node - (error, transition_system) - + (fun (error, transition_system) asso -> + add_node parameters error + (Ckappa_sig.Views_intbdu + .mvbdu_of_association_list asso) + transition_system) + (error, transition_system) mvbdu_list) + (error, transition_system) + [ lista; listb; listc ] + )) + (error, transition_system) proof) + (error, transition_system) proof' + else + error, transition_system + in + error, transition_system) + (error, transition_system) tail + in + aux map2 tail (error, transition_system) + in + aux map2 proof_list (error, transition_system)) + ambiguous_node (error, transition_system) let merge_neighbour parameters error concurrent_sites = LabelMap.fold (fun label (sites_in_conflict, _hconsed) (error, map) -> - let error, set, _list = - LabelMap.fold - (fun label' (sites_in_conflict', _hconsed') (error, set, list) -> - let error, diff1 = SiteSet.minus parameters error sites_in_conflict sites_in_conflict' in - let error, diff2 = SiteSet.minus parameters error sites_in_conflict' sites_in_conflict in - if SiteSet.is_singleton diff1 && SiteSet.is_singleton diff2 - then - let a1 = SiteSet.min_elt diff1 in - let a2 = SiteSet.min_elt diff2 in - match a1,a2 - with - | Some a1, Some a2 -> - let error, set = SitePairSet.add_when_not_in parameters error (a1,a2) set in - error, set, (label'::list) - | None, _ | _, None -> - let error, set = - Exception.warn parameters error __POS__ Exit set - in - error, set, list - else - error, set, list) - concurrent_sites - (error, SitePairSet.empty,[]) - in - if SitePairSet.is_singleton set - then - begin - match SitePairSet.min_elt set - with - | None -> - Exception.warn parameters error __POS__ Exit map - | Some (a1,_a2) -> - let error, sites_in_conflict = SiteSet.remove parameters error a1 sites_in_conflict in - let ext_list = SiteSet.elements sites_in_conflict in - let hconsed = - Ckappa_sig.Views_intbdu.build_variables_list ext_list - in - LabelMap.overwrite parameters error label (sites_in_conflict,hconsed) map - end - else - error, map) - concurrent_sites - (error, concurrent_sites) + let error, set, _list = + LabelMap.fold + (fun label' (sites_in_conflict', _hconsed') (error, set, list) -> + let error, diff1 = + SiteSet.minus parameters error sites_in_conflict + sites_in_conflict' + in + let error, diff2 = + SiteSet.minus parameters error sites_in_conflict' + sites_in_conflict + in + if SiteSet.is_singleton diff1 && SiteSet.is_singleton diff2 then ( + let a1 = SiteSet.min_elt diff1 in + let a2 = SiteSet.min_elt diff2 in + match a1, a2 with + | Some a1, Some a2 -> + let error, set = + SitePairSet.add_when_not_in parameters error (a1, a2) set + in + error, set, label' :: list + | None, _ | _, None -> + let error, set = + Exception.warn parameters error __POS__ Exit set + in + error, set, list + ) else + error, set, list) + concurrent_sites + (error, SitePairSet.empty, []) + in + if SitePairSet.is_singleton set then ( + match SitePairSet.min_elt set with + | None -> Exception.warn parameters error __POS__ Exit map + | Some (a1, _a2) -> + let error, sites_in_conflict = + SiteSet.remove parameters error a1 sites_in_conflict + in + let ext_list = SiteSet.elements sites_in_conflict in + let hconsed = Ckappa_sig.Views_intbdu.build_variables_list ext_list in + LabelMap.overwrite parameters error label + (sites_in_conflict, hconsed) + map + ) else + error, map) + concurrent_sites (error, concurrent_sites) let concurrent_sites parameters error mvbdu support = if Remanent_parameters.get_use_macrotransitions_in_local_traces parameters - then + then ( let error, concurrent = concurrent_sites parameters error mvbdu support in - if Remanent_parameters.get_ignore_local_losanges parameters - then + if Remanent_parameters.get_ignore_local_losanges parameters then merge_neighbour parameters error concurrent else error, concurrent - else + ) else trivial_concurrent_sites parameters error mvbdu support let add key im map = @@ -1019,791 +891,691 @@ let add key im map = Mods.IntMap.add key (Mods.IntSet.add im old_set) map let addsub small big transition_system = - { - transition_system - with - subframe = add small big transition_system.subframe; - } + { transition_system with subframe = add small big transition_system.subframe } let add_whether_subframe parameters error mvbdu1 mvbdu2 transition_system = - if - Ckappa_sig.Views_intbdu.equal mvbdu1 mvbdu2 - then + if Ckappa_sig.Views_intbdu.equal mvbdu1 mvbdu2 then error, transition_system - else + else ( let mvbdu_lub = Ckappa_sig.Views_intbdu.mvbdu_or mvbdu1 mvbdu2 in - if Ckappa_sig.Views_intbdu.equal mvbdu_lub mvbdu2 then + if Ckappa_sig.Views_intbdu.equal mvbdu_lub mvbdu2 then ( let error, hash1 = hash_of_mvbdu parameters error mvbdu1 in let error, hash2 = hash_of_mvbdu parameters error mvbdu2 in error, addsub hash1 hash2 transition_system - else + ) else error, transition_system + ) let check_all_subframes parameters error transition_system = List.fold_left (fun (error, transition_system) mvbdu1 -> - List.fold_left - (fun (error, transition_system) mvbdu2 -> - add_whether_subframe parameters error mvbdu1 mvbdu2 transition_system - ) - (error, transition_system) - transition_system.nodes - ) - (error, transition_system) - transition_system.nodes + List.fold_left + (fun (error, transition_system) mvbdu2 -> + add_whether_subframe parameters error mvbdu1 mvbdu2 transition_system) + (error, transition_system) transition_system.nodes) + (error, transition_system) transition_system.nodes let reduce_subframes transition_system = { - transition_system - with - subframe = - Mods.IntMap.map - (fun set -> - Mods.IntSet.filter - (fun i -> - Mods.IntSet.for_all - (fun j -> - not (Mods.IntSet.mem i (Mods.IntMap.find_default - Mods.IntSet.empty j transition_system.subframe))) - set) - set) - transition_system.subframe + transition_system with + subframe = + Mods.IntMap.map + (fun set -> + Mods.IntSet.filter + (fun i -> + Mods.IntSet.for_all + (fun j -> + not + (Mods.IntSet.mem i + (Mods.IntMap.find_default Mods.IntSet.empty j + transition_system.subframe))) + set) + set) + transition_system.subframe; } - -let print logger parameters compil handler_kappa handler error transition_system = +let print logger parameters compil handler_kappa handler error transition_system + = let () = Graph_loggers.print_graph_preamble logger transition_system.title in (* nodes -> Initial *) - let error,handler = + let error, handler = List.fold_left - (fun (error, handler) (mvbdu,_label) -> - let error, key = hash_of_mvbdu parameters error mvbdu in - let () = - Graph_loggers.print_node logger - ("Init_"^(string_of_int key)) - ~directives: - [ - Graph_loggers_sig.Width 0; - Graph_loggers_sig.Height 0; - Graph_loggers_sig.Shape Graph_loggers_sig.Invisible; - Graph_loggers_sig.Label "" - ] - in - error, handler) - (error, handler) - transition_system.nodes_creation + (fun (error, handler) (mvbdu, _label) -> + let error, key = hash_of_mvbdu parameters error mvbdu in + let () = + Graph_loggers.print_node logger + ("Init_" ^ string_of_int key) + ~directives: + [ + Graph_loggers_sig.Width 0; + Graph_loggers_sig.Height 0; + Graph_loggers_sig.Shape Graph_loggers_sig.Invisible; + Graph_loggers_sig.Label ""; + ] + in + error, handler) + (error, handler) transition_system.nodes_creation in (* nodes -> final *) - let error,handler = + let error, handler = List.fold_left - (fun (error, handler) (mvbdu,_label) -> - let error, key = hash_of_mvbdu parameters error mvbdu in - let () = - Graph_loggers.print_node logger - ("Final_"^(string_of_int key)) - ~directives: - [ - Graph_loggers_sig.Width 0; - Graph_loggers_sig.Height 0; - Graph_loggers_sig.Shape Graph_loggers_sig.Invisible; - Graph_loggers_sig.Label "" - ] - in - error, handler) - (error, handler) - transition_system.nodes_degradation + (fun (error, handler) (mvbdu, _label) -> + let error, key = hash_of_mvbdu parameters error mvbdu in + let () = + Graph_loggers.print_node logger + ("Final_" ^ string_of_int key) + ~directives: + [ + Graph_loggers_sig.Width 0; + Graph_loggers_sig.Height 0; + Graph_loggers_sig.Shape Graph_loggers_sig.Invisible; + Graph_loggers_sig.Label ""; + ] + in + error, handler) + (error, handler) transition_system.nodes_degradation in (* nodes -> regular *) let error = List.fold_left (fun error -> - dump_mvbdu logger parameters error handler_kappa transition_system) - error - transition_system.nodes + dump_mvbdu logger parameters error handler_kappa transition_system) + error transition_system.nodes in (* edges *) let error, handler = List.fold_left - (fun (error, handler) (q,label,q') -> - let error, key = hash_of_mvbdu parameters - error q - in - let error, key' = hash_of_mvbdu parameters error q' in - let error, rule_name = - if Remanent_parameters.get_show_rule_names_in_local_traces parameters - then - begin - match - label - with - | Rule r,_,_ -> - Handler.string_of_rule - ~with_loc:false ~with_rule:false ~with_ast:false - parameters error compil r - | Init _,_,_ -> - error, "" - end - else - error, "" - in - let () = - Graph_loggers.print_edge - logger - ("Node_"^(string_of_int key)) - ("Node_"^(string_of_int key')) - ~directives: - [ - Graph_loggers_sig.Label rule_name - ] - in - error,handler) - (error,handler) - transition_system.edges + (fun (error, handler) (q, label, q') -> + let error, key = hash_of_mvbdu parameters error q in + let error, key' = hash_of_mvbdu parameters error q' in + let error, rule_name = + if Remanent_parameters.get_show_rule_names_in_local_traces parameters + then ( + match label with + | Rule r, _, _ -> + Handler.string_of_rule ~with_loc:false ~with_rule:false + ~with_ast:false parameters error compil r + | Init _, _, _ -> error, "" + ) else + error, "" + in + let () = + Graph_loggers.print_edge logger + ("Node_" ^ string_of_int key) + ("Node_" ^ string_of_int key') + ~directives:[ Graph_loggers_sig.Label rule_name ] + in + error, handler) + (error, handler) transition_system.edges in - let error,_ = + let error, _ = List.fold_left - (fun (error, handler) (q,label) -> - let error, key = hash_of_mvbdu parameters error q in - let error, rule_name = - if - Remanent_parameters.get_show_rule_names_in_local_traces - parameters - then - begin - match - label - with - | Rule r,_,_ -> - Handler.string_of_rule - ~with_loc:false ~with_rule:false ~with_ast:false - parameters error compil r - | Init _,_,_ -> error, "" - end - else - error, "" - in - let () = - Graph_loggers.print_edge - logger - ("Init_"^(string_of_int key)) - ("Node_"^(string_of_int key)) - ~directives: - [ - Graph_loggers_sig.Label rule_name ; - ] - in - error, handler) - (error,handler) - transition_system.nodes_creation + (fun (error, handler) (q, label) -> + let error, key = hash_of_mvbdu parameters error q in + let error, rule_name = + if Remanent_parameters.get_show_rule_names_in_local_traces parameters + then ( + match label with + | Rule r, _, _ -> + Handler.string_of_rule ~with_loc:false ~with_rule:false + ~with_ast:false parameters error compil r + | Init _, _, _ -> error, "" + ) else + error, "" + in + let () = + Graph_loggers.print_edge logger + ("Init_" ^ string_of_int key) + ("Node_" ^ string_of_int key) + ~directives:[ Graph_loggers_sig.Label rule_name ] + in + error, handler) + (error, handler) transition_system.nodes_creation in - let error,_ = + let error, _ = List.fold_left - (fun (error, handler) (q,label) -> - let error, key = hash_of_mvbdu parameters error q in - let error, rule_name = - if - Remanent_parameters.get_show_rule_names_in_local_traces - parameters - then - begin - match - label - with - | Rule r,_,_ -> - Handler.string_of_rule - ~with_loc:false ~with_rule:false ~with_ast:false - parameters error compil r - | Init _,_,_ -> error, "" - end - else - error, "" - in - let () = - Graph_loggers.print_edge - logger - ("Node_"^(string_of_int key)) - ("Final_"^(string_of_int key)) - ~directives: - [ - Graph_loggers_sig.Label rule_name ; - ] - in - error, handler) - (error,handler) - transition_system.nodes_degradation + (fun (error, handler) (q, label) -> + let error, key = hash_of_mvbdu parameters error q in + let error, rule_name = + if Remanent_parameters.get_show_rule_names_in_local_traces parameters + then ( + match label with + | Rule r, _, _ -> + Handler.string_of_rule ~with_loc:false ~with_rule:false + ~with_ast:false parameters error compil r + | Init _, _, _ -> error, "" + ) else + error, "" + in + let () = + Graph_loggers.print_edge logger + ("Node_" ^ string_of_int key) + ("Final_" ^ string_of_int key) + ~directives:[ Graph_loggers_sig.Label rule_name ] + in + error, handler) + (error, handler) transition_system.nodes_degradation in let () = Mods.IntMap.iter (fun key l -> - if Mods.IntSet.is_empty l - then - () - else - let k = "Node_"^(string_of_int key) in - let l = List.rev (Mods.IntSet.fold (fun i list -> ("Node_"^(string_of_int i))::list) l []) in - Graph_loggers.print_one_to_n_relation logger ~style_one:Graph_loggers_sig.Dotted ~style_n:Graph_loggers_sig.Dashed k l) + if Mods.IntSet.is_empty l then + () + else ( + let k = "Node_" ^ string_of_int key in + let l = + List.rev + (Mods.IntSet.fold + (fun i list -> ("Node_" ^ string_of_int i) :: list) + l []) + in + Graph_loggers.print_one_to_n_relation logger + ~style_one:Graph_loggers_sig.Dotted + ~style_n:Graph_loggers_sig.Dashed k l + )) transition_system.subframe in let () = Graph_loggers.print_graph_foot logger in error let empty_bridge_set = Mods.IntMap.empty -let add_bridge (a,b,c) set = + +let add_bridge (a, b, c) set = let b = Ckappa_sig.int_of_rule_id b in - let old = - Mods.IntMap.find_default - [] b set - in - Mods.IntMap.add b ((a,c)::old) set + let old = Mods.IntMap.find_default [] b set in + Mods.IntMap.add b ((a, c) :: old) set -let agent_trace - parameters log_info error dead_rules handler static handler_kappa - compil output = +let agent_trace parameters log_info error dead_rules handler static + handler_kappa compil output = let transition_system_length = [] in let bridges = empty_bridge_set in - let error, low = - Graphs.Nodearray.create parameters error 1 - in - let error, pre = - Graphs.Nodearray.create parameters error 1 - in - let error, on_stack = - Graphs.Nodearray.create parameters error 1 - in - let error, scc = - Graphs.Nodearray.create parameters error 1 - in + let error, low = Graphs.Nodearray.create parameters error 1 in + let error, pre = Graphs.Nodearray.create parameters error 1 in + let error, on_stack = Graphs.Nodearray.create parameters error 1 in + let error, scc = Graphs.Nodearray.create parameters error 1 in let () = Ckappa_sig.Views_intbdu.import_handler handler in let rules = compil.Cckappa_sig.rules in let init = compil.Cckappa_sig.init in let error, side_effects = - smash_side_effect - parameters error static dead_rules + smash_side_effect parameters error static dead_rules in let error, (support, creation, degradation) = build_support parameters error handler_kappa rules dead_rules in let error, init = - Int_storage.Nearly_inf_Imperatif.fold - parameters - error + Int_storage.Nearly_inf_Imperatif.fold parameters error (fun parameters error i_id init init_map -> - let mixture = init.Cckappa_sig.e_init_c_mixture in - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error ag_id view init_map -> - match - view - with - | Cckappa_sig.Agent agent -> - let error', old_list = - Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs parameters error [] agent.Cckappa_sig.agent_name init_map - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let error, asso = - asso_of_view_in_map - parameters error agent.Cckappa_sig.agent_interface - in - let error, new_map = - Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite - parameters error agent.Cckappa_sig.agent_name - ((((Init i_id),ag_id),asso)::old_list) init_map - in - error, (new_map) - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _ -> - Exception.warn parameters error __POS__ Exit init_map - ) - mixture.Cckappa_sig.views - init_map) - init - creation + let mixture = init.Cckappa_sig.e_init_c_mixture in + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold + parameters error + (fun parameters error ag_id view init_map -> + match view with + | Cckappa_sig.Agent agent -> + let error', old_list = + Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs + parameters error [] agent.Cckappa_sig.agent_name init_map + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, asso = + asso_of_view_in_map parameters error + agent.Cckappa_sig.agent_interface + in + let error, new_map = + Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite parameters + error agent.Cckappa_sig.agent_name + (((Init i_id, ag_id), asso) :: old_list) + init_map + in + error, new_map + | Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ -> + Exception.warn parameters error __POS__ Exit init_map) + mixture.Cckappa_sig.views init_map) + init creation in let empty = Ckappa_sig.Views_intbdu.build_variables_list [] in let error, (_, _, _, _, bridges, transition_system_length, log_info) = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_type map - (pre,low,on_stack,scc, bridges, transition_system_length, log_info) -> - let error, support = - Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs parameters error - LabelMap.empty agent_type support - in - let error, degradation = - Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs - parameters error - LabelMap.empty agent_type degradation - in - let error', agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> Exception.warn parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - Wrapped_modules.LoggedIntMap.fold - (fun _ mvbdu - (error,(pre,low,on_stack,scc,bridges,transition_system_length,log_info)) -> - try - begin - let sites = - Ckappa_sig.Views_intbdu.variables_list_of_mvbdu - mvbdu - in - let ext_list = - Ckappa_sig.Views_intbdu.extensional_of_variables_list - sites - in - let def_list = - List.rev_map - (fun i -> (i,Ckappa_sig.state_index_of_int 0)) - ext_list - in - let mvbdu_default_value = - mvbdu_of_reverse_order_association_list - def_list - in - let error', site_set = - List.fold_left - (fun (error, set) site -> - SiteSet.add parameters error site set) - (error, SiteSet.empty) - ext_list - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let error, potential_side_effect = - build_side_effect - parameters error static agent_type site_set side_effects - in - let error, support = - LabelMap.fold - (fun label (test, asso_test, modif, asso_modif) - (error, map) -> - let error, test = - SiteSet.inter parameters error test site_set - in - let asso_test = - Ckappa_sig.Views_intbdu.mvbdu_project_keep_only - asso_test sites - in - let error, modif = - SiteSet.inter parameters error modif site_set - in - if SiteSet.is_empty modif - then error, map - else - let asso_modif = - Ckappa_sig.Views_intbdu.extensional_of_association_list - asso_modif + (pre, low, on_stack, scc, bridges, transition_system_length, log_info) -> + let error, support = + Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs parameters + error LabelMap.empty agent_type support + in + let error, degradation = + Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs parameters + error LabelMap.empty agent_type degradation + in + let error', agent_string = + try Handler.string_of_agent parameters error handler_kappa agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + Wrapped_modules.LoggedIntMap.fold + (fun _ mvbdu + ( error, + ( pre, + low, + on_stack, + scc, + bridges, + transition_system_length, + log_info ) ) -> + try + let sites = + Ckappa_sig.Views_intbdu.variables_list_of_mvbdu mvbdu + in + let ext_list = + Ckappa_sig.Views_intbdu.extensional_of_variables_list sites + in + let def_list = + List.rev_map + (fun i -> i, Ckappa_sig.state_index_of_int 0) + ext_list + in + let mvbdu_default_value = + mvbdu_of_reverse_order_association_list def_list + in + let error', site_set = + List.fold_left + (fun (error, set) site -> + SiteSet.add parameters error site set) + (error, SiteSet.empty) ext_list + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, potential_side_effect = + build_side_effect parameters error static agent_type site_set + side_effects + in + let error, support = + LabelMap.fold + (fun label (test, asso_test, modif, asso_modif) (error, map) -> + let error, test = + SiteSet.inter parameters error test site_set + in + let asso_test = + Ckappa_sig.Views_intbdu.mvbdu_project_keep_only asso_test + sites + in + let error, modif = + SiteSet.inter parameters error modif site_set + in + if SiteSet.is_empty modif then + error, map + else ( + let asso_modif = + Ckappa_sig.Views_intbdu.extensional_of_association_list + asso_modif + in + let asso_modif = + List.filter + (fun (a, _) -> SiteSet.mem a site_set) + asso_modif + in + let asso_modif = + Ckappa_sig.Views_intbdu.build_association_list + asso_modif + in + let error', map = + LabelMap.add parameters error label + (test, asso_test, modif, asso_modif) + map + in + let error = + Exception.check_point Exception.warn parameters error + error' __POS__ Exit + in + error, map + )) + support (error, LabelMap.empty) + in + let error, support = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun parameters error r_id list support -> + let error, support, _ = + List.fold_left + (fun (error, support, id) list -> + let error', test = + List.fold_left + (fun (error, set) (a, _) -> + SiteSet.add parameters error a set) + (error, SiteSet.empty) list + in + let error = + Exception.check_point Exception.warn parameters + error error' __POS__ Exit + in + let modif = test in + let asso_test = + Ckappa_sig.Views_intbdu.build_association_list list + in + let asso_test = + Ckappa_sig.Views_intbdu.mvbdu_redefine + (Ckappa_sig.Views_intbdu.mvbdu_true ()) + asso_test in let asso_modif = - List.filter - (fun (a,_) -> SiteSet.mem a site_set) asso_modif + List.rev_map + (fun (a, _) -> a, Ckappa_sig.dummy_state_index) + (List.rev list) in let asso_modif = Ckappa_sig.Views_intbdu.build_association_list asso_modif in - let error', map = - LabelMap.add parameters error label (test,asso_test,modif,asso_modif) map - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - error, map) - support - (error, LabelMap.empty) - in - let error, support = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error r_id list support -> - let error, support, _ = - List.fold_left - (fun (error, support, id) list -> - let error', test = - List.fold_left - (fun (error,set) (a,_) -> - SiteSet.add parameters error a set) - (error,SiteSet.empty) list - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let modif = test in - let asso_test = - Ckappa_sig.Views_intbdu.build_association_list list - in - let asso_test = - Ckappa_sig.Views_intbdu.mvbdu_redefine - (Ckappa_sig.Views_intbdu.mvbdu_true ()) - asso_test - in - let asso_modif = - List.rev_map - (fun (a,_) -> a,Ckappa_sig.dummy_state_index) - (List.rev list) - in - let asso_modif = - Ckappa_sig.Views_intbdu.build_association_list asso_modif in - let label = (Rule r_id, - Ckappa_sig.agent_id_of_int (-1),id) in - let error', support = - LabelMap.add parameters error label (test,asso_test,modif,asso_modif) support - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - (error, support, id+1) - ) - (error, support, 0) list - in error, support) - potential_side_effect - support - in - let error, concurrent_sites = - concurrent_sites parameters error mvbdu support - in - let error, concurrent_sites = - merge_neighbour parameters error concurrent_sites - in - let error, file_name = - List.fold_left - (fun (error, string) site -> - let error, site_string = - Handler.string_of_site_in_file_name - parameters error handler_kappa agent_type site - in - error, string^"."^site_string) - (error, - ((Remanent_parameters.get_local_trace_directory - parameters)^(Remanent_parameters.get_local_trace_prefix parameters)^(agent_string))) - ext_list - in - let transition_system = empty_transition_system file_name agent_string agent_type in - let fic = - if Remanent_parameters.get_compute_local_traces parameters - then - Remanent_parameters.open_out file_name - (Remanent_parameters.ext_format - (Remanent_parameters.get_local_trace_format - parameters)) - else - match - Loggers.channel_of_logger - (Remanent_parameters.get_logger parameters) - with - | Some channel -> channel - | None -> stdout - in - let error', init_list = - Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs - parameters error [] agent_type init - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let error, transition_system = - (* initial/creation states *) - List.fold_left - (fun (error, transition_system) ((i_id,ag_id),asso) - -> - let update = - restrict_asso asso site_set + let label = + Rule r_id, Ckappa_sig.agent_id_of_int (-1), id in - let mvbdu = - Ckappa_sig.Views_intbdu.mvbdu_redefine - mvbdu_default_value update + let error', support = + LabelMap.add parameters error label + (test, asso_test, modif, asso_modif) + support in - let error, transition_system = - add_creation - parameters error - i_id ag_id mvbdu transition_system + let error = + Exception.check_point Exception.warn parameters + error error' __POS__ Exit in - error, transition_system) - (error, transition_system) - init_list - in - let error, transition_system = - (* regular transitions *) - LabelMap.fold - (fun label (_test,asso,modif,asso_modif) (error, transition_system) - -> - if SiteSet.is_empty modif - then - error, transition_system - else - let error', concurrent_site = - LabelMap.find_default - parameters error (SiteSet.empty,empty) label - concurrent_sites - in - let error = - Exception.check_point - Exception.warn - parameters error error' - __POS__ - Exit - in - let mvbdu = - Ckappa_sig.Views_intbdu.mvbdu_project_abstract_away - mvbdu (snd concurrent_site) - in - let mvbdu = - Ckappa_sig.Views_intbdu.mvbdu_and - mvbdu asso + error, support, id + 1) + (error, support, 0) list + in + error, support) + potential_side_effect support + in + let error, concurrent_sites = + concurrent_sites parameters error mvbdu support + in + let error, concurrent_sites = + merge_neighbour parameters error concurrent_sites + in + let error, file_name = + List.fold_left + (fun (error, string) site -> + let error, site_string = + Handler.string_of_site_in_file_name parameters error + handler_kappa agent_type site + in + error, string ^ "." ^ site_string) + ( error, + Remanent_parameters.get_local_trace_directory parameters + ^ Remanent_parameters.get_local_trace_prefix parameters + ^ agent_string ) + ext_list + in + let transition_system = + empty_transition_system file_name agent_string agent_type + in + let fic = + if Remanent_parameters.get_compute_local_traces parameters then + Remanent_parameters.open_out file_name + (Remanent_parameters.ext_format + (Remanent_parameters.get_local_trace_format parameters)) + else ( + match + Loggers.channel_of_logger + (Remanent_parameters.get_logger parameters) + with + | Some channel -> channel + | None -> stdout + ) + in + let error', init_list = + Ckappa_sig.Agent_map_and_set.Map.find_default_without_logs + parameters error [] agent_type init + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, transition_system = + (* initial/creation states *) + List.fold_left + (fun (error, transition_system) ((i_id, ag_id), asso) -> + let update = restrict_asso asso site_set in + let mvbdu = + Ckappa_sig.Views_intbdu.mvbdu_redefine mvbdu_default_value + update + in + let error, transition_system = + add_creation parameters error i_id ag_id mvbdu + transition_system + in + error, transition_system) + (error, transition_system) init_list + in + let error, transition_system = + (* regular transitions *) + LabelMap.fold + (fun label (_test, asso, modif, asso_modif) + (error, transition_system) -> + if SiteSet.is_empty modif then + error, transition_system + else ( + let error', concurrent_site = + LabelMap.find_default parameters error + (SiteSet.empty, empty) label concurrent_sites + in + let error = + Exception.check_point Exception.warn parameters error + error' __POS__ Exit + in + let mvbdu = + Ckappa_sig.Views_intbdu.mvbdu_project_abstract_away + mvbdu (snd concurrent_site) + in + let mvbdu = + Ckappa_sig.Views_intbdu.mvbdu_and mvbdu asso + in + let pre = + Ckappa_sig.Views_intbdu.extensional_of_mvbdu mvbdu + in + let error, transition_system = + List.fold_left + (fun (error, transition_system) list -> + let pre = mvbdu_of_association_list list in + let post = + Ckappa_sig.Views_intbdu.mvbdu_redefine pre + asso_modif in - let pre = - Ckappa_sig.Views_intbdu.extensional_of_mvbdu - mvbdu + let error, transition_system = + add_node parameters error pre transition_system in let error, transition_system = - List.fold_left - (fun (error, transition_system) list -> - let pre = - mvbdu_of_association_list - list - in - let post = - Ckappa_sig.Views_intbdu.mvbdu_redefine - pre asso_modif - in - let error, transition_system = - add_node parameters error pre - transition_system - in - let error, transition_system = - add_node parameters error post - transition_system + add_node parameters error post transition_system + in - in - let transition_system = - add_edge pre post label transition_system - in - error, transition_system) - (error, transition_system) - pre + let transition_system = + add_edge pre post label transition_system in error, transition_system) - support - (error, transition_system) - in - (* degradation transitions *) - let transition_system = - LabelMap.fold - (fun label (asso) transition_system - -> - List.fold_left - (fun transition_system mvbdu -> - if Ckappa_sig.Views_intbdu.equal - (Ckappa_sig.Views_intbdu.mvbdu_false ()) - (Ckappa_sig.Views_intbdu.mvbdu_and - mvbdu asso) - then - transition_system - else - { - transition_system with - nodes_degradation = - (mvbdu,label)::transition_system.nodes_degradation} - ) - transition_system - transition_system.nodes) - degradation - transition_system - in - let transition_system_length = - (List.length transition_system.edges)::transition_system_length - in - let error, transition_system = - if Remanent_parameters.get_add_singular_macrostates - parameters - || - Remanent_parameters.get_add_singular_microstates parameters - then - add_singular parameters error transition_system - else + (error, transition_system) pre + in error, transition_system - in - let error, transition_system = - check_all_subframes parameters error transition_system - in - let transition_system = - reduce_subframes transition_system - in - let error, log_info = - if Remanent_parameters.get_compute_local_traces parameters - then - begin - let format = - match - Remanent_parameters.get_local_trace_format - parameters - with - | Remanent_parameters_sig.GEPHI -> Loggers.GEPHI - | Remanent_parameters_sig.DIM -> Loggers.Matrix - | Remanent_parameters_sig.DOT -> Loggers.DOT - | Remanent_parameters_sig.HTML -> Loggers.HTML_Graph - in - let logger = - Loggers.open_logger_from_channel fic - ~mode:format - in - let logger = - Graph_loggers_sig.extend_logger logger - in - let error = - print - logger parameters compil - handler_kappa () error transition_system - in - let _ = close_out fic in - error, log_info - end - else - error, log_info - in - let error, nodes, node_labels = + )) + support (error, transition_system) + in + (* degradation transitions *) + let transition_system = + LabelMap.fold + (fun label asso transition_system -> List.fold_left - (fun (error, nodes, node_labels) mvbdu -> - let error, node = - hash_of_mvbdu parameters error mvbdu - in - let error, list = build_asso_of_mvbdu parameters error mvbdu in - let error, label = - string_label_of_asso parameters error handler_kappa transition_system list in - let node = Graphs.node_of_int node in - error, - node::nodes, - Graphs.NodeMap.add node label node_labels) - (error, [], Graphs.NodeMap.empty) - transition_system.nodes - in - let node_label node = - Graphs.NodeMap.find_default "" node node_labels + (fun transition_system mvbdu -> + if + Ckappa_sig.Views_intbdu.equal + (Ckappa_sig.Views_intbdu.mvbdu_false ()) + (Ckappa_sig.Views_intbdu.mvbdu_and mvbdu asso) + then + transition_system + else + { + transition_system with + nodes_degradation = + (mvbdu, label) + :: transition_system.nodes_degradation; + }) + transition_system transition_system.nodes) + degradation transition_system + in + let transition_system_length = + List.length transition_system.edges :: transition_system_length + in + let error, transition_system = + if + Remanent_parameters.get_add_singular_macrostates parameters + || Remanent_parameters.get_add_singular_microstates parameters + then + add_singular parameters error transition_system + else + error, transition_system + in + let error, transition_system = + check_all_subframes parameters error transition_system + in + let transition_system = reduce_subframes transition_system in + let error, log_info = + if Remanent_parameters.get_compute_local_traces parameters then ( + let format = + match + Remanent_parameters.get_local_trace_format parameters + with + | Remanent_parameters_sig.GEPHI -> Loggers.GEPHI + | Remanent_parameters_sig.DIM -> Loggers.Matrix + | Remanent_parameters_sig.DOT -> Loggers.DOT + | Remanent_parameters_sig.HTML -> Loggers.HTML_Graph in - let error, edges = - List.fold_left - (fun (error, edges) (mvbdu1,label,mvbdu2) -> - let error, node1 = - hash_of_mvbdu parameters error mvbdu1 - in - let error, node2 = - hash_of_mvbdu parameters error mvbdu2 - in - match label with - (Init _,_,_) -> error, edges - | (Rule id,_,_) -> - error, - (Graphs.node_of_int node1, - id, - Graphs.node_of_int node2)::edges - ) - (error, []) transition_system.edges + let logger = + Loggers.open_logger_from_channel fic ~mode:format in - let edges = - Mods.IntMap.fold - (fun _ l edges -> - if Mods.IntSet.is_empty l - then - edges - else - let first_last, edges = - Mods.IntSet.fold - (fun next (first_last,edges) -> - let next = Graphs.node_of_int next in - match first_last - with - | None -> (Some (next,next),edges) - | Some (first,last) - -> - Some (first, next), - ((last,Ckappa_sig.dummy_rule_id,next)::edges)) - l - (None,edges) - in - match first_last with - | None -> edges - | Some (x,y) when x=y -> edges - | Some (first,last) -> - (last,Ckappa_sig.dummy_rule_id,first)::edges) - transition_system.subframe - edges + let logger = Graph_loggers_sig.extend_logger logger in + let error = + print logger parameters compil handler_kappa () error + transition_system in - let error, graph = - Graphs.create - parameters - error - node_label - nodes + let _ = close_out fic in + error, log_info + ) else + error, log_info + in + let error, nodes, node_labels = + List.fold_left + (fun (error, nodes, node_labels) mvbdu -> + let error, node = hash_of_mvbdu parameters error mvbdu in + let error, list = + build_asso_of_mvbdu parameters error mvbdu + in + let error, label = + string_label_of_asso parameters error handler_kappa + transition_system list + in + let node = Graphs.node_of_int node in + ( error, + node :: nodes, + Graphs.NodeMap.add node label node_labels )) + (error, [], Graphs.NodeMap.empty) + transition_system.nodes + in + let node_label node = + Graphs.NodeMap.find_default "" node node_labels + in + let error, edges = + List.fold_left + (fun (error, edges) (mvbdu1, label, mvbdu2) -> + let error, node1 = hash_of_mvbdu parameters error mvbdu1 in + let error, node2 = hash_of_mvbdu parameters error mvbdu2 in + match label with + | Init _, _, _ -> error, edges + | Rule id, _, _ -> + ( error, + (Graphs.node_of_int node1, id, Graphs.node_of_int node2) + :: edges )) + (error, []) transition_system.edges + in + let edges = + Mods.IntMap.fold + (fun _ l edges -> + if Mods.IntSet.is_empty l then edges - in - let - error, pre, low, on_stack, scc, bridges = - Graphs.add_bridges - ~low ~pre ~on_stack ~scc - add_bridge - parameters error - (fun n -> n) - (fun e -> - Ckappa_sig.string_of_rule_id e) - graph bridges - in - error, - (pre,low,on_stack,scc,bridges,transition_system_length,log_info) - end - with Sys.Break -> error, - (pre,low,on_stack,scc,bridges,transition_system_length,log_info) - ) - map - (error, (pre,low,on_stack,scc,bridges,transition_system_length,log_info))) + else ( + let first_last, edges = + Mods.IntSet.fold + (fun next (first_last, edges) -> + let next = Graphs.node_of_int next in + match first_last with + | None -> Some (next, next), edges + | Some (first, last) -> + ( Some (first, next), + (last, Ckappa_sig.dummy_rule_id, next) :: edges + )) + l (None, edges) + in + match first_last with + | None -> edges + | Some (x, y) when x = y -> edges + | Some (first, last) -> + (last, Ckappa_sig.dummy_rule_id, first) :: edges + )) + transition_system.subframe edges + in + let error, graph = + Graphs.create parameters error node_label nodes edges + in + let error, pre, low, on_stack, scc, bridges = + Graphs.add_bridges ~low ~pre ~on_stack ~scc add_bridge + parameters error + (fun n -> n) + (fun e -> Ckappa_sig.string_of_rule_id e) + graph bridges + in + ( error, + ( pre, + low, + on_stack, + scc, + bridges, + transition_system_length, + log_info ) ) + with Sys.Break -> + ( error, + ( pre, + low, + on_stack, + scc, + bridges, + transition_system_length, + log_info ) )) + map + ( error, + ( pre, + low, + on_stack, + scc, + bridges, + transition_system_length, + log_info ) )) output - (pre,low,on_stack,scc,bridges,transition_system_length,log_info) + (pre, low, on_stack, scc, bridges, transition_system_length, log_info) in let bridges = - if Remanent_parameters.get_compute_separating_transitions parameters - then + if Remanent_parameters.get_compute_separating_transitions parameters then Some bridges else None in let transition_system_length = Some transition_system_length in - match - Ckappa_sig.Views_intbdu.export_handler error - with + match Ckappa_sig.Views_intbdu.export_handler error with | error, Some h -> error, log_info, h, bridges, transition_system_length | error, None -> - let error, h = - Exception.warn parameters error __POS__ Exit handler in + let error, h = Exception.warn parameters error __POS__ Exit handler in error, log_info, h, bridges, transition_system_length diff --git a/core/KaSa_rep/reachability_analysis/agents_domain.ml b/core/KaSa_rep/reachability_analysis/agents_domain.ml index b0f034d628..d2fedc9bca 100644 --- a/core/KaSa_rep/reachability_analysis/agents_domain.ml +++ b/core/KaSa_rep/reachability_analysis/agents_domain.ml @@ -15,18 +15,16 @@ let local_trace = false -module Domain = -struct - - type static_information = - { - global_static_information : Analyzer_headers.global_static_information; - domain_static_information : - (Ckappa_sig.c_agent_name list Usual_domains.bot_or_not * - Ckappa_sig.c_agent_name list) Ckappa_sig.Rule_map_and_set.Map.t; - agents_without_interface : Ckappa_sig.c_rule_id list - Ckappa_sig.Agent_map_and_set.Map.t - } +module Domain = struct + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + domain_static_information: + (Ckappa_sig.c_agent_name list Usual_domains.bot_or_not + * Ckappa_sig.c_agent_name list) + Ckappa_sig.Rule_map_and_set.Map.t; + agents_without_interface: + Ckappa_sig.c_rule_id list Ckappa_sig.Agent_map_and_set.Map.t; + } (*--------------------------------------------------------------------*) (* array that indicates whether an agent type is already discovered, or @@ -37,11 +35,10 @@ struct type local_dynamic_information = bool Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t - type dynamic_information = - { - local : local_dynamic_information; - global : Analyzer_headers.global_dynamic_information; - } + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } (*--------------------------------------------------------------------*) (** global static information. @@ -50,13 +47,9 @@ struct never updated. *) let get_global_static_information static = static.global_static_information - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static - let get_kappa_handler static = lift Analyzer_headers.get_kappa_handler static - let get_compil static = lift Analyzer_headers.get_cc_code static (**domain *) @@ -64,18 +57,12 @@ struct let get_domain_static_information static = static.domain_static_information let set_domain_static_information domain static = - { - static with - domain_static_information = domain - } + { static with domain_static_information = domain } let get_agents_without_interface static = static.agents_without_interface let set_agents_without_interface agents static = - { - static with - agents_without_interface = agents - } + { static with agents_without_interface = agents } (*--------------------------------------------------------------------*) (** global static/dynamic information*) @@ -83,47 +70,44 @@ struct let get_global_dynamic_information dynamic = dynamic.global let set_global_dynamic_information gdynamic dynamic = - {dynamic with global = gdynamic} + { dynamic with global = gdynamic } (** dead rule local dynamic information*) let get_seen_agent dynamic = dynamic.local - let set_seen_agent seen_agent dynamic = - { - dynamic with local = seen_agent - } + let set_seen_agent seen_agent dynamic = { dynamic with local = seen_agent } (*--------------------------------------------------------------------*) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (**************************************************************************) (**initialize*) @@ -141,12 +125,12 @@ struct let map_to_list parameters error map = let error, list = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun _ error _ a current_list -> - let list = a :: current_list in - error, list - ) map [] + let list = a :: current_list in + error, list) + map [] in error, list @@ -159,21 +143,22 @@ struct match l with | [] -> error, Usual_domains.Not_bot output | agent :: tl -> - match agent with + (match agent with | Cckappa_sig.Ghost -> aux tl (error, output) - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Dead_agent _ -> error, Usual_domains.Bot + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Dead_agent _ -> + error, Usual_domains.Bot | Cckappa_sig.Agent agent -> let agent_type = agent.Cckappa_sig.agent_name in - aux tl (error, agent_type :: output) + aux tl (error, agent_type :: output)) in aux list_lhs_views (error, []) in let error, agents_created_list = - List.fold_left (fun (error, current_list) (_agent_id, agent_type) -> + List.fold_left + (fun (error, current_list) (_agent_id, agent_type) -> let agent_list = agent_type :: current_list in - error, agent_list - ) (error, []) rule.Cckappa_sig.actions.Cckappa_sig.creation + error, agent_list) + (error, []) rule.Cckappa_sig.actions.Cckappa_sig.creation in error, (agents_test_list, agents_created_list) @@ -185,76 +170,58 @@ struct match l with | [] -> error, Usual_domains.Not_bot output | agent :: tl -> - begin - match agent with - | Cckappa_sig.Ghost -> aux tl (error, output) - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Dead_agent _ -> error, Usual_domains.Bot - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - aux tl (error, agent_type :: output) - end + (match agent with + | Cckappa_sig.Ghost -> aux tl (error, output) + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Dead_agent _ -> + error, Usual_domains.Bot + | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + aux tl (error, agent_type :: output)) in match aux agents_lhs_list (error, []) with | error, Usual_domains.Bot -> error, map | error, Usual_domains.Not_bot l -> List.fold_left (fun (error, map) agent_type -> - let error, old_list = - match - Ckappa_sig.Agent_map_and_set.Map.find_option_without_logs - parameters - error - agent_type - map - with - | error, None -> error, [] - | error, Some l -> error, l - in - let rule_id_list = rule_id :: old_list in - Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite - parameters - error - agent_type - rule_id_list - map - ) + let error, old_list = + match + Ckappa_sig.Agent_map_and_set.Map.find_option_without_logs + parameters error agent_type map + with + | error, None -> error, [] + | error, Some l -> error, l + in + let rule_id_list = rule_id :: old_list in + Ckappa_sig.Agent_map_and_set.Map.add_or_overwrite parameters error + agent_type rule_id_list map) (error, map) l let scan_rule_set static dynamic error = let parameters = get_parameter static in let compil = get_compil static in let error, (result, agents) = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error rule_id rule (store_result, agents_without_interface) -> - let error, (agents_test_list, agents_created_list) = - collect_agents - parameters - error - rule.Cckappa_sig.e_rule_c_rule - in - (*add rule_id in map*) - let error, result = - Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite - parameters - error - rule_id - (agents_test_list, agents_created_list) - store_result - in - (*agents without interface*) - let error, agents_without_interface = - collect_agents_without_interface - parameters - error - rule_id - rule.Cckappa_sig.e_rule_c_rule - agents_without_interface - in - error, (result, agents_without_interface) - ) compil.Cckappa_sig.rules (Ckappa_sig.Rule_map_and_set.Map.empty, - Ckappa_sig.Agent_map_and_set.Map.empty) + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error + (fun parameters error rule_id rule + (store_result, agents_without_interface) -> + let error, (agents_test_list, agents_created_list) = + collect_agents parameters error rule.Cckappa_sig.e_rule_c_rule + in + (*add rule_id in map*) + let error, result = + Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite parameters error + rule_id + (agents_test_list, agents_created_list) + store_result + in + (*agents without interface*) + let error, agents_without_interface = + collect_agents_without_interface parameters error rule_id + rule.Cckappa_sig.e_rule_c_rule agents_without_interface + in + error, (result, agents_without_interface)) + compil.Cckappa_sig.rules + ( Ckappa_sig.Rule_map_and_set.Map.empty, + Ckappa_sig.Agent_map_and_set.Map.empty ) in let static = set_agents_without_interface agents static in let static = set_domain_static_information result static in @@ -268,34 +235,33 @@ struct { global_static_information = static; domain_static_information = Ckappa_sig.Rule_map_and_set.Map.empty; - agents_without_interface = Ckappa_sig.Agent_map_and_set.Map.empty; + agents_without_interface = Ckappa_sig.Agent_map_and_set.Map.empty; } in let kappa_handler = Analyzer_headers.get_kappa_handler static in - let nagents = Ckappa_sig.int_of_agent_name (Handler.nagents parameters error kappa_handler) - 1 in + let nagents = + Ckappa_sig.int_of_agent_name + (Handler.nagents parameters error kappa_handler) + - 1 + in let error, init_seen_agents_array = - if nagents < 0 - then - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 + if nagents < 0 then + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 else - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.init - parameters error nagents - (fun _ error _ -> error, false) + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.init parameters + error nagents (fun _ error _ -> error, false) in let init_global_dynamic_information = - { - global = dynamic; - local = init_seen_agents_array; - } + { global = dynamic; local = init_seen_agents_array } in let error, static, dynamic = - scan_rule_set init_global_static_information init_global_dynamic_information error + scan_rule_set init_global_static_information + init_global_dynamic_information error in error, static, dynamic, [] - let complete_wake_up_relation _static error wake_up = - error, wake_up + let complete_wake_up_relation _static error wake_up = error, wake_up (***************************************************************************) (*JF: Here, you should add in the event list, each rule that test for an @@ -311,76 +277,73 @@ struct an agent of this type and with an empty interface occur in the lhs of the rule *) - let add_event_list static dynamic error (agent_type: Ckappa_sig.c_agent_name) event_list = + let add_event_list static dynamic error (agent_type : Ckappa_sig.c_agent_name) + event_list = let parameters = get_parameter static in let map = get_agents_without_interface static in let log = Remanent_parameters.get_logger parameters in let local = get_seen_agent dynamic in let error, bool = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters error agent_type local in - match - bool - with - | Some false -> + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_type local + in + match bool with + | Some false -> let error, local = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters error agent_type true local + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_type true local in let dynamic = set_seen_agent local dynamic in let error, rule_id_list = - match Ckappa_sig.Agent_map_and_set.Map.find_option_without_logs - parameters - error - agent_type - map + match + Ckappa_sig.Agent_map_and_set.Map.find_option_without_logs parameters + error agent_type map with | error, None -> error, [] | error, Some l -> error, l in - let error, bool = - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_wl parameters + let error, bool = + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_wl parameters then List.fold_left - (fun (error,_) rule_id -> + (fun (error, _) rule_id -> let compiled = get_compil static in let error, rule_id_string = - try - Handler.string_of_rule parameters error compiled rule_id - with - | _ -> - Exception.warn - parameters error __POS__ Exit + try Handler.string_of_rule parameters error compiled rule_id + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_rule_id rule_id) in let title = "" in let tab = - if title = "" then "\t\t\t\t" else "\t\t\t" + if title = "" then + "\t\t\t\t" + else + "\t\t\t" in let () = Loggers.fprintf log "%s%s(%s) should be investigated " - (Remanent_parameters.get_prefix parameters) tab - rule_id_string + (Remanent_parameters.get_prefix parameters) + tab rule_id_string in - let () = Loggers.print_newline log in (error, true)) - (error,false) rule_id_list + let () = Loggers.print_newline log in + error, true) + (error, false) rule_id_list else - error,false - in - let () = - if bool - then - Loggers.print_newline log + error, false in + let () = if bool then Loggers.print_newline log in let event_list = - List.fold_left (fun event_list rule_id -> - Communication.Check_rule rule_id :: event_list - ) event_list rule_id_list + List.fold_left + (fun event_list rule_id -> + Communication.Check_rule rule_id :: event_list) + event_list rule_id_list in error, (dynamic, event_list) - | Some true -> - error, (dynamic, event_list) - | None -> - Exception.warn parameters error __POS__ Exit (dynamic, event_list) + | Some true -> error, (dynamic, event_list) + | None -> Exception.warn parameters error __POS__ Exit (dynamic, event_list) (**************************************************************************) (** collect the agent type of the agents of the species and declare @@ -389,27 +352,22 @@ struct let init_agents static dynamic error init_state event_list = let parameters = get_parameter static in let error, (dynamic, event_list) = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _ agent (dynamic, event_list) -> - match agent with - (*JF: warn: dead,unknown,ghost should not occur in initial states *) - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent _ -> - Exception.warn - parameters error __POS__ Exit (dynamic, event_list) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, (dynamic, event_list) = - add_event_list - static - dynamic - error - agent_type - event_list - in - error, (dynamic, event_list) - ) init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.views (dynamic, event_list) + match agent with + (*JF: warn: dead,unknown,ghost should not occur in initial states *) + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost + | Cckappa_sig.Dead_agent _ -> + Exception.warn parameters error __POS__ Exit (dynamic, event_list) + | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, (dynamic, event_list) = + add_event_list static dynamic error agent_type event_list + in + error, (dynamic, event_list)) + init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.views + (dynamic, event_list) in error, (dynamic, event_list) @@ -439,8 +397,9 @@ struct let parameters = get_parameter static in let domain_static = get_domain_static_information static in let error, (bot_or_not, _) = - match Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters error - rule_id domain_static + match + Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters + error rule_id domain_static with | error, None -> error, (Usual_domains.Not_bot [], []) | error, Some (l1, l2) -> error, (l1, l2) @@ -450,23 +409,19 @@ struct | Usual_domains.Not_bot l -> List.fold_left (fun (error, dynamic, s) agent_type -> - let local = get_seen_agent dynamic in - let error, bool = Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters error agent_type local in - match - bool - with - | Some true -> - error, dynamic, s - | Some false -> - error, dynamic, None - | None -> - let error, () = - Exception.warn - parameters error __POS__ Exit () - in - error, dynamic, None - ) - (error, dynamic, Some precondition) l + let local = get_seen_agent dynamic in + let error, bool = + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_type local + in + match bool with + | Some true -> error, dynamic, s + | Some false -> error, dynamic, None + | None -> + let error, () = Exception.warn parameters error __POS__ Exit () in + error, dynamic, None) + (error, dynamic, Some precondition) + l (***********************************************************) @@ -474,7 +429,6 @@ struct (* Please check that each agent type occuring in the pattern is reachable *) exception False of Exception.method_handler * dynamic_information - let maybe_reachable static dynamic error _flag pattern precondition = let parameters = get_parameter static in try @@ -482,36 +436,29 @@ struct Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error _agent_id agent dynamic -> - match agent with - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent (_, _, _, _) -> error, dynamic - | Cckappa_sig.Agent agent -> - let local = get_seen_agent dynamic in - let agent_type = agent.Cckappa_sig.agent_name in - let error, bool = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters error agent_type local in - match - bool - with - | Some true -> - error, dynamic - | Some false -> - raise (False (error,dynamic)) - | None -> - let error, () = - Exception.warn - parameters error __POS__ Exit () - in - error, dynamic - ) pattern.Cckappa_sig.views dynamic + match agent with + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost + | Cckappa_sig.Dead_agent (_, _, _, _) -> + error, dynamic + | Cckappa_sig.Agent agent -> + let local = get_seen_agent dynamic in + let agent_type = agent.Cckappa_sig.agent_name in + let error, bool = + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_type local + in + (match bool with + | Some true -> error, dynamic + | Some false -> raise (False (error, dynamic)) + | None -> + let error, () = + Exception.warn parameters error __POS__ Exit () + in + error, dynamic)) + pattern.Cckappa_sig.views dynamic in error, dynamic, Some precondition - with - False (error, dynamic) - -> - error, dynamic, None + with False (error, dynamic) -> error, dynamic, None (*********************************************************************) (** fold a list of creation each time update the array when agent is @@ -527,27 +474,22 @@ struct let event_list = [] in let domain_static = get_domain_static_information static in let error, list_created = - match Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs - parameters - error - rule_id - domain_static + match + Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters + error rule_id domain_static with | error, None -> error, [] | error, Some (_, l2) -> error, l2 in let error, (dynamic, event_list) = - List.fold_left (fun (error, (dynamic, event_list)) agent_type -> + List.fold_left + (fun (error, (dynamic, event_list)) agent_type -> let error, (dynamic, event_list) = - add_event_list - static - dynamic - error - agent_type - event_list + add_event_list static dynamic error agent_type event_list in - error, (dynamic, event_list) - ) (error, (dynamic, event_list)) list_created + error, (dynamic, event_list)) + (error, (dynamic, event_list)) + list_created in error, dynamic, (precondition, event_list) @@ -565,27 +507,25 @@ struct let compil = get_compil static in let array = get_seen_agent dynamic in let error, list = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold - parameters + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun _parameters error agent bool list -> - if bool then error, list - else - let error, info = - Handler.info_of_agent parameters error handler compil agent - in - let agent = Remanent_state.info_to_agent info in - error, agent::list - ) + if bool then + error, list + else ( + let error, info = + Handler.info_of_agent parameters error handler compil agent + in + let agent = Remanent_state.info_to_agent info in + error, agent :: list + )) array [] in error, dynamic, Remanent_state.set_dead_agents list kasa_state - let apply_one_side_effect - _static dynamic error - _ _ precondition - = - error, dynamic, (precondition,[]) (* this domain ignores side effects *) + let apply_one_side_effect _static dynamic error _ _ precondition = + error, dynamic, (precondition, []) + (* this domain ignores side effects *) (**************************************************************************) let stabilize _static dynamic error = error, dynamic, () @@ -594,16 +534,14 @@ struct let parameters = get_parameter static in let result = get_seen_agent dynamic in let handler = get_kappa_handler static in - if Remanent_parameters.get_dump_reachability_analysis_result parameters - then - let error, bool = Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold - parameters + if Remanent_parameters.get_dump_reachability_analysis_result parameters then ( + let error, bool = + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold parameters error - (fun _parameters error _k bool bool'-> error, bool && bool') - result - true + (fun _parameters error _k bool bool' -> error, bool && bool') + result true in - if not bool then + if not bool then ( let parameters = Remanent_parameters.update_prefix parameters "" in let () = Loggers.print_newline loggers in let () = @@ -612,8 +550,7 @@ struct in let () = Loggers.print_newline loggers in let () = - Loggers.fprintf loggers - "* There are some non creatable agents " + Loggers.fprintf loggers "* There are some non creatable agents " in let () = Loggers.print_newline loggers in let () = @@ -621,53 +558,50 @@ struct "------------------------------------------------------------" in let () = Loggers.print_newline loggers in - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.iter - parameters + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.iter parameters error (fun parameters error k bool -> - if bool - then - error - else - let error', agent_string = - try - Handler.string_of_agent parameters error handler - k - with - _ -> - Exception.warn - parameters error __POS__ Exit (Ckappa_sig.string_of_agent_name k) - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let () = Loggers.fprintf loggers - "%s cannot occur in the model" agent_string - in - let () = Loggers.print_newline loggers in - error) + if bool then + error + else ( + let error', agent_string = + try Handler.string_of_agent parameters error handler k + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name k) + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let () = + Loggers.fprintf loggers "%s cannot occur in the model" + agent_string + in + let () = Loggers.print_newline loggers in + error + )) result - else + ) else ( let () = Loggers.fprintf loggers "------------------------------------------------------------" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in let () = - Loggers.fprintf loggers - "every agent may occur in the model" + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = Loggers.fprintf loggers "every agent may occur in the model" in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in error - else + ) + ) else error let print ?dead_rules static dynamic error loggers = let _ = dead_rules in - let error = - print_dead_agent loggers static dynamic error - in + let error = print_dead_agent loggers static dynamic error in error, dynamic, () let _lkappa_mixture_is_reachable _static dynamic error _lkappa = @@ -676,10 +610,6 @@ struct let _cc_mixture_is_reachable _static dynamic error _ccmixture = error, dynamic, Usual_domains.Maybe (* to do *) - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects - + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects end diff --git a/core/KaSa_rep/reachability_analysis/agents_domain.mli b/core/KaSa_rep/reachability_analysis/agents_domain.mli index 3bb7d6f541..c7d21c8637 100644 --- a/core/KaSa_rep/reachability_analysis/agents_domain.mli +++ b/core/KaSa_rep/reachability_analysis/agents_domain.mli @@ -17,4 +17,4 @@ (** Abstract domain that abstracts away the interface of agents, and see each rule as a multiset-rewriting reaction over typed agents *) -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/analyzer.ml b/core/KaSa_rep/reachability_analysis/analyzer.ml index e484cde084..64bc469116 100644 --- a/core/KaSa_rep/reachability_analysis/analyzer.ml +++ b/core/KaSa_rep/reachability_analysis/analyzer.ml @@ -15,61 +15,60 @@ let local_trace = false -module type Analyzer = -sig - +module type Analyzer = sig type static_information type dynamic_information - val main: + val main : Remanent_parameters_sig.parameters -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> Ckappa_sig.Views_bdu.handler -> Cckappa_sig.compil -> Cckappa_sig.kappa_handler -> - Exception.method_handler * StoryProfiling.StoryStats.log_info * static_information * dynamic_information + Exception.method_handler + * StoryProfiling.StoryStats.log_info + * static_information + * dynamic_information - val export: + val export : static_information -> dynamic_information -> Exception.method_handler -> ('static, 'dynamic) Analyzer_headers.kasa_state -> - Exception.method_handler * dynamic_information * - ('static, 'dynamic) Analyzer_headers.kasa_state + Exception.method_handler + * dynamic_information + * ('static, 'dynamic) Analyzer_headers.kasa_state - val print: + val print : static_information -> dynamic_information -> Exception.method_handler -> Loggers.t -> Exception.method_handler * dynamic_information - val maybe_reachable: + val maybe_reachable : static_information -> dynamic_information -> Exception.method_handler -> Analyzer_headers.pattern_matching_flag -> Cckappa_sig.mixture -> Exception.method_handler * dynamic_information * bool - end (***************************************************************************) (*Analyzer is a functor takes a module Domain as its parameter.*) -module Make (Domain:Composite_domain.Composite_domain) = -struct - +module Make (Domain : Composite_domain.Composite_domain) = struct type static_information = Domain.static_information - type dynamic_information = Domain.dynamic_information let print static dynamic error loggers = let error, dynamic, () = Domain.print static dynamic error loggers in error, dynamic - let get_log_info dynamic = Analyzer_headers.get_log_info + let get_log_info dynamic = + Analyzer_headers.get_log_info (Domain.get_global_dynamic_information dynamic) let set_log_info log_info dynamic = @@ -86,7 +85,6 @@ struct error, dynamic let add_event = lift StoryProfiling.StoryStats.add_event - let close_event = lift StoryProfiling.StoryStats.close_event let main parameters log_info error mvbdu_handler compil kappa_handler = @@ -95,8 +93,8 @@ struct StoryProfiling.Global_initialization None log_info in let error, static, dynamic = - Analyzer_headers.initialize_global_information - parameters log_info error mvbdu_handler compil kappa_handler + Analyzer_headers.initialize_global_information parameters log_info error + mvbdu_handler compil kappa_handler in let error, log_info = StoryProfiling.StoryStats.close_event parameters error @@ -107,30 +105,30 @@ struct let log_info = Analyzer_headers.get_log_info dynamic in let error, log_info = StoryProfiling.StoryStats.add_event parameters error - StoryProfiling.Domains_initialization None log_info in + StoryProfiling.Domains_initialization None log_info + in let dynamic = Analyzer_headers.set_log_info log_info dynamic in - let error, static, dynamic = - Domain.initialize static dynamic error in - let error, dynamic = close_event parameters error - StoryProfiling.Domains_initialization None dynamic + let error, static, dynamic = Domain.initialize static dynamic error in + let error, dynamic = + close_event parameters error StoryProfiling.Domains_initialization None + dynamic in let error, dynamic, _ = List.fold_left (fun (error, dynamic, i) chemical_species -> - let error, dynamic = - add_event - parameters error (StoryProfiling.Initial_state i) None dynamic - in - let error, dynamic, () = - Domain.add_initial_state static dynamic error chemical_species - in - let error, dynamic = - close_event parameters error - (StoryProfiling.Initial_state i) None dynamic - in - error, dynamic, i + 1) - (error, dynamic, 1) - init + let error, dynamic = + add_event parameters error (StoryProfiling.Initial_state i) None + dynamic + in + let error, dynamic, () = + Domain.add_initial_state static dynamic error chemical_species + in + let error, dynamic = + close_event parameters error (StoryProfiling.Initial_state i) None + dynamic + in + error, dynamic, i + 1) + (error, dynamic, 1) init in let log = Remanent_parameters.get_logger parameters in let error, static, dynamic = @@ -140,69 +138,70 @@ struct | None -> error, static, dynamic | Some rule_id -> let error = - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_iteration - parameters - || Remanent_parameters.get_trace parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_iteration + parameters + || Remanent_parameters.get_trace parameters + then ( let error, rule_id_string = - try - Handler.string_of_rule parameters error compil rule_id - with - _ -> - Exception.warn - parameters error __POS__ Exit + try Handler.string_of_rule parameters error compil rule_id + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_rule_id rule_id) in let () = Loggers.print_newline log in let () = Loggers.fprintf log "\tApplying %s:" rule_id_string in let () = Loggers.print_newline log in error - else + ) else error in - begin - let error, dynamic, is_enabled = - Domain.is_enabled static dynamic error rule_id - in - match is_enabled with - | None -> - let _ = - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_iteration parameters + let error, dynamic, is_enabled = + Domain.is_enabled static dynamic error rule_id + in + (match is_enabled with + | None -> + let _ = + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_iteration + parameters || Remanent_parameters.get_trace parameters - then - let () = - Loggers.fprintf log - "\t\tthe precondition is not satisfied yet" - in - let () = Loggers.print_newline log - in - () - in - aux error dynamic - | Some precondition -> - let _ = - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_iteration parameters + then ( + let () = + Loggers.fprintf log + "\t\tthe precondition is not satisfied yet" + in + let () = Loggers.print_newline log in + () + ) + in + aux error dynamic + | Some precondition -> + let _ = + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_iteration + parameters || Remanent_parameters.get_trace parameters - then - let () = Loggers.fprintf log - "\t\tthe precondition is satisfied" in - let () = Loggers.print_newline log in - () - in - let error, dynamic, () = - Domain.apply_rule static dynamic error rule_id precondition - in - aux error dynamic - end - in aux error dynamic - in - let error, dynamic, () = - Domain.stabilize static dynamic error + then ( + let () = + Loggers.fprintf log "\t\tthe precondition is satisfied" + in + let () = Loggers.print_newline log in + () + ) + in + let error, dynamic, () = + Domain.apply_rule static dynamic error rule_id precondition + in + aux error dynamic) + in + aux error dynamic in - let error, dynamic = print static dynamic error log in + let error, dynamic, () = Domain.stabilize static dynamic error in + let error, dynamic = print static dynamic error log in let log_info = Analyzer_headers.get_log_info (Domain.get_global_dynamic_information dynamic) @@ -211,26 +210,21 @@ struct let export static dynamic error kasa_state = let kasa_state = - Remanent_state.set_internal_constraints_list [] kasa_state in + Remanent_state.set_internal_constraints_list [] kasa_state + in let error, dynamic, kasa_state = - Domain.export static dynamic error kasa_state in + Domain.export static dynamic error kasa_state + in let kasa_state = - match - Remanent_state.get_constraints_list kasa_state - with + match Remanent_state.get_constraints_list kasa_state with | None -> kasa_state - | Some l -> - Remanent_state.set_constraints_list - (List.rev l) kasa_state + | Some l -> Remanent_state.set_constraints_list (List.rev l) kasa_state in let kasa_state = - match - Remanent_state.get_internal_constraints_list kasa_state - with + match Remanent_state.get_internal_constraints_list kasa_state with | None -> kasa_state | Some l -> - Remanent_state.set_internal_constraints_list - (List.rev l) kasa_state + Remanent_state.set_internal_constraints_list (List.rev l) kasa_state in error, dynamic, kasa_state @@ -238,9 +232,7 @@ struct let error, dynamic, precondition = Domain.maybe_reachable static dynamic error flag pattern in - match - precondition - with + match precondition with | None -> error, dynamic, false | Some _ -> error, dynamic, true end diff --git a/core/KaSa_rep/reachability_analysis/analyzer.mli b/core/KaSa_rep/reachability_analysis/analyzer.mli index 465db6c9b0..78916f064d 100644 --- a/core/KaSa_rep/reachability_analysis/analyzer.mli +++ b/core/KaSa_rep/reachability_analysis/analyzer.mli @@ -15,43 +15,45 @@ (** Analyzer entry point *) -module type Analyzer = -sig - +module type Analyzer = sig type static_information type dynamic_information - val main: + val main : Remanent_parameters_sig.parameters -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> Ckappa_sig.Views_bdu.handler -> Cckappa_sig.compil -> Cckappa_sig.kappa_handler -> - Exception.method_handler * StoryProfiling.StoryStats.log_info * static_information * dynamic_information + Exception.method_handler + * StoryProfiling.StoryStats.log_info + * static_information + * dynamic_information - val export: + val export : static_information -> dynamic_information -> Exception.method_handler -> ('static, 'dynamic) Analyzer_headers.kasa_state -> - Exception.method_handler * dynamic_information * - ('static, 'dynamic) Analyzer_headers.kasa_state + Exception.method_handler + * dynamic_information + * ('static, 'dynamic) Analyzer_headers.kasa_state - val print: + val print : static_information -> dynamic_information -> Exception.method_handler -> Loggers.t -> Exception.method_handler * dynamic_information - val maybe_reachable: + val maybe_reachable : static_information -> dynamic_information -> Exception.method_handler -> - Analyzer_headers.pattern_matching_flag -> + Analyzer_headers.pattern_matching_flag -> Cckappa_sig.mixture -> Exception.method_handler * dynamic_information * bool end -module Make : functor (Domain:Composite_domain.Composite_domain) -> Analyzer +module Make : functor (Domain : Composite_domain.Composite_domain) -> Analyzer diff --git a/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.ml b/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.ml index 8a5b82325c..3604b27fb1 100644 --- a/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.ml +++ b/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.ml @@ -13,119 +13,135 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Domain = -sig +module type Domain = sig type static_information - type local_dynamic_information - type dynamic_information = - { - local : local_dynamic_information; - global: Analyzer_headers.global_dynamic_information - } + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } - val get_parameter: static_information -> Remanent_parameters_sig.parameters + val get_parameter : static_information -> Remanent_parameters_sig.parameters - val get_global_dynamic_information: dynamic_information -> - Analyzer_headers.global_dynamic_information + val get_global_dynamic_information : + dynamic_information -> Analyzer_headers.global_dynamic_information - val set_global_dynamic_information: - Analyzer_headers.global_dynamic_information -> dynamic_information -> + val set_global_dynamic_information : + Analyzer_headers.global_dynamic_information -> + dynamic_information -> dynamic_information - val initialize: + val initialize : Analyzer_headers.global_static_information -> Analyzer_headers.global_dynamic_information -> Exception.method_handler -> - Exception.method_handler * static_information * dynamic_information * Communication.event list + Exception.method_handler + * static_information + * dynamic_information + * Communication.event list - val complete_wake_up_relation: - static_information -> - Exception.method_handler -> - Common_static.site_to_rules_tmp -> - Exception.method_handler * Common_static.site_to_rules_tmp + val complete_wake_up_relation : + static_information -> + Exception.method_handler -> + Common_static.site_to_rules_tmp -> + Exception.method_handler * Common_static.site_to_rules_tmp type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd - - val add_initial_state: - (Analyzer_headers.initial_state, Communication.event list) unary - - val is_enabled: - (Ckappa_sig.c_rule_id, - Communication.precondition, Communication.precondition option) binary - - val apply_rule: - (Ckappa_sig.c_rule_id, - Communication.precondition, Communication.precondition * Communication.event list) binary + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd - val apply_one_side_effect: - (Ckappa_sig.c_rule_id, - ((Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) option) * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state), - Communication.precondition, - Communication.precondition * Communication.event list) ternary + val add_initial_state : + (Analyzer_headers.initial_state, Communication.event list) unary - val apply_event_list: + val is_enabled : + ( Ckappa_sig.c_rule_id, + Communication.precondition, + Communication.precondition option ) + binary + + val apply_rule : + ( Ckappa_sig.c_rule_id, + Communication.precondition, + Communication.precondition * Communication.event list ) + binary + + val apply_one_side_effect : + ( Ckappa_sig.c_rule_id, + (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + option + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state), + Communication.precondition, + Communication.precondition * Communication.event list ) + ternary + + val apply_event_list : (Communication.event list, Communication.event list) unary - val stabilize: - unit zeroary + val stabilize : unit zeroary - val export: - ( - ('static, 'dynamic) Analyzer_headers.kasa_state, - ('static, 'dynamic) Analyzer_headers.kasa_state - ) unary + val export : + ( ('static, 'dynamic) Analyzer_headers.kasa_state, + ('static, 'dynamic) Analyzer_headers.kasa_state ) + unary - val print: - ?dead_rules:(Remanent_parameters_sig.parameters -> Exception.method_handler -> Ckappa_sig.c_rule_id -> Exception.method_handler * bool) - -> (Loggers.t, unit) unary + val print : + ?dead_rules: + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_rule_id -> + Exception.method_handler * bool) -> + (Loggers.t, unit) unary - val maybe_reachable: - (Analyzer_headers.pattern_matching_flag, + val maybe_reachable : + ( Analyzer_headers.pattern_matching_flag, Cckappa_sig.mixture, - Communication.precondition, - Communication.precondition option) - ternary + Communication.precondition, + Communication.precondition option ) + ternary - val get_dead_rules: + val get_dead_rules : static_information -> dynamic_information -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> Ckappa_sig.c_rule_id -> Exception.method_handler * bool + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_rule_id -> + Exception.method_handler * bool - val get_side_effects: + val get_side_effects : static_information -> dynamic_information -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> + Remanent_parameters_sig.parameters -> + Exception.method_handler -> Ckappa_sig.c_rule_id -> Exception.method_handler * Ckappa_sig.side_effects option - end diff --git a/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.mli b/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.mli index a8d84fdc0b..95c0395299 100644 --- a/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.mli +++ b/core/KaSa_rep/reachability_analysis/analyzer_domain_sig.mli @@ -14,120 +14,135 @@ * under the terms of the GNU Library General Public License *) (** signature of abstract domains (with explicit communication) *) -module type Domain = -sig - +module type Domain = sig type static_information - type local_dynamic_information - type dynamic_information = - { - local:local_dynamic_information; - global:Analyzer_headers.global_dynamic_information - } + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } - val get_parameter: static_information -> Remanent_parameters_sig.parameters + val get_parameter : static_information -> Remanent_parameters_sig.parameters - val get_global_dynamic_information: dynamic_information -> - Analyzer_headers.global_dynamic_information + val get_global_dynamic_information : + dynamic_information -> Analyzer_headers.global_dynamic_information - val set_global_dynamic_information: - Analyzer_headers.global_dynamic_information -> dynamic_information -> + val set_global_dynamic_information : + Analyzer_headers.global_dynamic_information -> + dynamic_information -> dynamic_information - val initialize: + val initialize : Analyzer_headers.global_static_information -> Analyzer_headers.global_dynamic_information -> Exception.method_handler -> - Exception.method_handler * static_information * dynamic_information * - Communication.event list + Exception.method_handler + * static_information + * dynamic_information + * Communication.event list - val complete_wake_up_relation: + val complete_wake_up_relation : static_information -> Exception.method_handler -> Common_static.site_to_rules_tmp -> Exception.method_handler * Common_static.site_to_rules_tmp type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd - - val add_initial_state: - (Analyzer_headers.initial_state, Communication.event list) unary - - val is_enabled: - (Ckappa_sig.c_rule_id, - Communication.precondition, - Communication.precondition option) binary - - val apply_rule: - (Ckappa_sig.c_rule_id, - Communication.precondition, - Communication.precondition * Communication.event list) binary + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd - val apply_one_side_effect: - (Ckappa_sig.c_rule_id, - ((Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) option) * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state), - Communication.precondition, - Communication.precondition * Communication.event list) ternary + val add_initial_state : + (Analyzer_headers.initial_state, Communication.event list) unary - val apply_event_list: + val is_enabled : + ( Ckappa_sig.c_rule_id, + Communication.precondition, + Communication.precondition option ) + binary + + val apply_rule : + ( Ckappa_sig.c_rule_id, + Communication.precondition, + Communication.precondition * Communication.event list ) + binary + + val apply_one_side_effect : + ( Ckappa_sig.c_rule_id, + (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + option + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state), + Communication.precondition, + Communication.precondition * Communication.event list ) + ternary + + val apply_event_list : (Communication.event list, Communication.event list) unary - val stabilize: - unit zeroary - - val export: - (('static,'dynamic) Analyzer_headers.kasa_state, ('static,'dynamic) Analyzer_headers.kasa_state) unary - - val print: - ?dead_rules:(Remanent_parameters_sig.parameters -> Exception.method_handler -> Ckappa_sig.c_rule_id -> Exception.method_handler * bool) - -> (Loggers.t, unit) unary - - val maybe_reachable: - (Analyzer_headers.pattern_matching_flag, - Cckappa_sig.mixture, - Communication.precondition, - Communication.precondition option) - ternary - - val get_dead_rules: + val stabilize : unit zeroary + + val export : + ( ('static, 'dynamic) Analyzer_headers.kasa_state, + ('static, 'dynamic) Analyzer_headers.kasa_state ) + unary + + val print : + ?dead_rules: + (Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_rule_id -> + Exception.method_handler * bool) -> + (Loggers.t, unit) unary + + val maybe_reachable : + ( Analyzer_headers.pattern_matching_flag, + Cckappa_sig.mixture, + Communication.precondition, + Communication.precondition option ) + ternary + + val get_dead_rules : static_information -> dynamic_information -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> Ckappa_sig.c_rule_id -> Exception.method_handler * bool + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_rule_id -> + Exception.method_handler * bool - val get_side_effects: + val get_side_effects : static_information -> dynamic_information -> - Remanent_parameters_sig.parameters -> Exception.method_handler -> - Ckappa_sig.c_rule_id -> - Exception.method_handler * Ckappa_sig.side_effects option - - + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_rule_id -> + Exception.method_handler * Ckappa_sig.side_effects option end diff --git a/core/KaSa_rep/reachability_analysis/analyzer_headers.ml b/core/KaSa_rep/reachability_analysis/analyzer_headers.ml index 55dfb039b5..4da6b7ed11 100644 --- a/core/KaSa_rep/reachability_analysis/analyzer_headers.ml +++ b/core/KaSa_rep/reachability_analysis/analyzer_headers.ml @@ -13,42 +13,34 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type pattern_matching_flag = - | Embeddings - | Morphisms - -type compilation_result = - { - cc_code : Cckappa_sig.compil; - kappa_handler : Cckappa_sig.kappa_handler - } - -type global_static_information = - { - global_compilation_result : compilation_result; - global_parameter : Remanent_parameters_sig.parameters; - global_common_views : Common_static.common_views; - global_wake_up_relation: Common_static.site_to_rules ; - } +type pattern_matching_flag = Embeddings | Morphisms + +type compilation_result = { + cc_code: Cckappa_sig.compil; + kappa_handler: Cckappa_sig.kappa_handler; +} + +type global_static_information = { + global_compilation_result: compilation_result; + global_parameter: Remanent_parameters_sig.parameters; + global_common_views: Common_static.common_views; + global_wake_up_relation: Common_static.site_to_rules; +} let add_wake_up_relation static wake = - {static with global_wake_up_relation = wake } + { static with global_wake_up_relation = wake } -type global_dynamic_information = - { - dynamic_dummy: unit; - mvbdu_handler: Mvbdu_wrapper.Mvbdu.handler; - log_info: StoryProfiling.StoryStats.log_info; - } +type global_dynamic_information = { + dynamic_dummy: unit; + mvbdu_handler: Mvbdu_wrapper.Mvbdu.handler; + log_info: StoryProfiling.StoryStats.log_info; +} type ('static, 'dynamic) kasa_state = ('static, 'dynamic) Remanent_state.state - type initial_state = Cckappa_sig.enriched_init let get_wake_up_relation static = static.global_wake_up_relation - let get_parameter static = static.global_parameter - let get_compilation_information static = static.global_compilation_result let get_kappa_handler static = @@ -61,10 +53,7 @@ let get_cc_code static = (get_compilation_information static).cc_code let get_common_views static = static.global_common_views let set_common_views common static = - { - static with - global_common_views = common - } + { static with global_common_views = common } (*****************************************************************************) @@ -75,7 +64,7 @@ let set_agent_name agent_name static = set_common_views { (get_common_views static) with - Common_static.store_agent_name = agent_name + Common_static.store_agent_name = agent_name; } static @@ -86,7 +75,7 @@ let set_agent_name_from_pattern agent_name static = set_common_views { (get_common_views static) with - Common_static.store_agent_name_from_pattern = agent_name + Common_static.store_agent_name_from_pattern = agent_name; } static @@ -101,7 +90,7 @@ let set_side_effects_views eff static = set_common_views { (get_common_views static) with - Common_static.store_side_effects_views = eff + Common_static.store_side_effects_views = eff; } static @@ -112,7 +101,7 @@ let set_side_effects eff static = set_side_effects_views { (get_side_effects_views static) with - Common_static.store_side_effects = eff + Common_static.store_side_effects = eff; } static @@ -123,7 +112,7 @@ let set_potential_side_effects eff static = set_side_effects_views { (get_side_effects_views static) with - Common_static.store_potential_side_effects = eff + Common_static.store_potential_side_effects = eff; } static @@ -134,7 +123,7 @@ let set_potential_side_effects_per_rule eff static = set_common_views { (get_common_views static) with - Common_static.store_potential_side_effects_per_rule = eff + Common_static.store_potential_side_effects_per_rule = eff; } static @@ -147,10 +136,7 @@ let get_binding_views static = let set_binding_views b static = set_common_views - { - (get_common_views static) with - Common_static.store_binding_views = b - } + { (get_common_views static) with Common_static.store_binding_views = b } static let get_bonds_rhs static = @@ -158,10 +144,7 @@ let get_bonds_rhs static = let set_bonds_rhs bonds static = set_binding_views - { - (get_binding_views static) with - Common_static.store_bonds_rhs = bonds - } + { (get_binding_views static) with Common_static.store_bonds_rhs = bonds } static let get_bonds_lhs static = @@ -169,10 +152,7 @@ let get_bonds_lhs static = let set_bonds_lhs bonds static = set_binding_views - { - (get_binding_views static) with - Common_static.store_bonds_lhs = bonds - } + { (get_binding_views static) with Common_static.store_bonds_lhs = bonds } static let get_action_binding static = @@ -182,7 +162,7 @@ let set_action_binding bonds static = set_binding_views { (get_binding_views static) with - Common_static.store_action_binding = bonds + Common_static.store_action_binding = bonds; } static @@ -190,37 +170,25 @@ let set_action_binding bonds static = (*VIEWS*) (*****************************************************************************) -let get_test_views static = - (get_common_views static).Common_static.store_test +let get_test_views static = (get_common_views static).Common_static.store_test let set_test_views sites static = set_common_views - { - (get_common_views static) with - Common_static.store_test = sites - } + { (get_common_views static) with Common_static.store_test = sites } static -let get_views_rhs static = - (get_test_views static).Common_static.store_views_rhs +let get_views_rhs static = (get_test_views static).Common_static.store_views_rhs let set_views_rhs sites static = set_test_views - { - (get_test_views static) with - Common_static.store_views_rhs = sites - } + { (get_test_views static) with Common_static.store_views_rhs = sites } static -let get_views_lhs static = - (get_test_views static).Common_static.store_views_lhs +let get_views_lhs static = (get_test_views static).Common_static.store_views_lhs let set_views_lhs sites static = set_test_views - { - (get_test_views static) with - Common_static.store_views_lhs = sites - } + { (get_test_views static) with Common_static.store_views_lhs = sites } static (*****************************************************************************) @@ -232,10 +200,7 @@ let get_modified_views static = let set_modified_views sites static = set_common_views - { - (get_common_views static) with - Common_static.store_modification = sites - } + { (get_common_views static) with Common_static.store_modification = sites } static let get_modified_map static = @@ -245,7 +210,7 @@ let set_modified_map sites static = set_modified_views { (get_modified_views static) with - Common_static.store_modified_map = sites + Common_static.store_modified_map = sites; } static @@ -256,7 +221,7 @@ let set_project_modified_map sites static = set_modified_views { (get_modified_views static) with - Common_static.store_project_modified_map = sites + Common_static.store_project_modified_map = sites; } static @@ -271,11 +236,10 @@ let set_test_modif_map sites static = set_common_views { (get_common_views static) with - Common_static.store_test_modif_map = sites + Common_static.store_test_modif_map = sites; } static - (*****************************************************************************) (*INITIAL STATES*) @@ -283,12 +247,9 @@ let compute_initial_state error static = let parameters = get_parameter static in let compil = get_cc_code static in let error, init = - Int_storage.Nearly_inf_Imperatif.fold - parameters - error - (fun _parameters error _ i l -> error, i :: l) - compil.Cckappa_sig.init - [] + Int_storage.Nearly_inf_Imperatif.fold parameters error + (fun _parameters error _ i l -> error, i :: l) + compil.Cckappa_sig.init [] in error, List.rev init @@ -297,9 +258,9 @@ let compute_initial_state error static = (*****************************************************************************) let get_mvbdu_handler dynamic = dynamic.mvbdu_handler -let set_mvbdu_handler handler dynamic = {dynamic with mvbdu_handler = handler} +let set_mvbdu_handler handler dynamic = { dynamic with mvbdu_handler = handler } let get_log_info dynamic = dynamic.log_info -let set_log_info log_info dynamic = {dynamic with log_info = log_info} +let set_log_info log_info dynamic = { dynamic with log_info } let scan_rule static error = let parameters = get_parameter static in @@ -311,31 +272,21 @@ let scan_rule static error = let static = set_common_views store_result static in error, static -let initialize_global_information - parameters log_info error mvbdu_handler compilation kappa_handler = +let initialize_global_information parameters log_info error mvbdu_handler + compilation kappa_handler = let error, init_common = Common_static.init_common_views parameters error in - let error, wake_up = Common_static.empty_site_to_rules parameters error in + let error, wake_up = Common_static.empty_site_to_rules parameters error in let init_global_static = { - global_compilation_result = - { - cc_code = compilation; - kappa_handler = kappa_handler; - }; - global_parameter = parameters; + global_compilation_result = { cc_code = compilation; kappa_handler }; + global_parameter = parameters; global_common_views = init_common; global_wake_up_relation = wake_up; } in - let init_dynamic = - { - dynamic_dummy = () ; - mvbdu_handler = mvbdu_handler ; - log_info = log_info; - } - in + let init_dynamic = { dynamic_dummy = (); mvbdu_handler; log_info } in let error, static = scan_rule init_global_static error in error, static, init_dynamic let dummy_dead_rules _ error _ = error, false -let dummy_side_effects _ error _ = error, None +let dummy_side_effects _ error _ = error, None diff --git a/core/KaSa_rep/reachability_analysis/analyzer_headers.mli b/core/KaSa_rep/reachability_analysis/analyzer_headers.mli index 2db1607208..bd921d9a79 100644 --- a/core/KaSa_rep/reachability_analysis/analyzer_headers.mli +++ b/core/KaSa_rep/reachability_analysis/analyzer_headers.mli @@ -15,10 +15,7 @@ (** type declarations and values shared among the abstract domains *) -type pattern_matching_flag = - | Embeddings - | Morphisms - +type pattern_matching_flag = Embeddings | Morphisms type compilation_result (** type of the static information to be passed to each domain, let us @@ -31,40 +28,41 @@ type compilation_result type global_static_information type global_dynamic_information - -type ('static,'dynamic) kasa_state = - ('static,'dynamic) Remanent_state.state +type ('static, 'dynamic) kasa_state = ('static, 'dynamic) Remanent_state.state (** This is the type of the encoding of a chemical mixture as a result of compilation *) type initial_state = Cckappa_sig.enriched_init -val initialize_global_information: +val initialize_global_information : Remanent_parameters_sig.parameters -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> Mvbdu_wrapper.Mvbdu.handler -> Cckappa_sig.compil -> Cckappa_sig.kappa_handler -> - Exception.method_handler * global_static_information * global_dynamic_information + Exception.method_handler + * global_static_information + * global_dynamic_information -val add_wake_up_relation: +val add_wake_up_relation : global_static_information -> Common_static.site_to_rules -> global_static_information -val get_wake_up_relation: global_static_information -> - Common_static.site_to_rules +val get_wake_up_relation : + global_static_information -> Common_static.site_to_rules -val get_parameter: global_static_information -> Remanent_parameters_sig.parameters +val get_parameter : + global_static_information -> Remanent_parameters_sig.parameters -val get_compilation_information: global_static_information -> compilation_result +val get_compilation_information : + global_static_information -> compilation_result -val get_common_views : - global_static_information -> Common_static.common_views +val get_common_views : global_static_information -> Common_static.common_views -val set_common_views: +val set_common_views : Common_static.common_views -> global_static_information -> global_static_information @@ -87,7 +85,7 @@ val set_agent_name_from_pattern : global_static_information -> global_static_information -val get_side_effects: +val get_side_effects : global_static_information -> Common_static.half_break_action * Common_static.remove_action @@ -97,73 +95,75 @@ val set_side_effects : global_static_information val get_potential_side_effects : - global_static_information -> - Common_static.potential_side_effect + global_static_information -> Common_static.potential_side_effect -val set_potential_side_effects: +val set_potential_side_effects : Common_static.potential_side_effect -> global_static_information -> global_static_information val get_potential_side_effects_per_rule : global_static_information -> - ((Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state)) - list Ckappa_sig.Rule_map_and_set.Map.t - -val set_potential_side_effects_per_rule: - ((Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state)) - list Ckappa_sig.Rule_map_and_set.Map.t - -> + ((Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) + list + Ckappa_sig.Rule_map_and_set.Map.t + +val set_potential_side_effects_per_rule : + ((Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) + list + Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> global_static_information val get_bonds_rhs : global_static_information -> Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t val set_bonds_rhs : Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t -> + Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> global_static_information val get_bonds_lhs : global_static_information -> Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t val set_bonds_lhs : Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t -> + Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> global_static_information val get_action_binding : global_static_information -> - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t Ckappa_sig.Rule_map_and_set.Map.t + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t val set_action_binding : - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t Ckappa_sig.Rule_map_and_set.Map.t -> + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> global_static_information val get_views_rhs : global_static_information -> - Ckappa_sig.pair_of_states - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_map_and_set.Map.t - Ckappa_sig.Rule_map_and_set.Map.t + Ckappa_sig.pair_of_states Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t val set_views_rhs : -Ckappa_sig.pair_of_states - Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.pair_of_states Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_id_map_and_set.Map.t Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> @@ -171,81 +171,77 @@ Ckappa_sig.pair_of_states val get_views_lhs : global_static_information -> - Ckappa_sig.pair_of_states - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_map_and_set.Map.t - Ckappa_sig.Rule_map_and_set.Map.t + Ckappa_sig.pair_of_states Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t val set_views_lhs : - Ckappa_sig.pair_of_states - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_map_and_set.Map.t - Ckappa_sig.Rule_map_and_set.Map.t -> + Ckappa_sig.pair_of_states Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> global_static_information val get_modified_map : global_static_information -> - Ckappa_sig.AgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t + Ckappa_sig.AgentsSiteState_map_and_set.Set.t Ckappa_sig.Rule_map_and_set.Map.t val set_modified_map : - Ckappa_sig.AgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t -> + Ckappa_sig.AgentsSiteState_map_and_set.Set.t Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> global_static_information (**) val get_test_modif_map : global_static_information -> - Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.AgentSite_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Set.t Ckappa_sig.AgentSite_map_and_set.Map.t val set_test_modif_map : - Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.AgentSite_map_and_set.Map.t -> + Ckappa_sig.Rule_map_and_set.Set.t Ckappa_sig.AgentSite_map_and_set.Map.t -> global_static_information -> global_static_information val get_project_modified_map : global_static_information -> - Ckappa_sig.AgentSite_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t + Ckappa_sig.AgentSite_map_and_set.Set.t Ckappa_sig.Rule_map_and_set.Map.t val set_project_modified_map : - Ckappa_sig.AgentSite_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t -> + Ckappa_sig.AgentSite_map_and_set.Set.t Ckappa_sig.Rule_map_and_set.Map.t -> global_static_information -> global_static_information -val compute_initial_state: +val compute_initial_state : Exception.method_handler -> global_static_information -> Exception.method_handler * initial_state list -val get_kappa_handler: global_static_information -> Cckappa_sig.kappa_handler +val get_kappa_handler : global_static_information -> Cckappa_sig.kappa_handler +val get_cc_code : global_static_information -> Cckappa_sig.compil -val get_cc_code: global_static_information -> Cckappa_sig.compil +val get_mvbdu_handler : + global_dynamic_information -> Mvbdu_wrapper.Mvbdu.handler -val get_mvbdu_handler: global_dynamic_information -> Mvbdu_wrapper.Mvbdu.handler - -val set_mvbdu_handler: +val set_mvbdu_handler : Mvbdu_wrapper.Mvbdu.handler -> global_dynamic_information -> global_dynamic_information -val get_log_info: global_dynamic_information -> StoryProfiling.StoryStats.log_info -val set_log_info: StoryProfiling.StoryStats.log_info -> global_dynamic_information -> global_dynamic_information +val get_log_info : + global_dynamic_information -> StoryProfiling.StoryStats.log_info -val dummy_dead_rules: +val set_log_info : + StoryProfiling.StoryStats.log_info -> + global_dynamic_information -> + global_dynamic_information + +val dummy_dead_rules : Remanent_parameters_sig.parameters -> Exception.method_handler -> Ckappa_sig.c_rule_id -> Exception.method_handler * bool -val dummy_side_effects: -Remanent_parameters_sig.parameters -> -Exception.method_handler -> -Ckappa_sig.c_rule_id -> -Exception.method_handler * -(Ckappa_sig.side_effects option) +val dummy_side_effects : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_rule_id -> + Exception.method_handler * Ckappa_sig.side_effects option diff --git a/core/KaSa_rep/reachability_analysis/bdu_dynamic_views.ml b/core/KaSa_rep/reachability_analysis/bdu_dynamic_views.ml index 09bb2be3b1..eabd4a1c1a 100644 --- a/core/KaSa_rep/reachability_analysis/bdu_dynamic_views.ml +++ b/core/KaSa_rep/reachability_analysis/bdu_dynamic_views.ml @@ -15,25 +15,24 @@ let local_trace = false -type bdu_analysis_dynamic = - { - store_update : - Ckappa_sig.Rule_map_and_set.Set.t - Covering_classes_type.AgentCV_map_and_set.Map.t; - (*FIXME: compute dual contact map here*) - store_dual_contact_map : - Ckappa_sig.AgentSiteState_map_and_set.Set.t Ckappa_sig.AgentSiteState_map_and_set.Map.t - } +type bdu_analysis_dynamic = { + store_update: + Ckappa_sig.Rule_map_and_set.Set.t + Covering_classes_type.AgentCV_map_and_set.Map.t; + (*FIXME: compute dual contact map here*) + store_dual_contact_map: + Ckappa_sig.AgentSiteState_map_and_set.Set.t + Ckappa_sig.AgentSiteState_map_and_set.Map.t; +} (************************************************************************) (*implementation*) let add_link parameters error (agent_type, cv_id) rule_id_set store_result = let error, old_set = - match Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, cv_id) - store_result + match + Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs + parameters error (agent_type, cv_id) store_result with | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty | error, Some s -> error, s @@ -42,30 +41,25 @@ let add_link parameters error (agent_type, cv_id) rule_id_set store_result = Ckappa_sig.Rule_map_and_set.Set.union parameters error rule_id_set old_set in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error, store_result = - Covering_classes_type.AgentCV_map_and_set.Map.add_or_overwrite - parameters error - (agent_type, cv_id) - new_set - store_result + Covering_classes_type.AgentCV_map_and_set.Map.add_or_overwrite parameters + error (agent_type, cv_id) new_set store_result in error, store_result (**************************************************************************) - let store_covering_classes_modification_update_aux parameters error - agent_type_cv - site_type_cv cv_id store_test_modification_map store_result = + agent_type_cv site_type_cv cv_id store_test_modification_map store_result = (*----------------------------------------------------------------------*) let error, rule_id_set = - match Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_type_cv, site_type_cv) - store_test_modification_map + match + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameters + error + (agent_type_cv, site_type_cv) + store_test_modification_map with | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty | error, Some s -> error, s @@ -83,33 +77,26 @@ let store_covering_classes_modification_update_aux parameters error (***************************************************************************) let store_covering_classes_modification_update parameters error - store_test_modification_map - store_covering_classes_id = + store_test_modification_map store_covering_classes_id = let error, store_result = Ckappa_sig.AgentSite_map_and_set.Map.fold (fun (agent_type_cv, site_type_cv) l2 store_result -> - List.fold_left (fun (error, store_current_result) cv_id -> - let error, result = - store_covering_classes_modification_update_aux - parameters - error - agent_type_cv - site_type_cv - cv_id - store_test_modification_map - store_current_result - in - error, result - ) store_result l2 - (*REMARK: when it is folding inside a list, start with empty result, - because the add_link function has already called the old result.*) - ) store_covering_classes_id - (error, - Covering_classes_type.AgentCV_map_and_set.Map.empty) + List.fold_left + (fun (error, store_current_result) cv_id -> + let error, result = + store_covering_classes_modification_update_aux parameters error + agent_type_cv site_type_cv cv_id store_test_modification_map + store_current_result + in + error, result) + store_result l2 + (*REMARK: when it is folding inside a list, start with empty result, + because the add_link function has already called the old result.*)) + store_covering_classes_id + (error, Covering_classes_type.AgentCV_map_and_set.Map.empty) in let store_result = - Covering_classes_type.AgentCV_map_and_set.Map.map - (fun x -> x) store_result + Covering_classes_type.AgentCV_map_and_set.Map.map (fun x -> x) store_result in error, store_result @@ -120,155 +107,122 @@ let store_covering_classes_modification_update parameters error (*update function added information of rule_id in side effects*) let store_covering_classes_modification_side_effects parameters error - store_test_modification_map - store_potential_side_effects - covering_classes + store_test_modification_map store_potential_side_effects covering_classes store_result = (*------------------------------------------------------------------------*) let error, store_result = Ckappa_sig.AgentRule_map_and_set.Map.fold - (fun (agent_type_partner, rule_id_effect) pair_list (error, store_result) - -> - List.fold_left - (fun (error, store_result) (_,(site_type_partner, _state)) -> - let error, rule_id_set = - match - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_type_partner, site_type_partner) - store_test_modification_map - with - | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty - | error, Some s -> error, s - in - let error, new_rule_id_set = - Ckappa_sig.Rule_map_and_set.Set.add_when_not_in - parameters - error - rule_id_effect - rule_id_set - in - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error - (fun parameters error _agent_type_cv remanent store_result -> - let cv_dic = remanent.Covering_classes_type.store_dic in - let error, store_result = - Covering_classes_type.Dictionary_of_List_sites.fold - (fun _list_of_site_type ((), ()) cv_id + (fun (agent_type_partner, rule_id_effect) pair_list (error, store_result) -> + List.fold_left + (fun (error, store_result) (_, (site_type_partner, _state)) -> + let error, rule_id_set = + match + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs + parameters error + (agent_type_partner, site_type_partner) + store_test_modification_map + with + | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty + | error, Some s -> error, s + in + let error, new_rule_id_set = + Ckappa_sig.Rule_map_and_set.Set.add_when_not_in parameters error + rule_id_effect rule_id_set + in + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold + parameters error + (fun parameters error _agent_type_cv remanent store_result -> + let cv_dic = remanent.Covering_classes_type.store_dic in + let error, store_result = + Covering_classes_type.Dictionary_of_List_sites.fold + (fun _list_of_site_type ((), ()) cv_id (error, store_result) -> - (*get a set of rule_id in update(c)*) - let error, store_result = - add_link parameters error - (agent_type_partner, cv_id) - new_rule_id_set - store_result - in - error, store_result - ) cv_dic (error, store_result) - in - error, store_result - ) covering_classes store_result - in - error, store_result - ) (error, store_result) pair_list - ) store_potential_side_effects (error, store_result) + (*get a set of rule_id in update(c)*) + let error, store_result = + add_link parameters error + (agent_type_partner, cv_id) + new_rule_id_set store_result + in + error, store_result) + cv_dic (error, store_result) + in + error, store_result) + covering_classes store_result + in + error, store_result) + (error, store_result) pair_list) + store_potential_side_effects (error, store_result) in error, store_result (**************************************************************************) -let store_update - parameters - log_info - error - store_test_modification_map - store_potential_side_effects - store_covering_classes_id - covering_classes - store_result - = - let error, log_info = StoryProfiling.StoryStats.add_event parameters error - (StoryProfiling.Regular_influences) - None log_info +let store_update parameters log_info error store_test_modification_map + store_potential_side_effects store_covering_classes_id covering_classes + store_result = + let error, log_info = + StoryProfiling.StoryStats.add_event parameters error + StoryProfiling.Regular_influences None log_info in let error, store_update_modification = - store_covering_classes_modification_update - parameters - error - store_test_modification_map - store_covering_classes_id + store_covering_classes_modification_update parameters error + store_test_modification_map store_covering_classes_id in - let error, log_info = StoryProfiling.StoryStats.close_event parameters error - (StoryProfiling.Regular_influences) - None log_info + let error, log_info = + StoryProfiling.StoryStats.close_event parameters error + StoryProfiling.Regular_influences None log_info in - let init_cv_modification_side_effects = + let init_cv_modification_side_effects = Covering_classes_type.AgentCV_map_and_set.Map.empty in - let error, log_info = StoryProfiling.StoryStats.add_event parameters error - (StoryProfiling.Side_effects_influences) - None log_info + let error, log_info = + StoryProfiling.StoryStats.add_event parameters error + StoryProfiling.Side_effects_influences None log_info in let error, store_update_with_side_effects = - store_covering_classes_modification_side_effects - parameters - error - store_test_modification_map - store_potential_side_effects - covering_classes + store_covering_classes_modification_side_effects parameters error + store_test_modification_map store_potential_side_effects covering_classes init_cv_modification_side_effects in - let error, log_info = StoryProfiling.StoryStats.close_event parameters error - (StoryProfiling.Side_effects_influences) - None log_info + let error, log_info = + StoryProfiling.StoryStats.close_event parameters error + StoryProfiling.Side_effects_influences None log_info in - let error, log_info = StoryProfiling.StoryStats.add_event parameters error - (StoryProfiling.Merge_influences) - None log_info + let error, log_info = + StoryProfiling.StoryStats.add_event parameters error + StoryProfiling.Merge_influences None log_info in (*-------------------------------------------------------------------*) (*fold 2 map*) let error, store_result = - Covering_classes_type.AgentCV_map_and_set.Map.fold2 - parameters - error + Covering_classes_type.AgentCV_map_and_set.Map.fold2 parameters error (*exists in 'a t*) - (fun parameters error (agent_type, cv_id) rule_id_set store_result -> - let error, store_result = - add_link parameters error - (agent_type, cv_id) - rule_id_set store_result - in - error, store_result - ) + (fun parameters error (agent_type, cv_id) rule_id_set store_result -> + let error, store_result = + add_link parameters error (agent_type, cv_id) rule_id_set store_result + in + error, store_result) (*exists in 'b t*) - (fun parameters error (agent_type, cv_id) rule_id_set store_result -> - let error, store_result = - add_link parameters error - (agent_type, cv_id) - rule_id_set - store_result - in - error, store_result - ) + (fun parameters error (agent_type, cv_id) rule_id_set store_result -> + let error, store_result = + add_link parameters error (agent_type, cv_id) rule_id_set store_result + in + error, store_result) (*both*) - (fun parameters error (agent_type, cv_id) s1 s2 store_result -> - let error, union_set = - Ckappa_sig.Rule_map_and_set.Set.union parameters error s1 s2 - in - let error, store_result = - add_link parameters error - (agent_type, cv_id) union_set store_result - in - error, store_result - ) - store_update_modification - store_update_with_side_effects - store_result + (fun parameters error (agent_type, cv_id) s1 s2 store_result -> + let error, union_set = + Ckappa_sig.Rule_map_and_set.Set.union parameters error s1 s2 + in + let error, store_result = + add_link parameters error (agent_type, cv_id) union_set store_result + in + error, store_result) + store_update_modification store_update_with_side_effects store_result in - let error, log_info = StoryProfiling.StoryStats.close_event parameters error - (StoryProfiling.Merge_influences) - None log_info + let error, log_info = + StoryProfiling.StoryStats.close_event parameters error + StoryProfiling.Merge_influences None log_info in error, log_info, store_result @@ -280,15 +234,17 @@ let store_update let collect_dual_map parameters error handler store_result = let error, store_result = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.fold - parameters error + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .fold parameters error (fun parameters error (agent_type, (site_type, state)) - (agent_type', site_type', state') store_result -> + (agent_type', site_type', state') store_result -> let error, old_set = match Ckappa_sig.AgentSiteState_map_and_set.Map.find_option_without_logs parameters error - (agent_type, site_type, state) store_result + (agent_type, site_type, state) + store_result with | error, None -> error, Ckappa_sig.AgentSiteState_map_and_set.Set.empty @@ -313,60 +269,39 @@ let collect_dual_map parameters error handler store_result = Exit in let error, store_result = - Ckappa_sig.AgentSiteState_map_and_set.Map.add_or_overwrite - parameters + Ckappa_sig.AgentSiteState_map_and_set.Map.add_or_overwrite parameters error (agent_type, site_type, state) - new_set - store_result + new_set store_result in - error, store_result - ) handler.Cckappa_sig.dual store_result + error, store_result) + handler.Cckappa_sig.dual store_result in error, store_result (****************************************************************************) -let scan_rule_dynamic parameters log_info error _compiled - kappa_handler - handler_bdu - covering_classes - store_covering_classes_id - store_potential_side_effects - store_test_modif_map - store_result - = +let scan_rule_dynamic parameters log_info error _compiled kappa_handler + handler_bdu covering_classes store_covering_classes_id + store_potential_side_effects store_test_modif_map store_result = let error, log_info, store_update = - store_update - parameters - log_info - error - store_test_modif_map - store_potential_side_effects - store_covering_classes_id - covering_classes + store_update parameters log_info error store_test_modif_map + store_potential_side_effects store_covering_classes_id covering_classes store_result.store_update in let error, store_dual_contact_map = - collect_dual_map - parameters - error - kappa_handler + collect_dual_map parameters error kappa_handler store_result.store_dual_contact_map in - error, handler_bdu, log_info, - { - store_update = store_update; - store_dual_contact_map = store_dual_contact_map - } + error, handler_bdu, log_info, { store_update; store_dual_contact_map } (**************************************************************************) let init_bdu_analysis_dynamic = let init_bdu_analysis_dynamic = { - store_update = Covering_classes_type.AgentCV_map_and_set.Map.empty; - store_dual_contact_map = Ckappa_sig.AgentSiteState_map_and_set.Map.empty + store_update = Covering_classes_type.AgentCV_map_and_set.Map.empty; + store_dual_contact_map = Ckappa_sig.AgentSiteState_map_and_set.Map.empty; } in init_bdu_analysis_dynamic @@ -374,29 +309,13 @@ let init_bdu_analysis_dynamic = (**************************************************************************) (*rules*) -let scan_rule_set_dynamic - parameters - log_info - error - compiled - kappa_handler - handler_bdu - store_test_modif_map - covering_classes - store_covering_classes_id +let scan_rule_set_dynamic parameters log_info error compiled kappa_handler + handler_bdu store_test_modif_map covering_classes store_covering_classes_id store_potential_side_effects = let error, handler_bdu, log_info, store_result = - scan_rule_dynamic - parameters - log_info - error - compiled - kappa_handler - handler_bdu - covering_classes - store_covering_classes_id - store_potential_side_effects - store_test_modif_map + scan_rule_dynamic parameters log_info error compiled kappa_handler + handler_bdu covering_classes store_covering_classes_id + store_potential_side_effects store_test_modif_map init_bdu_analysis_dynamic in error, (handler_bdu, log_info, store_result) diff --git a/core/KaSa_rep/reachability_analysis/bdu_static_views.ml b/core/KaSa_rep/reachability_analysis/bdu_static_views.ml index 28e91dd565..832a8c644e 100644 --- a/core/KaSa_rep/reachability_analysis/bdu_static_views.ml +++ b/core/KaSa_rep/reachability_analysis/bdu_static_views.ml @@ -19,51 +19,43 @@ let local_trace = false (*TYPE of pattern*) (***************************************************************************) -type bdu_analysis_static_pattern = - { - (*pattern*) - store_proj_bdu_test_restriction_pattern : - (Covering_classes_type.cv_id * - Ckappa_sig.c_state Cckappa_sig.interval - Ckappa_sig.Site_map_and_set.Map.t) list - } +type bdu_analysis_static_pattern = { + (*pattern*) + store_proj_bdu_test_restriction_pattern: + (Covering_classes_type.cv_id + * Ckappa_sig.c_state Cckappa_sig.interval Ckappa_sig.Site_map_and_set.Map.t) + list; +} (***************************************************************************) (*initial values of pattern *) (***************************************************************************) let init_bdu_analysis_static_pattern = - { - store_proj_bdu_test_restriction_pattern = [] - } + { store_proj_bdu_test_restriction_pattern = [] } (***************************************************************************) (*TYPE of BDU static*) (***************************************************************************) -type bdu_analysis_static = - { - store_proj_bdu_creation_restriction_map: - Ckappa_sig.Views_bdu.mvbdu - Covering_classes_type.AgentCV_setmap.Map.t - Ckappa_sig.Rule_setmap.Map.t; - store_modif_list_restriction_map: - Ckappa_sig.Views_bdu.hconsed_association_list - Covering_classes_type.AgentsRuleCV_map_and_set.Map.t; - store_proj_bdu_potential_restriction_map : - (Ckappa_sig.Views_bdu.mvbdu * - Ckappa_sig.Views_bdu.hconsed_association_list) - Covering_classes_type.AgentSiteCV_setmap.Map.t - Ckappa_sig.Rule_setmap.Map.t; - store_proj_bdu_test_restriction : - Ckappa_sig.Views_bdu.mvbdu - Covering_classes_type.AgentsCV_setmap.Map.t - Ckappa_sig.Rule_setmap.Map.t; - site_to_renamed_site_list: - (Covering_classes_type.cv_id * Ckappa_sig.c_site_name) - list - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t - } +type bdu_analysis_static = { + store_proj_bdu_creation_restriction_map: + Ckappa_sig.Views_bdu.mvbdu Covering_classes_type.AgentCV_setmap.Map.t + Ckappa_sig.Rule_setmap.Map.t; + store_modif_list_restriction_map: + Ckappa_sig.Views_bdu.hconsed_association_list + Covering_classes_type.AgentsRuleCV_map_and_set.Map.t; + store_proj_bdu_potential_restriction_map: + (Ckappa_sig.Views_bdu.mvbdu * Ckappa_sig.Views_bdu.hconsed_association_list) + Covering_classes_type.AgentSiteCV_setmap.Map.t + Ckappa_sig.Rule_setmap.Map.t; + store_proj_bdu_test_restriction: + Ckappa_sig.Views_bdu.mvbdu Covering_classes_type.AgentsCV_setmap.Map.t + Ckappa_sig.Rule_setmap.Map.t; + site_to_renamed_site_list: + (Covering_classes_type.cv_id * Ckappa_sig.c_site_name) list + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t; +} (***************************************************************************) (*initial values of BDU static*) @@ -71,20 +63,18 @@ type bdu_analysis_static = let init_bdu_analysis_static parameters error = let error, init_site_to_renamed_site_list = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create parameters error (0,0) + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameters error (0, 0) in let init_bdu_analysis_static = { - store_proj_bdu_creation_restriction_map = - Ckappa_sig.Rule_setmap.Map.empty; + store_proj_bdu_creation_restriction_map = Ckappa_sig.Rule_setmap.Map.empty; store_modif_list_restriction_map = Covering_classes_type.AgentsRuleCV_map_and_set.Map.empty; store_proj_bdu_potential_restriction_map = Ckappa_sig.Rule_setmap.Map.empty; - store_proj_bdu_test_restriction = - Ckappa_sig.Rule_setmap.Map.empty; - site_to_renamed_site_list = - init_site_to_renamed_site_list + store_proj_bdu_test_restriction = Ckappa_sig.Rule_setmap.Map.empty; + site_to_renamed_site_list = init_site_to_renamed_site_list; } in error, init_bdu_analysis_static @@ -94,8 +84,8 @@ let init_bdu_analysis_static parameters error = (******************************************************************) (*creation rules*) -let get_bdu_map_and_set error bdu_false - (agent_type, rule_id, cv_id) store_result = +let get_bdu_map_and_set error bdu_false (agent_type, rule_id, cv_id) + store_result = let error, bdu_value = match Covering_classes_type.AgentRuleCV_setmap.Map.find_option @@ -103,7 +93,7 @@ let get_bdu_map_and_set error bdu_false store_result with | None -> error, bdu_false - (*default value when there is no creation in this rule*) + (*default value when there is no creation in this rule*) | Some bdu -> error, bdu in error, bdu_value @@ -111,8 +101,7 @@ let get_bdu_map_and_set error bdu_false let add_dependency_triple_bdu parameters handler error (agent_type, rule_id, cv_id) bdu store_result = let error, handler, bdu_false = - Ckappa_sig.Views_bdu.mvbdu_false - parameters handler error + Ckappa_sig.Views_bdu.mvbdu_false parameters handler error in let error, old_bdu = get_bdu_map_and_set error bdu_false @@ -121,196 +110,154 @@ let add_dependency_triple_bdu parameters handler error in (* In the case when the agent is created twice, we take the union *) let error, handler, bdu_new = - Ckappa_sig.Views_bdu.mvbdu_or - parameters handler error old_bdu bdu + Ckappa_sig.Views_bdu.mvbdu_or parameters handler error old_bdu bdu in let store_result = Covering_classes_type.AgentRuleCV_setmap.Map.add (agent_type, rule_id, cv_id) - bdu_new - store_result + bdu_new store_result in error, handler, store_result -let add_dependency_site parameters map_new_index_forward - site state (error, store_result) = +let add_dependency_site parameters map_new_index_forward site state + (error, store_result) = let error, site' = match - Ckappa_sig.Site_map_and_set.Map.find_option - parameters - error - site + Ckappa_sig.Site_map_and_set.Map.find_option parameters error site map_new_index_forward with | error, None -> - Exception.warn - parameters error __POS__ Exit Ckappa_sig.dummy_site_name + Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_site_name | error, Some s -> error, s in - Ckappa_sig.Site_map_and_set.Map.add - parameters error - site' - state - store_result + Ckappa_sig.Site_map_and_set.Map.add parameters error site' state store_result -let get_pair_cv_map_with_missing_association_creation - parameters error agent triple_list = - List.fold_left (fun (error, current_list) (cv_id, list, set) -> +let get_pair_cv_map_with_missing_association_creation parameters error agent + triple_list = + List.fold_left + (fun (error, current_list) (cv_id, list, set) -> let error, (map_new_index_forward, _) = Common_map.new_index_pair_map parameters error list in (*----------------------------------------------------*) let error', map_res = try - Ckappa_sig.Site_map_and_set.Map.fold_restriction_with_missing_associations - parameters error + Ckappa_sig.Site_map_and_set.Map + .fold_restriction_with_missing_associations parameters error (fun site port m -> - match - port.Cckappa_sig.site_state.Cckappa_sig.min, - port.Cckappa_sig.site_state.Cckappa_sig.max - with Some a, Some b when a=b - -> - add_dependency_site - parameters - map_new_index_forward - site - a - m - | Some _, Some _ | None,_ | _,None -> - raise Exit) + match + ( port.Cckappa_sig.site_state.Cckappa_sig.min, + port.Cckappa_sig.site_state.Cckappa_sig.max ) + with + | Some a, Some b when a = b -> + add_dependency_site parameters map_new_index_forward site a m + | Some _, Some _ | None, _ | _, None -> raise Exit) (fun site -> - add_dependency_site - parameters - map_new_index_forward - site - Ckappa_sig.dummy_state_index - ) - set - agent.Cckappa_sig.agent_interface + add_dependency_site parameters map_new_index_forward site + Ckappa_sig.dummy_state_index) + set agent.Cckappa_sig.agent_interface + Ckappa_sig.Site_map_and_set.Map.empty + with Exit -> + Exception.warn parameters error __POS__ Exit Ckappa_sig.Site_map_and_set.Map.empty - with - Exit -> Exception.warn parameters error __POS__ Exit - Ckappa_sig.Site_map_and_set.Map.empty in let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ + Exit in error, (cv_id, map_res) :: current_list) (error, []) triple_list -let collect_bdu_creation_restriction_map parameters handler error - rule_id rule - store_remanent_triple - store_result = +let collect_bdu_creation_restriction_map parameters handler error rule_id rule + store_remanent_triple store_result = (*-----------------------------------------------------------------*) Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error - (fun parameters error agent_type' triple_list (handler,store_result) -> - List.fold_left - (fun (error, (handler,store_result)) (agent_id, agent_type) -> - let error, agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_id - rule.Cckappa_sig.rule_rhs.Cckappa_sig.views - in - match agent with - | Some Cckappa_sig.Unknown_agent _ - | Some Cckappa_sig.Dead_agent _ - | None -> - Exception.warn - parameters error __POS__ Exit (handler,store_result) - | Some Cckappa_sig.Ghost -> error, (handler,store_result) - | Some Cckappa_sig.Agent agent -> - if agent_type' = agent_type - then - (*-----------------------------------------------------------*) - (*get map restriction from covering classes*) - let error, get_pair_list = - get_pair_cv_map_with_missing_association_creation - parameters error - agent - triple_list - in - (*----------------------------------------------------------*) - (*fold a list and get a pair of site and state and rule_id*) - let error, handler, store_result = - List.fold_left - (fun (error, handler, store_result) (cv_id,map_res) -> - let pair_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site' state current_list -> - (site', state) :: current_list ) - map_res [] - in - let error, handler, bdu_creation = - Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_association_list - parameters handler error pair_list - in - let error, handler, store_result = - add_dependency_triple_bdu - parameters - handler error - (agent_type, rule_id, cv_id) - bdu_creation - store_result - in - error, handler, store_result - ) (error, handler, store_result) - get_pair_list - in - error, (handler, store_result) - else error, (handler, store_result) - ) (error, (handler, store_result)) - rule.Cckappa_sig.actions.Cckappa_sig.creation - ) store_remanent_triple (handler, store_result) + (fun parameters error agent_type' triple_list (handler, store_result) -> + List.fold_left + (fun (error, (handler, store_result)) (agent_id, agent_type) -> + let error, agent = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_id + rule.Cckappa_sig.rule_rhs.Cckappa_sig.views + in + match agent with + | Some (Cckappa_sig.Unknown_agent _) + | Some (Cckappa_sig.Dead_agent _) + | None -> + Exception.warn parameters error __POS__ Exit (handler, store_result) + | Some Cckappa_sig.Ghost -> error, (handler, store_result) + | Some (Cckappa_sig.Agent agent) -> + if agent_type' = agent_type then ( + (*-----------------------------------------------------------*) + (*get map restriction from covering classes*) + let error, get_pair_list = + get_pair_cv_map_with_missing_association_creation parameters + error agent triple_list + in + (*----------------------------------------------------------*) + (*fold a list and get a pair of site and state and rule_id*) + let error, handler, store_result = + List.fold_left + (fun (error, handler, store_result) (cv_id, map_res) -> + let pair_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site' state current_list -> + (site', state) :: current_list) + map_res [] + in + let error, handler, bdu_creation = + Ckappa_sig.Views_bdu + .mvbdu_of_reverse_sorted_association_list parameters + handler error pair_list + in + let error, handler, store_result = + add_dependency_triple_bdu parameters handler error + (agent_type, rule_id, cv_id) + bdu_creation store_result + in + error, handler, store_result) + (error, handler, store_result) + get_pair_list + in + error, (handler, store_result) + ) else + error, (handler, store_result)) + (error, (handler, store_result)) + rule.Cckappa_sig.actions.Cckappa_sig.creation) + store_remanent_triple (handler, store_result) (*projection with rule_id*) let collect_proj_bdu_creation_restriction_map parameters handler_bdu error - rule_id rule - store_remanent_triple - store_result = + rule_id rule store_remanent_triple store_result = let store_init_bdu_creation_restriction_map = Covering_classes_type.AgentRuleCV_setmap.Map.empty in let error, (handler_bdu, store_bdu_creation_restriction_map) = collect_bdu_creation_restriction_map (* collect should work directly on the partitioned map (store_result) *) - parameters - handler_bdu - error - rule_id - rule - store_remanent_triple + parameters handler_bdu error rule_id rule store_remanent_triple store_init_bdu_creation_restriction_map in let error, handler_bdu, bdu_true = - Ckappa_sig.Views_bdu.mvbdu_true - parameters handler_bdu error + Ckappa_sig.Views_bdu.mvbdu_true parameters handler_bdu error in let (error, handler_bdu), store_result' = - Covering_classes_type.Project2bdu_creation.proj2_monadic - parameters + Covering_classes_type.Project2bdu_creation.proj2_monadic parameters (error, handler_bdu) (fun (_agent_type, rule_id, _cv_id) -> rule_id) (fun (agent_type, _rule_id, cv_id) -> agent_type, cv_id) bdu_true (fun parameters (error, handler_bdu) bdu bdu' -> - let error, handler_bdu, bdu_union = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler_bdu error bdu bdu' - in - (error, handler_bdu), bdu_union - ) + let error, handler_bdu, bdu_union = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler_bdu error bdu bdu' + in + (error, handler_bdu), bdu_union) store_bdu_creation_restriction_map in let store_result = - Ckappa_sig.Rule_setmap.Map.fold - Ckappa_sig.Rule_setmap.Map.add - store_result' + Ckappa_sig.Rule_setmap.Map.fold Ckappa_sig.Rule_setmap.Map.add store_result' store_result in (error, handler_bdu), store_result @@ -318,9 +265,10 @@ let collect_proj_bdu_creation_restriction_map parameters handler_bdu error (**************************************************************************) (*modification rule with creation rules*) -let get_pair_cv_map_with_restriction_modification - parameters error agent triple_list = - List.fold_left (fun (error, current_list) (cv_id, list, set) -> +let get_pair_cv_map_with_restriction_modification parameters error agent + triple_list = + List.fold_left + (fun (error, current_list) (cv_id, list, set) -> (*-----------------------------------------------------------*) (*new index for site type in covering class*) let error, (map_new_index_forward, _) = @@ -328,53 +276,42 @@ let get_pair_cv_map_with_restriction_modification in (*-----------------------------------------------------------*) let error, map_res = - Ckappa_sig.Site_map_and_set.Map.fold_restriction parameters - error + Ckappa_sig.Site_map_and_set.Map.fold_restriction parameters error (fun site port (error, store_result) -> - let state = port.Cckappa_sig.site_state.Cckappa_sig.min in - let error, () = - if state = port.Cckappa_sig.site_state.Cckappa_sig.max - then - error, () - else - Exception.warn parameters error __POS__ Exit () - in - let error, site' = - Ckappa_sig.Site_map_and_set.Map.find_default_without_logs - parameters - error - Ckappa_sig.dummy_site_name - site - map_new_index_forward - in - let error, map_res = - Ckappa_sig.Site_map_and_set.Map.add parameters error - site' - state - store_result - in - error, map_res - ) set - agent.Cckappa_sig.agent_interface + let state = port.Cckappa_sig.site_state.Cckappa_sig.min in + let error, () = + if state = port.Cckappa_sig.site_state.Cckappa_sig.max then + error, () + else + Exception.warn parameters error __POS__ Exit () + in + let error, site' = + Ckappa_sig.Site_map_and_set.Map.find_default_without_logs + parameters error Ckappa_sig.dummy_site_name site + map_new_index_forward + in + let error, map_res = + Ckappa_sig.Site_map_and_set.Map.add parameters error site' state + store_result + in + error, map_res) + set agent.Cckappa_sig.agent_interface Ckappa_sig.Site_map_and_set.Map.empty in - error, (cv_id, map_res) :: current_list - ) (error, []) triple_list + error, (cv_id, map_res) :: current_list) + (error, []) triple_list -let collect_modif_list_restriction_map - parameters handler error rule_id rule +let collect_modif_list_restriction_map parameters handler error rule_id rule (*store_new_index_pair_map*) - store_remanent_triple store_result = - let add_link error (agent_id, agent_type, rule_id, cv_id) - list_a store_result - = + store_remanent_triple store_result = + let add_link error (agent_id, agent_type, rule_id, cv_id) list_a store_result + = (*the association must be unique *) let error, result_map = Covering_classes_type.AgentsRuleCV_map_and_set.Map.add_or_overwrite parameters error (agent_id, agent_type, rule_id, cv_id) - list_a - store_result + list_a store_result in error, result_map in @@ -383,79 +320,75 @@ let collect_modif_list_restriction_map Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_id agent_modif (handler, store_result) -> - if Ckappa_sig.Site_map_and_set.Map.is_empty - agent_modif.Cckappa_sig.agent_interface - then error, (handler, store_result) - else - let agent_type = agent_modif.Cckappa_sig.agent_name in - let error, triple_list = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_type - store_remanent_triple - with - | error, None -> - Exception.warn parameters error __POS__ Exit [] - | error, Some x -> error, x - in - (*-----------------------------------------------------------------*) - (*get map restriction from covering classes*) - let error, get_pair_list = - get_pair_cv_map_with_restriction_modification - parameters error agent_modif - triple_list - in - (*-----------------------------------------------------------------*) - (*fold a list and get a pair of site and state and rule_id*) - let error, handler, store_result = - List.fold_left - (fun (error, handler, store_result) (cv_id,map_res) -> - if Ckappa_sig.Site_map_and_set.Map.is_empty map_res - then error, handler, store_result - else - begin - (*get a list of pair (site, state) in a map of new indexes - of site.*) - let error, pair_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site' state (error, current_list) -> - match state with - | Some state -> - let pair_list = (site', state) :: current_list in - error, pair_list - | None -> - Exception.warn parameters error __POS__ Exit - current_list - ) map_res (error, []) - in - (*-------------------------------------------------------*) - (*build list_a*) - let error, handler, list_a = - Ckappa_sig.Views_bdu.build_association_list - parameters - handler - error - pair_list - in - let error, store_result = - add_link error (agent_id, agent_type, rule_id, cv_id) - list_a store_result - in - error, handler, store_result - end - ) - (error, handler, store_result) - get_pair_list - in error, (handler, store_result)) + if + Ckappa_sig.Site_map_and_set.Map.is_empty + agent_modif.Cckappa_sig.agent_interface + then + error, (handler, store_result) + else ( + let agent_type = agent_modif.Cckappa_sig.agent_name in + let error, triple_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_type store_remanent_triple + with + | error, None -> Exception.warn parameters error __POS__ Exit [] + | error, Some x -> error, x + in + (*-----------------------------------------------------------------*) + (*get map restriction from covering classes*) + let error, get_pair_list = + get_pair_cv_map_with_restriction_modification parameters error + agent_modif triple_list + in + (*-----------------------------------------------------------------*) + (*fold a list and get a pair of site and state and rule_id*) + let error, handler, store_result = + List.fold_left + (fun (error, handler, store_result) (cv_id, map_res) -> + if Ckappa_sig.Site_map_and_set.Map.is_empty map_res then + error, handler, store_result + else ( + (*get a list of pair (site, state) in a map of new indexes + of site.*) + let error, pair_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site' state (error, current_list) -> + match state with + | Some state -> + let pair_list = (site', state) :: current_list in + error, pair_list + | None -> + Exception.warn parameters error __POS__ Exit + current_list) + map_res (error, []) + in + (*-------------------------------------------------------*) + (*build list_a*) + let error, handler, list_a = + Ckappa_sig.Views_bdu.build_association_list parameters handler + error pair_list + in + let error, store_result = + add_link error + (agent_id, agent_type, rule_id, cv_id) + list_a store_result + in + error, handler, store_result + )) + (error, handler, store_result) + get_pair_list + in + error, (handler, store_result) + )) rule.Cckappa_sig.diff_direct (handler, store_result) (**************************************************************************) (*build bdu for potential side effects*) let get_triple_map parameters error pair_list triple_list = - List.fold_left (fun (error, current_list) (cv_id, list, set) -> + List.fold_left + (fun (error, current_list) (cv_id, list, set) -> (*-------------------------------------------------------*) (*get new indexes for sites*) let error, (map_new_index_forward, _) = @@ -464,72 +397,58 @@ let get_triple_map parameters error pair_list triple_list = (*-----------------------------------------------------*) let error', map_res = List.fold_left - (fun (error, map_res) (_,(site, state)) -> - if Ckappa_sig.Site_map_and_set.Set.mem site set - then - let error, site' = - Ckappa_sig.Site_map_and_set.Map.find_default_without_logs - parameters - error - Ckappa_sig.dummy_site_name - site - map_new_index_forward - in - let error, old = - Ckappa_sig.Site_map_and_set.Map.find_default_without_logs - parameters error - [] - site' - map_res - in - let error, map_res = - Ckappa_sig.Site_map_and_set.Map.add_or_overwrite - parameters error - site' - (state :: old) - map_res - in - error, map_res - else error, map_res - ) (error, Ckappa_sig.Site_map_and_set.Map.empty) + (fun (error, map_res) (_, (site, state)) -> + if Ckappa_sig.Site_map_and_set.Set.mem site set then ( + let error, site' = + Ckappa_sig.Site_map_and_set.Map.find_default_without_logs + parameters error Ckappa_sig.dummy_site_name site + map_new_index_forward + in + let error, old = + Ckappa_sig.Site_map_and_set.Map.find_default_without_logs + parameters error [] site' map_res + in + let error, map_res = + Ckappa_sig.Site_map_and_set.Map.add_or_overwrite parameters + error site' (state :: old) map_res + in + error, map_res + ) else + error, map_res) + (error, Ckappa_sig.Site_map_and_set.Map.empty) pair_list in (*------------------------------------------------------*) let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ + Exit in - error, - Ckappa_sig.Site_map_and_set.Map.fold - (fun site' list_state list -> - (cv_id, site', list_state) :: list) map_res - current_list) + ( error, + Ckappa_sig.Site_map_and_set.Map.fold + (fun site' list_state list -> (cv_id, site', list_state) :: list) + map_res current_list )) (error, []) triple_list let store_bdu_potential_restriction_map_aux parameters handler error (*store_new_index_pair_map*) - store_remanent_triple - store_potential_side_effects - store_result = + store_remanent_triple store_potential_side_effects store_result = let error, handler, bdu_false = - Ckappa_sig.Views_bdu.mvbdu_false - parameters handler error + Ckappa_sig.Views_bdu.mvbdu_false parameters handler error in (*-----------------------------------------------------------------*) - let add_link handler error (agent_type, new_site_type, rule_id, cv_id) bdu store_result = + let add_link handler error (agent_type, new_site_type, rule_id, cv_id) bdu + store_result = (*build a list_a*) let error, handler, list = - Ckappa_sig.Views_bdu.build_reverse_sorted_association_list - parameters handler error - [new_site_type, Ckappa_sig.dummy_state_index] - (*state is 0*) + Ckappa_sig.Views_bdu.build_reverse_sorted_association_list parameters + handler error + [ new_site_type, Ckappa_sig.dummy_state_index ] + (*state is 0*) in let result_map = Covering_classes_type.AgentSiteRuleCV_setmap.Map.add (agent_type, new_site_type, rule_id, cv_id) - (bdu, list) - store_result + (bdu, list) store_result in error, handler, result_map in @@ -538,349 +457,300 @@ let store_bdu_potential_restriction_map_aux parameters handler error Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_type' triple_list (handler, store_result) -> - (*map of potential partner side_effect with site is bond*) - Ckappa_sig.AgentRule_map_and_set.Map.fold - (fun (agent_type, rule_id) pair_list (error, (handler, store_result)) - -> - if agent_type' = agent_type - then - let error, get_triple_list = - get_triple_map parameters error pair_list triple_list - in - (*---------------------------------------------------------*) - let error, handler, store_result = - List.fold_left - (fun (error, handler, store_result) (cv_id, site', map_res) -> - let error, handler, bdu = - List.fold_left (fun (error, handler, bdu) state -> - (*-----------------------------------------------*) - (*build bdu_potential side effects*) - let error, handler, bdu_potential_effect = - Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_association_list - parameters handler error [site', state] - in - (*union of bdu and bdu effect*) - let error, handler, bdu = - Ckappa_sig.Views_bdu.mvbdu_or - parameters handler error - bdu - bdu_potential_effect - in - error, handler, bdu) - (error, handler, bdu_false) - map_res - in - let error, handler, store_result = - add_link handler error - (agent_type, site', rule_id, cv_id) - bdu - store_result - in - error, handler, store_result - ) - (error, handler, store_result) - get_triple_list - in - error, (handler, store_result) - else - error, (handler, store_result) - ) store_potential_side_effects (error, (handler, store_result)) - ) store_remanent_triple (handler, store_result) + (*map of potential partner side_effect with site is bond*) + Ckappa_sig.AgentRule_map_and_set.Map.fold + (fun (agent_type, rule_id) pair_list (error, (handler, store_result)) -> + if agent_type' = agent_type then ( + let error, get_triple_list = + get_triple_map parameters error pair_list triple_list + in + (*---------------------------------------------------------*) + let error, handler, store_result = + List.fold_left + (fun (error, handler, store_result) (cv_id, site', map_res) -> + let error, handler, bdu = + List.fold_left + (fun (error, handler, bdu) state -> + (*-----------------------------------------------*) + (*build bdu_potential side effects*) + let error, handler, bdu_potential_effect = + Ckappa_sig.Views_bdu + .mvbdu_of_reverse_sorted_association_list parameters + handler error + [ site', state ] + in + (*union of bdu and bdu effect*) + let error, handler, bdu = + Ckappa_sig.Views_bdu.mvbdu_or parameters handler error + bdu bdu_potential_effect + in + error, handler, bdu) + (error, handler, bdu_false) + map_res + in + let error, handler, store_result = + add_link handler error + (agent_type, site', rule_id, cv_id) + bdu store_result + in + error, handler, store_result) + (error, handler, store_result) + get_triple_list + in + error, (handler, store_result) + ) else + error, (handler, store_result)) + store_potential_side_effects + (error, (handler, store_result))) + store_remanent_triple (handler, store_result) (*************************************************************************) (*build bdu_potential in the case of binding*) let store_bdu_potential_effect_restriction_map parameters handler error (*store_new_index_pair_map*) - store_remanent_triple - store_potential_side_effects store_result = + store_remanent_triple store_potential_side_effects store_result = let error', (handler, store_result) = - store_bdu_potential_restriction_map_aux - parameters - handler - error + store_bdu_potential_restriction_map_aux parameters handler error (*store_new_index_pair_map*) - store_remanent_triple - store_potential_side_effects - store_result + store_remanent_triple store_potential_side_effects store_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in error, (handler, store_result) -let collect_site_to_renamed_site_list - parameters error store_remanent_triple output - = +let collect_site_to_renamed_site_list parameters error store_remanent_triple + output = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_type' triple_list output -> - List.fold_left - (fun (error, output) (cv_id, list, _) -> - let rec aux error site list output = - match list with - | [] -> error, output - | h::t -> - begin - let key = (agent_type', h) in - let error, old = - match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameters error key output - with - | error, None -> error, [] - | error, Some l -> error, l - in - let new_list = (cv_id, site)::old in - let error, output = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameters error key new_list output - in - let site' = Ckappa_sig.next_site_name site in - aux error site' t output - end - in - aux error Ckappa_sig.dummy_site_name_1 list output) - (error, output) triple_list) - store_remanent_triple - output - + List.fold_left + (fun (error, output) (cv_id, list, _) -> + let rec aux error site list output = + match list with + | [] -> error, output + | h :: t -> + let key = agent_type', h in + let error, old = + match + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameters error key output + with + | error, None -> error, [] + | error, Some l -> error, l + in + let new_list = (cv_id, site) :: old in + let error, output = + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error key new_list output + in + let site' = Ckappa_sig.next_site_name site in + aux error site' t output + in + aux error Ckappa_sig.dummy_site_name_1 list output) + (error, output) triple_list) + store_remanent_triple output (**************************************************************************) (*projection with rule_id*) let collect_proj_bdu_potential_restriction_map parameters handler error (*store_new_index_pair_map*) - store_remanent_triple - store_potential_side_effects - store_result = + store_remanent_triple store_potential_side_effects store_result = let store_init_bdu_potential_restriction_map = Covering_classes_type.AgentSiteRuleCV_setmap.Map.empty in let error, (handler, store_bdu_potential_restriction_map) = (* this function should work directly on the partitioned map (store_result) *) - store_bdu_potential_effect_restriction_map - parameters - handler - error + store_bdu_potential_effect_restriction_map parameters handler error (*store_new_index_pair_map*) - store_remanent_triple - store_potential_side_effects + store_remanent_triple store_potential_side_effects store_init_bdu_potential_restriction_map in let error, handler, bdu_true = - Ckappa_sig.Views_bdu.mvbdu_true - parameters handler error + Ckappa_sig.Views_bdu.mvbdu_true parameters handler error in (*an empty hconsed list*) let error, handler, empty = - Ckappa_sig.Views_bdu.build_reverse_sorted_association_list - parameters handler error [] + Ckappa_sig.Views_bdu.build_reverse_sorted_association_list parameters + handler error [] in let (error, handler), store_result' = - Covering_classes_type.Project2bdu_potential.proj2_monadic - parameters + Covering_classes_type.Project2bdu_potential.proj2_monadic parameters (error, handler) (fun (_agent_type, _new_site_name, rule_id, _cv_id) -> rule_id) (fun (agent_type, new_site_name, _rule_id, cv_id) -> - agent_type, new_site_name, cv_id) + agent_type, new_site_name, cv_id) (bdu_true, empty) (fun _ (error, handler) _ pair' -> (error, handler), pair') store_bdu_potential_restriction_map in let store_result = - Ckappa_sig.Rule_setmap.Map.fold - Ckappa_sig.Rule_setmap.Map.add - store_result' + Ckappa_sig.Rule_setmap.Map.fold Ckappa_sig.Rule_setmap.Map.add store_result' store_result in (error, handler), store_result (**************************************************************************) -let get_pair_cv_map_with_restriction_views - parameters error agent triple_list = +let get_pair_cv_map_with_restriction_views parameters error agent triple_list = List.fold_left (fun (error, current_list) (cv_id, list, set) -> - (*----------------------------------------------------------*) - (*new index for site type in covering class*) - let error, (map_new_index_forward, _) = - Common_map.new_index_pair_map parameters error list - in - (*----------------------------------------------------------*) - let error', map_res = - Ckappa_sig.Site_map_and_set.Map.fold_restriction - parameters error - (fun site port (error, store_result) -> - let state = port.Cckappa_sig.site_state in - let error, site' = - Ckappa_sig.Site_map_and_set.Map.find_default parameters - error - Ckappa_sig.dummy_site_name - site - map_new_index_forward - in - let error, map_res = - Ckappa_sig.Site_map_and_set.Map.add parameters error - site' - state - store_result - in - error, map_res - ) set agent.Cckappa_sig.agent_interface - Ckappa_sig.Site_map_and_set.Map.empty - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - error, (cv_id, map_res) :: current_list) + (*----------------------------------------------------------*) + (*new index for site type in covering class*) + let error, (map_new_index_forward, _) = + Common_map.new_index_pair_map parameters error list + in + (*----------------------------------------------------------*) + let error', map_res = + Ckappa_sig.Site_map_and_set.Map.fold_restriction parameters error + (fun site port (error, store_result) -> + let state = port.Cckappa_sig.site_state in + let error, site' = + Ckappa_sig.Site_map_and_set.Map.find_default parameters error + Ckappa_sig.dummy_site_name site map_new_index_forward + in + let error, map_res = + Ckappa_sig.Site_map_and_set.Map.add parameters error site' state + store_result + in + error, map_res) + set agent.Cckappa_sig.agent_interface + Ckappa_sig.Site_map_and_set.Map.empty + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, (cv_id, map_res) :: current_list) (error, []) triple_list -let collect_bdu_test_restriction_map parameters _handler_kappa - handler error rule_id rule - (*store_new_index_pair_map*) - store_remanent_triple store_result = +let collect_bdu_test_restriction_map parameters _handler_kappa handler error + rule_id rule (*store_new_index_pair_map*) store_remanent_triple store_result + = let error, handler, bdu_false = - Ckappa_sig.Views_bdu.mvbdu_false - parameters handler error + Ckappa_sig.Views_bdu.mvbdu_false parameters handler error in (*let (map_new_index_forward, _) = store_new_index_pair_map in*) (*-----------------------------------------------------------------*) - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error agent_id agent (handler,store_result) -> - match agent with - | Cckappa_sig.Unknown_agent _ - (* Unfortunatly, we can do nothing with undefined agents in the views - domain *) - (* They will be handled with properly in the agents domain *) - | Cckappa_sig.Ghost -> error, (handler, store_result) - | Cckappa_sig.Dead_agent (agent, _, _, _) -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, triple_list = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_remanent_triple - with - | error, None -> error, [] - | error, Some x -> error, x - in - let error, store_result = - List.fold_left - (fun (error, store_result) (cv_id, _, _) -> - error, + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun parameters error agent_id agent (handler, store_result) -> + match agent with + | Cckappa_sig.Unknown_agent _ + (* Unfortunatly, we can do nothing with undefined agents in the views + domain *) + (* They will be handled with properly in the agents domain *) + | Cckappa_sig.Ghost -> + error, (handler, store_result) + | Cckappa_sig.Dead_agent (agent, _, _, _) -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, triple_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_remanent_triple + with + | error, None -> error, [] + | error, Some x -> error, x + in + let error, store_result = + List.fold_left + (fun (error, store_result) (cv_id, _, _) -> + ( error, Covering_classes_type.AgentsRuleCV_setmap.Map.add (agent_id, agent_type, rule_id, cv_id) - bdu_false store_result - ) (error, store_result) triple_list - in - error, (handler, store_result) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, triple_list = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_remanent_triple - with - | error, None -> error, [] - | error, Some x -> error, x - in - (*-----------------------------------------------------------------*) - (*get map restriction from covering classes*) - let error, get_pair_list = - get_pair_cv_map_with_restriction_views - parameters error agent triple_list - in - (*-----------------------------------------------------------------*) - let error, handler, store_result = - List.fold_left - (fun (error, handler, store_result) (cv_id, map_res) -> - if Ckappa_sig.Site_map_and_set.Map.is_empty map_res - then - error, handler, store_result - else - begin - let error, pair_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site' state (error,current_list) -> - let pair_list = - (site', - (state.Cckappa_sig.min, state.Cckappa_sig.max)) - :: current_list - in - error, pair_list - ) map_res (error, []) - in - (*build bdu_test*) - let error, handler, bdu_test = - Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_range_list - parameters handler error pair_list - in - let error, store_result = - error, Covering_classes_type.AgentsRuleCV_setmap.Map.add - (agent_id, agent_type, rule_id, cv_id) - bdu_test - store_result - in - error, handler, store_result - end) - - (error, handler, store_result) get_pair_list - in - error, (handler, store_result) - ) rule.Cckappa_sig.rule_lhs.Cckappa_sig.views (handler,store_result) + bdu_false store_result )) + (error, store_result) triple_list + in + error, (handler, store_result) + | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, triple_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_remanent_triple + with + | error, None -> error, [] + | error, Some x -> error, x + in + (*-----------------------------------------------------------------*) + (*get map restriction from covering classes*) + let error, get_pair_list = + get_pair_cv_map_with_restriction_views parameters error agent + triple_list + in + (*-----------------------------------------------------------------*) + let error, handler, store_result = + List.fold_left + (fun (error, handler, store_result) (cv_id, map_res) -> + if Ckappa_sig.Site_map_and_set.Map.is_empty map_res then + error, handler, store_result + else ( + let error, pair_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site' state (error, current_list) -> + let pair_list = + (site', (state.Cckappa_sig.min, state.Cckappa_sig.max)) + :: current_list + in + error, pair_list) + map_res (error, []) + in + (*build bdu_test*) + let error, handler, bdu_test = + Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_range_list + parameters handler error pair_list + in + let error, store_result = + ( error, + Covering_classes_type.AgentsRuleCV_setmap.Map.add + (agent_id, agent_type, rule_id, cv_id) + bdu_test store_result ) + in + error, handler, store_result + )) + (error, handler, store_result) + get_pair_list + in + error, (handler, store_result)) + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views (handler, store_result) (***************************************************************************) let collect_proj_bdu_test_restriction parameters handler_kappa handler error - rule_id rule - (*store_new_index_pair_map*) - store_remanent_triple - store_result = + rule_id rule (*store_new_index_pair_map*) store_remanent_triple store_result + = let store_init_bdu_test_restriction_map = Covering_classes_type.AgentsRuleCV_setmap.Map.empty in let error, (handler, store_bdu_test_restriction_map) = (* collect should work directly on the partitioned map (store_result) *) - collect_bdu_test_restriction_map - parameters - handler_kappa - handler - error - rule_id - rule - (*store_new_index_pair_map*) - store_remanent_triple - store_init_bdu_test_restriction_map + collect_bdu_test_restriction_map parameters handler_kappa handler error + rule_id rule (*store_new_index_pair_map*) + store_remanent_triple store_init_bdu_test_restriction_map in let error, handler, bdu_true = - Ckappa_sig.Views_bdu.mvbdu_true - parameters handler error + Ckappa_sig.Views_bdu.mvbdu_true parameters handler error in let (error, handler), store_result' = - Covering_classes_type.Project2_bdu_views.proj2_monadic - parameters + Covering_classes_type.Project2_bdu_views.proj2_monadic parameters (error, handler) (fun (_agent_id, _agent_type, rule_id, _cv_id) -> rule_id) (fun (agent_id, agent_type, _rule_id, cv_id) -> - (agent_id, agent_type, cv_id)) + agent_id, agent_type, cv_id) bdu_true (fun parameters (error, handler) bdu bdu' -> - let error, handler, bdu_union = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error bdu bdu' - in - (error, handler), bdu_union - ) + let error, handler, bdu_union = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu bdu' + in + (error, handler), bdu_union) store_bdu_test_restriction_map in let store_result = - Ckappa_sig.Rule_setmap.Map.fold - Ckappa_sig.Rule_setmap.Map.add - store_result' + Ckappa_sig.Rule_setmap.Map.fold Ckappa_sig.Rule_setmap.Map.add store_result' store_result in (error, handler), store_result @@ -891,154 +761,117 @@ let collect_proj_bdu_test_restriction parameters handler_kappa handler error let collect_proj_bdu_test_restriction_pattern parameters error (pattern : Cckappa_sig.mixture) (*store_new_index_pair_map*) - store_remanent_triple store_result = + store_remanent_triple store_result = (*let (map_new_index_forward, _) = store_new_index_pair_map in*) let error, store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id agent store_result -> - match agent with - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent (_, _, _, _) -> - error, store_result (*CHECK ME: SHOULD I RAISE A WARNING HERE?*) - (*Exception.warn parameters error __POS__ - ~message:"Dead_agent" - Exit store_result*) - (*----------------------------------------------------------*) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, triple_list = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - agent_type - store_remanent_triple - with - | error, None -> error, [] - | error, Some l -> error, l - in - let error, get_pair_list = - get_pair_cv_map_with_restriction_views - parameters error agent triple_list - in - error, get_pair_list - ) pattern.Cckappa_sig.views store_result + match agent with + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost + | Cckappa_sig.Dead_agent (_, _, _, _) -> + error, store_result (*CHECK ME: SHOULD I RAISE A WARNING HERE?*) + (*Exception.warn parameters error __POS__ + ~message:"Dead_agent" + Exit store_result*) + (*----------------------------------------------------------*) + | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, triple_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_remanent_triple + with + | error, None -> error, [] + | error, Some l -> error, l + in + let error, get_pair_list = + get_pair_cv_map_with_restriction_views parameters error agent + triple_list + in + error, get_pair_list) + pattern.Cckappa_sig.views store_result in error, store_result (***************************************************************************) let scan_rule_static parameters log_info error handler_kappa handler_bdu - (rule_id:Ckappa_sig.c_rule_id) rule + (rule_id : Ckappa_sig.c_rule_id) rule (*store_new_index_pair_map*) - store_remanent_triple - store_potential_side_effects _compil store_result = + store_remanent_triple store_potential_side_effects _compil store_result = (*-----------------------------------------------------------------------*) (*pre_static*) - let error, log_info = StoryProfiling.StoryStats.add_event parameters error + let error, log_info = + StoryProfiling.StoryStats.add_event parameters error (StoryProfiling.Scan_rule_static (Ckappa_sig.int_of_rule_id rule_id)) None log_info in (*------------------------------------------------------------------------*) let (error, handler_bdu), store_proj_bdu_creation_restriction_map = - collect_proj_bdu_creation_restriction_map - parameters - handler_bdu - error - rule_id - rule - (*store_new_index_pair_map*) - store_remanent_triple - store_result.store_proj_bdu_creation_restriction_map + collect_proj_bdu_creation_restriction_map parameters handler_bdu error + rule_id rule (*store_new_index_pair_map*) + store_remanent_triple store_result.store_proj_bdu_creation_restriction_map in (*-----------------------------------------------------------------------*) let error, (handler_bdu, store_modif_list_restriction_map) = - collect_modif_list_restriction_map - parameters - handler_bdu - error - rule_id - rule + collect_modif_list_restriction_map parameters handler_bdu error rule_id rule (*store_new_index_pair_map*) - store_remanent_triple - store_result.store_modif_list_restriction_map + store_remanent_triple store_result.store_modif_list_restriction_map in (*-----------------------------------------------------------------------*) let (error, handler_bdu), store_proj_bdu_potential_restriction_map = - collect_proj_bdu_potential_restriction_map - parameters - handler_bdu - error + collect_proj_bdu_potential_restriction_map parameters handler_bdu error (*store_new_index_pair_map*) - store_remanent_triple - store_potential_side_effects + store_remanent_triple store_potential_side_effects store_result.store_proj_bdu_potential_restriction_map in (*------------------------------------------------------------------------*) let (error, handler_bdu), store_proj_bdu_test_restriction = - collect_proj_bdu_test_restriction - parameters - handler_kappa - handler_bdu - error - rule_id - rule - (*store_new_index_pair_map*) - store_remanent_triple - store_result.store_proj_bdu_test_restriction + collect_proj_bdu_test_restriction parameters handler_kappa handler_bdu error + rule_id rule (*store_new_index_pair_map*) + store_remanent_triple store_result.store_proj_bdu_test_restriction in (*------------------------------------------------------------------------*) - let error, log_info = StoryProfiling.StoryStats.close_event parameters error + let error, log_info = + StoryProfiling.StoryStats.close_event parameters error (StoryProfiling.Scan_rule_static (Ckappa_sig.int_of_rule_id rule_id)) None log_info in - error, log_info, handler_bdu, - {store_result with - store_proj_bdu_creation_restriction_map = + ( error, + log_info, + handler_bdu, + { + store_result with store_proj_bdu_creation_restriction_map; - store_modif_list_restriction_map = store_modif_list_restriction_map; - store_proj_bdu_potential_restriction_map = + store_modif_list_restriction_map; store_proj_bdu_potential_restriction_map; - store_proj_bdu_test_restriction = store_proj_bdu_test_restriction; - } + store_proj_bdu_test_restriction; + } ) (***************************************************************************) let scan_rule_set parameters log_info handler_bdu error handler_kappa compiled - store_potential_side_effects - store_remanent_triple = + store_potential_side_effects store_remanent_triple = let error, init = init_bdu_analysis_static parameters error in let error, (handler_bdu, log_info, store_results) = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error rule_id rule (handler_bdu, log_info, store_result) - -> - let error, log_info, handler_bdu, store_result = - scan_rule_static - parameters - log_info - error - handler_kappa - handler_bdu - rule_id - rule.Cckappa_sig.e_rule_c_rule - store_remanent_triple - store_potential_side_effects - compiled - store_result - in - error, (handler_bdu, log_info, store_result) - ) compiled.Cckappa_sig.rules (handler_bdu, log_info, init) + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error + (fun parameters error rule_id rule (handler_bdu, log_info, store_result) -> + let error, log_info, handler_bdu, store_result = + scan_rule_static parameters log_info error handler_kappa handler_bdu + rule_id rule.Cckappa_sig.e_rule_c_rule store_remanent_triple + store_potential_side_effects compiled store_result + in + error, (handler_bdu, log_info, store_result)) + compiled.Cckappa_sig.rules + (handler_bdu, log_info, init) in let error, site_to_renamed_site_list = - collect_site_to_renamed_site_list - parameters error - store_remanent_triple + collect_site_to_renamed_site_list parameters error store_remanent_triple store_results.site_to_renamed_site_list in - error, (handler_bdu, log_info, - {store_results with site_to_renamed_site_list}) + ( error, + (handler_bdu, log_info, { store_results with site_to_renamed_site_list }) ) (***************************************************************************) (*PATTERN*) @@ -1046,42 +879,29 @@ let scan_rule_set parameters log_info handler_bdu error handler_kappa compiled let scan_rule_static_pattern parameters (*store_new_index_pair_map*) - store_remanent_triple error - rule store_result = + store_remanent_triple error rule store_result = let error, store_proj_bdu_test_restriction_pattern = - collect_proj_bdu_test_restriction_pattern - parameters - error + collect_proj_bdu_test_restriction_pattern parameters error rule.Cckappa_sig.rule_lhs (*pattern*) (*store_new_index_pair_map*) - store_remanent_triple - store_result.store_proj_bdu_test_restriction_pattern + store_remanent_triple store_result.store_proj_bdu_test_restriction_pattern in - error, - { - store_proj_bdu_test_restriction_pattern = - store_proj_bdu_test_restriction_pattern - } + error, { store_proj_bdu_test_restriction_pattern } let scan_rule_set_pattern parameters error (*store_new_index_pair_map*) - store_remanent_triple - compiled = + store_remanent_triple compiled = let init = init_bdu_analysis_static_pattern in let error, store_results = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error _ rule store_result -> - let error, store_result = - scan_rule_static_pattern - parameters - (*store_new_index_pair_map*) - store_remanent_triple - error - rule.Cckappa_sig.e_rule_c_rule - store_result - in - error, store_result - ) compiled.Cckappa_sig.rules init + let error, store_result = + scan_rule_static_pattern parameters + (*store_new_index_pair_map*) + store_remanent_triple error rule.Cckappa_sig.e_rule_c_rule + store_result + in + error, store_result) + compiled.Cckappa_sig.rules init in error, store_results diff --git a/core/KaSa_rep/reachability_analysis/common_map.ml b/core/KaSa_rep/reachability_analysis/common_map.ml index 5b664493bd..8238d42de3 100644 --- a/core/KaSa_rep/reachability_analysis/common_map.ml +++ b/core/KaSa_rep/reachability_analysis/common_map.ml @@ -20,27 +20,24 @@ let trace = false let get_list_from_agent_site parameters error (agent_type, site_type) store_result = let error, result = - match Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, site_type) - store_result + match + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameters + error (agent_type, site_type) store_result with | error, None -> error, [] | error, Some l -> error, l in error, result -let add_dependency_pair_sites_cv parameters error (agent_type, site_type) - cv_id store_result = +let add_dependency_pair_sites_cv parameters error (agent_type, site_type) cv_id + store_result = let error, old = get_list_from_agent_site parameters error (agent_type, site_type) store_result in let error, store_result = Ckappa_sig.AgentSite_map_and_set.Map.add_or_overwrite parameters error - (agent_type, site_type) - (cv_id :: old) - store_result + (agent_type, site_type) (cv_id :: old) store_result in error, store_result @@ -49,19 +46,15 @@ let add_dependency_pair_sites_cv parameters error (agent_type, site_type) let add_dependency_pair_sites parameters error (agent_type, site_type) x store_result = let error, (l, old) = - match Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters - error - (agent_type, site_type) - store_result + match + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameters + error (agent_type, site_type) store_result with | error, None -> error, ([], []) | error, Some (l, l') -> error, (l, l') in let error, store_result = - Ckappa_sig.AgentSite_map_and_set.Map.add_or_overwrite - parameters - error + Ckappa_sig.AgentSite_map_and_set.Map.add_or_overwrite parameters error (agent_type, site_type) (l, x :: old) store_result @@ -70,81 +63,65 @@ let add_dependency_pair_sites parameters error (agent_type, site_type) x (****************************************************************************) -let add_dependency_pair_sites_rule parameters error - (agent_type, rule_id) - l store_result = +let add_dependency_pair_sites_rule parameters error (agent_type, rule_id) l + store_result = let error, old = match - Ckappa_sig.AgentRule_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, rule_id) - store_result + Ckappa_sig.AgentRule_map_and_set.Map.find_option_without_logs parameters + error (agent_type, rule_id) store_result with | error, None -> error, [] | error, Some l -> error, l in - let new_list = List.concat [l; old] in + let new_list = List.concat [ l; old ] in let error, store_result = - Ckappa_sig.AgentRule_map_and_set.Map.add_or_overwrite - parameters error - (agent_type, rule_id) - new_list - store_result + Ckappa_sig.AgentRule_map_and_set.Map.add_or_overwrite parameters error + (agent_type, rule_id) new_list store_result in error, store_result (****************************************************************************) let add_dependency_triple_sites_rule parameters error - (agent_id, agent_type, site_type) - rule_id_set store_result = + (agent_id, agent_type, site_type) rule_id_set store_result = let error, old = - match Ckappa_sig.AgentsSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_id, agent_type, site_type) - store_result + match + Ckappa_sig.AgentsSite_map_and_set.Map.find_option_without_logs parameters + error + (agent_id, agent_type, site_type) + store_result with | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty | error, Some s -> error, s in let error', union = - Ckappa_sig.Rule_map_and_set.Set.union parameters error old rule_id_set in + Ckappa_sig.Rule_map_and_set.Set.union parameters error old rule_id_set + in let error = - Exception.check_point Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error, store_result = - Ckappa_sig.AgentsSite_map_and_set.Map.add_or_overwrite - parameters error + Ckappa_sig.AgentsSite_map_and_set.Map.add_or_overwrite parameters error (agent_id, agent_type, site_type) - union - store_result + union store_result in error, store_result (****************************************************************************) let add_triple_agents_site_rule parameters error - (agent_id, agent_type, site_type) rule_id - store_result = + (agent_id, agent_type, site_type) rule_id store_result = let error', current_set = - Ckappa_sig.Rule_map_and_set.Set.add - parameters - error - rule_id + Ckappa_sig.Rule_map_and_set.Set.add parameters error rule_id Ckappa_sig.Rule_map_and_set.Set.empty in let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error, store_result = - Ckappa_sig.AgentsSite_map_and_set.Map.add_or_overwrite - parameters error + Ckappa_sig.AgentsSite_map_and_set.Map.add_or_overwrite parameters error (agent_id, agent_type, site_type) - current_set - store_result + current_set store_result in error, store_result @@ -155,37 +132,31 @@ let add_triple_agents_site_rule parameters error let collect_projection_agent_id_from_triple parameters error store_result = Covering_classes_type.Project2_modif.monadic_proj_map (fun _parameters error (_agent_id, agent_type, site_type) -> - error, (agent_type, site_type)) - parameters - error - (Ckappa_sig.Rule_map_and_set.Set.empty) + error, (agent_type, site_type)) + parameters error Ckappa_sig.Rule_map_and_set.Set.empty (fun parameters error s1 s2 -> - let error', new_set = - Ckappa_sig.Rule_map_and_set.Set.union parameters error s1 s2 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error, new_set - ) store_result - -let project_second_site (b, c, _, e) = (b, c, e) -let project_second_site_state (b, c, _, _) = (b, c) -let project_first_site_state (b, _, d, _) = (b, d) -let project_state (b, c, _) = (b, c) + let error', new_set = + Ckappa_sig.Rule_map_and_set.Set.union parameters error s1 s2 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, new_set) + store_result +let project_second_site (b, c, _, e) = b, c, e +let project_second_site_state (b, c, _, _) = b, c +let project_first_site_state (b, _, d, _) = b, d +let project_state (b, c, _) = b, c (****************************************************************************) let get_rule_id_map_and_set parameter error rule_id empty store_result = let error, store_result = match - Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs - parameter - error - rule_id - store_result + Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameter error + rule_id store_result with | error, None -> error, empty | error, Some s -> error, s @@ -195,11 +166,8 @@ let get_rule_id_map_and_set parameter error rule_id empty store_result = let get_agent_id parameter error agent_id empty store_result = let error, store_result = match - Ckappa_sig.Agent_id_map_and_set.Map.find_option_without_logs - parameter - error - agent_id - store_result + Ckappa_sig.Agent_id_map_and_set.Map.find_option_without_logs parameter + error agent_id store_result with | error, None -> error, empty | error, Some s -> error, s @@ -209,20 +177,15 @@ let get_agent_id parameter error agent_id empty store_result = let get_pair_agent_cv parameters error (agent_type, cv_id) store_result = match Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, cv_id) - store_result + parameters error (agent_type, cv_id) store_result with | error, None -> error, [] | error, Some l -> error, l let get_agent_type parameters error agent_type empty store_result = match - Ckappa_sig.Agent_map_and_set.Map.find_option_without_logs - parameters - error - agent_type - store_result + Ckappa_sig.Agent_map_and_set.Map.find_option_without_logs parameters error + agent_type store_result with | error, None -> error, empty | error, Some l -> error, l @@ -231,14 +194,14 @@ let get_agent_type parameters error agent_type empty store_result = let list2set parameters error list = let error', set = - List.fold_left (fun (error,current_set) elt -> - Ckappa_sig.Site_map_and_set.Set.add - parameters error elt current_set - ) (error, Ckappa_sig.Site_map_and_set.Set.empty) list + List.fold_left + (fun (error, current_set) elt -> + Ckappa_sig.Site_map_and_set.Set.add parameters error elt current_set) + (error, Ckappa_sig.Site_map_and_set.Set.empty) + list in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in error, set @@ -250,87 +213,73 @@ let new_index_pair_map parameters error l = | [] -> error, (map1, map2) | h :: tl -> let error, map1 = - Ckappa_sig.Site_map_and_set.Map.add parameters error h k map1 in + Ckappa_sig.Site_map_and_set.Map.add parameters error h k map1 + in let error, map2 = - Ckappa_sig.Site_map_and_set.Map.add parameters error k h map2 in - aux - tl - (Ckappa_sig.site_name_of_int ((Ckappa_sig.int_of_site_name k)+1)) - map1 - map2 - error + Ckappa_sig.Site_map_and_set.Map.add parameters error k h map2 + in + aux tl + (Ckappa_sig.site_name_of_int (Ckappa_sig.int_of_site_name k + 1)) + map1 map2 error in let error', (map1, map2) = - aux - l + aux l (Ckappa_sig.site_name_of_int 1) Ckappa_sig.Site_map_and_set.Map.empty Ckappa_sig.Site_map_and_set.Map.empty error in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in - error,(map1,map2) + error, (map1, map2) (****************************************************************************) -let collect_sites_map_in_agent_interface parameters error agent - rule_id - (agent_id, agent_type) - store_result = +let collect_sites_map_in_agent_interface parameters error agent rule_id + (agent_id, agent_type) store_result = Ckappa_sig.Site_map_and_set.Map.fold (fun site_type _ (error, store_result) -> - let error, store_result = - add_triple_agents_site_rule - parameters - error - (agent_id, agent_type, site_type) - rule_id - store_result - in - error, store_result - ) agent.Cckappa_sig.agent_interface (error, store_result) + let error, store_result = + add_triple_agents_site_rule parameters error + (agent_id, agent_type, site_type) + rule_id store_result + in + error, store_result) + agent.Cckappa_sig.agent_interface (error, store_result) -let collect_site_map_for_views ?init:(init=false) parameters handler error agent = +let collect_site_map_for_views ?(init = false) parameters handler error agent = let error, last_site = - Handler.last_site_of_agent - parameters error handler agent.Cckappa_sig.agent_name + Handler.last_site_of_agent parameters error handler + agent.Cckappa_sig.agent_name in - let rec aux k (error,output) = - if - Ckappa_sig.compare_site_name k Ckappa_sig.dummy_site_name < 0 - then - error,output - else + let rec aux k (error, output) = + if Ckappa_sig.compare_site_name k Ckappa_sig.dummy_site_name < 0 then + error, output + else ( let output = - Ckappa_sig.Site_map_and_set.Map.add - parameters error - k - (Some Ckappa_sig.dummy_state_index ,Some Ckappa_sig.dummy_state_index) + Ckappa_sig.Site_map_and_set.Map.add parameters error k + (Some Ckappa_sig.dummy_state_index, Some Ckappa_sig.dummy_state_index) output in aux (Ckappa_sig.pred_site_name k) output + ) in let error, site_map = - if init then aux last_site (error,Ckappa_sig.Site_map_and_set.Map.empty) - else error, Ckappa_sig.Site_map_and_set.Map.empty + if init then + aux last_site (error, Ckappa_sig.Site_map_and_set.Map.empty) + else + error, Ckappa_sig.Site_map_and_set.Map.empty in let error, site_map = Ckappa_sig.Site_map_and_set.Map.fold (fun site_type port (error, store_map) -> - let state_max = port.Cckappa_sig.site_state.Cckappa_sig.max in - let state_min = port.Cckappa_sig.site_state.Cckappa_sig.min in - let error, store_map = - Ckappa_sig.Site_map_and_set.Map.add_or_overwrite - parameters error - site_type - (state_min, state_max) - store_map - in - error, store_map - ) - agent.Cckappa_sig.agent_interface - (error, site_map) + let state_max = port.Cckappa_sig.site_state.Cckappa_sig.max in + let state_min = port.Cckappa_sig.site_state.Cckappa_sig.min in + let error, store_map = + Ckappa_sig.Site_map_and_set.Map.add_or_overwrite parameters error + site_type (state_min, state_max) store_map + in + error, store_map) + agent.Cckappa_sig.agent_interface (error, site_map) in error, site_map diff --git a/core/KaSa_rep/reachability_analysis/common_static.ml b/core/KaSa_rep/reachability_analysis/common_static.ml index dc54227d0f..ffd9cedbec 100644 --- a/core/KaSa_rep/reachability_analysis/common_static.ml +++ b/core/KaSa_rep/reachability_analysis/common_static.ml @@ -19,38 +19,33 @@ let trace = false (*MODIFICATION*) (***************************************************************************) -type modification_views = - { - store_modified_map : - Ckappa_sig.AgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_project_modified_map : (*use in parallel domain*) - Ckappa_sig.AgentSite_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_modification_sites : - Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.AgentsSite_map_and_set.Map.t; - } +type modification_views = { + store_modified_map: + Ckappa_sig.AgentsSiteState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_project_modified_map: + (*use in parallel domain*) + Ckappa_sig.AgentSite_map_and_set.Set.t Ckappa_sig.Rule_map_and_set.Map.t; + store_modification_sites: + Ckappa_sig.Rule_map_and_set.Set.t Ckappa_sig.AgentsSite_map_and_set.Map.t; +} (***************************************************************************) (*VIEWS-TEST: LHS-RHS*) (***************************************************************************) -type test_views = - { - store_views_rhs : - Ckappa_sig.pair_of_states - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_map_and_set.Map.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_views_lhs : - Ckappa_sig.pair_of_states - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_map_and_set.Map.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_test_sites : Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.AgentsSite_map_and_set.Map.t; - } +type test_views = { + store_views_rhs: + Ckappa_sig.pair_of_states Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_views_lhs: + Ckappa_sig.pair_of_states Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_test_sites: + Ckappa_sig.Rule_map_and_set.Set.t Ckappa_sig.AgentsSite_map_and_set.Map.t; +} (***************************************************************************) (*SIDE EFFECTS*) @@ -58,42 +53,45 @@ type test_views = type half_break_action = (int list * (Ckappa_sig.c_rule_id * Ckappa_sig.pair_of_states) list) - Ckappa_sig.AgentSite_map_and_set.Map.t + Ckappa_sig.AgentSite_map_and_set.Map.t type remove_action = (int list * Ckappa_sig.c_rule_id list) Ckappa_sig.AgentSite_map_and_set.Map.t - type potential_side_effect = - ((Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name - * Ckappa_sig.c_state) * - (Ckappa_sig.c_site_name * Ckappa_sig.c_state)) list Ckappa_sig.AgentRule_map_and_set.Map.t - - -type side_effects_views = - { - store_side_effects : half_break_action * remove_action; - store_potential_side_effects : potential_side_effect; - } + ((Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_site_name * Ckappa_sig.c_state)) + list + Ckappa_sig.AgentRule_map_and_set.Map.t + +type side_effects_views = { + store_side_effects: half_break_action * remove_action; + store_potential_side_effects: potential_side_effect; +} (***************************************************************************) (*BINDING*) (***************************************************************************) -type binding_views = - { - store_bonds_rhs : Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_bonds_lhs : Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_action_binding : Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - } +type binding_views = { + store_bonds_rhs: + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_bonds_lhs: + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_action_binding: + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; +} (***************************************************************************) (*COVERING CLASSES*) (***************************************************************************) - (* +(* let new_index_pair_map parameters error l = let rec aux acc k map1 map2 error = @@ -128,29 +126,29 @@ let new_index_pair_map parameters error l = (*COMMON VIEWS*) (***************************************************************************) -type common_views = - { - store_agent_name : Ckappa_sig.c_agent_name - Ckappa_sig.RuleAgent_map_and_set.Map.t; - store_agent_name_from_pattern : - Ckappa_sig.c_agent_name Ckappa_sig.Agent_id_map_and_set.Map.t; - store_potential_side_effects_per_rule: - ( (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) - list Ckappa_sig.Rule_map_and_set.Map.t; - store_side_effects_views : side_effects_views; - store_binding_views : binding_views; - store_modification : modification_views; - store_test : test_views; - store_test_modification_sites : - Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.AgentsSite_map_and_set.Map.t; - store_test_modif_map: - Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.AgentSite_map_and_set.Map.t; - (* store_predicate_covering_classes : predicate_covering_classes;*) - } +type common_views = { + store_agent_name: + Ckappa_sig.c_agent_name Ckappa_sig.RuleAgent_map_and_set.Map.t; + store_agent_name_from_pattern: + Ckappa_sig.c_agent_name Ckappa_sig.Agent_id_map_and_set.Map.t; + store_potential_side_effects_per_rule: + ((Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) + list + Ckappa_sig.Rule_map_and_set.Map.t; + store_side_effects_views: side_effects_views; + store_binding_views: binding_views; + store_modification: modification_views; + store_test: test_views; + store_test_modification_sites: + Ckappa_sig.Rule_map_and_set.Set.t Ckappa_sig.AgentsSite_map_and_set.Map.t; + store_test_modif_map: + Ckappa_sig.Rule_map_and_set.Set.t Ckappa_sig.AgentSite_map_and_set.Map.t; + (* store_predicate_covering_classes : predicate_covering_classes;*) +} (*****************************************************************************) (*Initial states of bdu common statics*) @@ -184,52 +182,45 @@ let init_binding_views = let init_side_effect_views = { - store_side_effects = (empty_agentsite, empty_agentsite); - store_potential_side_effects = empty_agentrule ; + store_side_effects = empty_agentsite, empty_agentsite; + store_potential_side_effects = empty_agentrule; } - let init_common_views _parameters error = - error, - { - store_agent_name = Ckappa_sig.RuleAgent_map_and_set.Map.empty; - store_agent_name_from_pattern = Ckappa_sig.Agent_id_map_and_set.Map.empty; - store_side_effects_views = init_side_effect_views; - store_potential_side_effects_per_rule = empty_rule; - store_binding_views = init_binding_views; - store_modification = init_modification_views; - store_test = init_test_views; - store_test_modification_sites = - Ckappa_sig.AgentsSite_map_and_set.Map.empty; - store_test_modif_map = empty_agentsite; - } + ( error, + { + store_agent_name = Ckappa_sig.RuleAgent_map_and_set.Map.empty; + store_agent_name_from_pattern = Ckappa_sig.Agent_id_map_and_set.Map.empty; + store_side_effects_views = init_side_effect_views; + store_potential_side_effects_per_rule = empty_rule; + store_binding_views = init_binding_views; + store_modification = init_modification_views; + store_test = init_test_views; + store_test_modification_sites = + Ckappa_sig.AgentsSite_map_and_set.Map.empty; + store_test_modif_map = empty_agentsite; + } ) (****************************************************************************) (*return agent_name with a pair of key (rule_id and agent_id) in the lhs*) let collect_agent_name parameter error rule_id rule store_result = let error, store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameter + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error (fun parameter error agent_id agent store_result -> - match agent with - | Cckappa_sig.Ghost -> error, store_result - | Cckappa_sig.Unknown_agent _ -> - Exception.warn parameter error __POS__ Exit store_result - | Cckappa_sig.Dead_agent (agent, _, _, _) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, store_result = - Ckappa_sig.RuleAgent_map_and_set.Map.add_or_overwrite - parameter - error - (rule_id, agent_id) - agent_type - store_result - in - error, store_result - ) rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result + match agent with + | Cckappa_sig.Ghost -> error, store_result + | Cckappa_sig.Unknown_agent _ -> + Exception.warn parameter error __POS__ Exit store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, store_result = + Ckappa_sig.RuleAgent_map_and_set.Map.add_or_overwrite parameter + error (rule_id, agent_id) agent_type store_result + in + error, store_result) + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result in error, store_result @@ -238,27 +229,21 @@ let collect_agent_name parameter error rule_id rule store_result = let collect_agent_name_from_pattern parameters error pattern store_result = let error, store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_id agent store_result -> - match agent with - | Cckappa_sig.Ghost -> error, store_result - | Cckappa_sig.Unknown_agent _ -> - Exception.warn parameters error __POS__ Exit store_result - | Cckappa_sig.Dead_agent (agent, _, _, _) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, store_result = - Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite - parameters - error - agent_id - agent_type - store_result - in - error, store_result - ) pattern.Cckappa_sig.views store_result + match agent with + | Cckappa_sig.Ghost -> error, store_result + | Cckappa_sig.Unknown_agent _ -> + Exception.warn parameters error __POS__ Exit store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, store_result = + Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite parameters + error agent_id agent_type store_result + in + error, store_result) + pattern.Cckappa_sig.views store_result in error, store_result @@ -266,23 +251,19 @@ let collect_agent_name_from_pattern parameters error pattern store_result = (*Side effects*) (**************************************************************************) -let get_last_entry_in_state_dic parameters error (agent_type, site_type) - handler = +let get_last_entry_in_state_dic parameters error (agent_type, site_type) handler + = let error, state_dic = Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_type, site_type) + (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type, site_type) handler.Cckappa_sig.states_dic) (fun error -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init())) + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) in let error, last_entry = - Ckappa_sig.Dictionary_of_States.last_entry parameters error - state_dic + Ckappa_sig.Dictionary_of_States.last_entry parameters error state_dic in error, last_entry @@ -293,51 +274,44 @@ let get_states_in_handler parameter error add handler state_op = let error, (state_min, state_max) = match state_op with | None -> - begin - let error, last_entry = - get_last_entry_in_state_dic - parameter - error - (agent_type, site_type) - handler - in - error, (Some Ckappa_sig.dummy_state_index_1, Some last_entry) - end + let error, last_entry = + get_last_entry_in_state_dic parameter error (agent_type, site_type) + handler + in + error, (Some Ckappa_sig.dummy_state_index_1, Some last_entry) | Some interval -> - error, - (interval.Cckappa_sig.min, interval.Cckappa_sig.max) + error, (interval.Cckappa_sig.min, interval.Cckappa_sig.max) in error, (state_min, state_max) let half_break_action parameters error handler rule_id half_break store_result = (*module (agent_type, site) -> (rule_id, binding_state) list*) let error, store_result = - List.fold_left (fun (error, store_result) (site_address, state_op) -> + List.fold_left + (fun (error, store_result) (site_address, state_op) -> (*site_address: {agent_index, site, agent_type}*) let agent_type = site_address.Cckappa_sig.agent_type in let site_type = site_address.Cckappa_sig.site in (*state*) let error, (state_min, state_max) = - get_states_in_handler parameters error site_address handler - state_op + get_states_in_handler parameters error site_address handler state_op in (*-------------------------------------------------------------------*) (*return result*) let error, store_result = - Common_map.add_dependency_pair_sites - parameters - error + Common_map.add_dependency_pair_sites parameters error (agent_type, site_type) (rule_id, (state_min, state_max)) store_result in - error, store_result - ) (error, store_result) half_break + error, store_result) + (error, store_result) half_break in (*--------------------------------------------------------------------*) (*map function*) let store_result = - Ckappa_sig.AgentSite_map_and_set.Map.map (fun (l, x) -> List.rev l, x) + Ckappa_sig.AgentSite_map_and_set.Map.map + (fun (l, x) -> List.rev l, x) store_result in error, store_result @@ -348,26 +322,23 @@ let remove_action parameters error rule_id remove store_result = let error, store_result = List.fold_left (fun (error, store_result) (_agent_index, agent, list_undoc) -> - let agent_type = agent.Cckappa_sig.agent_name in - (*NOTE: if it is a site_free then do not consider this case.*) - (*result*) - let error, store_result = - List.fold_left - (fun (error, store_result) site_type -> - Common_map.add_dependency_pair_sites - parameters - error - (agent_type, site_type) - rule_id - store_result - ) (error, store_result) list_undoc - in - error, store_result - ) (error, store_result) remove + let agent_type = agent.Cckappa_sig.agent_name in + (*NOTE: if it is a site_free then do not consider this case.*) + (*result*) + let error, store_result = + List.fold_left + (fun (error, store_result) site_type -> + Common_map.add_dependency_pair_sites parameters error + (agent_type, site_type) rule_id store_result) + (error, store_result) list_undoc + in + error, store_result) + (error, store_result) remove in (*-------------------------------------------------------------------------*) let store_result = - Ckappa_sig.AgentSite_map_and_set.Map.map (fun (l, x) -> List.rev l, x) + Ckappa_sig.AgentSite_map_and_set.Map.map + (fun (l, x) -> List.rev l, x) store_result in error, store_result @@ -377,22 +348,12 @@ let collect_side_effects parameter error handler rule_id half_break remove let store_half_break_action, store_remove_action = store_result in (*if there is a half_break action*) let error, store_half_break_action = - half_break_action - parameter - error - handler - rule_id - half_break + half_break_action parameter error handler rule_id half_break store_half_break_action in (*if there is a remove action*) let error, store_remove_action = - remove_action - parameter - error - rule_id - remove - store_remove_action + remove_action parameter error rule_id remove store_remove_action in error, (store_half_break_action, store_remove_action) @@ -408,13 +369,15 @@ let collect_potential_free_and_bind parameter error handler rule_id let error, store_potential_free = Common_map.add_dependency_pair_sites_rule parameter error (agent_type2, rule_id) - (((agent_id,agent_type, site_type, k), (site2,Ckappa_sig.dummy_state_index)) :: []) + (( (agent_id, agent_type, site_type, k), + (site2, Ckappa_sig.dummy_state_index) ) + :: []) (fst store_result) in let error, store_potential_bind = Common_map.add_dependency_pair_sites_rule parameter error (agent_type2, rule_id) - (((agent_id,agent_type, site_type, k),(site2, state2)) :: []) + (((agent_id, agent_type, site_type, k), (site2, state2)) :: []) (snd store_result) in error, (store_potential_free, store_potential_bind) @@ -422,217 +385,157 @@ let collect_potential_free_and_bind parameter error handler rule_id let get_potential_partner parameter error handler rule_id (agent_id, agent_type, site_type) (state_min, state_max) store_result = let error, state_min = - match - state_min - with + match state_min with | None -> Exception.warn parameter error __POS__ Exit Ckappa_sig.dummy_state_index - | Some i -> - error, i + | Some i -> error, i in let error, state_max = - match - state_max - with + match state_max with | None -> Exception.warn parameter error __POS__ Exit Ckappa_sig.dummy_state_index - | Some i -> - error, i + | Some i -> error, i in let rec aux k (error, store_result) = - if Ckappa_sig.compare_state_index k state_max > 0 - then + if Ckappa_sig.compare_state_index k state_max > 0 then error, store_result - else - (*potential partner*) + else ( + (*potential partner*) let error, (store_potential_free, store_potential_bind) = - collect_potential_free_and_bind - parameter error handler rule_id + collect_potential_free_and_bind parameter error handler rule_id (agent_id, agent_type, site_type) - k - store_result + k store_result in aux (Ckappa_sig.next_state_index k) (error, (store_potential_free, store_potential_bind)) - in aux state_min (error, store_result) + ) + in + aux state_min (error, store_result) let store_potential_half_break parameter error handler rule_id half_break store_result = List.fold_left (fun (error, store_result) (add, state_op) -> - let agent_index = add.Cckappa_sig.agent_index in - let agent_type = add.Cckappa_sig.agent_type in - let site_type = add.Cckappa_sig.site in - (*state*) - let error, (state_min, state_max) = - get_states_in_handler parameter error add handler state_op - in - (*--------------------------------------------------------------------*) - let error, store_result = - get_potential_partner parameter error - handler rule_id (agent_index, agent_type, site_type) - (state_min, state_max) - store_result - in - error, store_result - ) (error, store_result) half_break + let agent_index = add.Cckappa_sig.agent_index in + let agent_type = add.Cckappa_sig.agent_type in + let site_type = add.Cckappa_sig.site in + (*state*) + let error, (state_min, state_max) = + get_states_in_handler parameter error add handler state_op + in + (*--------------------------------------------------------------------*) + let error, store_result = + get_potential_partner parameter error handler rule_id + (agent_index, agent_type, site_type) + (state_min, state_max) store_result + in + error, store_result) + (error, store_result) half_break let store_potential_remove parameter error handler rule_id remove store_result = List.fold_left (fun (error, store_result) (agent_index, agent, list_undoc) -> let agent_type = agent.Cckappa_sig.agent_name in let error, store_result = - List.fold_left (fun (error, store_result) site_type -> + List.fold_left + (fun (error, store_result) site_type -> let error, is_binding = Handler.is_binding_site parameter error handler agent_type site_type in - if is_binding - then - begin - let error, last_entry = - get_last_entry_in_state_dic parameter error - (agent_type, site_type) - handler - in - (*-----------------------------------------------------------*) - let error, store_result = - get_potential_partner parameter error handler rule_id - (agent_index, agent_type, site_type) - (Some Ckappa_sig.dummy_state_index_1, Some last_entry) - store_result - in - error, store_result - end - else + if is_binding then ( + let error, last_entry = + get_last_entry_in_state_dic parameter error + (agent_type, site_type) handler + in + (*-----------------------------------------------------------*) + let error, store_result = + get_potential_partner parameter error handler rule_id + (agent_index, agent_type, site_type) + (Some Ckappa_sig.dummy_state_index_1, Some last_entry) + store_result + in error, store_result - ) (error, store_result) list_undoc + ) else + error, store_result) + (error, store_result) list_undoc in - error, store_result - ) (error, store_result) remove - -let combine_half_break_and_remove parameter error - fst_or_snd_store_result_hb - fst_or_snd_store_result_remove - store_result_map = - (*-----------------------------------------------------------------------*) - Ckappa_sig.AgentRule_map_and_set.Map.fold2 - parameter - error + error, store_result) + (error, store_result) remove + +let combine_half_break_and_remove parameter error fst_or_snd_store_result_hb + fst_or_snd_store_result_remove store_result_map = + (*-----------------------------------------------------------------------*) + Ckappa_sig.AgentRule_map_and_set.Map.fold2 parameter error (*exists in 'a t*) - (fun parameter error (agent_type, rule_id) l1 store_result -> - let error, store_result = - Common_map.add_dependency_pair_sites_rule parameter error - (agent_type, rule_id) - l1 - store_result - in - error, store_result - ) + (fun parameter error (agent_type, rule_id) l1 store_result -> + let error, store_result = + Common_map.add_dependency_pair_sites_rule parameter error + (agent_type, rule_id) l1 store_result + in + error, store_result) (*exists in 'b t*) - (fun parameter error (agent_type, rule_id) l2 store_result -> - let error, store_result = - Common_map.add_dependency_pair_sites_rule parameter error - (agent_type, rule_id) - l2 - store_result - in - error, store_result - ) + (fun parameter error (agent_type, rule_id) l2 store_result -> + let error, store_result = + Common_map.add_dependency_pair_sites_rule parameter error + (agent_type, rule_id) l2 store_result + in + error, store_result) (*exists in both*) - (fun parameter error (agent_type, rule_id) l1 l2 store_result -> - let concat = List.concat [l1; l2] in - let error, store_result = - Common_map.add_dependency_pair_sites_rule parameter error - (agent_type, rule_id) - concat - store_result - in - error, store_result - ) - fst_or_snd_store_result_hb - fst_or_snd_store_result_remove - store_result_map + (fun parameter error (agent_type, rule_id) l1 l2 store_result -> + let concat = List.concat [ l1; l2 ] in + let error, store_result = + Common_map.add_dependency_pair_sites_rule parameter error + (agent_type, rule_id) concat store_result + in + error, store_result) + fst_or_snd_store_result_hb fst_or_snd_store_result_remove store_result_map let collect_potential_side_effects_free parameter error handler rule_id half_break remove store_result_map = let error, store_result_hb = - store_potential_half_break - parameter - error - handler - rule_id - half_break - (Ckappa_sig.AgentRule_map_and_set.Map.empty, - Ckappa_sig.AgentRule_map_and_set.Map.empty) + store_potential_half_break parameter error handler rule_id half_break + ( Ckappa_sig.AgentRule_map_and_set.Map.empty, + Ckappa_sig.AgentRule_map_and_set.Map.empty ) in let error, store_result_remove = - store_potential_remove - parameter - error - handler - rule_id - remove - (Ckappa_sig.AgentRule_map_and_set.Map.empty, - Ckappa_sig.AgentRule_map_and_set.Map.empty) + store_potential_remove parameter error handler rule_id remove + ( Ckappa_sig.AgentRule_map_and_set.Map.empty, + Ckappa_sig.AgentRule_map_and_set.Map.empty ) in (*-----------------------------------------------------------------------*) - combine_half_break_and_remove parameter error - (fst store_result_hb) - (fst store_result_remove) - store_result_map + combine_half_break_and_remove parameter error (fst store_result_hb) + (fst store_result_remove) store_result_map let collect_potential_side_effects_bind parameter error handler rule_id half_break remove store_result_map = let error, store_result_hb = - store_potential_half_break - parameter - error - handler - rule_id - half_break - (Ckappa_sig.AgentRule_map_and_set.Map.empty, - Ckappa_sig.AgentRule_map_and_set.Map.empty) + store_potential_half_break parameter error handler rule_id half_break + ( Ckappa_sig.AgentRule_map_and_set.Map.empty, + Ckappa_sig.AgentRule_map_and_set.Map.empty ) in let error, store_result_remove = - store_potential_remove - parameter - error - handler - rule_id - remove - (Ckappa_sig.AgentRule_map_and_set.Map.empty, - Ckappa_sig.AgentRule_map_and_set.Map.empty) + store_potential_remove parameter error handler rule_id remove + ( Ckappa_sig.AgentRule_map_and_set.Map.empty, + Ckappa_sig.AgentRule_map_and_set.Map.empty ) in (*------------------------------------------------------------------------*) - combine_half_break_and_remove parameter error - (snd store_result_hb) - (snd store_result_remove) - store_result_map + combine_half_break_and_remove parameter error (snd store_result_hb) + (snd store_result_remove) store_result_map let collect_potential_side_effects parameter error handler rule_id half_break remove store_result = let error, store_result = - collect_potential_side_effects_bind - parameter - error - handler - rule_id - half_break - remove - store_result + collect_potential_side_effects_bind parameter error handler rule_id + half_break remove store_result in error, store_result let scan_rule_side_effects_views parameter error kappa_handler rule_id rule store_result = let error, store_side_effects = - collect_side_effects - parameter - error - kappa_handler - rule_id + collect_side_effects parameter error kappa_handler rule_id rule.Cckappa_sig.actions.Cckappa_sig.half_break rule.Cckappa_sig.actions.Cckappa_sig.remove store_result.store_side_effects @@ -640,20 +543,12 @@ let scan_rule_side_effects_views parameter error kappa_handler rule_id rule (*-----------------------------------------------------------------------*) (*potential partner side effects*) let error, store_potential_side_effects = - collect_potential_side_effects - parameter - error - kappa_handler - rule_id + collect_potential_side_effects parameter error kappa_handler rule_id rule.Cckappa_sig.actions.Cckappa_sig.half_break rule.Cckappa_sig.actions.Cckappa_sig.remove store_result.store_potential_side_effects in - error, - { - store_side_effects = store_side_effects; - store_potential_side_effects = store_potential_side_effects; - } + error, { store_side_effects; store_potential_side_effects } (***************************************************************************) (*BINDING*) @@ -661,46 +556,37 @@ let scan_rule_side_effects_views parameter error kappa_handler rule_id rule let collect_agent_type_binding_state parameter error agent site_type = match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ -> - error, - (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_state_index) + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ -> + error, (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_state_index) | Cckappa_sig.Dead_agent _ -> Exception.warn parameter error __POS__ Exit (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_state_index) | Cckappa_sig.Agent agent1 -> let agent_type1 = agent1.Cckappa_sig.agent_name in let error, state1 = - match Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameter - error - site_type - agent1.Cckappa_sig.agent_interface + match + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameter error + site_type agent1.Cckappa_sig.agent_interface with | error, None -> - Exception.warn - parameter error __POS__ Exit (Ckappa_sig.dummy_state_index) + Exception.warn parameter error __POS__ Exit Ckappa_sig.dummy_state_index | error, Some port -> let state_max = port.Cckappa_sig.site_state.Cckappa_sig.max in let state_min = port.Cckappa_sig.site_state.Cckappa_sig.min in (* It is a binding state *) - match state_min,state_max - with - | Some a, Some b when a=b -> - error, a + (match state_min, state_max with + | Some a, Some b when a = b -> error, a | None, _ | _, None | Some _, Some _ -> - Exception.warn - parameter error __POS__ Exit (Ckappa_sig.dummy_state_index) + Exception.warn parameter error __POS__ Exit + Ckappa_sig.dummy_state_index) in error, (agent_type1, state1) let collect_fingerprint_of_binding parameter error agent_id site_type views = let error, agent_source = match - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameter error - agent_id - views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameter + error agent_id views with | error, None -> Exception.warn parameter error __POS__ Exit Cckappa_sig.Ghost @@ -708,11 +594,7 @@ let collect_fingerprint_of_binding parameter error agent_id site_type views = in (*get pair agent_type, state*) let error, (agent_type, state) = - collect_agent_type_binding_state - parameter - error - agent_source - site_type + collect_agent_type_binding_state parameter error agent_source site_type in error, (agent_type, state) @@ -722,57 +604,51 @@ let collect_fingerprint_of_bond parameter error site_add agent_id let agent_index_target = site_add.Cckappa_sig.agent_index in let site_type_target = site_add.Cckappa_sig.site in let error, (agent_type1, state1) = - collect_fingerprint_of_binding parameter error - agent_id - site_type_source + collect_fingerprint_of_binding parameter error agent_id site_type_source views in let error, (agent_type2, state2) = - collect_fingerprint_of_binding parameter error - agent_index_target - site_type_target - views + collect_fingerprint_of_binding parameter error agent_index_target + site_type_target views in - let pair = ((agent_type1, site_type_source, state1), - (agent_type2, site_type_target, state2)) + let pair = + ( (agent_type1, site_type_source, state1), + (agent_type2, site_type_target, state2) ) in error, pair in error, pair let collect_bonds_pattern parameters error views bonds store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error agent_id bonds_map store_result -> - Ckappa_sig.Site_map_and_set.Map.fold - (fun site_type_source site_add (error, store_result) -> - let agent_id_target = site_add.Cckappa_sig.agent_index in - let error, ((agent_type1, site_type_source, state1), - (agent_type2, site_type_target, state2)) = - collect_fingerprint_of_bond parameters - error - site_add - agent_id - site_type_source - views - in - let error, new_set = - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in - parameters error - ((agent_id, agent_type1, site_type_source, state1), - (agent_id_target, agent_type2, site_type_target, state2)) - store_result - in - let error, store_result = - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in - parameters error - ((agent_id_target, agent_type2, site_type_target, state2), - (agent_id, agent_type1, site_type_source, state1)) - new_set - in - error, store_result - ) bonds_map (error, store_result) - ) bonds store_result + Ckappa_sig.Site_map_and_set.Map.fold + (fun site_type_source site_add (error, store_result) -> + let agent_id_target = site_add.Cckappa_sig.agent_index in + let ( error, + ( (agent_type1, site_type_source, state1), + (agent_type2, site_type_target, state2) ) ) = + collect_fingerprint_of_bond parameters error site_add agent_id + site_type_source views + in + let error, new_set = + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in + parameters error + ( (agent_id, agent_type1, site_type_source, state1), + (agent_id_target, agent_type2, site_type_target, state2) ) + store_result + in + let error, store_result = + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in + parameters error + ( (agent_id_target, agent_type2, site_type_target, state2), + (agent_id, agent_type1, site_type_source, state1) ) + new_set + in + error, store_result) + bonds_map (error, store_result)) + bonds store_result let collect_bonds parameters error rule_id views bonds store_result = let error, store_set = @@ -780,28 +656,24 @@ let collect_bonds parameters error rule_id views bonds store_result = Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty in let error, store_result = - Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite - parameters error rule_id store_set store_result + Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite parameters error rule_id + store_set store_result in error, store_result let collect_bonds_rhs parameter error rule_id rule store_result = - collect_bonds parameter error - rule_id + collect_bonds parameter error rule_id rule.Cckappa_sig.rule_rhs.Cckappa_sig.views - rule.Cckappa_sig.rule_rhs.Cckappa_sig.bonds - store_result + rule.Cckappa_sig.rule_rhs.Cckappa_sig.bonds store_result let collect_bonds_lhs parameter error rule_id rule store_result = - collect_bonds - parameter error - rule_id + collect_bonds parameter error rule_id rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - rule.Cckappa_sig.rule_lhs.Cckappa_sig.bonds - store_result + rule.Cckappa_sig.rule_lhs.Cckappa_sig.bonds store_result let collect_action_binding parameter error rule_id rule store_result = - List.fold_left (fun (error, store_result) (site_add1, site_add2) -> + List.fold_left + (fun (error, store_result) (site_add1, site_add2) -> (*get information of a rule that created a bond*) let agent_id1 = site_add1.Cckappa_sig.agent_index in let site_type1 = site_add1.Cckappa_sig.site in @@ -812,135 +684,100 @@ let collect_action_binding parameter error rule_id rule store_result = rule.Cckappa_sig.rule_rhs.Cckappa_sig.views in let error, (agent_type2, state2) = - collect_fingerprint_of_binding parameter error - agent_id2 - site_type2 + collect_fingerprint_of_binding parameter error agent_id2 site_type2 rule.Cckappa_sig.rule_rhs.Cckappa_sig.views in (*add the pair inside the set*) let error, old_set = Common_map.get_rule_id_map_and_set parameter error rule_id - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty - store_result + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty store_result in let error, set = - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in - parameter error - ((agent_id1, agent_type1, site_type1, state1), - (agent_id2, agent_type2, site_type2, state2)) + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in parameter + error + ( (agent_id1, agent_type1, site_type1, state1), + (agent_id2, agent_type2, site_type2, state2) ) old_set in let error, set = - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in - parameter error - ((agent_id2, agent_type2, site_type2, state2), - (agent_id1, agent_type1, site_type1, state1)) + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in parameter + error + ( (agent_id2, agent_type2, site_type2, state2), + (agent_id1, agent_type1, site_type1, state1) ) set in let error, store_result = - Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite - parameter error - rule_id - set - store_result + Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite parameter error rule_id + set store_result in - error, store_result - ) (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.bind + error, store_result) + (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.bind let scan_rule_binding_views parameter error rule_id rule store_result = let error, store_bonds_rhs = - collect_bonds_rhs - parameter - error - rule_id - rule - store_result.store_bonds_rhs + collect_bonds_rhs parameter error rule_id rule store_result.store_bonds_rhs in let error, store_bonds_lhs = - collect_bonds_lhs - parameter - error - rule_id - rule - store_result.store_bonds_lhs + collect_bonds_lhs parameter error rule_id rule store_result.store_bonds_lhs in let error, store_action_binding = - collect_action_binding - parameter - error - rule_id - rule + collect_action_binding parameter error rule_id rule store_result.store_action_binding in - error, - { - store_bonds_rhs = store_bonds_rhs; - store_bonds_lhs = store_bonds_lhs; - store_action_binding = store_action_binding; - } + error, { store_bonds_rhs; store_bonds_lhs; store_action_binding } (***************************************************************************) (*VIEWS*) (***************************************************************************) -let collect_views_pattern_aux ?init:(init=false) parameter handler error views store_result = +let collect_views_pattern_aux ?(init = false) parameter handler error views + store_result = let error, store_result = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error (fun parameter error agent_id agent store_result -> - (* JF: Unknown_agent cannot be dealt as ghost agent *) - (* -> A ghost agent denotes no agent in a pattern, thus it is always - satisfy *) - (* A Dead_agent or an unknown agent, can never be satisfied *) - (* Whatever you do, a ghost agent shoudl not change the result *) - (* If the pattern contains an Unknown agent or a dead agent the - pattern may not be reachable *) - match agent with - | Cckappa_sig.Ghost -> error, store_result - | Cckappa_sig.Unknown_agent _ -> - Exception.warn parameter error __POS__ Exit store_result - | Cckappa_sig.Dead_agent (agent,_,_,_) - | Cckappa_sig.Agent agent -> - let error, site_map = - Common_map.collect_site_map_for_views ~init - parameter handler error agent - in - let error, store_result = - Ckappa_sig.Agent_id_map_and_set.Map.add - parameter error - agent_id - site_map - store_result - in - error, store_result - ) views store_result + (* JF: Unknown_agent cannot be dealt as ghost agent *) + (* -> A ghost agent denotes no agent in a pattern, thus it is always + satisfy *) + (* A Dead_agent or an unknown agent, can never be satisfied *) + (* Whatever you do, a ghost agent shoudl not change the result *) + (* If the pattern contains an Unknown agent or a dead agent the + pattern may not be reachable *) + match agent with + | Cckappa_sig.Ghost -> error, store_result + | Cckappa_sig.Unknown_agent _ -> + Exception.warn parameter error __POS__ Exit store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let error, site_map = + Common_map.collect_site_map_for_views ~init parameter handler error + agent + in + let error, store_result = + Ckappa_sig.Agent_id_map_and_set.Map.add parameter error agent_id + site_map store_result + in + error, store_result) + views store_result in error, store_result - let collect_test_sites parameters error rule_id viewslhs store_result = let error, store_result = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun _parameters error agent_id agent store_result -> - match agent with - | Cckappa_sig.Unknown_agent _ -> - Exception.warn parameters error __POS__ Exit store_result - | Cckappa_sig.Ghost -> error, store_result - | Cckappa_sig.Dead_agent (agent,_,_,_) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, store_result = - Common_map.collect_sites_map_in_agent_interface - parameters - error - agent - rule_id - (agent_id, agent_type) - store_result - in - error, store_result - ) viewslhs store_result + match agent with + | Cckappa_sig.Unknown_agent _ -> + Exception.warn parameters error __POS__ Exit store_result + | Cckappa_sig.Ghost -> error, store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, store_result = + Common_map.collect_sites_map_in_agent_interface parameters error + agent rule_id (agent_id, agent_type) store_result + in + error, store_result) + viewslhs store_result in let store_result = Ckappa_sig.AgentsSite_map_and_set.Map.map (fun x -> x) store_result @@ -949,162 +786,129 @@ let collect_test_sites parameters error rule_id viewslhs store_result = let collect_views_aux parameter handler error rule_id views store_result = let error, old_map = - Common_map.get_rule_id_map_and_set parameter error - rule_id - Ckappa_sig.Agent_id_map_and_set.Map.empty - store_result + Common_map.get_rule_id_map_and_set parameter error rule_id + Ckappa_sig.Agent_id_map_and_set.Map.empty store_result in let error, map = - collect_views_pattern_aux parameter handler error - views - old_map + collect_views_pattern_aux parameter handler error views old_map in let error, store_result = - Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite - parameter error rule_id map store_result + Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite parameter error rule_id map + store_result in error, store_result let collect_views_lhs parameter handler error rule_id rule store_result = - collect_views_aux - parameter handler error - rule_id - rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - store_result + collect_views_aux parameter handler error rule_id + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result let collect_views_rhs parameter handler error rule_id rule store_result = - collect_views_aux - parameter handler error - rule_id - rule.Cckappa_sig.rule_rhs.Cckappa_sig.views - store_result + collect_views_aux parameter handler error rule_id + rule.Cckappa_sig.rule_rhs.Cckappa_sig.views store_result let scan_rule_test parameters handler error rule_id rule store_result = let error, store_views_rhs = - collect_views_rhs - parameters handler error - rule_id - rule + collect_views_rhs parameters handler error rule_id rule store_result.store_views_rhs in let error, store_views_lhs = - collect_views_lhs - parameters handler error - rule_id - rule + collect_views_lhs parameters handler error rule_id rule store_result.store_views_lhs in let error, store_test_sites = - collect_test_sites - parameters - error - rule_id - rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - store_result.store_test_sites + collect_test_sites parameters error rule_id + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views store_result.store_test_sites in - error, - { - store_views_rhs = store_views_rhs; - store_views_lhs = store_views_lhs; - store_test_sites = store_test_sites; - } + error, { store_views_rhs; store_views_lhs; store_test_sites } (***************************************************************************) (*Modification*) (***************************************************************************) -let collect_sites_from_agent_interface parameters error kappa_handler agent_id agent store_result = +let collect_sites_from_agent_interface parameters error kappa_handler agent_id + agent store_result = let agent_type = agent.Cckappa_sig.agent_name in Ckappa_sig.Site_map_and_set.Map.fold (fun site_type port (error, store_result) -> - let error, b = - Handler.is_counter parameters error kappa_handler agent_type site_type - in - if b then error, store_result - else - let state_max = port.Cckappa_sig.site_state.Cckappa_sig.max in - let state_min = port.Cckappa_sig.site_state.Cckappa_sig.min in - (*NOTE: state in modification is a singleton state*) - let error, state = - match - state_min, state_max - with - | Some a, Some b when a=b -> - error, a - | None, _ | _, None | Some _, Some _ -> - Exception.warn parameters error __POS__ Exit - Ckappa_sig.dummy_state_index - in - let error, store_result = - Ckappa_sig.AgentsSiteState_map_and_set.Set.add_when_not_in - parameters error - (agent_id, agent_type, site_type, state) - store_result - in - error, store_result - ) agent.Cckappa_sig.agent_interface (error, store_result) - -let collect_modified_map parameter error kappa_handler rule_id rule store_result = + let error, b = + Handler.is_counter parameters error kappa_handler agent_type site_type + in + if b then + error, store_result + else ( + let state_max = port.Cckappa_sig.site_state.Cckappa_sig.max in + let state_min = port.Cckappa_sig.site_state.Cckappa_sig.min in + (*NOTE: state in modification is a singleton state*) + let error, state = + match state_min, state_max with + | Some a, Some b when a = b -> error, a + | None, _ | _, None | Some _, Some _ -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_state_index + in + let error, store_result = + Ckappa_sig.AgentsSiteState_map_and_set.Set.add_when_not_in parameters + error + (agent_id, agent_type, site_type, state) + store_result + in + error, store_result + )) + agent.Cckappa_sig.agent_interface (error, store_result) + +let collect_modified_map parameter error kappa_handler rule_id rule store_result + = let error, store_result = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error (fun parameter error agent_id agent store_result -> - (*if there is no modified sites then do nothing*) - if Ckappa_sig.Site_map_and_set.Map.is_empty - agent.Cckappa_sig.agent_interface - then error, store_result - else - (*old set*) - let error, old_set = - Common_map.get_rule_id_map_and_set - parameter error - rule_id - Ckappa_sig.AgentsSiteState_map_and_set.Set.empty - store_result - in - let error, new_set = - collect_sites_from_agent_interface - parameter error kappa_handler - agent_id - agent - old_set - in - let error, store_result = - Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite - parameter - error - rule_id - new_set - store_result - in - error, store_result - ) rule.Cckappa_sig.diff_direct store_result + (*if there is no modified sites then do nothing*) + if + Ckappa_sig.Site_map_and_set.Map.is_empty + agent.Cckappa_sig.agent_interface + then + error, store_result + else ( + (*old set*) + let error, old_set = + Common_map.get_rule_id_map_and_set parameter error rule_id + Ckappa_sig.AgentsSiteState_map_and_set.Set.empty store_result + in + let error, new_set = + collect_sites_from_agent_interface parameter error kappa_handler + agent_id agent old_set + in + let error, store_result = + Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite parameter error + rule_id new_set store_result + in + error, store_result + )) + rule.Cckappa_sig.diff_direct store_result in error, store_result -let collect_modification_sites parameters error rule_id diff_direct - store_result = +let collect_modification_sites parameters error rule_id diff_direct store_result + = let error, store_result = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error agent_id agent_modif store_result -> - if Ckappa_sig.Site_map_and_set.Map.is_empty - agent_modif.Cckappa_sig.agent_interface - then error, store_result - else - let agent_type = agent_modif.Cckappa_sig.agent_name in - (*return*) - let error, store_result = - Common_map.collect_sites_map_in_agent_interface - parameters - error - agent_modif - rule_id - (agent_id, agent_type) - store_result - in - error, store_result - ) diff_direct store_result + if + Ckappa_sig.Site_map_and_set.Map.is_empty + agent_modif.Cckappa_sig.agent_interface + then + error, store_result + else ( + let agent_type = agent_modif.Cckappa_sig.agent_name in + (*return*) + let error, store_result = + Common_map.collect_sites_map_in_agent_interface parameters error + agent_modif rule_id (agent_id, agent_type) store_result + in + error, store_result + )) + diff_direct store_result in let store_result = Ckappa_sig.AgentsSite_map_and_set.Map.map (fun x -> x) store_result @@ -1119,110 +923,78 @@ module Proj_modif = let store_project_modified_map parameter error rule_id store_modified_map store_result = let error, modified_set = - Common_map.get_rule_id_map_and_set - parameter error rule_id - Ckappa_sig.AgentsSiteState_map_and_set.Set.empty - store_modified_map + Common_map.get_rule_id_map_and_set parameter error rule_id + Ckappa_sig.AgentsSiteState_map_and_set.Set.empty store_modified_map in (*project set*) let error, project_set = Proj_modif.proj_set - (fun (_, agent_type, site_type, _) -> - (agent_type, site_type) - ) - parameter - error - modified_set + (fun (_, agent_type, site_type, _) -> agent_type, site_type) + parameter error modified_set in let error, store_result = - Ckappa_sig.Rule_map_and_set.Map.add - parameter error - rule_id - project_set + Ckappa_sig.Rule_map_and_set.Map.add parameter error rule_id project_set store_result in error, store_result -let scan_rule_modification parameters error kappa_handler rule_id rule store_result = +let scan_rule_modification parameters error kappa_handler rule_id rule + store_result = let error, store_modified_map = - collect_modified_map - parameters error kappa_handler - rule_id - rule + collect_modified_map parameters error kappa_handler rule_id rule store_result.store_modified_map in let error, store_project_modified_map = - store_project_modified_map - parameters error - rule_id - store_modified_map + store_project_modified_map parameters error rule_id store_modified_map store_result.store_project_modified_map in let error, store_modification_sites = - collect_modification_sites - parameters error - rule_id - rule.Cckappa_sig.diff_direct - store_result.store_modification_sites + collect_modification_sites parameters error rule_id + rule.Cckappa_sig.diff_direct store_result.store_modification_sites in - error, - { - store_modified_map = store_modified_map; - store_project_modified_map = store_project_modified_map; - store_modification_sites = store_modification_sites - } + ( error, + { store_modified_map; store_project_modified_map; store_modification_sites } + ) (*********************************************************************) (*VIEWS and MODIFICATION*) (*********************************************************************) -let collect_test_modification_sites - parameters error store_modification_map store_test_map store_result = - Ckappa_sig.AgentsSite_map_and_set.Map.fold2 - parameters error +let collect_test_modification_sites parameters error store_modification_map + store_test_map store_result = + Ckappa_sig.AgentsSite_map_and_set.Map.fold2 parameters error (*exists in 'a t*) - (fun parameters error (agent_id, agent_type, site_type) s1 store_result -> - let error, store_result = - Common_map.add_dependency_triple_sites_rule - parameters - error - (agent_id, agent_type, site_type) - s1 - store_result - in - error, store_result - ) + (fun parameters error (agent_id, agent_type, site_type) s1 store_result -> + let error, store_result = + Common_map.add_dependency_triple_sites_rule parameters error + (agent_id, agent_type, site_type) + s1 store_result + in + error, store_result) (*exists in 'b t*) - (fun parameters error (agent_id, agent_type, site_type) s2 store_result -> - let error, store_result = - Common_map.add_dependency_triple_sites_rule parameters - error - (agent_id, agent_type, site_type) - s2 - store_result - in - error, store_result - ) + (fun parameters error (agent_id, agent_type, site_type) s2 store_result -> + let error, store_result = + Common_map.add_dependency_triple_sites_rule parameters error + (agent_id, agent_type, site_type) + s2 store_result + in + error, store_result) (*exists in both*) - (fun parameters error (agent_id, agent_type, site_type) s1 s2 store_result - -> - let error',union = - Ckappa_sig.Rule_map_and_set.Set.union parameters error s1 s2 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let error, store_result = - Common_map.add_dependency_triple_sites_rule parameters - error - (agent_id, agent_type, site_type) - union - store_result - in - error, store_result - ) store_modification_map store_test_map store_result - + (fun parameters error (agent_id, agent_type, site_type) s1 s2 store_result -> + let error', union = + Ckappa_sig.Rule_map_and_set.Set.union parameters error s1 s2 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error, store_result = + Common_map.add_dependency_triple_sites_rule parameters error + (agent_id, agent_type, site_type) + union store_result + in + error, store_result) + store_modification_map store_test_map store_result (***************************************************************************) (*RULE*) @@ -1232,79 +1004,59 @@ let scan_rule parameter error kappa_handler rule_id rule store_result = (*-----------------------------------------------------------------------*) (*get agent_name*) let error, store_agent_name = - collect_agent_name - parameter - error - rule_id - rule + collect_agent_name parameter error rule_id rule store_result.store_agent_name in let error, store_agent_name_from_pattern = - collect_agent_name_from_pattern - parameter - error - rule.Cckappa_sig.rule_lhs + collect_agent_name_from_pattern parameter error rule.Cckappa_sig.rule_lhs store_result.store_agent_name_from_pattern in (*------------------------------------------------------------------------*) let error, store_side_effects_views = - scan_rule_side_effects_views - parameter error kappa_handler rule_id rule + scan_rule_side_effects_views parameter error kappa_handler rule_id rule store_result.store_side_effects_views in (*------------------------------------------------------------------------*) let error, store_binding_views = - scan_rule_binding_views - parameter error - rule_id rule + scan_rule_binding_views parameter error rule_id rule store_result.store_binding_views in (*------------------------------------------------------------------------*) let error, store_modification = - scan_rule_modification - parameter error kappa_handler - rule_id - rule + scan_rule_modification parameter error kappa_handler rule_id rule store_result.store_modification in (*------------------------------------------------------------------------*) let error, store_test = - scan_rule_test parameter kappa_handler error - rule_id - rule + scan_rule_test parameter kappa_handler error rule_id rule store_result.store_test in (*------------------------------------------------------------------------*) let error, store_test_modification_sites = - collect_test_modification_sites - parameter - error - store_modification.store_modification_sites - store_test.store_test_sites + collect_test_modification_sites parameter error + store_modification.store_modification_sites store_test.store_test_sites store_result.store_test_modification_sites in -(*--------------------------------------------------------------*) -(*valuations and update of the views that are tested and modification - without agent_id*) + (*--------------------------------------------------------------*) + (*valuations and update of the views that are tested and modification + without agent_id*) let error, store_test_modif_map = - Common_map.collect_projection_agent_id_from_triple - parameter - error + Common_map.collect_projection_agent_id_from_triple parameter error store_test_modification_sites in (*--------------------------------------------------------------*) - error, - { - store_result with - store_agent_name = store_agent_name; - store_agent_name_from_pattern = store_agent_name_from_pattern; - store_side_effects_views = store_side_effects_views; - store_binding_views = store_binding_views; - store_modification = store_modification; - store_test = store_test; - store_test_modification_sites = store_test_modification_sites; - store_test_modif_map = store_test_modif_map; - } + ( error, + { + store_result with + store_agent_name; + store_agent_name_from_pattern; + store_side_effects_views; + store_binding_views; + store_modification; + store_test; + store_test_modification_sites; + store_test_modif_map; + } ) (******************************************************************************) @@ -1316,73 +1068,61 @@ module Proj_agent_rule_to_rule = let scan_rule_set parameter error kappa_handler compil = let error, init_common_views = init_common_views parameter error in let error, store_result = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameter error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameter error (fun parameter error rule_id rule store_result -> - scan_rule - parameter - error - kappa_handler - rule_id - rule.Cckappa_sig.e_rule_c_rule - store_result - ) compil.Cckappa_sig.rules init_common_views + scan_rule parameter error kappa_handler rule_id + rule.Cckappa_sig.e_rule_c_rule store_result) + compil.Cckappa_sig.rules init_common_views in let error, potential_side_effects_per_rule = Proj_agent_rule_to_rule.monadic_proj_map_i - (fun _parameter error (_,rule_id) -> error, rule_id) + (fun _parameter error (_, rule_id) -> error, rule_id) parameter error [] - (fun _parameters error old (agent_name,_) l -> - let new_list = - List.fold_left - (fun old (source, (x,y)) -> (source, (agent_name,x,y))::old) - old l - in - error,new_list) - (store_result.store_side_effects_views.store_potential_side_effects) + (fun _parameters error old (agent_name, _) l -> + let new_list = + List.fold_left + (fun old (source, (x, y)) -> (source, (agent_name, x, y)) :: old) + old l + in + error, new_list) + store_result.store_side_effects_views.store_potential_side_effects in - error, - {store_result - with - store_potential_side_effects_per_rule = - potential_side_effects_per_rule - } + ( error, + { + store_result with + store_potential_side_effects_per_rule = potential_side_effects_per_rule; + } ) (******************************************************************) (******************************************************************) type site_to_rules_tmp = Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t type site_to_rules = Ckappa_sig.c_rule_id list - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t let add_dependency_site_rule parameter error agent site rule_id site_to_rules = let error, oldset = match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameter error - (agent, site) - site_to_rules + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameter error (agent, site) site_to_rules with | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty | error, Some old -> error, old in let error, newset = - Ckappa_sig.Rule_map_and_set.Set.add_when_not_in - parameter error rule_id oldset + Ckappa_sig.Rule_map_and_set.Set.add_when_not_in parameter error rule_id + oldset in Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameter error - (agent, site) - newset - site_to_rules + parameter error (agent, site) newset site_to_rules let empty_site_to_rules parameter error = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create - parameter error (0,0) + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameter error (0, 0) let consolidate_site_rule_dependencies parameter error site_to_rules = let error, output = empty_site_to_rules parameter error in @@ -1390,28 +1130,22 @@ let consolidate_site_rule_dependencies parameter error site_to_rules = parameter error (fun parameter error key set output -> let list = Ckappa_sig.Rule_map_and_set.Set.elements set in - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameter error key list output - ) - site_to_rules - output + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameter error key list output) + site_to_rules output let wake_up parameter error agent site site_to_rules = match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameter error - (agent,site) - site_to_rules + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameter error (agent, site) site_to_rules with | error, None -> error, [] | error, Some l -> error, l let get_tuple_of_interest parameters error agent site map = match - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent, site) - map + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameters + error (agent, site) map with | error, None -> error, Ckappa_sig.PairAgentSitesState_map_and_set.Set.empty | error, Some s -> error, s diff --git a/core/KaSa_rep/reachability_analysis/communication.ml b/core/KaSa_rep/reachability_analysis/communication.ml index e86049f429..8b271c6a6b 100644 --- a/core/KaSa_rep/reachability_analysis/communication.ml +++ b/core/KaSa_rep/reachability_analysis/communication.ml @@ -21,9 +21,10 @@ type path_defined_in = type event = | Dummy (* to avoid compilation warning *) | Check_rule of Ckappa_sig.c_rule_id - | See_a_new_bond of (*in contact map*) - ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) + | See_a_new_bond of + (*in contact map*) + ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) (*in the domain of parallel and site accross*) | Modified_sites of (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) @@ -50,108 +51,106 @@ type event = Exit current agent R2 by site y, then enter an agent of type R3 via a site y. *) -type step = - { - site_out: Ckappa_sig.c_site_name; - site_in: Ckappa_sig.c_site_name; - agent_type_in: Ckappa_sig.c_agent_name - } +type step = { + site_out: Ckappa_sig.c_site_name; + site_in: Ckappa_sig.c_site_name; + agent_type_in: Ckappa_sig.c_agent_name; +} -type path = - { - agent_id: Ckappa_sig.c_agent_id; - relative_address: step list; - site: Ckappa_sig.c_site_name; - } +type path = { + agent_id: Ckappa_sig.c_agent_id; + relative_address: step list; + site: Ckappa_sig.c_site_name; +} -type path_in_pattern = - { - defined_in: path_defined_in; - path:path; - } +type path_in_pattern = { defined_in: path_defined_in; path: path } let get_defined_in p = p.defined_in let get_agent_id p = p.path.agent_id let get_site p = p.path.site let get_relative_address p = p.path.relative_address - -module type PathMap = -sig +module type PathMap = sig type 'a t - val empty: 'a -> 'a t - val add: path -> 'a -> 'a t -> 'a t - val find: path -> 'a t -> 'a option + + val empty : 'a -> 'a t + val add : path -> 'a -> 'a t -> 'a t + val find : path -> 'a t -> 'a option end -module PathSetMap = - SetMap.Make (struct type t = path let compare = compare let print _ _ = () end) +module PathSetMap = SetMap.Make (struct + type t = path + + let compare = compare + let print _ _ = () +end) -module PathMap = - (struct - include PathSetMap.Map +module PathMap : PathMap = struct + include PathSetMap.Map - let empty _ = empty - let find = find_option - end:PathMap) + let empty _ = empty + let find = find_option +end type 'a fold = Remanent_parameters_sig.parameters -> Exception.method_handler -> Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> - Exception.method_handler * - ((Remanent_parameters_sig.parameters -> - Ckappa_sig.c_state -> - Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -> - Exception.method_handler * 'a -> - Exception.method_handler * 'a) -> - Exception.method_handler -> 'a -> - Exception.method_handler * 'a) Usual_domains.flat_lattice - -type prefold = - { - fold: 'a. 'a fold - } + Exception.method_handler + * ((Remanent_parameters_sig.parameters -> + Ckappa_sig.c_state -> + Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -> + Exception.method_handler * 'a -> + Exception.method_handler * 'a) -> + Exception.method_handler -> + 'a -> + Exception.method_handler * 'a) + Usual_domains.flat_lattice + +type prefold = { fold: 'a. 'a fold } (*precondition is used to get the information between domains*) -type precondition = - { - precondition_dummy: unit (* to avoid compilation warning *); - the_rule_is_applied_for_the_first_time: Usual_domains.maybe_bool ; - state_of_sites_in_precondition: - Remanent_parameters_sig.parameters -> - Exception.method_handler -> - Analyzer_headers.global_dynamic_information -> - path -> - Exception.method_handler * - Analyzer_headers.global_dynamic_information * - Ckappa_sig.c_state list Usual_domains.flat_lattice; - cache_state_of_sites: Ckappa_sig.c_state list Usual_domains.flat_lattice PathMap.t ; - partner_map: - Exception.method_handler -> Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> - Ckappa_sig.c_state -> - Exception.method_handler * (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * - Ckappa_sig.c_state) Usual_domains.flat_lattice; - partner_fold: 'a. 'a fold } +type precondition = { + precondition_dummy: unit; (* to avoid compilation warning *) + the_rule_is_applied_for_the_first_time: Usual_domains.maybe_bool; + state_of_sites_in_precondition: + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Analyzer_headers.global_dynamic_information -> + path -> + Exception.method_handler + * Analyzer_headers.global_dynamic_information + * Ckappa_sig.c_state list Usual_domains.flat_lattice; + cache_state_of_sites: + Ckappa_sig.c_state list Usual_domains.flat_lattice PathMap.t; + partner_map: + Exception.method_handler -> + Ckappa_sig.c_agent_name -> + Ckappa_sig.c_site_name -> + Ckappa_sig.c_state -> + Exception.method_handler + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + Usual_domains.flat_lattice; + partner_fold: 'a. 'a fold; +} let is_the_rule_applied_for_the_first_time precondition = precondition.the_rule_is_applied_for_the_first_time -let the_rule_is_or_not_applied_for_the_first_time bool parameter error precondition = +let the_rule_is_or_not_applied_for_the_first_time bool parameter error + precondition = match precondition.the_rule_is_applied_for_the_first_time with - | Usual_domains.Maybe -> error, - { - precondition with - the_rule_is_applied_for_the_first_time = Usual_domains.Sure_value bool - } + | Usual_domains.Maybe -> + ( error, + { + precondition with + the_rule_is_applied_for_the_first_time = Usual_domains.Sure_value bool; + } ) | Usual_domains.Sure_value b when b = bool -> error, precondition | Usual_domains.Sure_value _ -> - Exception.warn - parameter error __POS__ - ~message:"inconsistent computation in three-value logic" - Exit precondition + Exception.warn parameter error __POS__ + ~message:"inconsistent computation in three-value logic" Exit precondition let the_rule_is_applied_for_the_first_time p e wp = the_rule_is_or_not_applied_for_the_first_time true p e wp @@ -167,24 +166,23 @@ let dummy_precondition = (fun _ error dynamic _ -> error, dynamic, Usual_domains.Any); cache_state_of_sites = PathMap.empty Usual_domains.Any; partner_map = (fun error _ _ _ -> error, Usual_domains.Any); - partner_fold = (fun _ error _ _ -> error,Usual_domains.Any); + partner_fold = (fun _ error _ _ -> error, Usual_domains.Any); } let get_potential_partner precondition error agent_type site state = let error, rep = precondition.partner_map error agent_type site state in error, precondition, rep -let fold_over_potential_partners parameters error precondition agent_type site f init = - match - precondition.partner_fold parameters error agent_type site - with +let fold_over_potential_partners parameters error precondition agent_type site f + init = + match precondition.partner_fold parameters error agent_type site with | error, Usual_domains.Any -> error, precondition, Usual_domains.Top | error, Usual_domains.Undefined -> (* In theory, this could happen, but it would be worth being warned about it *) let error, () = - Exception.warn - parameters error __POS__ ~message:"bottom propagation" Exit () + Exception.warn parameters error __POS__ ~message:"bottom propagation" Exit + () in error, precondition, Usual_domains.Not_top init | error, Usual_domains.Val v -> @@ -192,19 +190,16 @@ let fold_over_potential_partners parameters error precondition agent_type site f error, precondition, Usual_domains.Not_top output let overwrite_potential_partners_map - (_parameters:Remanent_parameters_sig.parameters) - (error:Exception.method_handler) - precondition - f - (fold: prefold) = - error, - { - precondition with - partner_map = f; - partner_fold = - (fun parameters error agent_type site_type -> - fold.fold parameters error agent_type site_type) - } + (_parameters : Remanent_parameters_sig.parameters) + (error : Exception.method_handler) precondition f (fold : prefold) = + ( error, + { + precondition with + partner_map = f; + partner_fold = + (fun parameters error agent_type site_type -> + fold.fold parameters error agent_type site_type); + } ) type output = | Cannot_exist @@ -212,215 +207,167 @@ type output = | Located of Ckappa_sig.c_agent_id let last_agent_type parameters error rule path = - match - List.rev path.relative_address - with + match List.rev path.relative_address with | [] -> - begin - let agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - path.agent_id (*A*) - rule.Cckappa_sig.rule_rhs.Cckappa_sig.views - in - match agent - with - | error, None -> - Exception.warn - parameters error __POS__ Exit Ckappa_sig.dummy_agent_name - | error, Some agent -> - begin - match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _ -> - Exception.warn - parameters error __POS__ Exit - Ckappa_sig.dummy_agent_name - | Cckappa_sig.Agent proper_agent -> - error, - proper_agent.Cckappa_sig.agent_name - end - end - | head::_ -> - error, head.agent_type_in + let agent = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error path.agent_id (*A*) + rule.Cckappa_sig.rule_rhs.Cckappa_sig.views + in + (match agent with + | error, None -> + Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_agent_name + | error, Some agent -> + (match agent with + | Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ -> + Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_agent_name + | Cckappa_sig.Agent proper_agent -> + error, proper_agent.Cckappa_sig.agent_name)) + | head :: _ -> error, head.agent_type_in let may_be_modified parameters error rule path = let error, agent_name = last_agent_type parameters error rule path in let site_name = path.site in let modif = rule.Cckappa_sig.diff_direct in - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _ agent list -> - if agent.Cckappa_sig.agent_name = agent_name - then - match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters error site_name agent.Cckappa_sig.agent_interface - with - | error, None -> error, list - | error, Some interval -> - let range = interval.Cckappa_sig.site_state in - if range.Cckappa_sig.min = range.Cckappa_sig.max - then - match range.Cckappa_sig.min with - | None -> - Exception.warn - parameters error __POS__ - Exit list - | Some a -> - error,a::list - else - Exception.warn - parameters error __POS__ - Exit list - else - error, list - ) modif [] + if agent.Cckappa_sig.agent_name = agent_name then ( + match + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters + error site_name agent.Cckappa_sig.agent_interface + with + | error, None -> error, list + | error, Some interval -> + let range = interval.Cckappa_sig.site_state in + if range.Cckappa_sig.min = range.Cckappa_sig.max then ( + match range.Cckappa_sig.min with + | None -> Exception.warn parameters error __POS__ Exit list + | Some a -> error, a :: list + ) else + Exception.warn parameters error __POS__ Exit list + ) else + error, list) + modif [] let may_get_free_by_side_effect parameters error static _precondition rule_id rule path = let error, agent_name = last_agent_type parameters error rule path in let error, list = - Ckappa_sig.AgentRule_map_and_set.Map.find_default_without_logs - parameters - error - [] - (agent_name,rule_id) + Ckappa_sig.AgentRule_map_and_set.Map.find_default_without_logs parameters + error [] (agent_name, rule_id) (Analyzer_headers.get_potential_side_effects static) in - let site_name = path.site in (* TO DO BETTER *) - error, List.exists (fun (_,(a,_)) -> a=site_name) list + let site_name = path.site in + (* TO DO BETTER *) + error, List.exists (fun (_, (a, _)) -> a = site_name) list let min_not_free interv = - match interv.Cckappa_sig.min - with + match interv.Cckappa_sig.min with | None -> Ckappa_sig.dummy_state_index_1 | Some min -> - if min = Ckappa_sig.dummy_state_index - then Ckappa_sig.dummy_state_index_1 + if min = Ckappa_sig.dummy_state_index then + Ckappa_sig.dummy_state_index_1 else min -let check_state_compatibility parameters error kappa_handler - cc - agent_id_source site_source agent_target site_target = +let check_state_compatibility parameters error kappa_handler cc agent_id_source + site_source agent_target site_target = match Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters error agent_id_source (*A*) cc.Cckappa_sig.views with | error, Some Cckappa_sig.Ghost -> error, true | error, None - | error, - Some - (Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _) - -> - Exception.warn - parameters error __POS__ ~message:"null pointer" Exit false - | error, Some Cckappa_sig.Agent ag -> + | error, Some (Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _) -> + Exception.warn parameters error __POS__ ~message:"null pointer" Exit false + | error, Some (Cckappa_sig.Agent ag) -> let agent_source = ag.Cckappa_sig.agent_name in let error, interval = - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters error site_source - ag.Cckappa_sig.agent_interface + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters error + site_source ag.Cckappa_sig.agent_interface in - begin - match interval - with - | None -> error, true - | Some i when i.Cckappa_sig.site_state.Cckappa_sig.min = None || - i.Cckappa_sig.site_state.Cckappa_sig.max = None - -> Exception.warn parameters error __POS__ Exit true - | Some i -> - let interv = i.Cckappa_sig.site_state in - match interv.Cckappa_sig.min, interv.Cckappa_sig.max with - | None, _ | _, None -> - Exception.warn parameters error __POS__ Exit true - | Some _, Some max -> + (match interval with + | None -> error, true + | Some i + when i.Cckappa_sig.site_state.Cckappa_sig.min = None + || i.Cckappa_sig.site_state.Cckappa_sig.max = None -> + Exception.warn parameters error __POS__ Exit true + | Some i -> + let interv = i.Cckappa_sig.site_state in + (match interv.Cckappa_sig.min, interv.Cckappa_sig.max with + | None, _ | _, None -> Exception.warn parameters error __POS__ Exit true + | Some _, Some max -> let rec aux error k = - if Ckappa_sig.compare_state_index k max > 0 - then + if Ckappa_sig.compare_state_index k max > 0 then error, false - else + else ( let error, opt = - Handler.dual parameters error kappa_handler - agent_source site_source k + Handler.dual parameters error kappa_handler agent_source + site_source k in - match opt - with - | Some (agent_target', site_target',_) when - agent_target' = agent_target - && site_target' = site_target - -> error, true - | Some _ -> - aux error (Ckappa_sig.next_state_index k) + match opt with + | Some (agent_target', site_target', _) + when agent_target' = agent_target && site_target' = site_target -> + error, true + | Some _ -> aux error (Ckappa_sig.next_state_index k) | None -> - let error, () = - Exception.warn - parameters error __POS__ - Exit () - in + let error, () = Exception.warn parameters error __POS__ Exit () in aux error (Ckappa_sig.next_state_index k) - in aux error - (min_not_free interv) - end + ) + in + aux error (min_not_free interv))) -let rec follow_path_inside_cc - parameters error kappa_handler cc path - = - match - path.relative_address - with +let rec follow_path_inside_cc parameters error kappa_handler cc path = + match path.relative_address with | [] -> error, Located path.agent_id - | head::tail -> - begin - match - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error path.agent_id (*A*) cc.Cckappa_sig.bonds - with + | head :: tail -> + (match + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error path.agent_id (*A*) cc.Cckappa_sig.bonds + with + | error, None -> + let error, bool = + check_state_compatibility parameters error kappa_handler cc + path.agent_id head.site_out head.agent_type_in head.site_in + in + if bool then + error, May_exist path + else + error, Cannot_exist + | error, Some map -> + (match + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters + error head.site_out (*A.x*) map + with | error, None -> let error, bool = - check_state_compatibility parameters error kappa_handler - cc path.agent_id head.site_out head.agent_type_in head.site_in in - if bool - then error, May_exist path - else error, Cannot_exist - | error, Some map -> - begin - match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters error head.site_out (*A.x*) map - with - | error, None -> - let error, bool = - check_state_compatibility - parameters error kappa_handler - cc path.agent_id head.site_out head.agent_type_in head.site_in - in - if bool - then error, May_exist path - else error, Cannot_exist - | error, Some site_add -> - (*-----------------------------------------------*) - (*A.x is bound to something*) - let agent_type' = site_add.Cckappa_sig.agent_type in - let site_type' = site_add.Cckappa_sig.site in - (*check that A.x is bound to B.y*) - if agent_type' = head.agent_type_in - && site_type' = head.site_in - then - (*recursively apply to #i tail*) - follow_path_inside_cc - parameters error kappa_handler cc - {path with agent_id = site_add.Cckappa_sig.agent_index; - relative_address = tail} - else - error, Cannot_exist - end - end + check_state_compatibility parameters error kappa_handler cc + path.agent_id head.site_out head.agent_type_in head.site_in + in + if bool then + error, May_exist path + else + error, Cannot_exist + | error, Some site_add -> + (*-----------------------------------------------*) + (*A.x is bound to something*) + let agent_type' = site_add.Cckappa_sig.agent_type in + let site_type' = site_add.Cckappa_sig.site in + (*check that A.x is bound to B.y*) + if agent_type' = head.agent_type_in && site_type' = head.site_in then + (*recursively apply to #i tail*) + follow_path_inside_cc parameters error kappa_handler cc + { + path with + agent_id = site_add.Cckappa_sig.agent_index; + relative_address = tail; + } + else + error, Cannot_exist)) -let rec post_condition error rule_id r precondition static dynamic path = +let rec post_condition error rule_id r precondition static dynamic path = let parameters = Analyzer_headers.get_parameter static in let kappa_handler = Analyzer_headers.get_kappa_handler static in let rule = r.Cckappa_sig.e_rule_c_rule in @@ -428,237 +375,190 @@ let rec post_condition error rule_id r precondition static dynamic path = (*---------------------------------------------------------*) (*inside the pattern, check the binding information in the lhs of the current agent*) let error, (potential_values, continuation_opt) = - match follow_path_inside_cc parameters error kappa_handler cc path - with - | error, Cannot_exist -> - error, (Usual_domains.Undefined,None) + match follow_path_inside_cc parameters error kappa_handler cc path with + | error, Cannot_exist -> error, (Usual_domains.Undefined, None) | error, May_exist continuation -> error, (Usual_domains.Any, Some continuation) | error, Located agent_id -> - begin - let agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_id (*A*) - cc.Cckappa_sig.views - in - match agent - with - | error, None -> - Exception.warn - parameters error __POS__ Exit (Usual_domains.Undefined,None) - | error, Some agent -> - begin - match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _ -> - Exception.warn - parameters error __POS__ Exit - ~message:((string_of_int (Ckappa_sig.int_of_agent_id agent_id))) (Usual_domains.Undefined,None) - - | Cckappa_sig.Agent proper_agent -> - let error, state_opt = - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters - error - path.site - proper_agent.Cckappa_sig.agent_interface + let agent = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error agent_id (*A*) + cc.Cckappa_sig.views + in + (match agent with + | error, None -> + Exception.warn parameters error __POS__ Exit + (Usual_domains.Undefined, None) + | error, Some agent -> + (match agent with + | Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ -> + Exception.warn parameters error __POS__ Exit + ~message:(string_of_int (Ckappa_sig.int_of_agent_id agent_id)) + (Usual_domains.Undefined, None) + | Cckappa_sig.Agent proper_agent -> + let error, state_opt = + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters + error path.site proper_agent.Cckappa_sig.agent_interface + in + (match state_opt with + | None -> + if + List.exists + (fun (a, _) -> a = agent_id) + rule.Cckappa_sig.actions.Cckappa_sig.creation + then + (* the agent has been created and the site not specified *) + (* we know that its state is 0 *) + error, (Usual_domains.Val [ Ckappa_sig.dummy_state_index ], None) + else + ( error, + ( Usual_domains.Any, + Some { path with agent_id; relative_address = [] } ) ) + | Some interval -> + let interval = interval.Cckappa_sig.site_state in + let error, min = + match interval.Cckappa_sig.min with + | Some a -> error, a + | None -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_state_index + in + let error, max = + match interval.Cckappa_sig.max with + | Some a -> error, a + | None -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_state_index + in + let list = + let rec aux k output = + if Ckappa_sig.compare_state_index k min < 0 then + output + else + aux (Ckappa_sig.pred_state_index k) (k :: output) in - begin - match state_opt with - | None -> - if List.exists (fun (a,_) -> a=agent_id) - rule.Cckappa_sig.actions.Cckappa_sig.creation - then - (* the agent has been created and the site not specified *) - (* we know that its state is 0 *) - error, - (Usual_domains.Val [Ckappa_sig.dummy_state_index], None) - else - error, - (Usual_domains.Any, - Some - {path with agent_id = agent_id ; - relative_address = []}) - - | Some interval -> - let interval = interval.Cckappa_sig.site_state in - let error, min = - match interval.Cckappa_sig.min with - | Some a -> error, a - | None -> - Exception.warn parameters error __POS__ Exit - Ckappa_sig.dummy_state_index - in - let error, max = - match interval.Cckappa_sig.max with - | Some a -> error, a - | None -> - Exception.warn parameters error __POS__ Exit - Ckappa_sig.dummy_state_index - in - let list = - let rec aux k output = - if Ckappa_sig.compare_state_index k min < 0 - then output - else aux (Ckappa_sig.pred_state_index k) (k::output) - in - aux max [] - in - error, (Usual_domains.Val list, None) - end - end - end + aux max [] + in + error, (Usual_domains.Val list, None)))) in match potential_values with - | Usual_domains.Undefined | Usual_domains.Val _ - -> error, dynamic, potential_values + | Usual_domains.Undefined | Usual_domains.Val _ -> + error, dynamic, potential_values | Usual_domains.Any -> - begin - let error, path = - match continuation_opt with - | None -> - Exception.warn - parameters error __POS__ - Exit path - | Some path -> error, path - in - if List.exists (fun (a,_) -> a=path.agent_id) - rule.Cckappa_sig.actions.Cckappa_sig.creation - then - (* try to exit from a site that is unspecified in a created agent *) - (* this site is free, thus the path is not realisable *) - error, dynamic, Usual_domains.Undefined - else - let path = - { - defined_in = LHS (rule_id,r) ; - path = path - } - in - let error, dynamic, precondition, values = - get_state_of_site - error precondition static dynamic path - in - let error, bool = - may_get_free_by_side_effect parameters error static precondition rule_id rule path.path in - let error, list = - may_be_modified parameters error - rule path.path in - - match values with - | Usual_domains.Val l -> - if bool || list<>[] - then - let l_side = - if bool - then (Ckappa_sig.state_index_of_int 0)::l - else - l - in - let l_all = - List_util.remove_consecutive_double - (List.sort Ckappa_sig.compare_state_index - (List.rev_append list l_side)) - in - error, dynamic, Usual_domains.Val (l_all) - else error, dynamic, values - | Usual_domains.Undefined | Usual_domains.Any -> - error, dynamic, values - end -and get_state_of_site - error precondition static dynamic path = - begin - let parameters = Analyzer_headers.get_parameter static in - match path.defined_in with - | LHS _ | Pattern -> - let error, dynamic, range = - precondition.state_of_sites_in_precondition - parameters error dynamic path.path + let error, path = + match continuation_opt with + | None -> Exception.warn parameters error __POS__ Exit path + | Some path -> error, path + in + if + List.exists + (fun (a, _) -> a = path.agent_id) + rule.Cckappa_sig.actions.Cckappa_sig.creation + then + (* try to exit from a site that is unspecified in a created agent *) + (* this site is free, thus the path is not realisable *) + error, dynamic, Usual_domains.Undefined + else ( + let path = { defined_in = LHS (rule_id, r); path } in + let error, dynamic, precondition, values = + get_state_of_site error precondition static dynamic path in - error, dynamic, precondition, range - | RHS (rule_id, rule) -> - let error, dynamic, range = - post_condition - error rule_id rule precondition static dynamic path.path + let error, bool = + may_get_free_by_side_effect parameters error static precondition rule_id + rule path.path in - error, dynamic, precondition, range - end + let error, list = may_be_modified parameters error rule path.path in + + match values with + | Usual_domains.Val l -> + if bool || list <> [] then ( + let l_side = + if bool then + Ckappa_sig.state_index_of_int 0 :: l + else + l + in + let l_all = + List_util.remove_consecutive_double + (List.sort Ckappa_sig.compare_state_index + (List.rev_append list l_side)) + in + error, dynamic, Usual_domains.Val l_all + ) else + error, dynamic, values + | Usual_domains.Undefined | Usual_domains.Any -> error, dynamic, values + ) + +and get_state_of_site error precondition static dynamic path = + let parameters = Analyzer_headers.get_parameter static in + match path.defined_in with + | LHS _ | Pattern -> + let error, dynamic, range = + precondition.state_of_sites_in_precondition parameters error dynamic + path.path + in + error, dynamic, precondition, range + | RHS (rule_id, rule) -> + let error, dynamic, range = + post_condition error rule_id rule precondition static dynamic path.path + in + error, dynamic, precondition, range -let refine_information_about_state_of_sites_in_precondition - precondition f = +let refine_information_about_state_of_sites_in_precondition precondition f = let new_f parameter error dynamic path = let error, dynamic, old_output = - precondition.state_of_sites_in_precondition - parameter error dynamic path in + precondition.state_of_sites_in_precondition parameter error dynamic path + in f parameter error dynamic path old_output in { precondition with cache_state_of_sites = PathMap.empty Usual_domains.Any; - state_of_sites_in_precondition = new_f + state_of_sites_in_precondition = new_f; } -let get_state_of_site_in_pre_post_condition - get_global_static_information - get_global_dynamic_information set_global_dynamic_information - error static dynamic - agent_id site_type defined_in precondition = +let get_state_of_site_in_pre_post_condition get_global_static_information + get_global_dynamic_information set_global_dynamic_information error static + dynamic agent_id site_type defined_in precondition = let static = get_global_static_information static in let parameter = Analyzer_headers.get_parameter static in - let path_in_pattern = - { - agent_id = agent_id; - relative_address = []; - site = site_type; - } - in - let path = - { - defined_in = defined_in ; - path = path_in_pattern - } - in + let path_in_pattern = { agent_id; relative_address = []; site = site_type } in + let path = { defined_in; path = path_in_pattern } in (*get a list of site_type2 state in the precondition*) let error, global_dynamic, precondition, state_list_lattice = - get_state_of_site - error - precondition - static + get_state_of_site error precondition static (get_global_dynamic_information dynamic) path in let error, state_list = match state_list_lattice with | Usual_domains.Val l -> error, l - | Usual_domains.Undefined -> - Exception.warn parameter error __POS__ Exit [] + | Usual_domains.Undefined -> Exception.warn parameter error __POS__ Exit [] | Usual_domains.Any -> let error, () = - if Remanent_parameters.get_view_analysis parameter - then + if Remanent_parameters.get_view_analysis parameter then Exception.warn parameter error __POS__ Exit () else error, () in let error, l = match defined_in with - | RHS (_,r) | LHS (_,r) -> + | RHS (_, r) | LHS (_, r) -> let rule = r.Cckappa_sig.e_rule_c_rule in let error, agent_type = last_agent_type parameter error rule path_in_pattern in let error, l = - Handler.state_list parameter - (Analyzer_headers.get_kappa_handler static) - error agent_type site_type in - if l = [] - then Exception.warn parameter error __POS__ Exit [] - else error, l - | Pattern -> - Exception.warn parameter error __POS__ Exit [] + Handler.state_list parameter + (Analyzer_headers.get_kappa_handler static) + error agent_type site_type + in + if l = [] then + Exception.warn parameter error __POS__ Exit [] + else + error, l + | Pattern -> Exception.warn parameter error __POS__ Exit [] in error, l in @@ -667,39 +567,33 @@ let get_state_of_site_in_pre_post_condition (*use this function before apply a rule, like in is_enabled*) -let get_state_of_site_in_precondition - get_global_dynamic_information set_global_dynamic_information - parameter error kappa_handler dynamic rule agent_id site_type precondition = +let get_state_of_site_in_precondition get_global_dynamic_information + set_global_dynamic_information parameter error kappa_handler dynamic rule + agent_id site_type precondition = let defined_in = LHS rule in - get_state_of_site_in_pre_post_condition - get_global_dynamic_information set_global_dynamic_information - parameter error kappa_handler dynamic agent_id - site_type defined_in precondition - -let get_state_of_site_in_postcondition - get_global_dynamic_information set_global_dynamic_information - parameter error kappa_handler dynamic rule agent_id site_type precondition = - let defined_in = RHS rule in - get_state_of_site_in_pre_post_condition - get_global_dynamic_information set_global_dynamic_information - parameter error kappa_handler dynamic agent_id - site_type defined_in precondition + get_state_of_site_in_pre_post_condition get_global_dynamic_information + set_global_dynamic_information parameter error kappa_handler dynamic + agent_id site_type defined_in precondition +let get_state_of_site_in_postcondition get_global_dynamic_information + set_global_dynamic_information parameter error kappa_handler dynamic rule + agent_id site_type precondition = + let defined_in = RHS rule in + get_state_of_site_in_pre_post_condition get_global_dynamic_information + set_global_dynamic_information parameter error kappa_handler dynamic + agent_id site_type defined_in precondition -let add_rule ?local_trace:(local_trace=false) - parameters compiled _kappa_handler error rule_id event_list = +let add_rule ?(local_trace = false) parameters compiled _kappa_handler error + rule_id event_list = let error = - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_wl - parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_wl parameters + then ( let error, rule_id_string = - try - Handler.string_of_rule parameters error compiled rule_id - with - | _ -> - Exception.warn - parameters error __POS__ Exit + try Handler.string_of_rule parameters error compiled rule_id + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_rule_id rule_id) in let tab = "\t\t\t" in @@ -707,36 +601,47 @@ let add_rule ?local_trace:(local_trace=false) Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s(%s) should be investigated " - (Remanent_parameters.get_prefix parameters) tab - rule_id_string + (Remanent_parameters.get_prefix parameters) + tab rule_id_string in let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) in error - else + ) else error in - error, (Check_rule rule_id) :: event_list + error, Check_rule rule_id :: event_list type site_working_list = unit - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .t let init_sites_working_list parameters error = - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create parameters error (0,0) + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameters error (0, 0) let clear_sites_working_list parameters error sites_wl = - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.free_all parameters error sites_wl + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .free_all parameters error sites_wl let add_site parameters error agent site sites_wl = match - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get parameters error (agent,site) sites_wl + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameters error (agent, site) sites_wl with | error, None -> - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set parameters error (agent,site) () sites_wl + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error (agent, site) () sites_wl | error, Some _ -> error, sites_wl -let fold_sites p e f (acc:site_working_list) = - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.fold p e f acc +let fold_sites p e f (acc : site_working_list) = + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .fold p e f acc diff --git a/core/KaSa_rep/reachability_analysis/communication.mli b/core/KaSa_rep/reachability_analysis/communication.mli index 4ecf88d592..2a3f0f0fec 100644 --- a/core/KaSa_rep/reachability_analysis/communication.mli +++ b/core/KaSa_rep/reachability_analysis/communication.mli @@ -22,59 +22,53 @@ type event = | Dummy (* to avoid compilation warning *) | Check_rule of Ckappa_sig.c_rule_id | See_a_new_bond of - ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) -(* JF: No, you shall not communicate tuples of sites here, *) -(* Only site per site *) -(* It is up to each abstract domain, when a tuple is modified, to decompose it - into a list of sites *) -(* and then to send the message Modified_site s for each site in that list *) -(* This is important since we cannot assume that each tuple of sites of - interest will have the same number of sites in each domain *) -(* Already the number of sites in constraints expressed in the View domain is - not the same from that the number of sites in constraints expressed in the - other domains *) + ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state)) + (* JF: No, you shall not communicate tuples of sites here, *) + (* Only site per site *) + (* It is up to each abstract domain, when a tuple is modified, to decompose it + into a list of sites *) + (* and then to send the message Modified_site s for each site in that list *) + (* This is important since we cannot assume that each tuple of sites of + interest will have the same number of sites in each domain *) + (* Already the number of sites in constraints expressed in the View domain is + not the same from that the number of sites in constraints expressed in the + other domains *) | Modified_sites of (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) -type step = - { - site_out: Ckappa_sig.c_site_name; - site_in: Ckappa_sig.c_site_name; - agent_type_in: Ckappa_sig.c_agent_name - } - -type path = - { - agent_id: Ckappa_sig.c_agent_id; - relative_address: step list; - site: Ckappa_sig.c_site_name; - } - -type path_in_pattern = - { - defined_in: path_defined_in ; - path:path ; - } +type step = { + site_out: Ckappa_sig.c_site_name; + site_in: Ckappa_sig.c_site_name; + agent_type_in: Ckappa_sig.c_agent_name; +} + +type path = { + agent_id: Ckappa_sig.c_agent_id; + relative_address: step list; + site: Ckappa_sig.c_site_name; +} + +type path_in_pattern = { defined_in: path_defined_in; path: path } type output = | Cannot_exist | May_exist of path | Located of Ckappa_sig.c_agent_id -val get_defined_in: path_in_pattern -> path_defined_in -val get_agent_id: path_in_pattern -> Ckappa_sig.c_agent_id -val get_site: path_in_pattern -> Ckappa_sig.c_site_name -val get_relative_address: path_in_pattern -> step list +val get_defined_in : path_in_pattern -> path_defined_in +val get_agent_id : path_in_pattern -> Ckappa_sig.c_agent_id +val get_site : path_in_pattern -> Ckappa_sig.c_site_name +val get_relative_address : path_in_pattern -> step list -module type PathMap = -sig +module type PathMap = sig type 'a t - val empty: 'a -> 'a t - val add: path -> 'a -> 'a t -> 'a t - val find: path -> 'a t -> 'a option + + val empty : 'a -> 'a t + val add : path -> 'a -> 'a t -> 'a t + val find : path -> 'a t -> 'a option end -module PathMap:PathMap +module PathMap : PathMap type precondition @@ -83,27 +77,29 @@ type 'a fold = Exception.method_handler -> Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> - Exception.method_handler * - ((Remanent_parameters_sig.parameters -> - Ckappa_sig.c_state -> - Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -> - Exception.method_handler * 'a -> - Exception.method_handler * 'a) -> - Exception.method_handler -> 'a -> - Exception.method_handler * 'a) Usual_domains.flat_lattice - -val dummy_precondition: precondition - -val is_the_rule_applied_for_the_first_time: + Exception.method_handler + * ((Remanent_parameters_sig.parameters -> + Ckappa_sig.c_state -> + Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -> + Exception.method_handler * 'a -> + Exception.method_handler * 'a) -> + Exception.method_handler -> + 'a -> + Exception.method_handler * 'a) + Usual_domains.flat_lattice + +val dummy_precondition : precondition + +val is_the_rule_applied_for_the_first_time : precondition -> Usual_domains.maybe_bool -val the_rule_is_applied_for_the_first_time: +val the_rule_is_applied_for_the_first_time : Remanent_parameters_sig.parameters -> Exception.method_handler -> precondition -> Exception.method_handler * precondition -val the_rule_is_not_applied_for_the_first_time: +val the_rule_is_not_applied_for_the_first_time : Remanent_parameters_sig.parameters -> Exception.method_handler -> precondition -> @@ -117,124 +113,149 @@ val the_rule_is_not_applied_for_the_first_time: Exception.method_handler * Analyzer_headers.global_dynamic_information * precondition * Ckappa_sig.c_state list Usual_domains.flat_lattice*) -type prefold = { fold: 'a. 'a fold} +type prefold = { fold: 'a. 'a fold } (*fill in is_enable where it output the precondition, take the precondition, refine, the previous result, and output the new precondition*) -val refine_information_about_state_of_sites_in_precondition: +val refine_information_about_state_of_sites_in_precondition : precondition -> (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - Analyzer_headers.global_dynamic_information -> - path -> - Ckappa_sig.c_state list Usual_domains.flat_lattice -> - Exception.method_handler * Analyzer_headers.global_dynamic_information * - Ckappa_sig.c_state list Usual_domains.flat_lattice) -> + Exception.method_handler -> + Analyzer_headers.global_dynamic_information -> + path -> + Ckappa_sig.c_state list Usual_domains.flat_lattice -> + Exception.method_handler + * Analyzer_headers.global_dynamic_information + * Ckappa_sig.c_state list Usual_domains.flat_lattice) -> precondition -val get_potential_partner: +val get_potential_partner : precondition -> - (Exception.method_handler -> Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> Ckappa_sig.c_state -> - Exception.method_handler * precondition * - (((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) Usual_domains.flat_lattice))) + Exception.method_handler -> + Ckappa_sig.c_agent_name -> + Ckappa_sig.c_site_name -> + Ckappa_sig.c_state -> + Exception.method_handler + * precondition + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + Usual_domains.flat_lattice -val fold_over_potential_partners: +val fold_over_potential_partners : Remanent_parameters_sig.parameters -> Exception.method_handler -> precondition -> Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> (Remanent_parameters_sig.parameters -> - Ckappa_sig.c_state -> - Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -> - Exception.method_handler * 'a -> Exception.method_handler * 'a) -> + Ckappa_sig.c_state -> + Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state -> + Exception.method_handler * 'a -> + Exception.method_handler * 'a) -> 'a -> Exception.method_handler * precondition * 'a Usual_domains.top_or_not -val overwrite_potential_partners_map: +val overwrite_potential_partners_map : Remanent_parameters_sig.parameters -> Exception.method_handler -> precondition -> - (Exception.method_handler -> Ckappa_sig.c_agent_name -> - Ckappa_sig.c_site_name -> - Ckappa_sig.c_state -> - Exception.method_handler * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) Usual_domains.flat_lattice) - -> prefold -> + (Exception.method_handler -> + Ckappa_sig.c_agent_name -> + Ckappa_sig.c_site_name -> + Ckappa_sig.c_state -> + Exception.method_handler + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + Usual_domains.flat_lattice) -> + prefold -> Exception.method_handler * precondition -val get_state_of_site: +val get_state_of_site : Exception.method_handler -> precondition -> Analyzer_headers.global_static_information -> Analyzer_headers.global_dynamic_information -> path_in_pattern -> - Exception.method_handler * Analyzer_headers.global_dynamic_information * - precondition * - Ckappa_sig.c_state list Usual_domains.flat_lattice + Exception.method_handler + * Analyzer_headers.global_dynamic_information + * precondition + * Ckappa_sig.c_state list Usual_domains.flat_lattice -val follow_path_inside_cc: +val follow_path_inside_cc : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.mixture -> - path -> Exception.method_handler * output + path -> + Exception.method_handler * output -val get_state_of_site_in_precondition: +val get_state_of_site_in_precondition : ('static -> Analyzer_headers.global_static_information) -> ('dynamic -> Analyzer_headers.global_dynamic_information) -> (Analyzer_headers.global_dynamic_information -> 'dynamic -> 'dynamic) -> Exception.method_handler -> - 'static -> 'dynamic -> - (Ckappa_sig.c_rule_id * Cckappa_sig.enriched_rule) -> + 'static -> + 'dynamic -> + Ckappa_sig.c_rule_id * Cckappa_sig.enriched_rule -> Ckappa_sig.c_agent_id -> Ckappa_sig.c_site_name -> precondition -> - Exception.method_handler * 'dynamic * precondition * - Ckappa_sig.c_state list + Exception.method_handler * 'dynamic * precondition * Ckappa_sig.c_state list -val get_state_of_site_in_postcondition: +val get_state_of_site_in_postcondition : ('static -> Analyzer_headers.global_static_information) -> ('dynamic -> Analyzer_headers.global_dynamic_information) -> (Analyzer_headers.global_dynamic_information -> 'dynamic -> 'b) -> Exception.method_handler -> - 'static -> 'dynamic -> - (Ckappa_sig.c_rule_id * Cckappa_sig.enriched_rule) -> + 'static -> + 'dynamic -> + Ckappa_sig.c_rule_id * Cckappa_sig.enriched_rule -> Ckappa_sig.c_agent_id -> Ckappa_sig.c_site_name -> precondition -> - Exception.method_handler * 'b * precondition * - Ckappa_sig.c_state list + Exception.method_handler * 'b * precondition * Ckappa_sig.c_state list -val add_rule: +val add_rule : ?local_trace:bool -> Remanent_parameters_sig.parameters -> Cckappa_sig.compil -> Cckappa_sig.kappa_handler -> Exception.method_handler -> Ckappa_sig.c_rule_id -> - event list -> Exception.method_handler * event list + event list -> + Exception.method_handler * event list type site_working_list -val init_sites_working_list: - Remanent_parameters_sig.parameters -> Exception.method_handler -> + +val init_sites_working_list : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Exception.method_handler * site_working_list + +val clear_sites_working_list : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + site_working_list -> Exception.method_handler * site_working_list -val clear_sites_working_list: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - site_working_list -> Exception.method_handler * site_working_list -val add_site: - Remanent_parameters_sig.parameters -> Exception.method_handler -> - Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> + +val add_site : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.c_agent_name -> + Ckappa_sig.c_site_name -> site_working_list -> Exception.method_handler * site_working_list -val fold_sites: - ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name,unit, 'a, 'a) Int_storage.ternary, - site_working_list, - 'a, - 'a) Int_storage.ternary +val fold_sites : + ( ( Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name, + unit, + 'a, + 'a ) + Int_storage.ternary, + site_working_list, + 'a, + 'a ) + Int_storage.ternary (*val get_dead_rules: 'static -> 'dynamic -> diff --git a/core/KaSa_rep/reachability_analysis/composite_domain.ml b/core/KaSa_rep/reachability_analysis/composite_domain.ml index 24dc96b545..a79f68aa30 100644 --- a/core/KaSa_rep/reachability_analysis/composite_domain.ml +++ b/core/KaSa_rep/reachability_analysis/composite_domain.ml @@ -13,202 +13,185 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Composite_domain = -sig +module type Composite_domain = sig type static_information type dynamic_information - val initialize: + val initialize : Analyzer_headers.global_static_information -> Analyzer_headers.global_dynamic_information -> Exception.method_handler -> Exception.method_handler * static_information * dynamic_information type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a - - type ('a,'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b - - type ('a,'b,'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a - type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + type ('a, 'b) unary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b - val next_rule: Ckappa_sig.c_rule_id option zeroary + type ('a, 'b, 'c) binary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c - val add_initial_state: (Analyzer_headers.initial_state, unit) unary + type ('a, 'b, 'c, 'd) ternary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd - val is_enabled: (Ckappa_sig.c_rule_id, Communication.precondition option) unary + val next_rule : Ckappa_sig.c_rule_id option zeroary + val add_initial_state : (Analyzer_headers.initial_state, unit) unary - val apply_rule: (Ckappa_sig.c_rule_id, Communication.precondition,unit) binary + val is_enabled : + (Ckappa_sig.c_rule_id, Communication.precondition option) unary - val stabilize: unit zeroary + val apply_rule : + (Ckappa_sig.c_rule_id, Communication.precondition, unit) binary - val export: - ( - ('static, 'dynamic) Analyzer_headers.kasa_state, - ('static, 'dynamic) Analyzer_headers.kasa_state - ) - unary + val stabilize : unit zeroary + + val export : + ( ('static, 'dynamic) Analyzer_headers.kasa_state, + ('static, 'dynamic) Analyzer_headers.kasa_state ) + unary - val print: (Loggers.t, unit) unary + val print : (Loggers.t, unit) unary - val maybe_reachable: - (Analyzer_headers.pattern_matching_flag, - Cckappa_sig.mixture, Communication.precondition option) binary + val maybe_reachable : + ( Analyzer_headers.pattern_matching_flag, + Cckappa_sig.mixture, + Communication.precondition option ) + binary - val get_global_dynamic_information: dynamic_information -> Analyzer_headers.global_dynamic_information + val get_global_dynamic_information : + dynamic_information -> Analyzer_headers.global_dynamic_information - val set_global_dynamic_information: - Analyzer_headers.global_dynamic_information -> dynamic_information -> dynamic_information + val set_global_dynamic_information : + Analyzer_headers.global_dynamic_information -> + dynamic_information -> + dynamic_information end (****************************************************************************) (*Analyzer is a functor takes a module Domain as its parameters.*) -module Make (Domain:Analyzer_domain_sig.Domain) = -struct - +module Make (Domain : Analyzer_domain_sig.Domain) = struct type static_information = Analyzer_headers.global_static_information * Domain.static_information type working_list = Ckappa_sig.Rule_FIFO.t - type dynamic_information = - { - modified_sites_blackboard: Communication.site_working_list; - rule_working_list: working_list; - bonds: - Ckappa_sig.AgentSite_map_and_set.Set.t - Ckappa_sig.AgentSite_map_and_set.Map.t ; - domain : Domain.dynamic_information - } + type dynamic_information = { + modified_sites_blackboard: Communication.site_working_list; + rule_working_list: working_list; + bonds: + Ckappa_sig.AgentSite_map_and_set.Set.t + Ckappa_sig.AgentSite_map_and_set.Map.t; + domain: Domain.dynamic_information; + } let get_modified_sites_blackboard dynamic = dynamic.modified_sites_blackboard - let get_bonds dynamic = dynamic.bonds - let set_bonds bonds dynamic = - {dynamic with bonds = bonds} + let set_bonds bonds dynamic = { dynamic with bonds } let get_global_static_information = fst - let get_domain_static_information = snd - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static - let get_compil static = lift Analyzer_headers.get_cc_code static - let get_wake_up_relation static = lift Analyzer_headers.get_wake_up_relation static + let get_wake_up_relation static = + lift Analyzer_headers.get_wake_up_relation static let empty_working_list = Ckappa_sig.Rule_FIFO.empty type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a - - type ('a,'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b - - type ('a,'b,'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a + + type ('a, 'b) unary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b + + type ('a, 'b, 'c) binary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (** push r_id in the working_list *) let get_working_list dynamic = dynamic.rule_working_list let set_working_list rule_working_list dynamic = - { - dynamic with rule_working_list = rule_working_list - } + { dynamic with rule_working_list } - let set_domain domain dynamic = - { - dynamic with domain = domain - } + let set_domain domain dynamic = { dynamic with domain } - let get_global_dynamic_information dynamic = Domain.get_global_dynamic_information dynamic.domain + let get_global_dynamic_information dynamic = + Domain.get_global_dynamic_information dynamic.domain let set_global_dynamic_information gdynamic dynamic = { dynamic with - domain = - Domain.set_global_dynamic_information gdynamic dynamic.domain} + domain = Domain.set_global_dynamic_information gdynamic dynamic.domain; + } let push_rule static dynamic error r_id = let working_list = get_working_list dynamic in let parameters = get_parameter static in let compiled = get_compil static in let error, rule_working_list = - Ckappa_sig.Rule_FIFO.push - parameters - error - r_id - working_list + Ckappa_sig.Rule_FIFO.push parameters error r_id working_list in let error = if - not (rule_working_list == working_list) - && - Remanent_parameters.get_dump_reachability_analysis_wl - parameters - then + (not (rule_working_list == working_list)) + && Remanent_parameters.get_dump_reachability_analysis_wl parameters + then ( let error, rule_id_string = - try - Handler.string_of_rule parameters error compiled r_id - with - | _ -> - Exception.warn - parameters error __POS__ Exit + try Handler.string_of_rule parameters error compiled r_id + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_rule_id r_id) in let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "\t\t\t(%s) should be investigated\n" - rule_id_string - in error - else error + "\t\t\t(%s) should be investigated\n" rule_id_string + in + error + ) else + error in let dynamic = set_working_list rule_working_list dynamic in error, dynamic @@ -220,8 +203,7 @@ struct Common_static.wake_up parameter error agent site wake_up in List.fold_left - (fun (error, dynamic) r_id -> - push_rule static dynamic error r_id) + (fun (error, dynamic) r_id -> push_rule static dynamic error r_id) (error, dynamic) rules_list (**[next_rule static dynamic] returns a rule_id inside a working list @@ -230,49 +212,45 @@ struct let next_rule static dynamic error = let working_list = get_working_list dynamic in (* see if the working list is empty, if not pop an element *) - if - Ckappa_sig.Rule_FIFO.is_empty - working_list - then error, dynamic, None - else + if Ckappa_sig.Rule_FIFO.is_empty working_list then + error, dynamic, None + else ( let parameters = get_parameter static in let error, (rule_id_op, working_list_tail) = - Ckappa_sig.Rule_FIFO.pop - parameters error working_list + Ckappa_sig.Rule_FIFO.pop parameters error working_list in let dynamic = set_working_list working_list_tail dynamic in error, dynamic, rule_id_op + ) (*for each rule with no lhs, push the rule in the working list *) let push_rule_creation static dynamic error rule_id rule = let parameters = get_parameter static in let error, dynamic = - List.fold_left (fun (error, dynamic) (agent_id, _agent_type) -> + List.fold_left + (fun (error, dynamic) (agent_id, _agent_type) -> let error, agent = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_id + parameters error agent_id rule.Cckappa_sig.rule_rhs.Cckappa_sig.views in match agent with - | Some Cckappa_sig.Dead_agent _ - | Some Cckappa_sig.Ghost -> error, dynamic - | None -> - Exception.warn parameters error __POS__ Exit dynamic - | Some Cckappa_sig.Unknown_agent _ - | Some Cckappa_sig.Agent _ -> - let error, dynamic = - push_rule static dynamic error rule_id - in + | Some (Cckappa_sig.Dead_agent _) | Some Cckappa_sig.Ghost -> error, dynamic - ) (error, dynamic) rule.Cckappa_sig.actions.Cckappa_sig.creation + | None -> Exception.warn parameters error __POS__ Exit dynamic + | Some (Cckappa_sig.Unknown_agent _) | Some (Cckappa_sig.Agent _) -> + let error, dynamic = push_rule static dynamic error rule_id in + error, dynamic) + (error, dynamic) rule.Cckappa_sig.actions.Cckappa_sig.creation in let error, dynamic = - if rule.Cckappa_sig.actions.Cckappa_sig.creation = [] + if + rule.Cckappa_sig.actions.Cckappa_sig.creation = [] && Ckappa_sig.skip_only rule.Cckappa_sig.rule_lhs.Cckappa_sig.c_mixture - then push_rule static dynamic error rule_id - else error, dynamic + then + push_rule static dynamic error rule_id + else + error, dynamic in error, dynamic @@ -281,25 +259,17 @@ struct let compil = get_compil static in let rules = compil.Cckappa_sig.rules in let error, dynamic = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun _parameters error rule_id rule dynamic -> - let error, dynamic = - push_rule_creation - static - dynamic - error - rule_id - rule.Cckappa_sig.e_rule_c_rule - in - error, dynamic - ) + let error, dynamic = + push_rule_creation static dynamic error rule_id + rule.Cckappa_sig.e_rule_c_rule + in + error, dynamic) rules dynamic in error, dynamic - - (**[lift_unary f static dynamic] is a function lifted of unary type, returns information of dynamic information and its output*) @@ -338,31 +308,18 @@ struct let dynamic = set_domain domain_dynamic dynamic in error, dynamic, output - (**[is_enabled static dynamic error a] returns a triple of type binary when given a rule_id [a], check that if this rule is enable or not *) let is_enabled static dynamic error a = - lift_binary - Domain.is_enabled - static - dynamic - error - a + lift_binary Domain.is_enabled static dynamic error a Communication.dummy_precondition - -(***********************************************************) + (***********************************************************) (**[pre_apply_rule static dynamic error a b] *) let pre_apply_rule static dynamic error a b = - lift_binary - Domain.apply_rule - static - dynamic - error - a - b + lift_binary Domain.apply_rule static dynamic error a b (**apply a list of event if it is empty then do nothing, otherwise go through this list and at each event push rule_id inside a working @@ -370,149 +327,126 @@ struct let get_partner parameter error site bonds = match - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameter error site bonds + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameter + error site bonds with | error, None -> error, Ckappa_sig.AgentSite_map_and_set.Set.empty | error, Some set -> error, set - let p (a,b,_) = (a,b) - let add_oriented_bond parameter error (site,site') bonds = + let p (a, b, _) = a, b + + let add_oriented_bond parameter error (site, site') bonds = let site = p site in let site' = p site' in let error, old = get_partner parameter error site bonds in let error, newset = - Ckappa_sig.AgentSite_map_and_set.Set.add_when_not_in - parameter error site' old + Ckappa_sig.AgentSite_map_and_set.Set.add_when_not_in parameter error site' + old in - Ckappa_sig.AgentSite_map_and_set.Map.add_or_overwrite - parameter error site newset bonds - - let add_bond parameter error (site,site') bonds = - let error, bonds = add_oriented_bond parameter error (site,site') bonds in - add_oriented_bond parameter error (site',site) bonds + Ckappa_sig.AgentSite_map_and_set.Map.add_or_overwrite parameter error site + newset bonds + let add_bond parameter error (site, site') bonds = + let error, bonds = add_oriented_bond parameter error (site, site') bonds in + add_oriented_bond parameter error (site', site) bonds - let rec apply_event_list (static:static_information) dynamic error event_list - = + let rec apply_event_list (static : static_information) dynamic error + event_list = let parameter = get_parameter static in - if event_list = [] - then + if event_list = [] then error, dynamic, () - else + else ( let split event_list = List.fold_left (fun (check_rules, modified_sites, bonds, others) event -> - match - event - with - | Communication.Check_rule r_id -> - r_id::check_rules, modified_sites, bonds, others - | Communication.Modified_sites site -> - check_rules, site::modified_sites, bonds, others - | Communication.See_a_new_bond bond -> - check_rules, modified_sites, bond::bonds, event::others - | Communication.Dummy -> - check_rules, modified_sites, bonds, event::others) - ([],[],[],[]) event_list - in - let check_rules, modified_sites, bonds, event_list = - split event_list + match event with + | Communication.Check_rule r_id -> + r_id :: check_rules, modified_sites, bonds, others + | Communication.Modified_sites site -> + check_rules, site :: modified_sites, bonds, others + | Communication.See_a_new_bond bond -> + check_rules, modified_sites, bond :: bonds, event :: others + | Communication.Dummy -> + check_rules, modified_sites, bonds, event :: others) + ([], [], [], []) event_list in - let dyn_bonds = get_bonds dynamic in + let check_rules, modified_sites, bonds, event_list = split event_list in + let dyn_bonds = get_bonds dynamic in let error, dyn_bonds = List.fold_left (fun (error, dyn_bonds) bond -> - add_bond parameter error bond dyn_bonds) + add_bond parameter error bond dyn_bonds) (error, dyn_bonds) bonds in let dynamic = set_bonds dyn_bonds dynamic in let error, dynamic, event_list' = - lift_unary - Domain.apply_event_list - static - dynamic - error - event_list + lift_unary Domain.apply_event_list static dynamic error event_list in let modified_sites_blackboard = get_modified_sites_blackboard dynamic in let error, modified_sites_blackboard = List.fold_left - (fun (error, modified_sites_blackboard) (agent,site) -> - let error, modified_sites_blackboard = - Communication.add_site - parameter error agent site modified_sites_blackboard - in - let (error:Exception.method_handler), set = - get_partner parameter error (agent,site) dyn_bonds - in - Ckappa_sig.AgentSite_map_and_set.Set.fold - (fun (agent,site) (error, modified_sites_blackboard) -> - Communication.add_site - parameter - error - agent - site modified_sites_blackboard) - set - (error, modified_sites_blackboard) - ) + (fun (error, modified_sites_blackboard) (agent, site) -> + let error, modified_sites_blackboard = + Communication.add_site parameter error agent site + modified_sites_blackboard + in + let (error : Exception.method_handler), set = + get_partner parameter error (agent, site) dyn_bonds + in + Ckappa_sig.AgentSite_map_and_set.Set.fold + (fun (agent, site) (error, modified_sites_blackboard) -> + Communication.add_site parameter error agent site + modified_sites_blackboard) + set + (error, modified_sites_blackboard)) (error, modified_sites_blackboard) modified_sites in let f l error dynamic = List.fold_left - (fun (error, dynamic) r_id -> - push_rule - static dynamic error r_id) + (fun (error, dynamic) r_id -> push_rule static dynamic error r_id) (error, dynamic) l in let error, dynamic = f check_rules error dynamic in - let wake_up = - Analyzer_headers.get_wake_up_relation (fst static) - in + let wake_up = Analyzer_headers.get_wake_up_relation (fst static) in let error, dynamic = - Communication.fold_sites - parameter error - (fun parameter error (agent,site) () dynamic -> - let error, list_r_id = - Common_static.wake_up parameter error agent site wake_up in - f list_r_id error dynamic) - modified_sites_blackboard dynamic + Communication.fold_sites parameter error + (fun parameter error (agent, site) () dynamic -> + let error, list_r_id = + Common_static.wake_up parameter error agent site wake_up + in + f list_r_id error dynamic) + modified_sites_blackboard dynamic in let error, dynamic = - List.fold_left (fun (error, dynamic) event -> + List.fold_left + (fun (error, dynamic) event -> match event with | Communication.Check_rule rule_id -> - push_rule - static dynamic error - rule_id - | Communication.Modified_sites (agent,site) -> - push_modified_site - static dynamic error - agent site - | Communication.See_a_new_bond _ - | Communication.Dummy -> - error, dynamic - ) (error, dynamic) event_list + push_rule static dynamic error rule_id + | Communication.Modified_sites (agent, site) -> + push_modified_site static dynamic error agent site + | Communication.See_a_new_bond _ | Communication.Dummy -> + error, dynamic) + (error, dynamic) event_list in apply_event_list static dynamic error event_list' - + ) let initialize static dynamic error = let error, domain_static, domain_dynamic, event_list = Domain.initialize static dynamic error in - let parameters = get_parameter (static,domain_static) in + let parameters = get_parameter (static, domain_static) in let error, wake_up_tmp = Common_static.empty_site_to_rules parameters error in let error, wake_up_tmp = - Domain.complete_wake_up_relation domain_static - error wake_up_tmp + Domain.complete_wake_up_relation domain_static error wake_up_tmp in let error, wake_up = - Common_static.consolidate_site_rule_dependencies - parameters error wake_up_tmp + Common_static.consolidate_site_rule_dependencies parameters error + wake_up_tmp in let static = Analyzer_headers.add_wake_up_relation static wake_up, domain_static @@ -529,12 +463,7 @@ struct bonds = Ckappa_sig.AgentSite_map_and_set.Map.empty; } in - let error, dynamic = - scan_rule_creation - static - dynamic - error - in + let error, dynamic = scan_rule_creation static dynamic error in let error, dynamic, () = apply_event_list static dynamic error event_list in error, static, dynamic @@ -543,185 +472,98 @@ struct let add_initial_state static dynamic error initial_state = let error, dynamic, event_list = - pre_add_initial_state - static - dynamic - error - initial_state + pre_add_initial_state static dynamic error initial_state in apply_event_list static dynamic error event_list - let get_rule parameter error static r_id = - let compil = get_compil static in - let error, rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameter - error - r_id - compil.Cckappa_sig.rules - in - error, rule - - let apply_one_side_effect - static - dynamic - error - r_id - (source,target) - precondition - event_list - = - let error, dynamic, (precondition, event_list') = - lift_ternary - Domain.apply_one_side_effect - static - dynamic - error - r_id - (source,target) - precondition - in error, dynamic, (precondition, (event_list'@event_list)) -(**if it has a precondition for this rule_id then apply a list of event + let get_rule parameter error static r_id = + let compil = get_compil static in + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameter error r_id + compil.Cckappa_sig.rules + in + error, rule + + (**if it has a precondition for this rule_id then apply a list of event starts from this new list*) + let apply_one_side_effect static dynamic error r_id (source, target) + precondition event_list = + let error, dynamic, (precondition, event_list') = + lift_ternary Domain.apply_one_side_effect static dynamic error r_id + (source, target) precondition + in + error, dynamic, (precondition, event_list' @ event_list) - let check_side_effect static dynamic error precondition event_list r_id rule source target = - let (agent_id, _, site, state) = source in + let check_side_effect static dynamic error precondition event_list r_id rule + source target = + let agent_id, _, site, state = source in let error, dynamic, precondition, state_list = Communication.get_state_of_site_in_precondition - get_global_static_information - get_global_dynamic_information - set_global_dynamic_information - error - static - dynamic - (r_id, rule) + get_global_static_information get_global_dynamic_information + set_global_dynamic_information error static dynamic (r_id, rule) agent_id (*A*) - site - precondition + site precondition in - if List.mem state state_list - then - apply_one_side_effect - static - dynamic - error - r_id - (Some source,target) - precondition - event_list + if List.mem state state_list then + apply_one_side_effect static dynamic error r_id (Some source, target) + precondition event_list else - (error, dynamic, (precondition, event_list)) - - let - apply_side_effect - static - dynamic - error - r_id - precondition - event_list - = + error, dynamic, (precondition, event_list) + + let apply_side_effect static dynamic error r_id precondition event_list = let parameters = - Analyzer_headers.get_parameter - (get_global_static_information static) + Analyzer_headers.get_parameter (get_global_static_information static) in let error, side_effects = - Ckappa_sig.Rule_map_and_set.Map.find_default_without_logs - parameters error - [] - r_id + Ckappa_sig.Rule_map_and_set.Map.find_default_without_logs parameters error + [] r_id (Analyzer_headers.get_potential_side_effects_per_rule (get_global_static_information static)) in - let error, rule_opt = - get_rule - parameters error static r_id - in + let error, rule_opt = get_rule parameters error static r_id in match rule_opt with | Some rule -> let error, side_effects_opt = - Domain.get_side_effects - (get_domain_static_information static) - dynamic.domain - parameters error - r_id + Domain.get_side_effects + (get_domain_static_information static) + dynamic.domain parameters error r_id in - begin - match side_effects_opt with - | - None -> - List.fold_left - (fun - (error, dynamic, (precondition, event_list)) - (source,target) -> - check_side_effect static dynamic error precondition event_list r_id rule source target) - (error, dynamic, (precondition, event_list)) - side_effects - | Some side_effects -> - begin - let error, dynamic, (precondition, event_list) = - Ckappa_sig.AgentSiteState_map_and_set.Set.fold - (fun target - (error, dynamic, (precondition, event_list)) -> - apply_one_side_effect - static - dynamic - error - r_id - (None,target) - precondition - event_list - ) - side_effects.Ckappa_sig.seen - (error, dynamic, (precondition, event_list)) - in - let error, dynamic, (precondition, event_list) = - Ckappa_sig.AgentsSiteState_map_and_set.Map.fold - (fun source target - (error, dynamic, (precondition, event_list)) -> - apply_one_side_effect - static - dynamic - error - r_id - (Some source,target) - precondition - event_list - ) - side_effects.Ckappa_sig.not_seen_yet - (error, dynamic, (precondition, event_list)) - in - error, dynamic, (precondition, event_list) - - end - end - + (match side_effects_opt with + | None -> + List.fold_left + (fun (error, dynamic, (precondition, event_list)) (source, target) -> + check_side_effect static dynamic error precondition event_list r_id + rule source target) + (error, dynamic, (precondition, event_list)) + side_effects + | Some side_effects -> + let error, dynamic, (precondition, event_list) = + Ckappa_sig.AgentSiteState_map_and_set.Set.fold + (fun target (error, dynamic, (precondition, event_list)) -> + apply_one_side_effect static dynamic error r_id (None, target) + precondition event_list) + side_effects.Ckappa_sig.seen + (error, dynamic, (precondition, event_list)) + in + let error, dynamic, (precondition, event_list) = + Ckappa_sig.AgentsSiteState_map_and_set.Map.fold + (fun source target (error, dynamic, (precondition, event_list)) -> + apply_one_side_effect static dynamic error r_id + (Some source, target) precondition event_list) + side_effects.Ckappa_sig.not_seen_yet + (error, dynamic, (precondition, event_list)) + in + error, dynamic, (precondition, event_list)) | None -> - let error, () = - Exception.warn - parameters error - __POS__ - Exit () - in - (error, dynamic, (precondition, event_list)) + let error, () = Exception.warn parameters error __POS__ Exit () in + error, dynamic, (precondition, event_list) let apply_rule static dynamic error r_id precondition = let error, dynamic, (precondition, event_list) = - pre_apply_rule - static - dynamic - error - r_id - precondition + pre_apply_rule static dynamic error r_id precondition in let error, dynamic, (_precondition, event_list) = - apply_side_effect - static - dynamic - error - r_id - precondition - event_list + apply_side_effect static dynamic error r_id precondition event_list in apply_event_list static dynamic error event_list @@ -734,20 +576,12 @@ struct let print static dynamic error loggers = let dead_rules = Domain.get_dead_rules - (get_domain_static_information static) dynamic.domain + (get_domain_static_information static) + dynamic.domain in lift_unary (Domain.print ~dead_rules) static dynamic error loggers - - let maybe_reachable (static:static_information) dynamic error flag mixture = - lift_ternary - Domain.maybe_reachable - static - dynamic - error - flag - mixture + let maybe_reachable (static : static_information) dynamic error flag mixture = + lift_ternary Domain.maybe_reachable static dynamic error flag mixture Communication.dummy_precondition - - end diff --git a/core/KaSa_rep/reachability_analysis/composite_domain.mli b/core/KaSa_rep/reachability_analysis/composite_domain.mli index 2fcc95017b..201e724da8 100644 --- a/core/KaSa_rep/reachability_analysis/composite_domain.mli +++ b/core/KaSa_rep/reachability_analysis/composite_domain.mli @@ -15,70 +15,77 @@ (** composite abstract domain (no longer with communications which have been internalized) *) -module type Composite_domain = -sig - +module type Composite_domain = sig type static_information - type dynamic_information - val initialize: + val initialize : Analyzer_headers.global_static_information -> Analyzer_headers.global_dynamic_information -> Exception.method_handler -> Exception.method_handler * static_information * dynamic_information type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd - - val next_rule: Ckappa_sig.c_rule_id option zeroary + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd - val add_initial_state: (Analyzer_headers.initial_state, unit) unary + val next_rule : Ckappa_sig.c_rule_id option zeroary + val add_initial_state : (Analyzer_headers.initial_state, unit) unary - val is_enabled: (Ckappa_sig.c_rule_id, Communication.precondition option) unary + val is_enabled : + (Ckappa_sig.c_rule_id, Communication.precondition option) unary - val apply_rule: (Ckappa_sig.c_rule_id, Communication.precondition, unit) binary + val apply_rule : + (Ckappa_sig.c_rule_id, Communication.precondition, unit) binary - val stabilize: unit zeroary - val export: (('static,'dynamic) Analyzer_headers.kasa_state, ('static,'dynamic) Analyzer_headers.kasa_state) unary + val stabilize : unit zeroary - val print: (Loggers.t, unit) unary + val export : + ( ('static, 'dynamic) Analyzer_headers.kasa_state, + ('static, 'dynamic) Analyzer_headers.kasa_state ) + unary - val maybe_reachable: - (Analyzer_headers.pattern_matching_flag, - Cckappa_sig.mixture, Communication.precondition option) binary + val print : (Loggers.t, unit) unary - val get_global_dynamic_information: dynamic_information -> Analyzer_headers.global_dynamic_information - val set_global_dynamic_information: Analyzer_headers.global_dynamic_information -> dynamic_information -> dynamic_information + val maybe_reachable : + ( Analyzer_headers.pattern_matching_flag, + Cckappa_sig.mixture, + Communication.precondition option ) + binary + val get_global_dynamic_information : + dynamic_information -> Analyzer_headers.global_dynamic_information + val set_global_dynamic_information : + Analyzer_headers.global_dynamic_information -> + dynamic_information -> + dynamic_information end -module Make : functor (Domain:Analyzer_domain_sig.Domain) -> Composite_domain +module Make : functor (Domain : Analyzer_domain_sig.Domain) -> Composite_domain diff --git a/core/KaSa_rep/reachability_analysis/counters_domain.ml b/core/KaSa_rep/reachability_analysis/counters_domain.ml index 66aed444fb..ccffe1d604 100644 --- a/core/KaSa_rep/reachability_analysis/counters_domain.ml +++ b/core/KaSa_rep/reachability_analysis/counters_domain.ml @@ -20,218 +20,192 @@ let local_trace = false module Functor = - functor - (MI: Mat_inter.Mat_inter with type var = Occu1.trans) - -> - struct - - type static_information = - { - global_static_information : - Analyzer_headers.global_static_information; - local_static_information : - Counters_domain_type.static +functor + (MI : Mat_inter.Mat_inter with type var = Occu1.trans) + -> + struct + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + local_static_information: Counters_domain_type.static; } - (*--------------------------------------------------------------*) - (* One map: for each tuple: Yes, No, Maybe. - - Yes: to say that when the sites x and y are bound with sites of - the good type, then they are bound to the same B. - - No: to say that when the sites x and y are bound with sites of the good - type, then they are never bound to the same B. - - Maybe: both cases may happen.*) - - type local_dynamic_information = - { + (*--------------------------------------------------------------*) + (* One map: for each tuple: Yes, No, Maybe. + - Yes: to say that when the sites x and y are bound with sites of + the good type, then they are bound to the same B. + - No: to say that when the sites x and y are bound with sites of the good + type, then they are never bound to the same B. + - Maybe: both cases may happen.*) + + type local_dynamic_information = { dummy: unit; store_value: MI.prod - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.t + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .t; } - type dynamic_information = - { - local : local_dynamic_information ; - global : Analyzer_headers.global_dynamic_information; + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; } - (** Static information: + (** Static information: Explain how to extract the handler for kappa expressions from a value of type static_information. Kappa handler is static and thus it should never updated. *) - (*global static information*) - - let get_global_static_information static = static.global_static_information - - let lift f x = f (get_global_static_information x) - - let get_parameter static = lift Analyzer_headers.get_parameter static - - let get_kappa_handler static = lift Analyzer_headers.get_kappa_handler static - - let get_compil static = lift Analyzer_headers.get_cc_code static - - let get_local_static_information static = static.local_static_information - - let get_rule parameter error static r_id = - let compil = get_compil static in - let error, rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameter - error - r_id - compil.Cckappa_sig.rules - in - error, rule - - (*static information*) - - let get_counters_set static = - (get_local_static_information static).Counters_domain_type.counters - - let get_rule_restriction static = - (get_local_static_information - static).Counters_domain_type.rule_restrictions - - let get_rule_creation static = - (get_local_static_information - static).Counters_domain_type.rule_creation - - let get_packs static = - (get_local_static_information - static).Counters_domain_type.packs + (*global static information*) - let get_backward_pointers static = - (get_local_static_information - static).Counters_domain_type.backward_pointers + let get_global_static_information static = static.global_static_information + let lift f x = f (get_global_static_information x) + let get_parameter static = lift Analyzer_headers.get_parameter static + let get_kappa_handler static = + lift Analyzer_headers.get_kappa_handler static - (*global dynamic information*) + let get_compil static = lift Analyzer_headers.get_cc_code static + let get_local_static_information static = static.local_static_information - let get_global_dynamic_information dynamic = dynamic.global - - let get_local_dynamic_information dynamic = dynamic.local + let get_rule parameter error static r_id = + let compil = get_compil static in + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameter error + r_id compil.Cckappa_sig.rules + in + error, rule - let set_local_dynamic_information local dynamic = - { - dynamic with local = local - } + (*static information*) - let set_global_dynamic_information global dynamic = - { - dynamic with global = global - } + let get_counters_set static = + (get_local_static_information static).Counters_domain_type.counters -(*dynamic information*) + let get_rule_restriction static = + (get_local_static_information static) + .Counters_domain_type.rule_restrictions - let get_value dynamic = - (get_local_dynamic_information dynamic).store_value + let get_rule_creation static = + (get_local_static_information static).Counters_domain_type.rule_creation - let set_value value dynamic = - set_local_dynamic_information - { - (get_local_dynamic_information dynamic) with - store_value = value - } dynamic + let get_packs static = + (get_local_static_information static).Counters_domain_type.packs - (*--------------------------------------------------------------*) + let get_backward_pointers static = + (get_local_static_information static) + .Counters_domain_type.backward_pointers - type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + (*global dynamic information*) - type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + let get_global_dynamic_information dynamic = dynamic.global + let get_local_dynamic_information dynamic = dynamic.local + let set_local_dynamic_information local dynamic = { dynamic with local } + let set_global_dynamic_information global dynamic = { dynamic with global } - type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + (*dynamic information*) - type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + let get_value dynamic = (get_local_dynamic_information dynamic).store_value - (****************************************************************) - (*rule*) - (*****************************************************************) + let set_value value dynamic = + set_local_dynamic_information + { (get_local_dynamic_information dynamic) with store_value = value } + dynamic - let compute_local_static_information global_static_information _dynamic error = - let parameters = Analyzer_headers.get_parameter global_static_information in - let compil = Analyzer_headers.get_cc_code global_static_information in - let kappa_handler = Analyzer_headers.get_kappa_handler global_static_information in - let error, local_static_information = - Counters_domain_static.compute_static - parameters error kappa_handler compil - in - let static = {global_static_information; local_static_information} in - error, static + (*--------------------------------------------------------------*) -(****************************************************************) -(*rules*) -(****************************************************************) + type 'a zeroary = + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a + + type ('a, 'b) unary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b + + type ('a, 'b, 'c) binary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c + + type ('a, 'b, 'c, 'd) ternary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd + + (****************************************************************) + (*rule*) + (*****************************************************************) + + let compute_local_static_information global_static_information _dynamic + error = + let parameters = + Analyzer_headers.get_parameter global_static_information + in + let compil = Analyzer_headers.get_cc_code global_static_information in + let kappa_handler = + Analyzer_headers.get_kappa_handler global_static_information + in + let error, local_static_information = + Counters_domain_static.compute_static parameters error kappa_handler + compil + in + let static = { global_static_information; local_static_information } in + error, static + (****************************************************************) + (*rules*) + (****************************************************************) - let initialize static dynamic error = - let parameters = Analyzer_headers.get_parameter static in - let error, static = - compute_local_static_information static dynamic error - in - let error, store_value = - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create parameters error (0,0) - in - let init_local_dynamic_information = - { - dummy = (); - store_value - } - in - let dynamic = - { - global = dynamic; - local = init_local_dynamic_information ; - } - in - error, static, dynamic, [] + let initialize static dynamic error = + let parameters = Analyzer_headers.get_parameter static in + let error, static = + compute_local_static_information static dynamic error + in + let error, store_value = + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameters error (0, 0) + in + let init_local_dynamic_information = { dummy = (); store_value } in + let dynamic = + { global = dynamic; local = init_local_dynamic_information } + in + error, static, dynamic, [] - (* fold over all the rules, all the tuples of interest, all the sites in - these tuples, and apply the function Common_static.add_dependency_site_rule - to update the wake_up relation *) - let complete_wake_up_relation static error wake_up = - let parameters = get_parameter static in - let rule_restriction = get_rule_restriction static in - let packs = get_packs static in - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error rule_id agent_map wake_up -> - let error, rule = get_rule parameters error static rule_id in - match rule with - | None -> - let error, () = - Exception.warn parameters error __POS__ Exit () - in - error, wake_up - | Some rule -> - let lhs = - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views in - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error agent_id counter_map wake_up -> + (* fold over all the rules, all the tuples of interest, all the sites in + these tuples, and apply the function Common_static.add_dependency_site_rule + to update the wake_up relation *) + let complete_wake_up_relation static error wake_up = + let parameters = get_parameter static in + let rule_restriction = get_rule_restriction static in + let packs = get_packs static in + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun parameters error rule_id agent_map wake_up -> + let error, rule = get_rule parameters error static rule_id in + match rule with + | None -> + let error, () = Exception.warn parameters error __POS__ Exit () in + error, wake_up + | Some rule -> + let lhs = + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs + .Cckappa_sig.views + in + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun parameters error agent_id counter_map wake_up -> let error, agent = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters error agent_id lhs @@ -242,291 +216,202 @@ module Functor = error, ag.Cckappa_sig.agent_name | None | Some - (Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ | - Cckappa_sig.Unknown_agent _) -> + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) -> Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_agent_name in match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type packs + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type packs with - | error, None -> - error, wake_up + | error, None -> error, wake_up | error, Some pack_map -> - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error counter _ wake_up -> - match - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get - parameters error counter pack_map - with - | error, None -> error, wake_up - | error, Some site_set -> - Ckappa_sig.Site_map_and_set.Set.fold - (fun site (error, wake_up) -> - Common_static.add_dependency_site_rule - parameters error agent_type site rule_id - wake_up) - site_set (error, wake_up)) - counter_map - wake_up - ) - agent_map - wake_up - ) - rule_restriction - wake_up - - let update_event_list static error agent_type counter event_list = - let parameters = get_parameter static in - let packs = get_packs static in - match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_type - packs - with - | error, None -> Exception.warn parameters error __POS__ Exit event_list - | error, Some a -> + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif + .fold parameters error + (fun parameters error counter _ wake_up -> + match + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif + .get parameters error counter pack_map + with + | error, None -> error, wake_up + | error, Some site_set -> + Ckappa_sig.Site_map_and_set.Set.fold + (fun site (error, wake_up) -> + Common_static.add_dependency_site_rule parameters + error agent_type site rule_id wake_up) + site_set (error, wake_up)) + counter_map wake_up) + agent_map wake_up) + rule_restriction wake_up + + let update_event_list static error agent_type counter event_list = + let parameters = get_parameter static in + let packs = get_packs static in match - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get - parameters error - counter - a + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameters + error agent_type packs with | error, None -> Exception.warn parameters error __POS__ Exit event_list | error, Some a -> - Ckappa_sig.Site_map_and_set.Set.fold - (fun site (error, event_list) -> - error, - (Communication.Modified_sites (agent_type,site))::event_list) - a - (error, event_list) - - - let new_prod_gen bin static dynamic error dump_title agent_type counter prod event_list = - let local = dynamic.local in - let store_value = local.store_value in - let kappa_handler = get_kappa_handler static in - let parameters = get_parameter static in - let (error, store_value), event_list = - match - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameters error - (agent_type, counter) - store_value - with - | error, None -> - let error, completed_event_list = update_event_list static error agent_type counter event_list in - let error = - if Remanent_parameters.get_dump_reachability_analysis_diff parameters - then - let parameters = Remanent_parameters.update_prefix parameters "\t\t" - in - let () = dump_title () - in - let error, agent_string = - Handler.translate_agent parameters error kappa_handler agent_type - in - let error, counter_string = - match - Handler.translate_site parameters error kappa_handler agent_type counter - with - | error, Ckappa_sig.Counter x -> error, x - | error,(Ckappa_sig.Internal x | Ckappa_sig.Binding x) -> - Exception.warn parameters error __POS__ Exit x - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s Agent: %s ; Counter: %s" - (Remanent_parameters.get_prefix parameters) - agent_string - counter_string - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let error = MI.affiche_mat parameters error prod in - error - else - error - in - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameters error - (agent_type, counter) - prod - store_value, - completed_event_list - | error, Some old_prod -> - let error, old = MI.copy parameters error old_prod in - let error, (new_prod, var_list) = bin parameters error old prod in - if var_list = false - then - (error, store_value), event_list - else + (match + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get parameters + error counter a + with + | error, None -> Exception.warn parameters error __POS__ Exit event_list + | error, Some a -> + Ckappa_sig.Site_map_and_set.Set.fold + (fun site (error, event_list) -> + ( error, + Communication.Modified_sites (agent_type, site) :: event_list )) + a (error, event_list)) + + let new_prod_gen bin static dynamic error dump_title agent_type counter prod + event_list = + let local = dynamic.local in + let store_value = local.store_value in + let kappa_handler = get_kappa_handler static in + let parameters = get_parameter static in + let (error, store_value), event_list = + match + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameters error (agent_type, counter) store_value + with + | error, None -> + let error, completed_event_list = + update_event_list static error agent_type counter event_list + in let error = - if Remanent_parameters.get_dump_reachability_analysis_diff parameters - then - let parameters = Remanent_parameters.update_prefix parameters "\t\t" - in - let () = dump_title () + if + Remanent_parameters.get_dump_reachability_analysis_diff parameters + then ( + let parameters = + Remanent_parameters.update_prefix parameters "\t\t" in + let () = dump_title () in let error, agent_string = - Handler.translate_agent parameters error kappa_handler agent_type + Handler.translate_agent parameters error kappa_handler + agent_type in let error, counter_string = match - Handler.translate_site parameters error kappa_handler agent_type counter + Handler.translate_site parameters error kappa_handler + agent_type counter with | error, Ckappa_sig.Counter x -> error, x - | error,(Ckappa_sig.Internal x | Ckappa_sig.Binding x) -> + | error, (Ckappa_sig.Internal x | Ckappa_sig.Binding x) -> Exception.warn parameters error __POS__ Exit x in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s Agent: %s ; Counter: %s" (Remanent_parameters.get_prefix parameters) - agent_string - counter_string + agent_string counter_string in let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) + Loggers.print_newline + (Remanent_parameters.get_logger parameters) in - let error = MI.affiche_mat parameters error new_prod in + let error = MI.affiche_mat parameters error prod in error - else + ) else error in + ( Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error (agent_type, counter) prod store_value, + completed_event_list ) + | error, Some old_prod -> + let error, old = MI.copy parameters error old_prod in + let error, (new_prod, var_list) = bin parameters error old prod in + if var_list = false then + (error, store_value), event_list + else ( + let error = + if + Remanent_parameters.get_dump_reachability_analysis_diff + parameters + then ( + let parameters = + Remanent_parameters.update_prefix parameters "\t\t" + in + let () = dump_title () in + let error, agent_string = + Handler.translate_agent parameters error kappa_handler + agent_type + in + let error, counter_string = + match + Handler.translate_site parameters error kappa_handler + agent_type counter + with + | error, Ckappa_sig.Counter x -> error, x + | error, (Ckappa_sig.Internal x | Ckappa_sig.Binding x) -> + Exception.warn parameters error __POS__ Exit x + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s Agent: %s ; Counter: %s" + (Remanent_parameters.get_prefix parameters) + agent_string counter_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + let error = MI.affiche_mat parameters error new_prod in + error + ) else + error + in - let error, completed_event_list = - update_event_list static error agent_type - counter event_list - in - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameters error - (agent_type, counter) - new_prod - store_value, - completed_event_list - in - let local = {local with store_value} in - error, {dynamic with local}, event_list - - let new_union static dynamic error agent_type counter prod event_list = - new_prod_gen MI.union_incr static dynamic error agent_type counter prod event_list - let new_widen static dynamic error agent_type counter prod event_list = - new_prod_gen MI.widen static dynamic error agent_type counter prod event_list - (*************************************************************) - - let prod_of_assignement parameters error assignement = - let list = List.rev_map fst assignement in - let error, prod = - MI.compt_of_var_list - parameters error - list - in - let error, prod = - List.fold_left - (fun (error, prod) (v,delta) -> - MI.push parameters error - prod v {Fraction.num=delta-1;Fraction.den=1}) - (error, prod) - assignement - in - error, prod - - let add_initial_state static dynamic error species = - let parameters = get_parameter static in - let compil = get_compil static in - let kappa_handler = get_kappa_handler static in - let packs = get_packs static in - let event_list = [] in - let dump_title () = - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%sUpdate information about counters" - (Remanent_parameters.get_prefix parameters) - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - Loggers.print_newline (Remanent_parameters.get_logger parameters) - else - () - in - (*parallel bonds in the initial states*) - let error, (dynamic, event_list) = - let enriched_init = species.Cckappa_sig.e_init_c_mixture in - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters - error - (fun parameters error _ag_id ag (dynamic, event_list) -> - match ag with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Dead_agent _ -> - Exception.warn - parameters error __POS__ Exit - (dynamic, event_list) - | Cckappa_sig.Agent ag -> - let agent_type = ag.Cckappa_sig.agent_name in - let error, assignements = - Counters_domain_static.convert_view - parameters error kappa_handler compil packs - agent_type (Some (Cckappa_sig.Agent ag)) - in - let error, dynamic, event_list = - List.fold_left - (fun (error, dynamic, event_list) - ((agent_type, counter),assignement) -> - let error, prod = - prod_of_assignement - parameters error assignement - in - new_union static dynamic error dump_title agent_type counter prod event_list) - (error, dynamic, event_list) - assignements - in - error, (dynamic, event_list) - ) - enriched_init.Cckappa_sig.views - (dynamic, event_list) - in - error, dynamic, event_list + let error, completed_event_list = + update_event_list static error agent_type counter event_list + in + ( Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error (agent_type, counter) new_prod store_value, + completed_event_list ) + ) + in + let local = { local with store_value } in + error, { dynamic with local }, event_list - (*************************************************************) - (* if a parallel bound occurs on the lhs, check that this is possible *) + let new_union static dynamic error agent_type counter prod event_list = + new_prod_gen MI.union_incr static dynamic error agent_type counter prod + event_list + let new_widen static dynamic error agent_type counter prod event_list = + new_prod_gen MI.widen static dynamic error agent_type counter prod + event_list (*************************************************************) - let restrict parameters error x test = - MI.guard parameters error x test - - let is_enabled static dynamic error (rule_id:Ckappa_sig.c_rule_id) - precondition = - let parameters = get_parameter static in - let rule_restriction = get_rule_restriction static in - (*-----------------------------------------------------------*) - let error, rule = get_rule parameters error static rule_id in - match rule with - | None -> - let error, () = - Exception.warn parameters error __POS__ Exit () - in - error, dynamic, None - | Some rule -> - let parameters = - Remanent_parameters.update_prefix parameters "\t\t" + let prod_of_assignement parameters error assignement = + let list = List.rev_map fst assignement in + let error, prod = MI.compt_of_var_list parameters error list in + let error, prod = + List.fold_left + (fun (error, prod) (v, delta) -> + MI.push parameters error prod v + { Fraction.num = delta - 1; Fraction.den = 1 }) + (error, prod) assignement in + error, prod + + let add_initial_state static dynamic error species = + let parameters = get_parameter static in + let compil = get_compil static in + let kappa_handler = get_kappa_handler static in + let packs = get_packs static in + let event_list = [] in let dump_title () = - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff parameters + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) @@ -537,23 +422,95 @@ module Functor = Loggers.print_newline (Remanent_parameters.get_logger parameters) in Loggers.print_newline (Remanent_parameters.get_logger parameters) - else + ) else () in - let lhs = - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views in - match - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error rule_id rule_restriction - with - | error, None -> error, dynamic, None - | error, Some map -> - let store_value = get_value dynamic in - let error, bool = - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.for_all - parameters error - (fun parameters error agent_id pack_map - -> + (*parallel bonds in the initial states*) + let error, (dynamic, event_list) = + let enriched_init = species.Cckappa_sig.e_init_c_mixture in + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold + parameters error + (fun parameters error _ag_id ag (dynamic, event_list) -> + match ag with + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Dead_agent _ -> + Exception.warn parameters error __POS__ Exit (dynamic, event_list) + | Cckappa_sig.Agent ag -> + let agent_type = ag.Cckappa_sig.agent_name in + let error, assignements = + Counters_domain_static.convert_view parameters error + kappa_handler compil packs agent_type + (Some (Cckappa_sig.Agent ag)) + in + let error, dynamic, event_list = + List.fold_left + (fun (error, dynamic, event_list) + ((agent_type, counter), assignement) -> + let error, prod = + prod_of_assignement parameters error assignement + in + new_union static dynamic error dump_title agent_type counter + prod event_list) + (error, dynamic, event_list) + assignements + in + error, (dynamic, event_list)) + enriched_init.Cckappa_sig.views (dynamic, event_list) + in + error, dynamic, event_list + + (*************************************************************) + (* if a parallel bound occurs on the lhs, check that this is possible *) + + (*************************************************************) + + let restrict parameters error x test = MI.guard parameters error x test + + let is_enabled static dynamic error (rule_id : Ckappa_sig.c_rule_id) + precondition = + let parameters = get_parameter static in + let rule_restriction = get_rule_restriction static in + (*-----------------------------------------------------------*) + let error, rule = get_rule parameters error static rule_id in + match rule with + | None -> + let error, () = Exception.warn parameters error __POS__ Exit () in + error, dynamic, None + | Some rule -> + let parameters = Remanent_parameters.update_prefix parameters "\t\t" in + let dump_title () = + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff + parameters + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sUpdate information about counters" + (Remanent_parameters.get_prefix parameters) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) else + () + in + let lhs = + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views + in + (match + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error rule_id rule_restriction + with + | error, None -> error, dynamic, None + | error, Some map -> + let store_value = get_value dynamic in + let error, bool = + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.for_all + parameters error + (fun parameters error agent_id pack_map -> let error, agent = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters error agent_id lhs @@ -564,133 +521,266 @@ module Functor = error, ag.Cckappa_sig.agent_name | None | Some - (Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ | - Cckappa_sig.Unknown_agent _) -> + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) -> Exception.warn parameters error __POS__ Exit - Ckappa_sig.dummy_agent_name + Ckappa_sig.dummy_agent_name in - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.for_all - parameters error - (fun parameters error counter restriction -> - match - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters error - (agent_type, counter) - store_value - with - | error, None -> - Exception.warn parameters error __POS__ Exit true - | error, Some x -> - let error, x' = MI.copy parameters error x in - let error, x_opt = - restrict parameters error x' - restriction.Counters_domain_type.tests - in - match x_opt with - | None -> - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then - let () = dump_title () in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%sBot detected" (Remanent_parameters.get_prefix parameters) - in - let error = MI.affiche_mat parameters error x' in - error, false - else - error, false - | Some _ -> error, true) - pack_map - ) - map - in - if bool - then - error, dynamic, Some precondition - else - error, dynamic, None - - (***********************************************************) - - let maybe_reachable static dynamic error _flag _pattern precondition = - (* non parallel bonds in a pattern can be maps to parallel ones through morphisms *) - (* thus when the flag is Morphisms with ignore non parallel bonds *) - let _parameters = get_parameter static in - let _store_value = get_value dynamic in - let error, bool = error, true in (* to do *) - if bool - then error, dynamic, Some precondition - else - error, dynamic, None - - -(*if it is not the first time it is apply then do not apply *) - - let can_we_prove_this_is_not_the_first_application precondition = - match - Communication.is_the_rule_applied_for_the_first_time precondition - with - | Usual_domains.Sure_value b -> - if b - then true - else false - | Usual_domains.Maybe -> false + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif + .for_all parameters error + (fun parameters error counter restriction -> + match + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type, counter) store_value + with + | error, None -> + Exception.warn parameters error __POS__ Exit true + | error, Some x -> + let error, x' = MI.copy parameters error x in + let error, x_opt = + restrict parameters error x' + restriction.Counters_domain_type.tests + in + (match x_opt with + | None -> + if + local_trace + || Remanent_parameters + .get_dump_reachability_analysis_diff parameters + then ( + let () = dump_title () in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sBot detected" + (Remanent_parameters.get_prefix parameters) + in + let error = MI.affiche_mat parameters error x' in + error, false + ) else + error, false + | Some _ -> error, true)) + pack_map) + map + in + if bool then + error, dynamic, Some precondition + else + error, dynamic, None) + + (***********************************************************) + + let maybe_reachable static dynamic error _flag _pattern precondition = + (* non parallel bonds in a pattern can be maps to parallel ones through morphisms *) + (* thus when the flag is Morphisms with ignore non parallel bonds *) + let _parameters = get_parameter static in + let _store_value = get_value dynamic in + let error, bool = error, true in + (* to do *) + if bool then + error, dynamic, Some precondition + else + error, dynamic, None + (*if it is not the first time it is apply then do not apply *) - let abstract_away parameters error x list = - MI.abstract_away parameters error x - (List.rev_map fst (List.rev list)) + let can_we_prove_this_is_not_the_first_application precondition = + match + Communication.is_the_rule_applied_for_the_first_time precondition + with + | Usual_domains.Sure_value b -> + if b then + true + else + false + | Usual_domains.Maybe -> false - let set parameters error x list = - let error, prod = - prod_of_assignement - parameters error list - in - match - MI.merge parameters error x prod - with - | error, None -> Exception.warn parameters error __POS__ Exit x - | error, Some a -> error, a + let abstract_away parameters error x list = + MI.abstract_away parameters error x (List.rev_map fst (List.rev list)) - let translate parameters error x list = - List.fold_left - (fun (error,x) (v,delta) -> - try - MI.push parameters error x v {Fraction.num=delta;Fraction.den=1} - with - Not_found -> - Exception.warn parameters error __POS__ Exit x - ) - (error, x) - list + let set parameters error x list = + let error, prod = prod_of_assignement parameters error list in + match MI.merge parameters error x prod with + | error, None -> Exception.warn parameters error __POS__ Exit x + | error, Some a -> error, a - let apply_rule static dynamic error rule_id precondition = - (*--------------------------------------------------------------*) - let parameters = get_parameter static in - let event_list = [] in - let rule_restriction = get_rule_restriction static in - let rule_creation = get_rule_creation static in - (*-----------------------------------------------------------*) - let error, rule = get_rule parameters error static rule_id in - let first_application = - can_we_prove_this_is_not_the_first_application - precondition - in - match rule with - | None -> - let error, () = - Exception.warn parameters error __POS__ Exit () - in - error, dynamic, (precondition, event_list) - | Some rule -> - let parameters = - Remanent_parameters.update_prefix parameters "\t\t" + let translate parameters error x list = + List.fold_left + (fun (error, x) (v, delta) -> + try + MI.push parameters error x v + { Fraction.num = delta; Fraction.den = 1 } + with Not_found -> Exception.warn parameters error __POS__ Exit x) + (error, x) list + + let apply_rule static dynamic error rule_id precondition = + (*--------------------------------------------------------------*) + let parameters = get_parameter static in + let event_list = [] in + let rule_restriction = get_rule_restriction static in + let rule_creation = get_rule_creation static in + (*-----------------------------------------------------------*) + let error, rule = get_rule parameters error static rule_id in + let first_application = + can_we_prove_this_is_not_the_first_application precondition in + match rule with + | None -> + let error, () = Exception.warn parameters error __POS__ Exit () in + error, dynamic, (precondition, event_list) + | Some rule -> + let parameters = Remanent_parameters.update_prefix parameters "\t\t" in + let dump_title () = + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff + parameters + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sUpdate information about counters" + (Remanent_parameters.get_prefix parameters) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) else + () + in + let lhs = + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views + in + (* regular updates *) + let error, dynamic, event_list = + match + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error rule_id rule_restriction + with + | error, None -> error, dynamic, event_list + | error, Some map -> + let error, (dynamic, event_list) = + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.fold + parameters error + (fun parameters error agent_id pack_map (dynamic, event_list) -> + let error, agent = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .get parameters error agent_id lhs + in + let error, agent_type = + match agent with + | Some (Cckappa_sig.Agent ag) -> + error, ag.Cckappa_sig.agent_name + | None + | Some + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_agent_name + in + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif + .fold parameters error + (fun parameters error counter restriction + (dynamic, event_list) -> + let store_value = get_value dynamic in + let error, x = + match + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type, counter) + store_value + with + | error, None -> + Exception.warn parameters error __POS__ Exit + (MI.create parameters 0) + | error, Some x -> error, x + in + let error, x' = MI.copy parameters error x in + let error, x_opt = + restrict parameters error x' + restriction.Counters_domain_type.tests + in + let error, x = + match x_opt with + | None -> + Exception.warn parameters error __POS__ Exit x' + | Some x -> error, x + in + let error, x = + abstract_away parameters error x + restriction + .Counters_domain_type.non_invertible_assignments + in + let error, x = + set parameters error x + restriction + .Counters_domain_type.non_invertible_assignments + in + let error, x = + translate parameters error x + restriction + .Counters_domain_type.invertible_assignments + in + let error, dynamic, event_list = + if first_application then + new_union static dynamic error dump_title agent_type + counter x event_list + else + new_widen static dynamic error dump_title agent_type + counter x event_list + in + error, (dynamic, event_list)) + pack_map (dynamic, event_list)) + map (dynamic, event_list) + in + error, dynamic, event_list + in + (* creation *) + let error, dynamic, event_list = + if first_application then ( + match + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error rule_id rule_creation + with + | error, None -> error, dynamic, event_list + | error, Some map -> + let error, (dynamic, event_list) = + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .fold parameters error + (fun parameters error (agent_type, counter) assignement_list + (dynamic, event_list) -> + List.fold_left + (fun (error, (dynamic, event_list)) assignement -> + let error, prod = + prod_of_assignement parameters error assignement + in + let error, dynamic, event_list = + new_union static dynamic error dump_title agent_type + counter prod event_list + in + error, (dynamic, event_list)) + (error, (dynamic, event_list)) + assignement_list) + map (dynamic, event_list) + in + error, dynamic, event_list + ) else + error, dynamic, event_list + in + error, dynamic, (precondition, event_list) + + let apply_one_side_effect static dynamic error _rule_id + (_, (agent, site, state)) precondition = + let parameters = get_parameter static in + let backward = get_backward_pointers static in let dump_title () = - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff parameters + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) @@ -701,411 +791,256 @@ module Functor = Loggers.print_newline (Remanent_parameters.get_logger parameters) in Loggers.print_newline (Remanent_parameters.get_logger parameters) - else + ) else () in - let lhs = - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views in - (* regular updates *) + let event_list = [] in let error, dynamic, event_list = match - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error rule_id rule_restriction + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameters error (agent, site) backward with | error, None -> error, dynamic, event_list - | error, Some map -> - let error, (dynamic, event_list) = - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error agent_id pack_map - (dynamic, event_list) -> - let error, agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get parameters error agent_id - lhs - in - let error, agent_type = - match agent with - | Some (Cckappa_sig.Agent ag) -> - error, ag.Cckappa_sig.agent_name - | None - | Some - (Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ | Cckappa_sig.Unknown_agent _) -> - Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_agent_name - in - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error counter restriction (dynamic, event_list) -> - let store_value = get_value dynamic in - let error, x = - match - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters error - (agent_type, counter) - store_value - with - | error, None -> - Exception.warn parameters error __POS__ Exit - (MI.create parameters 0) - | error, Some x -> error, x - in - let error, x' = MI.copy parameters error x in - let error, x_opt = - restrict parameters error x' - restriction.Counters_domain_type.tests - in - let error, x = - match x_opt with - | None -> - Exception.warn parameters error __POS__ Exit x' - | Some x -> error, x - in - let error, x = - abstract_away parameters error x - restriction.Counters_domain_type.non_invertible_assignments - in - let error, x = - set parameters error x - restriction.Counters_domain_type.non_invertible_assignments - in - let error, x = - translate parameters error x - restriction.Counters_domain_type.invertible_assignments - in - let error, dynamic, event_list = - if first_application then - new_union - static dynamic error dump_title - agent_type counter x event_list - else - new_widen - static dynamic error dump_title - agent_type counter x event_list - in - error, (dynamic, event_list) - ) - pack_map - (dynamic, event_list) - ) - map - (dynamic, event_list) - in - error, dynamic, event_list - in - (* creation *) - let error, dynamic, event_list = - if first_application - then - match - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error rule_id rule_creation - with - | error, None -> error, dynamic, event_list - | error, Some map -> - begin - let error, (dynamic, event_list) = - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.fold - parameters error - (fun parameters error (agent_type, counter) assignement_list - (dynamic, event_list) -> - List.fold_left - (fun (error, (dynamic, event_list)) assignement -> - let error, prod = - prod_of_assignement - parameters error assignement - in - let error, dynamic, event_list = - new_union static dynamic error dump_title agent_type counter - prod event_list - in error, (dynamic, event_list)) - (error, (dynamic, event_list)) assignement_list) - map - (dynamic, event_list) + | error, Some set -> + Ckappa_sig.Site_map_and_set.Set.fold + (fun counter (error, dynamic, event_list) -> + let value = get_value dynamic in + let guard = + [ Occu1.Bool (site, state), Counters_domain_type.EQ, 1 ] in - error, dynamic, event_list - end - else error, dynamic, event_list + let update = + [ + Occu1.Bool (site, state), -1; + Occu1.Bool (site, Ckappa_sig.state_index_of_int 0), 1; + ] + in + let error, x = + match + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent, counter) value + with + | error, None -> + Exception.warn parameters error __POS__ Exit + (MI.create parameters 0) + | error, Some x -> error, x + in + let error, x' = MI.copy parameters error x in + let error, x_opt = restrict parameters error x' guard in + let error, x = + match x_opt with + | None -> Exception.warn parameters error __POS__ Exit x' + | Some x -> error, x + in + let error, x = translate parameters error x update in + let error, dynamic, event_list = + new_union static dynamic error dump_title agent counter x + event_list + in + error, dynamic, event_list) + set + (error, dynamic, event_list) in error, dynamic, (precondition, event_list) - let apply_one_side_effect - static dynamic error - _rule_id (_,(agent,site,state)) precondition - = - let parameters = get_parameter static in - let backward = get_backward_pointers static in - let dump_title () = - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%sUpdate information about counters" - (Remanent_parameters.get_prefix parameters) - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - Loggers.print_newline (Remanent_parameters.get_logger parameters) - else - () - in - let event_list = [] in - let error, dynamic, event_list = - match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameters error - (agent,site) - backward - with - | error, None -> error, dynamic, event_list - | error, Some set -> - Ckappa_sig.Site_map_and_set.Set.fold - (fun counter (error,dynamic, event_list) -> - let value = get_value dynamic in - let guard = [Occu1.Bool (site, state), - Counters_domain_type.EQ, - 1] in - let update = [Occu1.Bool (site, state),-1; - Occu1.Bool (site, Ckappa_sig.state_index_of_int - 0),1] - in - let error, x = - match - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters error - (agent, counter) - value - with - | error, None -> - Exception.warn parameters error __POS__ Exit - (MI.create parameters 0) - | error, Some x -> error, x - in - let error, x' = MI.copy parameters error x in - let error, x_opt = restrict parameters error x' guard in - let error, x = - match x_opt with - | None -> - Exception.warn parameters error __POS__ Exit x' - | Some x -> error, x - in - let error, x = translate parameters error x update in - let error, dynamic, event_list = - new_union - static dynamic error dump_title - agent counter x event_list - in - error, dynamic, event_list) - set - (error, dynamic, event_list) - in - error, dynamic, (precondition, event_list) - - (*-----------------------------------------------------------*) - - let apply_event_list _static dynamic error _event_list = - error, dynamic, [] - - (****************************************************************) - - let stabilize static dynamic error = - let store_value = get_value dynamic in - let parameters = get_parameter static in - let error, store_value = - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.fold - parameters - error - (fun parameters error k prod store -> - let error, prod_opt = - MI.solve_all parameters error prod - in - match prod_opt with - | None -> - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.free parameters error - k - store - | Some a -> - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set parameters error - k a - store - ) - store_value - store_value - in - let dynamic = set_value store_value dynamic in - error, dynamic, () + (*-----------------------------------------------------------*) - let get_interval static error (agent_type,site) store_value = - let back = get_backward_pointers static in - let parameters = get_parameter static in - let error, back_site_opt = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters error (agent_type, site) back - in - let error, back_site = - match back_site_opt with - | None -> Exception.warn parameters error __POS__ Exit - Ckappa_sig.Site_map_and_set.Set.empty - | Some set -> error, set - in - Ckappa_sig.Site_map_and_set.Set.fold - (fun counter (error, intervalle_opt) -> - let error, mi_opt = - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters error (agent_type,counter) store_value - in - match mi_opt with - | Some new_mi -> - begin - let error, interv = - MI.interval_of_pro parameters error new_mi (Occu1.Counter site) - in - match intervalle_opt, interv with - | None, _ -> error, interv - | _, None -> error, intervalle_opt - | Some (a,b), Some (c,d) -> - error, Some (Fraction.ffmax a c, Fraction.ffmin b d) - end - | None -> - Exception.warn parameters error __POS__ Exit intervalle_opt - ) - back_site - (error, None) + let apply_event_list _static dynamic error _event_list = error, dynamic, [] + (****************************************************************) - let print ?dead_rules static dynamic (error:Exception.method_handler) loggers = - let _ = dead_rules in - let kappa_handler = get_kappa_handler static in - let counter_set = get_counters_set static in - let parameters = get_parameter static in - let log = loggers in - (*-------------------------------------------------------*) - let error = - if Remanent_parameters.get_dump_reachability_analysis_result - parameters - then - let () = - Loggers.fprintf log - "------------------------------------------------------------\n"; - Loggers.fprintf log "* Properties of counters\n"; - Loggers.fprintf log - "------------------------------------------------------------\n" - in - let store_value = get_value dynamic in - Ckappa_sig.AgentSite_map_and_set.Set.fold - (fun (agent_type, site) error -> - let error, intervalle_opt = - get_interval static error (agent_type, site) store_value - in - let error, agent_string = - Handler.translate_agent - parameters error - kappa_handler - agent_type - in - let error, site_string = - Handler.translate_site - parameters error kappa_handler - agent_type site - in - let error, site_string = - match site_string with - | Ckappa_sig.Counter x -> error, x - | (Ckappa_sig.Internal _ | Ckappa_sig.Binding _ ) -> - Exception.warn parameters error __POS__ Exit "" - in - let error,() = - match - intervalle_opt - with - | None - | Some (Fraction.Minfinity, Fraction.Infinity) - -> error, () - | Some (Fraction.Minfinity, Fraction.Frac f) -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s%s%s => %s%s%s%s%s%s%s%s%s%s%s" - agent_string - (Remanent_parameters.get_agent_open_symbol parameters) - (Remanent_parameters.get_agent_close_symbol parameters) - agent_string - (Remanent_parameters.get_agent_open_symbol parameters) - site_string - (Remanent_parameters.get_open_counter_state parameters) - (Remanent_parameters.get_open_int_interval_infinity_symbol parameters) - (Remanent_parameters.get_minus_infinity_symbol parameters) - (Remanent_parameters.get_int_interval_separator_symbol parameters) - (Fraction.string_of f) - (Remanent_parameters.get_close_int_interval_inclusive_symbol parameters) - (Remanent_parameters.get_close_counter_state parameters) - - (Remanent_parameters.get_agent_close_symbol parameters) - in - error, Loggers.print_newline - (Remanent_parameters.get_logger parameters) + let stabilize static dynamic error = + let store_value = get_value dynamic in + let parameters = get_parameter static in + let error, store_value = + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .fold parameters error + (fun parameters error k prod store -> + let error, prod_opt = MI.solve_all parameters error prod in + match prod_opt with + | None -> + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .free parameters error k store + | Some a -> + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error k a store) + store_value store_value + in + let dynamic = set_value store_value dynamic in + error, dynamic, () - | Some (Fraction.Frac f, Fraction.Infinity) -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s%s%s => %s%s%s%s%s%s%s%s%s%s%s" - agent_string - (Remanent_parameters.get_agent_open_symbol parameters) - (Remanent_parameters.get_agent_close_symbol parameters) - agent_string - (Remanent_parameters.get_agent_open_symbol parameters) - site_string - (Remanent_parameters.get_open_counter_state parameters) - (Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) - (Fraction.string_of f) - (Remanent_parameters.get_int_interval_separator_symbol parameters) - (Remanent_parameters.get_plus_infinity_symbol parameters) - (Remanent_parameters.get_close_int_interval_infinity_symbol parameters) - (Remanent_parameters.get_close_counter_state parameters) - (Remanent_parameters.get_agent_close_symbol parameters) - in - error, Loggers.print_newline - (Remanent_parameters.get_logger parameters) - | Some (Fraction.Frac f1, Fraction.Frac f2) -> - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - "%s%s%s => %s%s%s%s%s%s%s%s%s%s%s" - agent_string - (Remanent_parameters.get_agent_open_symbol parameters) - (Remanent_parameters.get_agent_close_symbol parameters) - agent_string - (Remanent_parameters.get_agent_open_symbol parameters) - site_string - (Remanent_parameters.get_open_counter_state parameters) - (Remanent_parameters.get_open_int_interval_inclusive_symbol parameters) - (Fraction.string_of f1) - (Remanent_parameters.get_int_interval_separator_symbol parameters) - (Fraction.string_of f2) - (Remanent_parameters.get_close_int_interval_inclusive_symbol parameters) - (Remanent_parameters.get_close_counter_state parameters) - (Remanent_parameters.get_agent_close_symbol parameters) - in - error, Loggers.print_newline - (Remanent_parameters.get_logger parameters) - | Some (Fraction.Unknown, _) | Some (_, Fraction.Unknown) - | Some (Fraction.Infinity, _) | Some (_, Fraction.Minfinity) - -> - Exception.warn parameters error __POS__ Exit - () - in - error) - counter_set error - else - error - in - error, dynamic, () + let get_interval static error (agent_type, site) store_value = + let back = get_backward_pointers static in + let parameters = get_parameter static in + let error, back_site_opt = + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type, site) back + in + let error, back_site = + match back_site_opt with + | None -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.Site_map_and_set.Set.empty + | Some set -> error, set + in + Ckappa_sig.Site_map_and_set.Set.fold + (fun counter (error, intervalle_opt) -> + let error, mi_opt = + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type, counter) store_value + in + match mi_opt with + | Some new_mi -> + let error, interv = + MI.interval_of_pro parameters error new_mi (Occu1.Counter site) + in + (match intervalle_opt, interv with + | None, _ -> error, interv + | _, None -> error, intervalle_opt + | Some (a, b), Some (c, d) -> + error, Some (Fraction.ffmax a c, Fraction.ffmin b d)) + | None -> Exception.warn parameters error __POS__ Exit intervalle_opt) + back_site (error, None) + + let print ?dead_rules static dynamic (error : Exception.method_handler) + loggers = + let _ = dead_rules in + let kappa_handler = get_kappa_handler static in + let counter_set = get_counters_set static in + let parameters = get_parameter static in + let log = loggers in + (*-------------------------------------------------------*) + let error = + if Remanent_parameters.get_dump_reachability_analysis_result parameters + then ( + let () = + Loggers.fprintf log + "------------------------------------------------------------\n"; + Loggers.fprintf log "* Properties of counters\n"; + Loggers.fprintf log + "------------------------------------------------------------\n" + in + let store_value = get_value dynamic in + Ckappa_sig.AgentSite_map_and_set.Set.fold + (fun (agent_type, site) error -> + let error, intervalle_opt = + get_interval static error (agent_type, site) store_value + in + let error, agent_string = + Handler.translate_agent parameters error kappa_handler + agent_type + in + let error, site_string = + Handler.translate_site parameters error kappa_handler agent_type + site + in + let error, site_string = + match site_string with + | Ckappa_sig.Counter x -> error, x + | Ckappa_sig.Internal _ | Ckappa_sig.Binding _ -> + Exception.warn parameters error __POS__ Exit "" + in + let error, () = + match intervalle_opt with + | None | Some (Fraction.Minfinity, Fraction.Infinity) -> + error, () + | Some (Fraction.Minfinity, Fraction.Frac f) -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s%s => %s%s%s%s%s%s%s%s%s%s%s" agent_string + (Remanent_parameters.get_agent_open_symbol parameters) + (Remanent_parameters.get_agent_close_symbol parameters) + agent_string + (Remanent_parameters.get_agent_open_symbol parameters) + site_string + (Remanent_parameters.get_open_counter_state parameters) + (Remanent_parameters.get_open_int_interval_infinity_symbol + parameters) + (Remanent_parameters.get_minus_infinity_symbol parameters) + (Remanent_parameters.get_int_interval_separator_symbol + parameters) + (Fraction.string_of f) + (Remanent_parameters + .get_close_int_interval_inclusive_symbol parameters) + (Remanent_parameters.get_close_counter_state parameters) + (Remanent_parameters.get_agent_close_symbol parameters) + in + ( error, + Loggers.print_newline + (Remanent_parameters.get_logger parameters) ) + | Some (Fraction.Frac f, Fraction.Infinity) -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s%s => %s%s%s%s%s%s%s%s%s%s%s" agent_string + (Remanent_parameters.get_agent_open_symbol parameters) + (Remanent_parameters.get_agent_close_symbol parameters) + agent_string + (Remanent_parameters.get_agent_open_symbol parameters) + site_string + (Remanent_parameters.get_open_counter_state parameters) + (Remanent_parameters + .get_open_int_interval_inclusive_symbol parameters) + (Fraction.string_of f) + (Remanent_parameters.get_int_interval_separator_symbol + parameters) + (Remanent_parameters.get_plus_infinity_symbol parameters) + (Remanent_parameters + .get_close_int_interval_infinity_symbol parameters) + (Remanent_parameters.get_close_counter_state parameters) + (Remanent_parameters.get_agent_close_symbol parameters) + in + ( error, + Loggers.print_newline + (Remanent_parameters.get_logger parameters) ) + | Some (Fraction.Frac f1, Fraction.Frac f2) -> + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s%s => %s%s%s%s%s%s%s%s%s%s%s" agent_string + (Remanent_parameters.get_agent_open_symbol parameters) + (Remanent_parameters.get_agent_close_symbol parameters) + agent_string + (Remanent_parameters.get_agent_open_symbol parameters) + site_string + (Remanent_parameters.get_open_counter_state parameters) + (Remanent_parameters + .get_open_int_interval_inclusive_symbol parameters) + (Fraction.string_of f1) + (Remanent_parameters.get_int_interval_separator_symbol + parameters) + (Fraction.string_of f2) + (Remanent_parameters + .get_close_int_interval_inclusive_symbol parameters) + (Remanent_parameters.get_close_counter_state parameters) + (Remanent_parameters.get_agent_close_symbol parameters) + in + ( error, + Loggers.print_newline + (Remanent_parameters.get_logger parameters) ) + | Some (Fraction.Unknown, _) + | Some (_, Fraction.Unknown) + | Some (Fraction.Infinity, _) + | Some (_, Fraction.Minfinity) -> + Exception.warn parameters error __POS__ Exit () + in + error) + counter_set error + ) else + error + in + error, dynamic, () - (***********************************************************) + (***********************************************************) - let export static dynamic error kasa_state = + let export static dynamic error kasa_state = let parameters = get_parameter static in let kappa_handler = get_kappa_handler static in let store_value = get_value dynamic in @@ -1120,68 +1055,63 @@ module Functor = in let error, internal_constraints_list = match internal_constraints_list with - | None -> - Exception.warn parameters error __POS__ Exit [] + | None -> Exception.warn parameters error __POS__ Exit [] | Some l -> error, l in let error, current_list = Ckappa_sig.AgentSite_map_and_set.Set.fold (fun (agent_type, site) (error, current_list) -> - let error, intervalle_opt = - get_interval static error (agent_type, site) store_value - in - match intervalle_opt with - | None - | Some (Fraction.Infinity, _ | _, Fraction.Minfinity - | Fraction.Unknown , _ | _, Fraction.Unknown) - -> - Exception.warn parameters error __POS__ Exit current_list - | Some (Fraction.Minfinity, Fraction.Infinity) -> - error, current_list - | Some ((Fraction.Frac _ | Fraction.Minfinity) as inf, - ((Fraction.Frac _ | Fraction.Infinity) as sup)) -> - let t = Site_graphs.KaSa_site_graph.empty in - let error', agent_id, t = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler agent_type t - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error, inf = - match inf with - | Fraction.Minfinity -> error, None - | Fraction.Infinity | Fraction.Unknown -> - Exception.warn parameters error __POS__ Exit None - | Fraction.Frac _ -> - error, Some (Fraction.floor_int inf) - in - let error, sup = - match sup with - | Fraction.Infinity -> error, None - | Fraction.Minfinity | Fraction.Unknown -> - Exception.warn parameters error __POS__ Exit None - | Fraction.Frac _-> - error, Some (Fraction.cell_int sup) - in - let error', t' = - Site_graphs.KaSa_site_graph.add_counter_range - parameters error kappa_handler agent_id site ?inf ?sup t - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - error, - { - Public_data.hyp = t; - Public_data.refinement = [t']; - }::current_list) - counters_set - (error, current_list) + let error, intervalle_opt = + get_interval static error (agent_type, site) store_value + in + match intervalle_opt with + | None + | Some + ( Fraction.Infinity, _ + | _, Fraction.Minfinity + | Fraction.Unknown, _ + | _, Fraction.Unknown ) -> + Exception.warn parameters error __POS__ Exit current_list + | Some (Fraction.Minfinity, Fraction.Infinity) -> + error, current_list + | Some + ( ((Fraction.Frac _ | Fraction.Minfinity) as inf), + ((Fraction.Frac _ | Fraction.Infinity) as sup) ) -> + let t = Site_graphs.KaSa_site_graph.empty in + let error', agent_id, t = + Site_graphs.KaSa_site_graph.add_agent parameters error + kappa_handler agent_type t + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, inf = + match inf with + | Fraction.Minfinity -> error, None + | Fraction.Infinity | Fraction.Unknown -> + Exception.warn parameters error __POS__ Exit None + | Fraction.Frac _ -> error, Some (Fraction.floor_int inf) + in + let error, sup = + match sup with + | Fraction.Infinity -> error, None + | Fraction.Minfinity | Fraction.Unknown -> + Exception.warn parameters error __POS__ Exit None + | Fraction.Frac _ -> error, Some (Fraction.cell_int sup) + in + let error', t' = + Site_graphs.KaSa_site_graph.add_counter_range parameters error + kappa_handler agent_id site ?inf ?sup t + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + ( error, + { Public_data.hyp = t; Public_data.refinement = [ t' ] } + :: current_list )) + counters_set (error, current_list) in let pair_list = (domain_name, List.rev current_list) :: internal_constraints_list @@ -1191,15 +1121,11 @@ module Functor = in error, dynamic, kasa_state - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects - -end + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects + end -module Domain_affine_equalities_and_intervalles = Functor(Mat_inter.Mat_int) -module Domain_octagons = Functor(Octo.Octo) -module Domain_non_relational = Functor(Non_rel.Non_rel) -module Domain_abstract_multisets = Functor(Mat_inter.Mat_int) (* to do *) +module Domain_affine_equalities_and_intervalles = Functor (Mat_inter.Mat_int) +module Domain_octagons = Functor (Octo.Octo) +module Domain_non_relational = Functor (Non_rel.Non_rel) +module Domain_abstract_multisets = Functor (Mat_inter.Mat_int) (* to do *) diff --git a/core/KaSa_rep/reachability_analysis/counters_domain.mli b/core/KaSa_rep/reachability_analysis/counters_domain.mli index 0701ff20bb..85e8ec6941 100644 --- a/core/KaSa_rep/reachability_analysis/counters_domain.mli +++ b/core/KaSa_rep/reachability_analysis/counters_domain.mli @@ -17,8 +17,7 @@ (** Abstract domain to over-approximate the set of reachable views *) - -module Domain_affine_equalities_and_intervalles:Analyzer_domain_sig.Domain -module Domain_octagons:Analyzer_domain_sig.Domain -module Domain_non_relational:Analyzer_domain_sig.Domain -module Domain_abstract_multisets:Analyzer_domain_sig.Domain +module Domain_affine_equalities_and_intervalles : Analyzer_domain_sig.Domain +module Domain_octagons : Analyzer_domain_sig.Domain +module Domain_non_relational : Analyzer_domain_sig.Domain +module Domain_abstract_multisets : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/counters_domain_static.ml b/core/KaSa_rep/reachability_analysis/counters_domain_static.ml index 0d86d0cdd7..c08ce95722 100644 --- a/core/KaSa_rep/reachability_analysis/counters_domain_static.ml +++ b/core/KaSa_rep/reachability_analysis/counters_domain_static.ml @@ -1,302 +1,287 @@ module EQUREL = - Union_find.Make (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif) + Union_find.Make + (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif) -let add_relation_one_step parameters error - ~agent_name ~source ~target array - = +let add_relation_one_step parameters error ~agent_name ~source ~target array = let error, old_set = match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get parameters error (agent_name,source) array + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameters error (agent_name, source) array with | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty | error, Some a -> error, a in let error, new_set = - Ckappa_sig.Site_map_and_set.Set.add_when_not_in parameters error - target old_set + Ckappa_sig.Site_map_and_set.Set.add_when_not_in parameters error target + old_set in - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set parameters error (agent_name,source) new_set array + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set + parameters error (agent_name, source) new_set array -let add_relation_two_steps parameters error - ~agent_name ~source ~target array - = +let add_relation_two_steps parameters error ~agent_name ~source ~target array = let error, old_map = match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters error agent_name array + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error agent_name array with | error, None -> - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create - parameters - error - 0 + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 | error, Some a -> error, a in let error, old_set = match - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters error source old_map + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error source old_map with - | error, None -> - error, Ckappa_sig.Site_map_and_set.Set.empty + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty | error, Some a -> error, a in let error, new_set = - Ckappa_sig.Site_map_and_set.Set.add_when_not_in parameters error - target old_set + Ckappa_sig.Site_map_and_set.Set.add_when_not_in parameters error target + old_set in let error, new_map = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set parameters error source new_set old_map + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set parameters error + source new_set old_map in - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters error agent_name new_map array - + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters error + agent_name new_map array -let add_dependence parameters error - ~agent_name ~site ~counter ~counter_set ~packs ~backward_dependences ~equivalence_relation = +let add_dependence parameters error ~agent_name ~site ~counter ~counter_set + ~packs ~backward_dependences ~equivalence_relation = let error, packs = - add_relation_two_steps - parameters error - ~agent_name ~source:counter ~target:site packs + add_relation_two_steps parameters error ~agent_name ~source:counter + ~target:site packs in let error, counter_set = - Ckappa_sig.AgentSite_map_and_set.Set.add_when_not_in - parameters error - (agent_name,counter) - counter_set + Ckappa_sig.AgentSite_map_and_set.Set.add_when_not_in parameters error + (agent_name, counter) counter_set in let error, backward_dependences = - add_relation_one_step - parameters error - ~agent_name~source:site ~target:counter - backward_dependences + add_relation_one_step parameters error ~agent_name ~source:site + ~target:counter backward_dependences in let error, equivalence_relation = - EQUREL.union_list - parameters - error - equivalence_relation - [agent_name,site;agent_name,counter] + EQUREL.union_list parameters error equivalence_relation + [ agent_name, site; agent_name, counter ] in - error, (counter_set, packs, backward_dependences,equivalence_relation) + error, (counter_set, packs, backward_dependences, equivalence_relation) let quotient_packs parameters error packs equivalence = let error, agent_array = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create - parameters error 1 + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 1 in let error, (equivalence, packs) = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_name site_map (equivalence, new_packs) -> - let error, new_site_map = - match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_name new_packs - with - | error, None -> - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters error 1 - | error, Some a -> error, a - in - let error, (equivalence, new_site_map) = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error site pack (equivalence, new_site_map) -> - let error, equivalence, (agent',site') = - EQUREL.get_representent - parameters error (agent_name,site) equivalence - in - let error, new_site_map = - if agent_name = agent' - then - let error, old_pack_opt = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - site' - new_site_map - in - let error, new_pack = - match old_pack_opt with None -> error, pack - | Some old_pack -> - Ckappa_sig.Site_map_and_set.Set.union - parameters error pack old_pack - in - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set - parameters error site' - new_pack new_site_map - else - Exception.warn parameters error __POS__ Exit new_site_map - in - error, (equivalence, new_site_map) - ) - site_map - (equivalence, new_site_map) - in - let error, new_agent_array = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set - parameters error agent_name new_site_map new_packs - in - error, (equivalence, new_agent_array) - ) - packs - (equivalence, agent_array) + let error, new_site_map = + match + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error agent_name new_packs + with + | error, None -> + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create + parameters error 1 + | error, Some a -> error, a + in + let error, (equivalence, new_site_map) = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.fold parameters + error + (fun parameters error site pack (equivalence, new_site_map) -> + let error, equivalence, (agent', site') = + EQUREL.get_representent parameters error (agent_name, site) + equivalence + in + let error, new_site_map = + if agent_name = agent' then ( + let error, old_pack_opt = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error site' new_site_map + in + let error, new_pack = + match old_pack_opt with + | None -> error, pack + | Some old_pack -> + Ckappa_sig.Site_map_and_set.Set.union parameters error + pack old_pack + in + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set + parameters error site' new_pack new_site_map + ) else + Exception.warn parameters error __POS__ Exit new_site_map + in + error, (equivalence, new_site_map)) + site_map + (equivalence, new_site_map) + in + let error, new_agent_array = + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_name new_site_map new_packs + in + error, (equivalence, new_agent_array)) + packs (equivalence, agent_array) in error, equivalence, packs let quotient_back parameters error back equivalence = let error, new_back = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create - parameters error - (1,1) + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameters error (1, 1) in let error, (equivalence, back) = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.fold - parameters error - (fun parameters error (agent_name, site) set (equivalence,new_back) -> - let error, equivalence, new_set = - Ckappa_sig.Site_map_and_set.Set.fold - (fun key (error, equivalence, new_set) -> - let error, equivalence, (agent_name',key') = - EQUREL.get_representent parameters error (agent_name,key) equivalence + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .fold parameters error + (fun parameters error (agent_name, site) set (equivalence, new_back) -> + let error, equivalence, new_set = + Ckappa_sig.Site_map_and_set.Set.fold + (fun key (error, equivalence, new_set) -> + let error, equivalence, (agent_name', key') = + EQUREL.get_representent parameters error (agent_name, key) + equivalence + in + if agent_name = agent_name' then ( + let error, new_set = + Ckappa_sig.Site_map_and_set.Set.add_when_not_in parameters + error key' new_set in - if agent_name = agent_name' - then - let error, new_set = - Ckappa_sig.Site_map_and_set.Set.add_when_not_in - parameters - error - key' - new_set - in - error, equivalence, new_set - else - let error, () = - Exception.warn parameters error __POS__ Exit () - in - error, equivalence, new_set) - set (error, equivalence, Ckappa_sig.Site_map_and_set.Set.empty) - in - let error, new_back = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set parameters error (agent_name, site) new_set new_back - in - error, (equivalence, new_back) - ) - back - (equivalence, new_back) + error, equivalence, new_set + ) else ( + let error, () = + Exception.warn parameters error __POS__ Exit () + in + error, equivalence, new_set + )) + set + (error, equivalence, Ckappa_sig.Site_map_and_set.Set.empty) + in + let error, new_back = + Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error (agent_name, site) new_set new_back + in + error, (equivalence, new_back)) + back (equivalence, new_back) in error, equivalence, back let quotient parameters error packs backward equivalence = - let error, equivalence, packs = quotient_packs parameters error packs equivalence in - let error, equivalence, backward = quotient_back parameters error backward equivalence in + let error, equivalence, packs = + quotient_packs parameters error packs equivalence + in + let error, equivalence, backward = + quotient_back parameters error backward equivalence + in error, equivalence, packs, backward let compute_packs parameters error handler compil = let error, packs = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in let error, backward_dependences = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create parameters error (0,0) - in - let counter_set = - Ckappa_sig.AgentSite_map_and_set.Set.empty - in - let error, equivalence_relation = - EQUREL.create parameters error (1,1) + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameters error (0, 0) in + let counter_set = Ckappa_sig.AgentSite_map_and_set.Set.empty in + let error, equivalence_relation = EQUREL.create parameters error (1, 1) in let error, (counter_set, packs, backward_dependences, equivalence_relation) = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error _rule_id rule - (counter_set, packs, backward_dependences,equivalence_relation) -> - let rule = rule.Cckappa_sig.e_rule_c_rule in - let actions = rule.Cckappa_sig.actions.Cckappa_sig.translate_counters in - let error, agents_with_counters = - List.fold_left - (fun - (error, map) (site_address,_) - -> - let error, is_counter = - Handler.is_counter - parameters error handler site_address.Cckappa_sig.agent_type site_address.Cckappa_sig.site - in - if is_counter (* the site is a counter *) - then - let ag_id = site_address.Cckappa_sig.agent_index in - let error, old = - Ckappa_sig.Agent_id_map_and_set.Map.find_default_without_logs - parameters error [] - ag_id - map - in - Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite - parameters error ag_id (site_address.Cckappa_sig.site::old) - map - - else - error, map - ) - (error, Ckappa_sig.Agent_id_map_and_set.Map.empty) - actions - in - let error, - (counter_set, packs, backward_dependences,equivalence_relation) = - Ckappa_sig.Agent_id_map_and_set.Map.fold - (fun - ag list_of_counters - (error, (counter_set, packs, backward_dependences,equivalence_relation)) - -> - match - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - ag - rule.Cckappa_sig.rule_rhs.Cckappa_sig.views - with - | error, None -> error, - (counter_set, - packs, - backward_dependences, - equivalence_relation) - | error, Some a -> - begin - match a with - | Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _ -> - error, - ( - counter_set, - packs, - backward_dependences, - equivalence_relation - ) - | Cckappa_sig.Agent ag -> - let agent_name = ag.Cckappa_sig.agent_name in - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ - (error, (counter_set, packs, backward_dependences,equivalence_relation)) -> - List.fold_left - (fun - (error, - (counter_set, - packs, backward_dependences,equivalence_relation)) - counter -> - add_dependence - parameters error - ~agent_name ~site ~counter ~counter_set ~packs ~backward_dependences - ~equivalence_relation) - (error, - (counter_set, packs, backward_dependences, equivalence_relation)) - list_of_counters - ) - ag.Cckappa_sig.agent_interface - (error, (counter_set, packs, backward_dependences, equivalence_relation)) - end - ) - agents_with_counters - (error, (counter_set, packs, backward_dependences, equivalence_relation)) - in - error, (counter_set, packs, backward_dependences, equivalence_relation) - ) + (counter_set, packs, backward_dependences, equivalence_relation) -> + let rule = rule.Cckappa_sig.e_rule_c_rule in + let actions = rule.Cckappa_sig.actions.Cckappa_sig.translate_counters in + let error, agents_with_counters = + List.fold_left + (fun (error, map) (site_address, _) -> + let error, is_counter = + Handler.is_counter parameters error handler + site_address.Cckappa_sig.agent_type + site_address.Cckappa_sig.site + in + if is_counter (* the site is a counter *) then ( + let ag_id = site_address.Cckappa_sig.agent_index in + let error, old = + Ckappa_sig.Agent_id_map_and_set.Map.find_default_without_logs + parameters error [] ag_id map + in + Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite parameters + error ag_id + (site_address.Cckappa_sig.site :: old) + map + ) else + error, map) + (error, Ckappa_sig.Agent_id_map_and_set.Map.empty) + actions + in + let ( error, + (counter_set, packs, backward_dependences, equivalence_relation) ) + = + Ckappa_sig.Agent_id_map_and_set.Map.fold + (fun ag list_of_counters + ( error, + ( counter_set, + packs, + backward_dependences, + equivalence_relation ) ) -> + match + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error ag + rule.Cckappa_sig.rule_rhs.Cckappa_sig.views + with + | error, None -> + ( error, + ( counter_set, + packs, + backward_dependences, + equivalence_relation ) ) + | error, Some a -> + (match a with + | Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ -> + ( error, + ( counter_set, + packs, + backward_dependences, + equivalence_relation ) ) + | Cckappa_sig.Agent ag -> + let agent_name = ag.Cckappa_sig.agent_name in + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _ + ( error, + ( counter_set, + packs, + backward_dependences, + equivalence_relation ) ) -> + List.fold_left + (fun ( error, + ( counter_set, + packs, + backward_dependences, + equivalence_relation ) ) counter -> + add_dependence parameters error ~agent_name ~site + ~counter ~counter_set ~packs ~backward_dependences + ~equivalence_relation) + ( error, + ( counter_set, + packs, + backward_dependences, + equivalence_relation ) ) + list_of_counters) + ag.Cckappa_sig.agent_interface + ( error, + ( counter_set, + packs, + backward_dependences, + equivalence_relation ) ))) + agents_with_counters + ( error, + (counter_set, packs, backward_dependences, equivalence_relation) + ) + in + error, (counter_set, packs, backward_dependences, equivalence_relation)) compil.Cckappa_sig.rules (counter_set, packs, backward_dependences, equivalence_relation) in @@ -305,413 +290,310 @@ let compute_packs parameters error handler compil = in error, (counter_set, packs, backward_dependences) - - let fold_counter_dep parameter error backward f agent_type site remanent = let error, dep_counters = match - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameter error - (agent_type,site) - backward + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameter error (agent_type, site) backward with - | error, None -> - error, Ckappa_sig.Site_map_and_set.Set.empty + | error, None -> error, Ckappa_sig.Site_map_and_set.Set.empty | error, Some a -> error, a in Ckappa_sig.Site_map_and_set.Set.fold (fun counter (error, remanent) -> - f parameter error agent_type counter site remanent) - dep_counters - (error, remanent) + f parameter error agent_type counter site remanent) + dep_counters (error, remanent) -let add_generic_in_agent_description - parameters error get set update counter agent_restriction = - let error, counter_restriction = - match - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error counter agent_restriction - with - | error, None -> error, - Counters_domain_type.empty_restriction - | error, Some a -> error, a - in - let specific = get counter_restriction in - let updated = update specific in - let counter_restriction = set updated counter_restriction in - let error, agent_restriction = - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error counter counter_restriction agent_restriction - in - error, agent_restriction +let add_generic_in_agent_description parameters error get set update counter + agent_restriction = + let error, counter_restriction = + match + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error counter agent_restriction + with + | error, None -> error, Counters_domain_type.empty_restriction + | error, Some a -> error, a + in + let specific = get counter_restriction in + let updated = update specific in + let counter_restriction = set updated counter_restriction in + let error, agent_restriction = + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error counter counter_restriction agent_restriction + in + error, agent_restriction -let add_test_in_agent_description - parameters errors test counter agent_restriction = - add_generic_in_agent_description - parameters errors - (fun x -> x.Counters_domain_type.tests) - (fun x y -> {y with Counters_domain_type.tests = x}) - (fun a -> test::a) - counter - agent_restriction +let add_test_in_agent_description parameters errors test counter + agent_restriction = + add_generic_in_agent_description parameters errors + (fun x -> x.Counters_domain_type.tests) + (fun x y -> { y with Counters_domain_type.tests = x }) + (fun a -> test :: a) + counter agent_restriction -let add_invertible_action_in_agent_description - parameters errors action counter agent_restriction = - add_generic_in_agent_description - parameters errors +let add_invertible_action_in_agent_description parameters errors action counter + agent_restriction = + add_generic_in_agent_description parameters errors (fun x -> x.Counters_domain_type.invertible_assignments) - (fun x y -> {y with Counters_domain_type.invertible_assignments = x}) - (fun a -> action::a) - counter - agent_restriction + (fun x y -> { y with Counters_domain_type.invertible_assignments = x }) + (fun a -> action :: a) + counter agent_restriction -let add_non_invertible_action_in_agent_description - parameters errors action counter agent_restriction = - add_generic_in_agent_description - parameters errors - (fun x -> x.Counters_domain_type.non_invertible_assignments) - (fun x y -> {y with Counters_domain_type.non_invertible_assignments = x}) - (fun a -> action::a) - counter - agent_restriction +let add_non_invertible_action_in_agent_description parameters errors action + counter agent_restriction = + add_generic_in_agent_description parameters errors + (fun x -> x.Counters_domain_type.non_invertible_assignments) + (fun x y -> { y with Counters_domain_type.non_invertible_assignments = x }) + (fun a -> action :: a) + counter agent_restriction let collect_tests parameters handler error ag_id ag backward restriction = let agent_type = ag.Cckappa_sig.agent_name in let view = ag.Cckappa_sig.agent_interface in let error, agent_restriction = match - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - ag_id - restriction + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters + error ag_id restriction with | error, None -> - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters - error 0 + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 | error, Some a -> error, a in let error, agent_restriction = Ckappa_sig.Site_map_and_set.Map.fold (fun site port (error, agent_restriction) -> - let error, is_counter = - Handler.is_counter parameters error handler - agent_type site in - if is_counter - then - error, agent_restriction - else - let interval = port.Cckappa_sig.site_state in - let error, max_state = Handler.last_state_of_site parameters error - handler agent_type site in - let add_test - parameter error - agent_type site agent_restriction state - cmp int = - fold_counter_dep - parameter error backward - (fun parameters error _agent_type counter site agent_restriction - -> - let test = Occu1.Bool (site, state), cmp, int in - add_test_in_agent_description - parameters error - test counter agent_restriction - ) - agent_type - site - agent_restriction - in - match interval.Cckappa_sig.min, interval.Cckappa_sig.max with - | Some a, Some b when a=b -> - let rec aux error k agent_restriction = - if Ckappa_sig.compare_state_index k max_state > 0 - then - let test = - Occu1.Site site, - Counters_domain_type.EQ, - Ckappa_sig.int_of_state_index a - in - fold_counter_dep - parameters error backward - (fun parameters error _agent_type counter _site agent_restriction - -> - add_test_in_agent_description - parameters error - test counter agent_restriction - ) - agent_type - site - agent_restriction - else + let error, is_counter = + Handler.is_counter parameters error handler agent_type site + in + if is_counter then + error, agent_restriction + else ( + let interval = port.Cckappa_sig.site_state in + let error, max_state = + Handler.last_state_of_site parameters error handler agent_type site + in + let add_test parameter error agent_type site agent_restriction state + cmp int = + fold_counter_dep parameter error backward + (fun parameters error _agent_type counter site agent_restriction -> + let test = Occu1.Bool (site, state), cmp, int in + add_test_in_agent_description parameters error test counter + agent_restriction) + agent_type site agent_restriction + in + match interval.Cckappa_sig.min, interval.Cckappa_sig.max with + | Some a, Some b when a = b -> + let rec aux error k agent_restriction = + if Ckappa_sig.compare_state_index k max_state > 0 then ( + let test = + ( Occu1.Site site, + Counters_domain_type.EQ, + Ckappa_sig.int_of_state_index a ) + in + fold_counter_dep parameters error backward + (fun parameters error _agent_type counter _site + agent_restriction -> + add_test_in_agent_description parameters error test counter + agent_restriction) + agent_type site agent_restriction + ) else ( let error, agent_restriction = - add_test - parameters error - agent_type site - agent_restriction - k Counters_domain_type.EQ (if k=a then 1 else 0) + add_test parameters error agent_type site agent_restriction k + Counters_domain_type.EQ + (if k = a then + 1 + else + 0) in aux error (Ckappa_sig.next_state_index k) agent_restriction - in - aux error (Ckappa_sig.state_index_of_int 0) agent_restriction - | Some a, Some b when a=Ckappa_sig.state_index_of_int 1 - && b = max_state -> - let error, agent_restriction = - add_test - parameters error - agent_type site - agent_restriction - (Ckappa_sig.state_index_of_int 0) Counters_domain_type.EQ 0 - in - let test = - Occu1.Site site, - Counters_domain_type.GTEQ, - 1 - in - fold_counter_dep - parameters error backward - (fun parameters error _agent_type counter _site agent_restriction - -> - add_test_in_agent_description - parameters error - test counter agent_restriction - ) - agent_type - site - agent_restriction - | (Some _ | None), (Some _ | None) -> - error, agent_restriction - ) - view - (error, agent_restriction) - in - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.set - parameters error - ag_id agent_restriction - restriction - + ) + in + aux error (Ckappa_sig.state_index_of_int 0) agent_restriction + | Some a, Some b + when a = Ckappa_sig.state_index_of_int 1 && b = max_state -> + let error, agent_restriction = + add_test parameters error agent_type site agent_restriction + (Ckappa_sig.state_index_of_int 0) + Counters_domain_type.EQ 0 + in + let test = Occu1.Site site, Counters_domain_type.GTEQ, 1 in + fold_counter_dep parameters error backward + (fun parameters error _agent_type counter _site agent_restriction -> + add_test_in_agent_description parameters error test counter + agent_restriction) + agent_type site agent_restriction + | (Some _ | None), (Some _ | None) -> error, agent_restriction + )) + view (error, agent_restriction) + in + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.set parameters error + ag_id agent_restriction restriction -let collect_updates parameters handler error ag_id agl diff_agr backward restriction = +let collect_updates parameters handler error ag_id agl diff_agr backward + restriction = let agent_type = agl.Cckappa_sig.agent_name in let viewl = agl.Cckappa_sig.agent_interface in let diffviewr = diff_agr.Cckappa_sig.agent_interface in let error, agent_restriction = match - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - ag_id - restriction + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters + error ag_id restriction with | error, None -> Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.create - parameters - error 0 + parameters error 0 | error, Some a -> error, a in - let add_invertible_action - parameter error - agent_type site agent_restriction state - action = - fold_counter_dep - parameter error backward - (fun parameters error _agent_type counter site agent_restriction - -> - let action = Occu1.Bool (site, state), action in - add_invertible_action_in_agent_description - parameters error - action counter agent_restriction - ) - agent_type - site - agent_restriction - in - let add_non_invertible_action - parameter error _handler - agent_type site agent_restriction state - action = - fold_counter_dep - parameter error backward - (fun parameters error _agent_type counter site agent_restriction - -> + let add_invertible_action parameter error agent_type site agent_restriction + state action = + fold_counter_dep parameter error backward + (fun parameters error _agent_type counter site agent_restriction -> + let action = Occu1.Bool (site, state), action in + add_invertible_action_in_agent_description parameters error action + counter agent_restriction) + agent_type site agent_restriction + in + let add_non_invertible_action parameter error _handler agent_type site + agent_restriction state action = + fold_counter_dep parameter error backward + (fun parameters error _agent_type counter site agent_restriction -> let action = Occu1.Bool (site, state), action in - add_non_invertible_action_in_agent_description - parameters error - action counter agent_restriction - ) - agent_type - site - agent_restriction + add_non_invertible_action_in_agent_description parameters error action + counter agent_restriction) + agent_type site agent_restriction in let error, agent_restriction = - Ckappa_sig.Site_map_and_set.Map.fold2 - parameters error + Ckappa_sig.Site_map_and_set.Map.fold2 parameters error (fun _ error _ _ agent_restriction -> error, agent_restriction) (fun parameters error _ _ agent_restriction -> - Exception.warn parameters error __POS__ Exit agent_restriction) + Exception.warn parameters error __POS__ Exit agent_restriction) (fun parameters error site portl portr agent_restriction -> - let error, is_counter = - Handler.is_counter parameters error handler - agent_type site in - if is_counter - then - error, agent_restriction - else - let intervall = portl.Cckappa_sig.site_state in - let intervalr = portr.Cckappa_sig.site_state in - match - intervalr.Cckappa_sig.min, intervalr.Cckappa_sig.max - with - | Some ar, Some br when ar=br -> - begin - match - intervall.Cckappa_sig.min, intervall.Cckappa_sig.max - with - | Some al, Some bl when al=bl -> + let error, is_counter = + Handler.is_counter parameters error handler agent_type site + in + if is_counter then + error, agent_restriction + else ( + let intervall = portl.Cckappa_sig.site_state in + let intervalr = portr.Cckappa_sig.site_state in + match intervalr.Cckappa_sig.min, intervalr.Cckappa_sig.max with + | Some ar, Some br when ar = br -> + (match intervall.Cckappa_sig.min, intervall.Cckappa_sig.max with + | Some al, Some bl when al = bl -> let action1 = ar, 1 in let action2 = al, -1 in let error, agent_restriction = List.fold_left - (fun (error, agent_restriction) (state,action) -> - add_invertible_action - parameters error - agent_type site agent_restriction state - action) - (error, agent_restriction) - [action1;action2] + (fun (error, agent_restriction) (state, action) -> + add_invertible_action parameters error agent_type site + agent_restriction state action) + (error, agent_restriction) [ action1; action2 ] in - fold_counter_dep - parameters error backward - (fun parameters error _agent_type counter site agent_restriction - -> - let action = Occu1.Site (site), - (Ckappa_sig.int_of_state_index ar)- - (Ckappa_sig.int_of_state_index al) - in - add_invertible_action_in_agent_description - parameters error - action counter agent_restriction - ) - agent_type - site - agent_restriction - - | Some al, Some bl -> - let rec declare_potential_updates - state list seen = - if Ckappa_sig.compare_state_index state bl > 0 - then list, seen - else - let list, seen = - if state = br - then - let list = (state, 1)::list in - let seen = true in - list, seen - else - let list = (state, 0)::list in - list, seen - in - declare_potential_updates - (Ckappa_sig.next_state_index state) - list seen - in - let list, seen = + fold_counter_dep parameters error backward + (fun parameters error _agent_type counter site agent_restriction -> + let action = + ( Occu1.Site site, + Ckappa_sig.int_of_state_index ar + - Ckappa_sig.int_of_state_index al ) + in + add_invertible_action_in_agent_description parameters error + action counter agent_restriction) + agent_type site agent_restriction + | Some al, Some bl -> + let rec declare_potential_updates state list seen = + if Ckappa_sig.compare_state_index state bl > 0 then + list, seen + else ( + let list, seen = + if state = br then ( + let list = (state, 1) :: list in + let seen = true in + list, seen + ) else ( + let list = (state, 0) :: list in + list, seen + ) + in declare_potential_updates - al - [] - false - in - let error, agent_restriction = - List.fold_left - (fun (error, agent_restriction) (state,bool) -> - add_non_invertible_action - parameters error handler - agent_type site agent_restriction - state bool) - (error, agent_restriction) - list - in - let error, agent_restriction = + (Ckappa_sig.next_state_index state) + list seen + ) + in + let list, seen = declare_potential_updates al [] false in + let error, agent_restriction = + List.fold_left + (fun (error, agent_restriction) (state, bool) -> + add_non_invertible_action parameters error handler + agent_type site agent_restriction state bool) + (error, agent_restriction) list + in + let error, agent_restriction = if seen then error, agent_restriction else - add_invertible_action - parameters error - agent_type site agent_restriction - ar 1 - in - fold_counter_dep - parameters error backward - (fun parameters error _agent_type counter site agent_restriction - -> - let action = Occu1.Site site, Ckappa_sig.int_of_state_index ar in - add_non_invertible_action_in_agent_description - parameters error - action counter agent_restriction - ) - agent_type - site - agent_restriction - - | None, _ | Some _ , None -> - add_non_invertible_action - parameters error handler - agent_type site agent_restriction ar - 1 - end - | (Some _ | None), (Some _ | None) -> - Exception.warn parameters error __POS__ Exit agent_restriction - ) - viewl - diffviewr - agent_restriction - in - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.set - parameters error - ag_id agent_restriction - restriction + add_invertible_action parameters error agent_type site + agent_restriction ar 1 + in + fold_counter_dep parameters error backward + (fun parameters error _agent_type counter site agent_restriction -> + let action = + Occu1.Site site, Ckappa_sig.int_of_state_index ar + in + add_non_invertible_action_in_agent_description parameters + error action counter agent_restriction) + agent_type site agent_restriction + | None, _ | Some _, None -> + add_non_invertible_action parameters error handler agent_type site + agent_restriction ar 1) + | (Some _ | None), (Some _ | None) -> + Exception.warn parameters error __POS__ Exit agent_restriction + )) + viewl diffviewr agent_restriction + in + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.set parameters error + ag_id agent_restriction restriction -let compute_rule_restrictions parameters error handler (_packs, backward) compil = +let compute_rule_restrictions parameters error handler (_packs, backward) compil + = let error, rule_restrictions = - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error rule_id rule rule_restrictions -> - let error, restriction = - match - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - rule_id - rule_restrictions - with - | error, None -> - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.create - parameters error - 0 - | error, Some a -> error, a - in - let error, restriction = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold2 - parameters error - (fun parameters error id l_view restriction -> - match l_view with - | (Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Dead_agent _ ) -> - (* nothing to do *) - error, restriction - | Cckappa_sig.Agent ag -> - let error, restriction = - collect_tests parameters handler error id ag backward restriction - in - error, restriction - ) - (fun parameters error _id _r_diff restriction -> + let error, restriction = + match + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error rule_id rule_restrictions + with + | error, None -> + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 + | error, Some a -> error, a + in + let error, restriction = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold2 + parameters error + (fun parameters error id l_view restriction -> + match l_view with + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Dead_agent _ -> + (* nothing to do *) + error, restriction + | Cckappa_sig.Agent ag -> + let error, restriction = + collect_tests parameters handler error id ag backward + restriction + in + error, restriction) + (fun parameters error _id _r_diff restriction -> Exception.warn parameters error __POS__ Exit restriction) - (fun parameters error id l_view r_diff restriction -> + (fun parameters error id l_view r_diff restriction -> match l_view, r_diff with - | (Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Dead_agent _ ), _ -> + | ( ( Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Dead_agent _ ), + _ ) -> (* nothing to do *) error, restriction | Cckappa_sig.Agent agl, diff_agr -> @@ -720,250 +602,220 @@ let compute_rule_restrictions parameters error handler (_packs, backward) compil restriction in let error, restriction = - collect_updates parameters handler error id agl diff_agr backward restriction - in - error, restriction - - ) - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.diff_direct - restriction - in - let error, restriction = - List.fold_left - (fun (error, restriction) (site_address,action) -> - let agent_id = site_address.Cckappa_sig.agent_index in - let agent_type = site_address.Cckappa_sig.agent_type in - let site = site_address.Cckappa_sig.site in - let error, agent_restriction = - match - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_id restriction - with - | error, None -> - Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 - | error, Some a -> error, a - in - let precondition = action.Cckappa_sig.precondition in - let translate = action.Cckappa_sig.increment in - let error, test = - match - precondition.Cckappa_sig.min, precondition.Cckappa_sig.max - with - | None, None -> error, None - | Some a, None -> error, Some (Counters_domain_type.GTEQ,a) - | None, Some a -> error, Some (Counters_domain_type.LTEQ,a) - | Some a,Some b when a=b -> error, Some (Counters_domain_type.EQ,a) - | Some _,Some _ -> - Exception.warn parameters error __POS__ Exit None - in - let error, agent_restriction = - match test with - | None -> error, agent_restriction - | Some (cmp,threshold) -> - let test = Occu1.Counter site, cmp, Ckappa_sig.int_of_state_index threshold in - fold_counter_dep - parameters error backward - (fun parameters error _agent_type counter _site agent_restriction - -> - add_test_in_agent_description - parameters error - test counter agent_restriction - ) - agent_type - site - agent_restriction - in - let error, agent_restriction = - if translate=0 - then error, agent_restriction - else - let action = Occu1.Counter site, translate in - fold_counter_dep - parameters error backward - (fun parameters error _agent_type counter _site agent_restriction - -> - add_invertible_action_in_agent_description - parameters error - action counter agent_restriction - ) - agent_type - site - agent_restriction + collect_updates parameters handler error id agl diff_agr + backward restriction in - Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.set - parameters error agent_id agent_restriction restriction - ) - (error, restriction) - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions.Cckappa_sig.translate_counters - in - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - rule_id restriction - rule_restrictions - ) - compil.Cckappa_sig.rules - rule_restrictions - + error, restriction) + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.diff_direct restriction + in + let error, restriction = + List.fold_left + (fun (error, restriction) (site_address, action) -> + let agent_id = site_address.Cckappa_sig.agent_index in + let agent_type = site_address.Cckappa_sig.agent_type in + let site = site_address.Cckappa_sig.site in + let error, agent_restriction = + match + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error agent_id restriction + with + | error, None -> + Ckappa_sig.Site_type_quick_nearly_Inf_Int_storage_Imperatif + .create parameters error 0 + | error, Some a -> error, a + in + let precondition = action.Cckappa_sig.precondition in + let translate = action.Cckappa_sig.increment in + let error, test = + match + precondition.Cckappa_sig.min, precondition.Cckappa_sig.max + with + | None, None -> error, None + | Some a, None -> error, Some (Counters_domain_type.GTEQ, a) + | None, Some a -> error, Some (Counters_domain_type.LTEQ, a) + | Some a, Some b when a = b -> + error, Some (Counters_domain_type.EQ, a) + | Some _, Some _ -> + Exception.warn parameters error __POS__ Exit None + in + let error, agent_restriction = + match test with + | None -> error, agent_restriction + | Some (cmp, threshold) -> + let test = + ( Occu1.Counter site, + cmp, + Ckappa_sig.int_of_state_index threshold ) + in + fold_counter_dep parameters error backward + (fun parameters error _agent_type counter _site + agent_restriction -> + add_test_in_agent_description parameters error test counter + agent_restriction) + agent_type site agent_restriction + in + let error, agent_restriction = + if translate = 0 then + error, agent_restriction + else ( + let action = Occu1.Counter site, translate in + fold_counter_dep parameters error backward + (fun parameters error _agent_type counter _site + agent_restriction -> + add_invertible_action_in_agent_description parameters error + action counter agent_restriction) + agent_type site agent_restriction + ) + in + Ckappa_sig.Agent_id_nearly_Inf_Int_storage_Imperatif.set parameters + error agent_id agent_restriction restriction) + (error, restriction) + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions + .Cckappa_sig.translate_counters + in + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error rule_id restriction rule_restrictions) + compil.Cckappa_sig.rules rule_restrictions let convert_view parameters error handler compil packs agent_type ag = - match - ag - with -| (Some (Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent _ - | Cckappa_sig.Unknown_agent _) - | None) -> - Exception.warn parameters error __POS__ Exit [] -| Some (Cckappa_sig.Agent ag_r) -> - begin - match - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - agent_type - packs - with + match ag with + | Some + ( Cckappa_sig.Ghost | Cckappa_sig.Dead_agent _ + | Cckappa_sig.Unknown_agent _ ) + | None -> + Exception.warn parameters error __POS__ Exit [] + | Some (Cckappa_sig.Agent ag_r) -> + (match + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error agent_type packs + with | error, None -> error, [] | error, Some agent_packs -> - let interface_r = - ag_r.Cckappa_sig.agent_interface - in - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.fold - parameters error + let interface_r = ag_r.Cckappa_sig.agent_interface in + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error counter site_set list -> - let error, interface = - Ckappa_sig.Site_map_and_set.Set.fold - (fun site (error,interface) -> - let error, is_counter = - Handler.is_counter - parameters error handler agent_type site - in - let error, state = - match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters error - site - interface_r - with - | error, None -> - if is_counter - then - begin - match - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_type,site) - compil.Cckappa_sig.counter_default - with - | error, (None | Some None) -> error, Ckappa_sig.state_index_of_int 0 - | error, Some (Some a) -> error, a - end - else error, Ckappa_sig.state_index_of_int 0 - | error, Some port -> + let error, interface = + Ckappa_sig.Site_map_and_set.Set.fold + (fun site (error, interface) -> + let error, is_counter = + Handler.is_counter parameters error handler agent_type site + in + let error, state = + match + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs + parameters error site interface_r + with + | error, None -> + if is_counter then ( match - port.Cckappa_sig.site_state.Cckappa_sig.min, - port.Cckappa_sig.site_state.Cckappa_sig.max - with Some a, Some b when a=b -> - error, a - | (Some _ | None), (Some _ | None) -> - Exception.warn parameters error __POS__ - Exit (Ckappa_sig.state_index_of_int 0) + Ckappa_sig.AgentSite_map_and_set.Map + .find_option_without_logs parameters error + (agent_type, site) compil.Cckappa_sig.counter_default + with + | error, (None | Some None) -> + error, Ckappa_sig.state_index_of_int 0 + | error, Some (Some a) -> error, a + ) else + error, Ckappa_sig.state_index_of_int 0 + | error, Some port -> + (match + ( port.Cckappa_sig.site_state.Cckappa_sig.min, + port.Cckappa_sig.site_state.Cckappa_sig.max ) + with + | Some a, Some b when a = b -> error, a + | (Some _ | None), (Some _ | None) -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.state_index_of_int 0)) + in + if is_counter then + ( error, + (Occu1.Counter site, Ckappa_sig.int_of_state_index state) + :: interface ) + else ( + let error, last_state = + Handler.last_state_of_site parameters error handler + agent_type site in - if is_counter - then - error, (Occu1.Counter site, - Ckappa_sig.int_of_state_index state)::interface - else - let error, last_state = - Handler.last_state_of_site parameters error handler agent_type site - in - let rec aux k interface = - if Ckappa_sig.compare_state_index k last_state > 0 - then interface - else - let pred = Occu1.Bool (site,k) in - let interface = - if k=state then - (pred,1)::interface - else - (pred,0)::interface - in - aux (Ckappa_sig.next_state_index k) interface - in - error, + let rec aux k interface = + if Ckappa_sig.compare_state_index k last_state > 0 then + interface + else ( + let pred = Occu1.Bool (site, k) in + let interface = + if k = state then + (pred, 1) :: interface + else + (pred, 0) :: interface + in + aux (Ckappa_sig.next_state_index k) interface + ) + in + ( error, aux (Ckappa_sig.state_index_of_int 0) - ((Occu1.Site (site), Ckappa_sig.int_of_state_index state)::interface) - - ) - site_set - (error,[]) - in - error, - ((agent_type, counter), interface)::list - ) - agent_packs - [] - end + ((Occu1.Site site, Ckappa_sig.int_of_state_index state) + :: interface) ) + )) + site_set (error, []) + in + error, ((agent_type, counter), interface) :: list) + agent_packs []) let compute_rule_creation parameters error handler (packs, _backward) compil = let error, creation = - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 - in - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters - error - (fun parameters error rule_id rule rule_creations -> - let error, creation = - match - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - rule_id - rule_creations - with - | error, None -> - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.create - parameters error (0,0) - | error, Some a -> error, a - in - let error, creation = - List.fold_left - (fun (error, creation) (ag_id, agent_type) -> + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 + in + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error + (fun parameters error rule_id rule rule_creations -> + let error, creation = + match + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get + parameters error rule_id rule_creations + with + | error, None -> + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .create parameters error (0, 0) + | error, Some a -> error, a + in + let error, creation = + List.fold_left + (fun (error, creation) (ag_id, agent_type) -> let error, ag_r = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - ag_id - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs.Cckappa_sig.views + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error ag_id + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_rhs + .Cckappa_sig.views in let error, list = - convert_view parameters error handler compil packs agent_type - ag_r + convert_view parameters error handler compil packs agent_type ag_r in List.fold_left (fun (error, creation) ((agent_type, counter), interface) -> - let error, old = - match - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameters error (agent_type,counter) creation - with - | error, Some l -> error, l - | error, None -> error, [] - in - Ckappa_sig.Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.set - parameters error (agent_type,counter) (interface::old) creation) - (error, creation) list - ) - (error, creation) - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions.Cckappa_sig.creation - in - Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - rule_id creation - rule_creations) - compil.Cckappa_sig.rules - creation - + let error, old = + match + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameters error (agent_type, counter) creation + with + | error, Some l -> error, l + | error, None -> error, [] + in + Ckappa_sig + .Agent_type_site_quick_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .set parameters error (agent_type, counter) (interface :: old) + creation) + (error, creation) list) + (error, creation) + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.actions + .Cckappa_sig.creation + in + Ckappa_sig.Rule_id_quick_nearly_Inf_Int_storage_Imperatif.set parameters + error rule_id creation rule_creations) + compil.Cckappa_sig.rules creation let compute_static parameters error handler compil = let error, (counter_set, packs, backward) = @@ -975,13 +827,11 @@ let compute_static parameters error handler compil = let error, rule_creation = compute_rule_creation parameters error handler (packs, backward) compil in - error, - { - Counters_domain_type.counters = counter_set ; - Counters_domain_type.packs = packs ; - Counters_domain_type.backward_pointers = backward ; - Counters_domain_type.rule_restrictions = - rule_restrictions ; - Counters_domain_type.rule_creation = - rule_creation ; - } + ( error, + { + Counters_domain_type.counters = counter_set; + Counters_domain_type.packs; + Counters_domain_type.backward_pointers = backward; + Counters_domain_type.rule_restrictions; + Counters_domain_type.rule_creation; + } ) diff --git a/core/KaSa_rep/reachability_analysis/counters_domain_static.mli b/core/KaSa_rep/reachability_analysis/counters_domain_static.mli index 155be8161d..abbc36eae6 100644 --- a/core/KaSa_rep/reachability_analysis/counters_domain_static.mli +++ b/core/KaSa_rep/reachability_analysis/counters_domain_static.mli @@ -1,20 +1,22 @@ -val compute_static: - Remanent_parameters_sig.parameters -> Exception.method_handler -> +val compute_static : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> Exception.method_handler * Counters_domain_type.static -val convert_view: - Remanent_parameters_sig.parameters -> Exception.method_handler -> +val convert_view : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> Cckappa_sig.kappa_handler -> Cckappa_sig.compil -> Ckappa_sig.Site_map_and_set.Set.t - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t -> + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.t -> Ckappa_sig.c_agent_name -> Cckappa_sig.agent option -> - Exception.method_handler * - ((Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.key * - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.key) * - (Occu1.trans * int) list) + Exception.method_handler + * ((Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.key + * Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.key) + * (Occu1.trans * int) list) list diff --git a/core/KaSa_rep/reachability_analysis/covering_classes_main.ml b/core/KaSa_rep/reachability_analysis/covering_classes_main.ml index 86c55c4b67..c49c0bdfc1 100644 --- a/core/KaSa_rep/reachability_analysis/covering_classes_main.ml +++ b/core/KaSa_rep/reachability_analysis/covering_classes_main.ml @@ -18,164 +18,144 @@ let trace = false let compare_unit_covering_class_id _ _ = Covering_classes_type.dummy_cv_id -let collect_modified_map parameters error kappa_handler diff_reverse store_modified_map = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error +let collect_modified_map parameters error kappa_handler diff_reverse + store_modified_map = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id site_modif store_modified_map -> - let agent_type = site_modif.Cckappa_sig.agent_name in - let error, old_map = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - store_modified_map - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Map.empty - | error, Some m -> error, m - in - let error', new_map = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _port (error,current_map) -> - (*store site map*) - let error, b = - Handler.is_counter parameters error kappa_handler - agent_type site + let agent_type = site_modif.Cckappa_sig.agent_name in + let error, old_map = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_modified_map + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Map.empty + | error, Some m -> error, m + in + let error', new_map = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _port (error, current_map) -> + (*store site map*) + let error, b = + Handler.is_counter parameters error kappa_handler agent_type site + in + if b then + error, current_map + else ( + let error, site_map = + Ckappa_sig.Site_map_and_set.Map.add_or_overwrite parameters + error site site current_map in - if b then error, current_map - else - let error,site_map = - Ckappa_sig.Site_map_and_set.Map.add_or_overwrite - parameters - error - site - site - current_map - in - error,site_map) - site_modif.Cckappa_sig.agent_interface - (error, old_map) - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - (*compute site_map*) - (*store*) - let error', store_modified_map = - if Ckappa_sig.Site_map_and_set.Map.is_empty new_map - then - error, store_modified_map - else - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_map - store_modified_map - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error, store_modified_map - ) diff_reverse - store_modified_map + error, site_map + )) + site_modif.Cckappa_sig.agent_interface (error, old_map) + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + (*compute site_map*) + (*store*) + let error', store_modified_map = + if Ckappa_sig.Site_map_and_set.Map.is_empty new_map then + error, store_modified_map + else + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type new_map store_modified_map + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + error, store_modified_map) + diff_reverse store_modified_map (*-------------------------------------------------------------------------*) (*compute covering classes, site test and bdu*) -let collect_covering_classes_regular parameters error kappa_handler views diff_reverse store_result = +let collect_covering_classes_regular parameters error kappa_handler views + diff_reverse store_result = let error, store_result = Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold2_common parameters error (fun parameters error _agent_id agent site_modif store_result -> - (* if in the interface there is no site modified then do nothing *) - if Ckappa_sig.Site_map_and_set.Map.is_empty - site_modif.Cckappa_sig.agent_interface - then error, store_result - else - match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ -> error, store_result - | Cckappa_sig.Dead_agent (agent, _, _, _) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - (*get a list of sites from an interface at each rule*) - let error, site_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ (error, current_list) -> - let error, b = Handler.is_counter parameters error kappa_handler agent_type site in - if b then error, current_list - else - error, site :: current_list - ) agent.Cckappa_sig.agent_interface (error, []) - in - (*compute covering_class*) - match site_list with - | [] -> error, store_result - | _ -> - let error, old_list = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - store_result - with - | error, None -> error, [] - | error, Some l -> error, l - in - let new_pair_list = (List.rev site_list) :: old_list in - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_pair_list - store_result - in - error, store_result - ) views diff_reverse store_result - in error, store_result + (* if in the interface there is no site modified then do nothing *) + if + Ckappa_sig.Site_map_and_set.Map.is_empty + site_modif.Cckappa_sig.agent_interface + then + error, store_result + else ( + match agent with + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ -> + error, store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + (*get a list of sites from an interface at each rule*) + let error, site_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _ (error, current_list) -> + let error, b = + Handler.is_counter parameters error kappa_handler agent_type + site + in + if b then + error, current_list + else + error, site :: current_list) + agent.Cckappa_sig.agent_interface (error, []) + in + (*compute covering_class*) + (match site_list with + | [] -> error, store_result + | _ -> + let error, old_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result + with + | error, None -> error, [] + | error, Some l -> error, l + in + let new_pair_list = List.rev site_list :: old_list in + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type new_pair_list store_result + in + error, store_result) + )) + views diff_reverse store_result + in + error, store_result -let collect_covering_classes_side_effects parameters error _kappa_handler remove store_result = +let collect_covering_classes_side_effects parameters error _kappa_handler remove + store_result = List.fold_left - (fun (error, store_result) (_,agent,list) -> - let declared = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ list -> site::list) - agent.Cckappa_sig.agent_interface - [] - in - let declared = List.rev declared in - let error, old_list = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent.Cckappa_sig.agent_name - store_result - with - | error, None -> error, [] - | error, Some l -> error, l - in - let new_list = - List.fold_left - (fun new_list site -> - (List.merge Ckappa_sig.compare_site_name declared [site])::new_list - ) - old_list - list - in - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent.Cckappa_sig.agent_name - new_list - store_result) - (error, store_result) - remove - + (fun (error, store_result) (_, agent, list) -> + let declared = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _ list -> site :: list) + agent.Cckappa_sig.agent_interface [] + in + let declared = List.rev declared in + let error, old_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent.Cckappa_sig.agent_name store_result + with + | error, None -> error, [] + | error, Some l -> error, l + in + let new_list = + List.fold_left + (fun new_list site -> + List.merge Ckappa_sig.compare_site_name declared [ site ] + :: new_list) + old_list list + in + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent.Cckappa_sig.agent_name new_list store_result) + (error, store_result) remove (************************************************************************************) (*compute covering class: it is a covering class whenever there is a @@ -195,39 +175,28 @@ let scan_rule_covering_classes parameters error kappa_handler rule classes = (*----------------------------------------------------------------------*) (*compute modified map*) let error, store_modified_map = - collect_modified_map - parameters - error - kappa_handler + collect_modified_map parameters error kappa_handler rule.Cckappa_sig.diff_reverse classes.Covering_classes_type.store_modified_map in (*----------------------------------------------------------------------*) (*compute covering_class*) let error, store_covering_classes = - collect_covering_classes_regular - parameters - error - kappa_handler - rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - rule.Cckappa_sig.diff_reverse + collect_covering_classes_regular parameters error kappa_handler + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views rule.Cckappa_sig.diff_reverse classes.Covering_classes_type.store_covering_classes in let error, store_covering_classes = - collect_covering_classes_side_effects - parameters - error - kappa_handler - rule.Cckappa_sig.actions.Cckappa_sig.remove - store_covering_classes + collect_covering_classes_side_effects parameters error kappa_handler + rule.Cckappa_sig.actions.Cckappa_sig.remove store_covering_classes in (*----------------------------------------------------------------------*) (*result*) - error, - { - Covering_classes_type.store_modified_map = store_modified_map; - Covering_classes_type.store_covering_classes = store_covering_classes; - } + ( error, + { + Covering_classes_type.store_modified_map; + Covering_classes_type.store_covering_classes; + } ) (***************************************************************************) (*RULES*) @@ -235,82 +204,69 @@ let scan_rule_covering_classes parameters error kappa_handler rule classes = let scan_rule_set_covering_classes parameters error handler rules = let n_agents = handler.Cckappa_sig.nagents in let error, init_modif_map = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key parameters error n_agents in + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameters error n_agents + in let error, init_class = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key parameters error n_agents in + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameters error n_agents + in (*----------------------------------------------------------------------*) (* add each singleton as a covering class *) let error, init_class = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold - parameters - error + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_type b init_class -> - Ckappa_sig.Dictionary_of_sites.fold - (fun _ _ b (error, init_class) -> - let error, bool = - Handler.is_counter parameters error handler - agent_type b + Ckappa_sig.Dictionary_of_sites.fold + (fun _ _ b (error, init_class) -> + let error, bool = + Handler.is_counter parameters error handler agent_type b + in + if bool then + error, init_class + else ( + let error, l' = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type init_class + with + | error, None -> error, [ [ b ] ] + | error, Some l -> error, [ b ] :: l in - if bool then error, init_class - else - let error, l' = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - init_class - with - | error,None -> error, [[b]] - | error,Some l -> error, [b]::l - in - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - l' - init_class - ) - b (error, init_class) - ) - handler.Cckappa_sig.sites - init_class + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type l' init_class + )) + b (error, init_class)) + handler.Cckappa_sig.sites init_class in (*-----------------------------------------------------------------------*) (*init state of covering class*) let init_class = { - Covering_classes_type.store_modified_map = init_modif_map; + Covering_classes_type.store_modified_map = init_modif_map; Covering_classes_type.store_covering_classes = init_class; } in (*---------------------------------------------------------------------*) (*map each agent to a list of covering classes*) let error, store_covering_classes = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error _rule_id rule classes -> - let error, result = - scan_rule_covering_classes - parameters - error - handler - rule.Cckappa_sig.e_rule_c_rule - classes - in - error, result - ) rules init_class + let error, result = + scan_rule_covering_classes parameters error handler + rule.Cckappa_sig.e_rule_c_rule classes + in + error, result) + rules init_class in error, store_covering_classes (***************************************************************************) (*clean covering classes*) -let length_sorted (l: Ckappa_sig.c_site_name list list): - Ckappa_sig.c_site_name list list = +let length_sorted (l : Ckappa_sig.c_site_name list list) : + Ckappa_sig.c_site_name list list = let list_length = List.rev_map (fun list -> list, List.length list) l in - let lists = - List.sort (fun a b -> compare (snd a) (snd b)) list_length in + let lists = List.sort (fun a b -> compare (snd a) (snd b)) list_length in List.rev_map fst lists (******************************************************************************) @@ -318,75 +274,61 @@ let length_sorted (l: Ckappa_sig.c_site_name list list): let store_remanent parameters error covering_class _modified_map remanent = (* current state of remanent*) - let pointer_backward = - remanent.Covering_classes_type.store_pointer_backward in + let pointer_backward = + remanent.Covering_classes_type.store_pointer_backward + in let good_covering_class = remanent.Covering_classes_type.store_dic in (*-------------------------------------------------------------------------*) (*covering class dictionary*) let error, output = - Covering_classes_type.Dictionary_of_List_sites.allocate - parameters - error - compare_unit_covering_class_id - covering_class (*value: c_site_name list*) - () - Misc_sa.const_unit - good_covering_class + Covering_classes_type.Dictionary_of_List_sites.allocate parameters error + compare_unit_covering_class_id covering_class (*value: c_site_name list*) + () Misc_sa.const_unit good_covering_class in let error, (cv_id, store_dic) = match output with | Some (id, _, _, dic) -> error, (id, dic) | None -> - Exception.warn - parameters error __POS__ Exit + Exception.warn parameters error __POS__ Exit (Covering_classes_type.dummy_cv_id, good_covering_class) in (*-----------------------------------------------------------------------*) (*store pointer backward*) let error, pointer_backward = - List.fold_left (fun (error, pointer_backward) old_cv_id -> + List.fold_left + (fun (error, pointer_backward) old_cv_id -> let error, old_cv_set = match Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - old_cv_id - pointer_backward + parameters error old_cv_id pointer_backward with | error, None -> error, Covering_classes_type.CV_map_and_set.Set.empty | error, Some s -> error, s in let error', new_cv_set = - Covering_classes_type.CV_map_and_set.Set.add - parameters - error - cv_id + Covering_classes_type.CV_map_and_set.Set.add parameters error cv_id old_cv_set in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ + Exit in let error, pointer_backward = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set - parameters - error - old_cv_id (*int*) + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set parameters + error old_cv_id (*int*) new_cv_set (*set of int*) pointer_backward in - error, pointer_backward - ) - (error, pointer_backward) - covering_class + error, pointer_backward) + (error, pointer_backward) covering_class in (*--------------------------------------------------------------------*) (*result*) - error, - { - Covering_classes_type.store_pointer_backward = pointer_backward; - Covering_classes_type.store_dic = store_dic; - } + ( error, + { + Covering_classes_type.store_pointer_backward = pointer_backward; + Covering_classes_type.store_dic; + } ) (*--------------------------------------------------------------------------*) (*CLEAN: In a covering class, it will store the old result of the previous @@ -401,7 +343,8 @@ let store_remanent parameters error covering_class _modified_map remanent = let clean_classes parameters error covering_classes modified_map = let error, init_pointer = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in let init_store_dic = Covering_classes_type.Dictionary_of_List_sites.init () in (*------------------------------------------------------------------------*) @@ -409,17 +352,20 @@ let clean_classes parameters error covering_classes modified_map = let init_remanent = { Covering_classes_type.store_pointer_backward = init_pointer; - Covering_classes_type.store_dic = init_store_dic; + Covering_classes_type.store_dic = init_store_dic; } in (*------------------------------------------------------------------------*) (*cleaning*) let current_covering_classes = length_sorted covering_classes in - List.fold_left (fun (error, remanent) covering_class -> + List.fold_left + (fun (error, remanent) covering_class -> match covering_class with | [] -> error, remanent | t :: tl -> - let pointer_backward = remanent.Covering_classes_type.store_pointer_backward in + let pointer_backward = + remanent.Covering_classes_type.store_pointer_backward + in (* return the set of list(id) containing t. For example: current_covering_classes: [[0;1];[0]] t = 0 => (id:1;id:2) of type set; @@ -429,10 +375,7 @@ let clean_classes parameters error covering_classes modified_map = let error, potential_supersets = match Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - t - pointer_backward + parameters error t pointer_backward with | error, None -> error, Covering_classes_type.CV_map_and_set.Set.empty | error, Some set -> error, set @@ -445,63 +388,46 @@ let clean_classes parameters error covering_classes modified_map = let error, potential_supersets' = match Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - t' - pointer_backward + parameters error t' pointer_backward with - | error, None -> error, Covering_classes_type.CV_map_and_set.Set.empty + | error, None -> + error, Covering_classes_type.CV_map_and_set.Set.empty | error, Some set -> error, set in (*------------------------------------------------------------*) (* intersection of two sets *) - let error',potential_superset = - Covering_classes_type.CV_map_and_set.Set.inter - parameters - error - potential_supersets - potential_supersets' + let error', potential_superset = + Covering_classes_type.CV_map_and_set.Set.inter parameters error + potential_supersets potential_supersets' in let error = - Exception.check_point - Exception.warn parameters error error' + Exception.check_point Exception.warn parameters error error' __POS__ Exit in if Covering_classes_type.CV_map_and_set.Set.is_empty potential_superset - then + then ( let error, result_covering_dic = - store_remanent - parameters - error - covering_class - modified_map + store_remanent parameters error covering_class modified_map remanent in error, result_covering_dic - else + ) else aux tl' potential_superset in (*-------------------------------------------------------------------*) (*check the beginning state of a superset*) if Covering_classes_type.CV_map_and_set.Set.is_empty potential_supersets - then + then ( (*if it is empty then store it to remanent*) let error, result_covering_dic = - store_remanent - parameters - error - covering_class - modified_map - remanent + store_remanent parameters error covering_class modified_map remanent in error, result_covering_dic - else - aux tl potential_supersets - ) - (error, init_remanent) - current_covering_classes + ) else + aux tl potential_supersets) + (error, init_remanent) current_covering_classes (*-------------------------------------------------------------------------*) (*compute covering classes in the set of rules*) @@ -509,7 +435,8 @@ let clean_classes parameters error covering_classes modified_map = let scan_rule_set_remanent parameters error handler rules = (*create a new initial state to store after cleaning the covering classes*) let error, init_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 in let error, store_covering_classes = scan_rule_set_covering_classes parameters error handler rules @@ -518,101 +445,91 @@ let scan_rule_set_remanent parameters error handler rules = store_covering_classes.Covering_classes_type.store_covering_classes in let error, remanent_dictionary = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error agent_type covering_class init_remanent -> - (*----------------------------------------------------------------*) - (*get modified site*) - let error, modified_map = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - store_covering_classes.Covering_classes_type.store_modified_map - with - | error, None -> error, Ckappa_sig.Site_map_and_set.Map.empty - | error, Some m -> error, m - in - (*-----------------------------------------------------------------*) - (*clean the covering classes, removed duplicate of covering classes*) - let error, store_remanent_dic = - clean_classes - parameters - error - covering_class - modified_map - in - (*---------------------------------------------------------------*) - (*compute the number of covering classes*) - let error, get_number_cv = - (Covering_classes_type.Dictionary_of_List_sites.last_entry - parameters error - store_remanent_dic.Covering_classes_type.store_dic) - in - let number_cv = (Covering_classes_type.int_of_cv_id get_number_cv) + 1 in - (*----------------------------------------------------------------*) - (*print covering classes*) - let _ = - if Remanent_parameters.get_dump_site_dependencies parameters - then - let parameters = - Remanent_parameters.update_prefix parameters "" - in - let error, agent_string = - Handler.string_of_agent parameters error handler agent_type - in - let _ = - Covering_classes_type.Dictionary_of_List_sites.iter parameters error - (fun parameters error elt_id(*key*) site_type_list(*value*) _ - _ -> - let _ = - Printf.fprintf stdout - "Potential dependencies between sites:Number of covering classes:%i\n" - number_cv - in - let _ = - (*print covering_class_id*) - Printf.fprintf stdout - "Potential dependencies between sites:\nagent_type:%s:%s:covering_class_id:%i\n" - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - (Covering_classes_type.int_of_cv_id elt_id) - in - let error = - List.fold_left (fun error site_type -> - let error, site_string = - Handler.string_of_site parameters error handler - agent_type site_type - in - let () = - Printf.fprintf stdout "site_type:%i:%s\n" - (Ckappa_sig.int_of_site_name site_type) - site_string - in - error - ) error site_type_list - in - error - ) store_remanent_dic.Covering_classes_type.store_dic - in - () - in - (*---------------------------------------------------------------*) - (*store the covering classes after cleaning theirs duplicate classes*) - let error, store_remanent = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - store_remanent_dic - init_remanent - in - (*----------------------------------------------------------------*) - (*result*) - error, store_remanent - ) - result_covering_classes - init_result + (*----------------------------------------------------------------*) + (*get modified site*) + let error, modified_map = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type + store_covering_classes.Covering_classes_type.store_modified_map + with + | error, None -> error, Ckappa_sig.Site_map_and_set.Map.empty + | error, Some m -> error, m + in + (*-----------------------------------------------------------------*) + (*clean the covering classes, removed duplicate of covering classes*) + let error, store_remanent_dic = + clean_classes parameters error covering_class modified_map + in + (*---------------------------------------------------------------*) + (*compute the number of covering classes*) + let error, get_number_cv = + Covering_classes_type.Dictionary_of_List_sites.last_entry parameters + error store_remanent_dic.Covering_classes_type.store_dic + in + let number_cv = Covering_classes_type.int_of_cv_id get_number_cv + 1 in + (*----------------------------------------------------------------*) + (*print covering classes*) + let _ = + if Remanent_parameters.get_dump_site_dependencies parameters then ( + let parameters = Remanent_parameters.update_prefix parameters "" in + let error, agent_string = + Handler.string_of_agent parameters error handler agent_type + in + let _ = + Covering_classes_type.Dictionary_of_List_sites.iter parameters + error + (fun parameters error elt_id (*key*) site_type_list (*value*) _ + _ -> + let _ = + Printf.fprintf stdout + "Potential dependencies between sites:Number of covering \ + classes:%i\n" + number_cv + in + let _ = + (*print covering_class_id*) + Printf.fprintf stdout + "Potential dependencies between sites:\n\ + agent_type:%s:%s:covering_class_id:%i\n" + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + (Covering_classes_type.int_of_cv_id elt_id) + in + let error = + List.fold_left + (fun error site_type -> + let error, site_string = + Handler.string_of_site parameters error handler + agent_type site_type + in + let () = + Printf.fprintf stdout "site_type:%i:%s\n" + (Ckappa_sig.int_of_site_name site_type) + site_string + in + error) + error site_type_list + in + error) + store_remanent_dic.Covering_classes_type.store_dic + in + () + ) + in + (*---------------------------------------------------------------*) + (*store the covering classes after cleaning theirs duplicate classes*) + let error, store_remanent = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type store_remanent_dic init_remanent + in + (*----------------------------------------------------------------*) + (*result*) + error, store_remanent) + result_covering_classes init_result in error, remanent_dictionary @@ -621,63 +538,64 @@ let scan_rule_set_remanent parameters error handler rules = let covering_classes parameters error handler cc_compil = let parameters = Remanent_parameters.update_prefix parameters "agent_type:" in - let error, result = scan_rule_set_remanent parameters error handler - cc_compil.Cckappa_sig.rules + let error, result = + scan_rule_set_remanent parameters error handler cc_compil.Cckappa_sig.rules in error, result - let init_predicate_covering_classes parameters error = - let error, init_covering_classes = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 - in - let error, init_remanent_triple = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 - in - let error, init_site_correspondence = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 - in - error, +let init_predicate_covering_classes parameters error = + let error, init_covering_classes = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + let error, init_remanent_triple = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + let error, init_site_correspondence = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + ( error, { - Covering_classes_type.store_covering_classes_predicate = init_covering_classes; + Covering_classes_type.store_covering_classes_predicate = + init_covering_classes; Covering_classes_type.store_list_of_site_type_in_covering_classes = Covering_classes_type.AgentCV_map_and_set.Map.empty; - Covering_classes_type.store_covering_classes_id = Common_static.empty_agentsite; + Covering_classes_type.store_covering_classes_id = + Common_static.empty_agentsite; Covering_classes_type.store_remanent_triple = init_remanent_triple; - Covering_classes_type.site_correspondence = init_site_correspondence ; - } + Covering_classes_type.site_correspondence = init_site_correspondence; + } ) let site_covering_classes parameters error covering_classes = let error, store_result = (*From sites return a list of covering_class_id*) - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun _parameters error agent_type_cv remanent store_result -> - (*get a list of covering_class_id from remanent*) - let cv_dic = remanent.Covering_classes_type.store_dic in - (*fold a dictionary*) - let error, store_result = - Covering_classes_type.Dictionary_of_List_sites.fold - (fun list_of_site_type ((),()) cv_id (error, store_result) -> - (*get site_cv in value*) - List.fold_left (fun (_error, store_result) site_type_cv -> - let error, store_result = - Common_map.add_dependency_pair_sites_cv - parameters error - (agent_type_cv, site_type_cv) - cv_id - store_result - in - error, store_result - ) (error, store_result) list_of_site_type - ) cv_dic (error, store_result) - in - error, store_result - (*REMARK: when it is folding inside a list, start with empty result, - because the add_link function has already called the old result.*) - ) covering_classes Ckappa_sig.AgentSite_map_and_set.Map.empty + (*get a list of covering_class_id from remanent*) + let cv_dic = remanent.Covering_classes_type.store_dic in + (*fold a dictionary*) + let error, store_result = + Covering_classes_type.Dictionary_of_List_sites.fold + (fun list_of_site_type ((), ()) cv_id (error, store_result) -> + (*get site_cv in value*) + List.fold_left + (fun (_error, store_result) site_type_cv -> + let error, store_result = + Common_map.add_dependency_pair_sites_cv parameters error + (agent_type_cv, site_type_cv) + cv_id store_result + in + error, store_result) + (error, store_result) list_of_site_type) + cv_dic (error, store_result) + in + error, store_result + (*REMARK: when it is folding inside a list, start with empty result, + because the add_link function has already called the old result.*)) + covering_classes Ckappa_sig.AgentSite_map_and_set.Map.empty in let store_result = Ckappa_sig.AgentSite_map_and_set.Map.map (fun x -> x) store_result @@ -686,33 +604,27 @@ let site_covering_classes parameters error covering_classes = let list_of_site_type_in_covering_class parameters error covering_classes = let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error agent_type_cv remenent store_result -> - let cv_dic = remenent.Covering_classes_type.store_dic in - Covering_classes_type.Dictionary_of_List_sites.fold - (fun list_of_site_type ((), ()) cv_id (error, store_result) -> - let error, old = - Common_map.get_pair_agent_cv parameters error - (agent_type_cv, cv_id) store_result - in - let new_list = List.append list_of_site_type old in - let error, store_result = - Covering_classes_type.AgentCV_map_and_set.Map.add_or_overwrite - parameters - error - (agent_type_cv, cv_id) - new_list - store_result - in - error, store_result - ) cv_dic (error, store_result) - ) covering_classes Covering_classes_type.AgentCV_map_and_set.Map.empty + let cv_dic = remenent.Covering_classes_type.store_dic in + Covering_classes_type.Dictionary_of_List_sites.fold + (fun list_of_site_type ((), ()) cv_id (error, store_result) -> + let error, old = + Common_map.get_pair_agent_cv parameters error + (agent_type_cv, cv_id) store_result + in + let new_list = List.append list_of_site_type old in + let error, store_result = + Covering_classes_type.AgentCV_map_and_set.Map.add_or_overwrite + parameters error (agent_type_cv, cv_id) new_list store_result + in + error, store_result) + cv_dic (error, store_result)) + covering_classes Covering_classes_type.AgentCV_map_and_set.Map.empty in let store_result = - Covering_classes_type.AgentCV_map_and_set.Map.map (fun x -> x) - store_result + Covering_classes_type.AgentCV_map_and_set.Map.map (fun x -> x) store_result in error, store_result @@ -721,138 +633,105 @@ let collect_remanent_triple parameters error store_remanent = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error agent_type remanent store_result -> - let store_dic = remanent.Covering_classes_type.store_dic in - (*-----------------------------------------------------------------*) - let error, triple_list = - Covering_classes_type.Dictionary_of_List_sites.fold - (fun list _ cv_id (error, current_list) -> - let error, set = Common_map.list2set parameters error list in - let triple_list = (cv_id, list, set) :: current_list in - error, triple_list - ) store_dic (error, []) - in - (*--------------------------------------------------------*) - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - (List.rev triple_list) - store_result - in - error, store_result - ) store_remanent - empty_array - - + let store_dic = remanent.Covering_classes_type.store_dic in + (*-----------------------------------------------------------------*) + let error, triple_list = + Covering_classes_type.Dictionary_of_List_sites.fold + (fun list _ cv_id (error, current_list) -> + let error, set = Common_map.list2set parameters error list in + let triple_list = (cv_id, list, set) :: current_list in + error, triple_list) + store_dic (error, []) + in + (*--------------------------------------------------------*) + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type (List.rev triple_list) store_result + in + error, store_result) + store_remanent empty_array let scan_predicate_covering_classes parameters error handler_kappa compil = let error, store_covering_classes = - covering_classes - parameters - error - handler_kappa - compil + covering_classes parameters error handler_kappa compil in (*-----------------------------------------------------------------------*) let error, store_list_of_site_type_in_covering_classes = - list_of_site_type_in_covering_class - parameters - error - store_covering_classes + list_of_site_type_in_covering_class parameters error store_covering_classes in (*-----------------------------------------------------------------------*) (*static information of covering classes: from sites -> covering_class id list*) let error, store_covering_classes_id = - site_covering_classes - parameters - error - store_covering_classes + site_covering_classes parameters error store_covering_classes in (*------------------------------------------------------------------------*) let error, store_remanent_triple = - collect_remanent_triple - parameters - error - store_covering_classes + collect_remanent_triple parameters error store_covering_classes in let error, init_array = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 in let error, site_correspondence = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error ag list map -> - let error, last_site = - Handler.last_site_of_agent parameters error handler_kappa ag - in - let size_map1 = - 1+Ckappa_sig.int_of_site_name last_site in - let size_map2 = - 1+(List.length list) - in - let error, array = - List.fold_left - (fun (error, array) (cv_id,list,_) -> - let rec aux acc k map1 map2 error = - match acc with - | [] -> error, (map1, map2) - | h :: tl -> - let error, map1 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set - parameters error h k map1 - in - let error, map2 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set - parameters error k h map2 - in - aux - tl - (Ckappa_sig.site_name_of_int - ((Ckappa_sig.int_of_site_name k)+1)) - map1 - map2 - error - in - let error, map1 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create - parameters error size_map1 - in - let error, map2 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create - parameters error size_map2 - in - let error, (map1, map2) = - aux - list - (Ckappa_sig.site_name_of_int 1) - map1 map2 - error - in - Covering_classes_type.Cv_id_nearly_Inf_Int_storage_Imperatif.set - parameters error cv_id (map1,map2) array) - (Covering_classes_type.Cv_id_nearly_Inf_Int_storage_Imperatif.create - parameters error 0) - list - in - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error - ag - array - map) - store_remanent_triple - init_array - in - error, - { - Covering_classes_type.store_covering_classes_predicate = store_covering_classes; - Covering_classes_type.store_list_of_site_type_in_covering_classes = - store_list_of_site_type_in_covering_classes; - Covering_classes_type.store_covering_classes_id = store_covering_classes_id; - Covering_classes_type.store_remanent_triple = store_remanent_triple; - Covering_classes_type.site_correspondence = site_correspondence ; - } + let error, last_site = + Handler.last_site_of_agent parameters error handler_kappa ag + in + let size_map1 = 1 + Ckappa_sig.int_of_site_name last_site in + let size_map2 = 1 + List.length list in + let error, array = + List.fold_left + (fun (error, array) (cv_id, list, _) -> + let rec aux acc k map1 map2 error = + match acc with + | [] -> error, (map1, map2) + | h :: tl -> + let error, map1 = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set + parameters error h k map1 + in + let error, map2 = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.set + parameters error k h map2 + in + aux tl + (Ckappa_sig.site_name_of_int + (Ckappa_sig.int_of_site_name k + 1)) + map1 map2 error + in + let error, map1 = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create + parameters error size_map1 + in + let error, map2 = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create + parameters error size_map2 + in + let error, (map1, map2) = + aux list (Ckappa_sig.site_name_of_int 1) map1 map2 error + in + Covering_classes_type.Cv_id_nearly_Inf_Int_storage_Imperatif.set + parameters error cv_id (map1, map2) array) + (Covering_classes_type.Cv_id_nearly_Inf_Int_storage_Imperatif.create + parameters error 0) + list + in + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error ag array map) + store_remanent_triple init_array + in + ( error, + { + Covering_classes_type.store_covering_classes_predicate = + store_covering_classes; + Covering_classes_type.store_list_of_site_type_in_covering_classes; + Covering_classes_type.store_covering_classes_id; + Covering_classes_type.store_remanent_triple; + Covering_classes_type.site_correspondence; + } ) diff --git a/core/KaSa_rep/reachability_analysis/covering_classes_type.ml b/core/KaSa_rep/reachability_analysis/covering_classes_type.ml index 17025d8e58..5953db5f40 100644 --- a/core/KaSa_rep/reachability_analysis/covering_classes_type.ml +++ b/core/KaSa_rep/reachability_analysis/covering_classes_type.ml @@ -13,16 +13,16 @@ * under the terms of the GNU Library General Public License *) let local_trace = false - let _ = local_trace -type covering_classes = - { - store_modified_map : Ckappa_sig.c_site_name Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_covering_classes : Ckappa_sig.c_site_name list list - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - } +type covering_classes = { + store_modified_map: + Ckappa_sig.c_site_name Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_covering_classes: + Ckappa_sig.c_site_name list list + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; +} (***************************************************************************) (* DICTIONARY for covering classes *) @@ -33,166 +33,156 @@ type covering_classes = type cv_id = int -module Cv_id_nearly_Inf_Int_storage_Imperatif = - ( - Int_storage.Nearly_inf_Imperatif: Int_storage.Storage - with type key = cv_id - and type dimension = int - ) +module Cv_id_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = cv_id and type dimension = int = + Int_storage.Nearly_inf_Imperatif let dummy_cv_id = 0 - -let int_of_cv_id (a: cv_id) : int = a -let cv_id_of_int (a: int) : cv_id = a +let int_of_cv_id (a : cv_id) : int = a +let cv_id_of_int (a : int) : cv_id = a (***************************************************************************) -module List_sites = -struct +module List_sites = struct type t = Ckappa_sig.c_site_name list (*value type*) + let compare = compare let print = Pp.list Pp.space (fun _ _ -> ()) end -module CV_map_and_set = - Map_wrapper.Make ( - SetMap.Make ( - struct - type t = cv_id - let compare = compare - let print = Format.pp_print_int - end)) - -module Dictionary_of_List_sites = - ( - Dictionary.Dictionary_of_Ord (List_sites) : Dictionary.Dictionary +module CV_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = cv_id + + let compare = compare + let print = Format.pp_print_int +end)) + +module Dictionary_of_List_sites : + Dictionary.Dictionary with type key = cv_id - and type value = Ckappa_sig.c_site_name list - ) - -type pair_dic = (unit, unit) Dictionary_of_List_sites.dictionary - -type remanent = - { - store_pointer_backward : CV_map_and_set.Set.t Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t; - store_dic : pair_dic; - } - -module AgentCV_map_and_set = - Map_wrapper.Make ( - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_name * cv_id - let compare = compare - let print _ _ = () - end)) - -module AgentIDCV_map_and_set = - Map_wrapper.Make ( - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_id * cv_id - let compare = compare - let print _ _ = () - end)) - -module AgentsRuleCV_map_and_set = - Map_wrapper.Make - (SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_rule_id * cv_id - let compare = compare - let print _ _ = () - end)) + and type value = Ckappa_sig.c_site_name list = + Dictionary.Dictionary_of_Ord (List_sites) + +type pair_dic = (unit, unit) Dictionary_of_List_sites.dictionary + +type remanent = { + store_pointer_backward: + CV_map_and_set.Set.t Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t; + store_dic: pair_dic; +} + +module AgentCV_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = Ckappa_sig.c_agent_name * cv_id + + let compare = compare + let print _ _ = () +end)) + +module AgentIDCV_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = Ckappa_sig.c_agent_id * cv_id + + let compare = compare + let print _ _ = () +end)) + +module AgentsRuleCV_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_rule_id + * cv_id + + let compare = compare + let print _ _ = () +end)) (******************************************************************************) -module AgentCV_setmap = - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_name * cv_id - let compare = compare - let print _ _ = () - end) - -module AgentsCV_setmap = - SetMap.Make - (struct - type t = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * cv_id - let compare = compare - let print _ _ = () - end) - -module AgentSiteCV_setmap = - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * cv_id - let compare = compare - let print _ _ = () - end) - -module AgentRuleCV_setmap = - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_rule_id * cv_id - let compare = compare - let print _ _ = () - end) - -module AgentsRuleCV_setmap = - (SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * Ckappa_sig.c_rule_id * cv_id - let compare = compare - let print _ _ = () - end)) - -module AgentSiteRuleCV_setmap = - SetMap.Make ( - struct - type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_rule_id * cv_id - let compare = compare - let print _ _ = () - end) +module AgentCV_setmap = SetMap.Make (struct + type t = Ckappa_sig.c_agent_name * cv_id + + let compare = compare + let print _ _ = () +end) + +module AgentsCV_setmap = SetMap.Make (struct + type t = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * cv_id + + let compare = compare + let print _ _ = () +end) + +module AgentSiteCV_setmap = SetMap.Make (struct + type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * cv_id + + let compare = compare + let print _ _ = () +end) + +module AgentRuleCV_setmap = SetMap.Make (struct + type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_rule_id * cv_id + + let compare = compare + let print _ _ = () +end) + +module AgentsRuleCV_setmap = SetMap.Make (struct + type t = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_rule_id + * cv_id + + let compare = compare + let print _ _ = () +end) + +module AgentSiteRuleCV_setmap = SetMap.Make (struct + type t = + Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_rule_id + * cv_id + + let compare = compare + let print _ _ = () +end) (****************************************************************************) module Project2bdu_creation = - SetMap.Proj2 (AgentRuleCV_setmap)(Ckappa_sig.Rule_setmap)(AgentCV_setmap) + SetMap.Proj2 (AgentRuleCV_setmap) (Ckappa_sig.Rule_setmap) (AgentCV_setmap) module Project2bdu_potential = - SetMap.Proj2 (AgentSiteRuleCV_setmap)(Ckappa_sig.Rule_setmap)(AgentSiteCV_setmap) + SetMap.Proj2 (AgentSiteRuleCV_setmap) (Ckappa_sig.Rule_setmap) + (AgentSiteCV_setmap) module Project2_bdu_views = - SetMap.Proj2 (AgentsRuleCV_setmap)(Ckappa_sig.Rule_setmap)(AgentsCV_setmap) + SetMap.Proj2 (AgentsRuleCV_setmap) (Ckappa_sig.Rule_setmap) (AgentsCV_setmap) module Project2_modif = - Map_wrapper.Proj (Ckappa_sig.AgentsSite_map_and_set) (Ckappa_sig.AgentSite_map_and_set) - -type predicate_covering_classes = - { - store_covering_classes_predicate: - remanent - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_list_of_site_type_in_covering_classes: - Ckappa_sig.c_site_name list - AgentCV_map_and_set.Map.t; - store_covering_classes_id : - cv_id list - Ckappa_sig.AgentSite_map_and_set.Map.t; - (*rewrite/ change type of this function ?*) - store_remanent_triple: - ((Dictionary_of_List_sites.key * - Dictionary_of_List_sites.value * - Ckappa_sig.Site_map_and_set.Set.t) list) - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - - site_correspondence: - (Ckappa_sig.c_site_name - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t - * Ckappa_sig.c_site_name - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t) - Cv_id_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - } + Map_wrapper.Proj + (Ckappa_sig.AgentsSite_map_and_set) + (Ckappa_sig.AgentSite_map_and_set) + +type predicate_covering_classes = { + store_covering_classes_predicate: + remanent Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_list_of_site_type_in_covering_classes: + Ckappa_sig.c_site_name list AgentCV_map_and_set.Map.t; + store_covering_classes_id: cv_id list Ckappa_sig.AgentSite_map_and_set.Map.t; + (*rewrite/ change type of this function ?*) + store_remanent_triple: + (Dictionary_of_List_sites.key + * Dictionary_of_List_sites.value + * Ckappa_sig.Site_map_and_set.Set.t) + list + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + site_correspondence: + (Ckappa_sig.c_site_name + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t + * Ckappa_sig.c_site_name + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t) + Cv_id_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; +} diff --git a/core/KaSa_rep/reachability_analysis/covering_classes_type.mli b/core/KaSa_rep/reachability_analysis/covering_classes_type.mli index 6076c7e115..a7a1025675 100644 --- a/core/KaSa_rep/reachability_analysis/covering_classes_type.mli +++ b/core/KaSa_rep/reachability_analysis/covering_classes_type.mli @@ -15,129 +15,148 @@ type cv_id -module Cv_id_nearly_Inf_Int_storage_Imperatif: - Int_storage.Storage - with type key = cv_id - and type dimension = int - -val dummy_cv_id: cv_id +module Cv_id_nearly_Inf_Int_storage_Imperatif : + Int_storage.Storage with type key = cv_id and type dimension = int -val int_of_cv_id: cv_id -> int -val cv_id_of_int: int -> cv_id +val dummy_cv_id : cv_id +val int_of_cv_id : cv_id -> int +val cv_id_of_int : int -> cv_id (****************************************************************************************) -type covering_classes = - { - store_modified_map : Ckappa_sig.c_site_name Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_covering_classes : Ckappa_sig.c_site_name list list - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - } - -module Dictionary_of_List_sites : Dictionary.Dictionary - with type key = cv_id - and type value = Ckappa_sig.c_site_name list +type covering_classes = { + store_modified_map: + Ckappa_sig.c_site_name Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_covering_classes: + Ckappa_sig.c_site_name list list + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; +} + +module Dictionary_of_List_sites : + Dictionary.Dictionary + with type key = cv_id + and type value = Ckappa_sig.c_site_name list -type pair_dic = (unit, unit) Dictionary_of_List_sites.dictionary +type pair_dic = (unit, unit) Dictionary_of_List_sites.dictionary -module CV_map_and_set: Map_wrapper.S_with_logs - with type elt = cv_id +module CV_map_and_set : Map_wrapper.S_with_logs with type elt = cv_id -type remanent = - { - store_pointer_backward: CV_map_and_set.Set.t Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t; - store_dic : pair_dic; - } +type remanent = { + store_pointer_backward: + CV_map_and_set.Set.t Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t; + store_dic: pair_dic; +} (****************************************************************************************) -module AgentCV_map_and_set: Map_wrapper.S_with_logs - with type elt = Ckappa_sig.c_agent_name * cv_id +module AgentCV_map_and_set : + Map_wrapper.S_with_logs with type elt = Ckappa_sig.c_agent_name * cv_id -module AgentIDCV_map_and_set: Map_wrapper.S_with_logs - with type elt = Ckappa_sig.c_agent_id * cv_id +module AgentIDCV_map_and_set : + Map_wrapper.S_with_logs with type elt = Ckappa_sig.c_agent_id * cv_id -module AgentsRuleCV_map_and_set: Map_wrapper.S_with_logs - with type elt = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_rule_id * cv_id +module AgentsRuleCV_map_and_set : + Map_wrapper.S_with_logs + with type elt = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_rule_id + * cv_id (****************************************************************************************) -module AgentCV_setmap: SetMap.S - with type elt = Ckappa_sig.c_agent_name * cv_id - -module AgentsCV_setmap: SetMap.S - with type elt = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * cv_id - -module AgentSiteCV_setmap: SetMap.S - with type elt = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * cv_id - -module AgentRuleCV_setmap: SetMap.S - with type elt = Ckappa_sig.c_agent_name * Ckappa_sig.c_rule_id * cv_id - -module AgentsRuleCV_setmap: SetMap.S - with type elt = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_rule_id * cv_id - -module AgentSiteRuleCV_setmap: SetMap.S - with type elt = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_rule_id * cv_id - -module Project2bdu_creation: SetMap.Projection2 - with type elt_a = Ckappa_sig.c_agent_name * Ckappa_sig.c_rule_id * cv_id - and type elt_b = Ckappa_sig.c_rule_id - and type elt_c = Ckappa_sig.c_agent_name * cv_id - and type 'a map_a = 'a AgentRuleCV_setmap.Map.t - and type 'a map_b = 'a Ckappa_sig.Rule_setmap.Map.t - and type 'a map_c = 'a AgentCV_setmap.Map.t - -module Project2bdu_potential: SetMap.Projection2 - with type elt_a = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_rule_id * cv_id - and type elt_b = Ckappa_sig.c_rule_id - and type 'a map_a = 'a AgentSiteRuleCV_setmap.Map.t - and type 'a map_b = 'a Ckappa_sig.Rule_setmap.Map.t - and type elt_c = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * cv_id - and type 'a map_c = 'a AgentSiteCV_setmap.Map.t - -module Project2_bdu_views: SetMap.Projection2 - with type elt_a = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_rule_id * cv_id - and type elt_b = Ckappa_sig.c_rule_id - and type 'a map_a = 'a AgentsRuleCV_setmap.Map.t - and type 'a map_b = 'a Ckappa_sig.Rule_setmap.Map.t - and type elt_c = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * cv_id - (* find the appropriate type names *) - and type 'a map_c = 'a AgentsCV_setmap.Map.t - -module Project2_modif: Map_wrapper.Projection - with type elt_a = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name - and type elt_b = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name - and type 'a map_a = 'a Ckappa_sig.AgentsSite_map_and_set.Map.t - and type 'a map_b = 'a Ckappa_sig.AgentSite_map_and_set.Map.t - -type predicate_covering_classes = - { - store_covering_classes_predicate: - remanent - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - store_list_of_site_type_in_covering_classes: - Ckappa_sig.c_site_name list - AgentCV_map_and_set.Map.t; - store_covering_classes_id : - cv_id list - Ckappa_sig.AgentSite_map_and_set.Map.t; - store_remanent_triple: - ((Dictionary_of_List_sites.key * - Dictionary_of_List_sites.value * - Ckappa_sig.Site_map_and_set.Set.t) list) - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - - site_correspondence: - (Ckappa_sig.c_site_name Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t - * Ckappa_sig.c_site_name Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t) - Cv_id_nearly_Inf_Int_storage_Imperatif.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; - } +module AgentCV_setmap : SetMap.S with type elt = Ckappa_sig.c_agent_name * cv_id + +module AgentsCV_setmap : + SetMap.S + with type elt = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * cv_id + +module AgentSiteCV_setmap : + SetMap.S + with type elt = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * cv_id + +module AgentRuleCV_setmap : + SetMap.S + with type elt = Ckappa_sig.c_agent_name * Ckappa_sig.c_rule_id * cv_id + +module AgentsRuleCV_setmap : + SetMap.S + with type elt = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_rule_id + * cv_id + +module AgentSiteRuleCV_setmap : + SetMap.S + with type elt = + Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_rule_id + * cv_id + +module Project2bdu_creation : + SetMap.Projection2 + with type elt_a = Ckappa_sig.c_agent_name * Ckappa_sig.c_rule_id * cv_id + and type elt_b = Ckappa_sig.c_rule_id + and type elt_c = Ckappa_sig.c_agent_name * cv_id + and type 'a map_a = 'a AgentRuleCV_setmap.Map.t + and type 'a map_b = 'a Ckappa_sig.Rule_setmap.Map.t + and type 'a map_c = 'a AgentCV_setmap.Map.t + +module Project2bdu_potential : + SetMap.Projection2 + with type elt_a = + Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_rule_id + * cv_id + and type elt_b = Ckappa_sig.c_rule_id + and type 'a map_a = 'a AgentSiteRuleCV_setmap.Map.t + and type 'a map_b = 'a Ckappa_sig.Rule_setmap.Map.t + and type elt_c = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * cv_id + and type 'a map_c = 'a AgentSiteCV_setmap.Map.t + +module Project2_bdu_views : + SetMap.Projection2 + with type elt_a = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_rule_id + * cv_id + and type elt_b = Ckappa_sig.c_rule_id + and type 'a map_a = 'a AgentsRuleCV_setmap.Map.t + and type 'a map_b = 'a Ckappa_sig.Rule_setmap.Map.t + and type elt_c = Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * cv_id + (* find the appropriate type names *) + and type 'a map_c = 'a AgentsCV_setmap.Map.t + +module Project2_modif : + Map_wrapper.Projection + with type elt_a = + Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name + and type elt_b = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name + and type 'a map_a = 'a Ckappa_sig.AgentsSite_map_and_set.Map.t + and type 'a map_b = 'a Ckappa_sig.AgentSite_map_and_set.Map.t + +type predicate_covering_classes = { + store_covering_classes_predicate: + remanent Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + store_list_of_site_type_in_covering_classes: + Ckappa_sig.c_site_name list AgentCV_map_and_set.Map.t; + store_covering_classes_id: cv_id list Ckappa_sig.AgentSite_map_and_set.Map.t; + store_remanent_triple: + (Dictionary_of_List_sites.key + * Dictionary_of_List_sites.value + * Ckappa_sig.Site_map_and_set.Set.t) + list + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; + site_correspondence: + (Ckappa_sig.c_site_name + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t + * Ckappa_sig.c_site_name + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.t) + Cv_id_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; +} diff --git a/core/KaSa_rep/reachability_analysis/domain_selection.ml b/core/KaSa_rep/reachability_analysis/domain_selection.ml index 57c9997f25..e599b48982 100644 --- a/core/KaSa_rep/reachability_analysis/domain_selection.ml +++ b/core/KaSa_rep/reachability_analysis/domain_selection.ml @@ -13,108 +13,83 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - -let select_domain - ?reachability_parameters - () - = +let select_domain ?reachability_parameters () = let parameters = - match - reachability_parameters - with - | None -> - Remanent_parameters.get_reachability_parameters () + match reachability_parameters with + | None -> Remanent_parameters.get_reachability_parameters () | Some p -> p in let base = - (module - Product.Product - (Side_effects_domain.Domain) - (Product.Product - (Agents_domain.Domain) - (Rules_domain.Domain)):Analyzer_domain_sig.Domain) + (module Product.Product + (Side_effects_domain.Domain) + (Product.Product (Agents_domain.Domain) (Rules_domain.Domain)) + : Analyzer_domain_sig.Domain) in - let module Base = (val base: Analyzer_domain_sig.Domain) in + let module Base = (val base : Analyzer_domain_sig.Domain) in let with_cm = - if Remanent_parameters.get_dynamic_contact_map_1 parameters - then - (module - Product.Product - (Dynamic_contact_map_domain.Domain) - (Base) : Analyzer_domain_sig.Domain) + if Remanent_parameters.get_dynamic_contact_map_1 parameters then + (module Product.Product (Dynamic_contact_map_domain.Domain) (Base) + : Analyzer_domain_sig.Domain) else - (module - Product.Product - (Static_contact_map_domain.Domain) - (Base) : Analyzer_domain_sig.Domain) + (module Product.Product (Static_contact_map_domain.Domain) (Base) + : Analyzer_domain_sig.Domain) in - let module With_cm = (val with_cm: Analyzer_domain_sig.Domain) in + let module With_cm = (val with_cm : Analyzer_domain_sig.Domain) in let with_views = - if Remanent_parameters.get_view_analysis_1 parameters - then - (module - Product.Product(Views_domain.Domain)(With_cm) : Analyzer_domain_sig.Domain) + if Remanent_parameters.get_view_analysis_1 parameters then + (module Product.Product (Views_domain.Domain) (With_cm) + : Analyzer_domain_sig.Domain) else (module With_cm : Analyzer_domain_sig.Domain) in - let module With_views = (val with_views: Analyzer_domain_sig.Domain) in + let module With_views = (val with_views : Analyzer_domain_sig.Domain) in let with_site_across = - if Remanent_parameters.get_site_across_bonds_analysis_1 parameters - then - (module - Product.Product(Site_across_bonds_domain.Domain)(With_views) : Analyzer_domain_sig.Domain) + if Remanent_parameters.get_site_across_bonds_analysis_1 parameters then + (module Product.Product (Site_across_bonds_domain.Domain) (With_views) + : Analyzer_domain_sig.Domain) else (module With_views : Analyzer_domain_sig.Domain) in let module With_site_across = - (val with_site_across: Analyzer_domain_sig.Domain) + (val with_site_across : Analyzer_domain_sig.Domain) in let with_parallel_bonds = - if Remanent_parameters.get_parallel_bonds_analysis_1 parameters - then - (module - Product.Product(Parallel_bonds.Domain)(With_site_across) : - Analyzer_domain_sig.Domain) + if Remanent_parameters.get_parallel_bonds_analysis_1 parameters then + (module Product.Product (Parallel_bonds.Domain) (With_site_across) + : Analyzer_domain_sig.Domain) else (module With_site_across) in let module With_parallel_bonds = - (val with_parallel_bonds: Analyzer_domain_sig.Domain) + (val with_parallel_bonds : Analyzer_domain_sig.Domain) in - let with_counters= - if Remanent_parameters.get_counters_analysis_1 parameters - then - match Remanent_parameters.get_counters_domain_1 parameters - with + let with_counters = + if Remanent_parameters.get_counters_analysis_1 parameters then ( + match Remanent_parameters.get_counters_domain_1 parameters with | Remanent_parameters_sig.Mi -> - (module - Product.Product(Counters_domain.Domain_affine_equalities_and_intervalles)(With_parallel_bonds) : - Analyzer_domain_sig.Domain) + (module Product.Product + (Counters_domain.Domain_affine_equalities_and_intervalles) + (With_parallel_bonds) : Analyzer_domain_sig.Domain) | Remanent_parameters_sig.Non_relational -> - (module - Product.Product(Counters_domain.Domain_non_relational)(With_parallel_bonds) : - Analyzer_domain_sig.Domain) - | Remanent_parameters_sig.Octagons-> - (module - Product.Product(Counters_domain.Domain_octagons)(With_parallel_bonds) : - Analyzer_domain_sig.Domain) - | Remanent_parameters_sig.Abstract_multiset-> - (module - Product.Product(Counters_domain.Domain_abstract_multisets)(With_parallel_bonds) : - Analyzer_domain_sig.Domain) - - - else + (module Product.Product + (Counters_domain.Domain_non_relational) + (With_parallel_bonds) : Analyzer_domain_sig.Domain) + | Remanent_parameters_sig.Octagons -> + (module Product.Product + (Counters_domain.Domain_octagons) + (With_parallel_bonds) : Analyzer_domain_sig.Domain) + | Remanent_parameters_sig.Abstract_multiset -> + (module Product.Product + (Counters_domain.Domain_abstract_multisets) + (With_parallel_bonds) : Analyzer_domain_sig.Domain) + ) else (module With_parallel_bonds) in - let module With_counters = - (val with_counters: Analyzer_domain_sig.Domain) - in + let module With_counters = (val with_counters : Analyzer_domain_sig.Domain) in let comp = - (module Composite_domain.Make(With_counters) : Composite_domain.Composite_domain) - in - let module Comp = (val comp: Composite_domain.Composite_domain) in - let main = - (module Analyzer.Make(Comp) : Analyzer.Analyzer) + (module Composite_domain.Make (With_counters) + : Composite_domain.Composite_domain) in + let module Comp = (val comp : Composite_domain.Composite_domain) in + let main = (module Analyzer.Make (Comp) : Analyzer.Analyzer) in main diff --git a/core/KaSa_rep/reachability_analysis/dune b/core/KaSa_rep/reachability_analysis/dune index 372005a754..6b29adafd1 100644 --- a/core/KaSa_rep/reachability_analysis/dune +++ b/core/KaSa_rep/reachability_analysis/dune @@ -1,19 +1,37 @@ (library - (name kappa_reachability) - (libraries kappa_kasa_remanent_state kappa_numerical_domains kappa_classical_graphs kappa_kasa_backend) - (flags (:standard) - -open Kappa_kasa_kastor_toolset - -open Kappa_kasa_frontend - -open Kappa_generic_toolset - -open Kappa_parameters - -open Kappa_kasa_site_graphs - -open Kappa_kasa_remanent_state - -open Kappa_errors - -open Kappa_profiling - -open Kappa_mvbdu - -open Kappa_numerical_domains - -open Kappa_logging - -open Kappa_classical_graphs - -open Kappa_kasa_backend - -open Kappa_kasa_type_interface -)) + (name kappa_reachability) + (libraries + kappa_kasa_remanent_state + kappa_numerical_domains + kappa_classical_graphs + kappa_kasa_backend) + (flags + (:standard) + -open + Kappa_kasa_kastor_toolset + -open + Kappa_kasa_frontend + -open + Kappa_generic_toolset + -open + Kappa_parameters + -open + Kappa_kasa_site_graphs + -open + Kappa_kasa_remanent_state + -open + Kappa_errors + -open + Kappa_profiling + -open + Kappa_mvbdu + -open + Kappa_numerical_domains + -open + Kappa_logging + -open + Kappa_classical_graphs + -open + Kappa_kasa_backend + -open + Kappa_kasa_type_interface)) diff --git a/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.ml b/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.ml index d6aa135859..78252619ac 100644 --- a/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.ml +++ b/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.ml @@ -15,62 +15,47 @@ let local_trace = false -module Domain = -struct - - type static_information = - { - global_static_information : Analyzer_headers.global_static_information; - bonds_to_rules: - Ckappa_sig.Rule_map_and_set.Set.t - Ckappa_sig.PairAgentSiteState_map_and_set.Map.t } - - type local_dynamic_information = - { - contact_map_dynamic : Ckappa_sig.PairAgentSiteState_map_and_set.Set.t; - bonds_per_site : - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) - Ckappa_sig.State_map_and_set.Map.t - Ckappa_sig.AgentSite_map_and_set.Map.t - } - - type dynamic_information = - { - local : local_dynamic_information; - global : Analyzer_headers.global_dynamic_information - } +module Domain = struct + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + bonds_to_rules: + Ckappa_sig.Rule_map_and_set.Set.t + Ckappa_sig.PairAgentSiteState_map_and_set.Map.t; + } + + type local_dynamic_information = { + contact_map_dynamic: Ckappa_sig.PairAgentSiteState_map_and_set.Set.t; + bonds_per_site: + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + Ckappa_sig.State_map_and_set.Map.t + Ckappa_sig.AgentSite_map_and_set.Map.t; + } + + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } (**************************************************************************) (*local static information*) let get_global_static_information static = static.global_static_information - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static - let get_compil static = lift Analyzer_headers.get_cc_code static - let get_bond_rhs static = lift Analyzer_headers.get_bonds_rhs static - let get_bond_lhs static = lift Analyzer_headers.get_bonds_lhs static - let get_bounds_to_rule static = static.bonds_to_rules (*--------------------------------------------------------------------*) (** dynamic information*) let get_local_dynamic_information dynamic = dynamic.local - - let set_local_dynamic_information local dynamic = - { - dynamic with local = local - } - + let set_local_dynamic_information local dynamic = { dynamic with local } let get_global_dynamic_information dynamic = dynamic.global let set_global_dynamic_information gdynamic dynamic = - {dynamic with global = gdynamic} + { dynamic with global = gdynamic } let get_contact_map_dynamic dynamic = (get_local_dynamic_information dynamic).contact_map_dynamic @@ -79,18 +64,17 @@ struct set_local_dynamic_information { (get_local_dynamic_information dynamic) with - contact_map_dynamic = contact_map - } dynamic + contact_map_dynamic = contact_map; + } + dynamic let get_bonds_per_site dynamic = (get_local_dynamic_information dynamic).bonds_per_site let set_bonds_per_site bonds dynamic = set_local_dynamic_information - { - (get_local_dynamic_information dynamic) with - bonds_per_site = bonds - } dynamic + { (get_local_dynamic_information dynamic) with bonds_per_site = bonds } + dynamic (**************************************************************************) (*implementations*) @@ -99,91 +83,87 @@ struct let error, old_set = match Ckappa_sig.PairAgentSiteState_map_and_set.Map.find_option_without_logs - parameter error (site1,site2) map + parameter error (site1, site2) map with | error, None -> error, Ckappa_sig.Rule_map_and_set.Set.empty | error, Some s -> error, s in let error, new_set = - Ckappa_sig.Rule_map_and_set.Set.add_when_not_in - parameter error r_id old_set + Ckappa_sig.Rule_map_and_set.Set.add_when_not_in parameter error r_id + old_set in - Ckappa_sig.PairAgentSiteState_map_and_set.Map.add_or_overwrite - parameter error (site1,site2) new_set map + Ckappa_sig.PairAgentSiteState_map_and_set.Map.add_or_overwrite parameter + error (site1, site2) new_set map let add_relation parameter error r_id site1 site2 map = - let error, map = add_oriented_relation parameter error r_id site1 site2 map in + let error, map = + add_oriented_relation parameter error r_id site1 site2 map + in add_oriented_relation parameter error r_id site2 site1 map let initialize static dynamic error = let init_local = { - contact_map_dynamic = Ckappa_sig.PairAgentSiteState_map_and_set.Set.empty; - bonds_per_site = Ckappa_sig.AgentSite_map_and_set.Map.empty + contact_map_dynamic = + Ckappa_sig.PairAgentSiteState_map_and_set.Set.empty; + bonds_per_site = Ckappa_sig.AgentSite_map_and_set.Map.empty; } in let init_global_dynamic_information = - { - local = init_local; - global = dynamic - } + { local = init_local; global = dynamic } in let parameter = Analyzer_headers.get_parameter static in let bonds_lhs = Analyzer_headers.get_bonds_lhs static in let bonds_to_rules = Ckappa_sig.PairAgentSiteState_map_and_set.Map.empty in - let p (_,a,b,c) = (a,b,c) in + let p (_, a, b, c) = a, b, c in let error, bonds_to_rules = Ckappa_sig.Rule_map_and_set.Map.fold - (fun r_id set (error,bonds_to_rules) -> - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold - (fun (site1,site2) (error,bonds_to_rules) -> - add_relation - parameter error r_id (p site1) (p site2) bonds_to_rules - ) set (error,bonds_to_rules)) - bonds_lhs (error,bonds_to_rules) + (fun r_id set (error, bonds_to_rules) -> + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold + (fun (site1, site2) (error, bonds_to_rules) -> + add_relation parameter error r_id (p site1) (p site2) + bonds_to_rules) + set (error, bonds_to_rules)) + bonds_lhs (error, bonds_to_rules) in let init_global_static_information = - { - global_static_information = static; - bonds_to_rules = bonds_to_rules; - } + { global_static_information = static; bonds_to_rules } in error, init_global_static_information, init_global_dynamic_information, [] - let complete_wake_up_relation _static error wake_up = - error, wake_up + let complete_wake_up_relation _static error wake_up = error, wake_up (**************************************************************************) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (**************************************************************************) (*Implementation*) @@ -192,40 +172,33 @@ struct let parameters = get_parameter static in let contact_map_dynamic = get_contact_map_dynamic dynamic in let error, contact_map_dynamic = - Ckappa_sig.PairAgentSiteState_map_and_set.Set.add_when_not_in - parameters error - (x, y) - contact_map_dynamic + Ckappa_sig.PairAgentSiteState_map_and_set.Set.add_when_not_in parameters + error (x, y) contact_map_dynamic in let dynamic = set_contact_map_dynamic contact_map_dynamic dynamic in error, dynamic let add_oriented_bond_in_map_of_bonds static dynamic error (x, y) = - let (agent_type, site_type, state) = x in - let (agent_type', site_type', state') = y in + let agent_type, site_type, state = x in + let agent_type', site_type', state' = y in let parameters = get_parameter static in let bonds_per_site = get_bonds_per_site dynamic in let error, old_map = match - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, site_type) - bonds_per_site + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameters + error (agent_type, site_type) bonds_per_site with | error, None -> error, Ckappa_sig.State_map_and_set.Map.empty | error, Some m -> error, m in let error, state_map = - Ckappa_sig.State_map_and_set.Map.add_or_overwrite parameters error - state + Ckappa_sig.State_map_and_set.Map.add_or_overwrite parameters error state (agent_type', site_type', state') old_map in let error, bonds_per_site = Ckappa_sig.AgentSite_map_and_set.Map.add_or_overwrite parameters error - (agent_type, site_type) - state_map - bonds_per_site + (agent_type, site_type) state_map bonds_per_site in let dynamic = set_bonds_per_site bonds_per_site dynamic in error, dynamic @@ -238,7 +211,8 @@ struct let add_oriented_bond static dynamic error bond = let error, dynamic = - add_oriented_bond_in_set_of_bonds static dynamic error bond in + add_oriented_bond_in_set_of_bonds static dynamic error bond + in add_oriented_bond_in_map_of_bonds static dynamic error bond (* make sure the appropriate version among oriented and unoriented, is @@ -253,29 +227,27 @@ struct let collect_bonds_initial static dynamic error init_state = let parameters = get_parameter static in let error, dynamic = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error agent_id bonds_map dynamic -> - let error, dynamic = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site_type_source site_add (error, dynamic) -> - let error, pair = - Common_static.collect_fingerprint_of_bond - parameters - error - site_add - agent_id - site_type_source - init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.views - in - (*use the oriented bonds, when given the bond (x, y), the - bond (y, x) is given as well*) - let error, dynamic = add_oriented_bond static dynamic error pair in - error, dynamic - ) bonds_map (error, dynamic) - in - error, dynamic - ) init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.bonds dynamic + let error, dynamic = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site_type_source site_add (error, dynamic) -> + let error, pair = + Common_static.collect_fingerprint_of_bond parameters error + site_add agent_id site_type_source + init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.views + in + (*use the oriented bonds, when given the bond (x, y), the + bond (y, x) is given as well*) + let error, dynamic = + add_oriented_bond static dynamic error pair + in + error, dynamic) + bonds_map (error, dynamic) + in + error, dynamic) + init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.bonds dynamic in error, dynamic @@ -285,97 +257,92 @@ struct let bonds_to_rules = get_bounds_to_rule static in let parameter = get_parameter static in Ckappa_sig.PairAgentSiteState_map_and_set.Set.fold - (fun pair (error,event_list) -> - let error, event_list = - match - Ckappa_sig.PairAgentSiteState_map_and_set.Map.find_option_without_logs - parameter error pair bonds_to_rules - with error, None -> - error, event_list - | error, Some r_set -> + (fun pair (error, event_list) -> + let error, event_list = + match + Ckappa_sig.PairAgentSiteState_map_and_set.Map + .find_option_without_logs parameter error pair bonds_to_rules + with + | error, None -> error, event_list + | error, Some r_set -> + let error = + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_wl + parameter + then ( + let log = Remanent_parameters.get_logger parameter in + (*---------------------------------------------------------------*) let error = - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_wl parameter - then - begin - let log = Remanent_parameters.get_logger parameter in - (*---------------------------------------------------------------*) - let error = - Ckappa_sig.Rule_map_and_set.Set.fold - (fun rule_id error -> - let compiled = get_compil static in - let error, rule_id_string = - try - Handler.string_of_rule parameter error compiled rule_id - with - | _ -> - Exception.warn - parameter error __POS__ Exit - (Ckappa_sig.string_of_rule_id rule_id) - in - let title = "" in - let tab = - if title = "" then "\t\t\t\t" else "\t\t\t" - in - let () = - Loggers.fprintf log "%s%s(%s) should be investigated " - (Remanent_parameters.get_prefix parameter) tab - rule_id_string - in - let () = Loggers.print_newline log in error) - r_set error + Ckappa_sig.Rule_map_and_set.Set.fold + (fun rule_id error -> + let compiled = get_compil static in + let error, rule_id_string = + try + Handler.string_of_rule parameter error compiled + rule_id + with _ -> + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.string_of_rule_id rule_id) + in + let title = "" in + let tab = + if title = "" then + "\t\t\t\t" + else + "\t\t\t" + in + let () = + Loggers.fprintf log "%s%s(%s) should be investigated " + (Remanent_parameters.get_prefix parameter) + tab rule_id_string in let () = Loggers.print_newline log in - error - end - else - error + error) + r_set error in - error, - Ckappa_sig.Rule_map_and_set.Set.fold - (fun r_id event_list -> - (Communication.Check_rule r_id) :: event_list) - r_set event_list - in - error,(Communication.See_a_new_bond pair) :: event_list) + let () = Loggers.print_newline log in + error + ) else + error + in + ( error, + Ckappa_sig.Rule_map_and_set.Set.fold + (fun r_id event_list -> + Communication.Check_rule r_id :: event_list) + r_set event_list ) + in + error, Communication.See_a_new_bond pair :: event_list) map_diff (error, event_list) let add_initial_state static dynamic error species = let parameter = get_parameter static in let set_before = get_contact_map_dynamic dynamic in (*------------------------------------------------------*) - let error, dynamic = - collect_bonds_initial - static - dynamic - error - species - in + let error, dynamic = collect_bonds_initial static dynamic error species in let set_after = get_contact_map_dynamic dynamic in (*------------------------------------------------------*) let error, set_diff = - Ckappa_sig.PairAgentSiteState_map_and_set.Set.diff - parameter error set_after set_before - in - let error, event_list = - collect_events static error set_diff [] + Ckappa_sig.PairAgentSiteState_map_and_set.Set.diff parameter error + set_after set_before in + let error, event_list = collect_events static error set_diff [] in error, dynamic, event_list (**************************************************************************) module Proj_bonds = Map_wrapper.Proj - (Ckappa_sig.PairAgentsSiteState_map_and_set) (*potential tuple pair set*) - (Ckappa_sig.PairAgentSiteState_map_and_set) (*use to search the set in bonds rhs*) + (Ckappa_sig.PairAgentsSiteState_map_and_set) + (*potential tuple pair set*) + (Ckappa_sig.PairAgentSiteState_map_and_set) + (*use to search the set in bonds rhs*) - let proj (_, b, c, d) = (b, c, d) + let proj (_, b, c, d) = b, c, d let proj2 (x, y) = proj x, proj y let proj_bonds_aux parameters error bonds_set = - Proj_bonds.proj_set - (fun (x, y) -> proj2 (x, y)) - parameters error bonds_set + Proj_bonds.proj_set (fun (x, y) -> proj2 (x, y)) parameters error bonds_set let is_enabled static dynamic error rule_id precondition = (*test if the bond in the lhs has already in the contact map, if not @@ -386,9 +353,8 @@ struct (*------------------------------------------------------*) let error, bond_lhs_set = match - Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters error - rule_id - bond_lhs + Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters + error rule_id bond_lhs with | error, None -> error, Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty @@ -396,9 +362,10 @@ struct in let error, bond_lhs_set = proj_bonds_aux parameters error bond_lhs_set in (*------------------------------------------------------*) - if Ckappa_sig.PairAgentSiteState_map_and_set.Set.subset bond_lhs_set + if + Ckappa_sig.PairAgentSiteState_map_and_set.Set.subset bond_lhs_set contact_map - then + then ( (* use the function Communication.overwrite_potential_partners_map to fill the two fields related to the dynamic contact map *) (* then use the functions get_potential_partner and/or @@ -406,64 +373,55 @@ struct (dynamic) contact map *) (* instead of the static one *) let error, precondition = - Communication.overwrite_potential_partners_map - parameters - error + Communication.overwrite_potential_partners_map parameters error precondition (fun error agent_type site_type state -> - (* Here you should fetch the partner in the dynamic contact - map, if defined, *) - let error, statemap_bottop = - (* JF: error should be propagated, Please correct !!! *) - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, site_type) - dynamic.local.bonds_per_site - in - match statemap_bottop with - | None -> - (*error, Usual_domains.Val (agent_type, site_type, state) *) - Exception.warn - parameters error __POS__ ~message:"state map bottop is empty" - Exit (Usual_domains.Val (agent_type, site_type, state)) - (* I think you should raise an error here *) - | Some statemap -> - match - Ckappa_sig.State_map_and_set.Map.find_option - parameters error + (* Here you should fetch the partner in the dynamic contact + map, if defined, *) + let error, statemap_bottop = + (* JF: error should be propagated, Please correct !!! *) + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs + parameters error (agent_type, site_type) + dynamic.local.bonds_per_site + in + match statemap_bottop with + | None -> + (*error, Usual_domains.Val (agent_type, site_type, state) *) + Exception.warn parameters error __POS__ + ~message:"state map bottop is empty" Exit + (Usual_domains.Val (agent_type, site_type, state)) + (* I think you should raise an error here *) + | Some statemap -> + (match + Ckappa_sig.State_map_and_set.Map.find_option parameters error state statemap with - | error, None -> error, Usual_domains.Undefined - | error, Some tuple -> error, Usual_domains.Val tuple) + | error, None -> error, Usual_domains.Undefined + | error, Some tuple -> error, Usual_domains.Val tuple)) { Communication.fold = - begin - fun parameters error agent_type site_type -> - let error, statemap_bottop = - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, site_type) - dynamic.local.bonds_per_site - in - match statemap_bottop with - | None -> error, - (Usual_domains.Val - (fun _f error init -> error, init)) - | Some statemap -> - error, + (fun parameters error agent_type site_type -> + let error, statemap_bottop = + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs + parameters error (agent_type, site_type) + dynamic.local.bonds_per_site + in + match statemap_bottop with + | None -> + error, Usual_domains.Val (fun _f error init -> error, init) + | Some statemap -> + ( error, Usual_domains.Val (fun f error init -> - Ckappa_sig.State_map_and_set.Map.fold - (f parameters) - statemap - (error, init)) - end + Ckappa_sig.State_map_and_set.Map.fold (f parameters) + statemap (error, init)) )); } in error, dynamic, Some precondition - else error, dynamic, None + ) else + error, dynamic, None - (***********************************************************) + (***********************************************************) (* TO DO *) (* ignore the flag *) @@ -483,75 +441,59 @@ struct let error, bond_rhs_set = match Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters - error - rule_id - bond_rhs_map + error rule_id bond_rhs_map with | error, None -> - error, - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty + error, Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty | error, Some s -> error, s in - let error, bond_rhs_set = - proj_bonds_aux parameters error bond_rhs_set - in + let error, bond_rhs_set = proj_bonds_aux parameters error bond_rhs_set in (*------------------------------------------------------*) let error', union = - Ckappa_sig.PairAgentSiteState_map_and_set.Set.union - parameters error contact_map bond_rhs_set + Ckappa_sig.PairAgentSiteState_map_and_set.Set.union parameters error + contact_map bond_rhs_set in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let dynamic = set_contact_map_dynamic union dynamic in (*------------------------------------------------------*) let new_contact_map = get_contact_map_dynamic dynamic in let error', map_diff = - Ckappa_sig.PairAgentSiteState_map_and_set.Set.diff - parameters error new_contact_map contact_map + Ckappa_sig.PairAgentSiteState_map_and_set.Set.diff parameters error + new_contact_map contact_map in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in (*------------------------------------------------------*) (*update the second field*) let error, dynamic = Ckappa_sig.PairAgentSiteState_map_and_set.Set.fold (fun bond (error, dynamic) -> - add_bond_in_map_of_bonds static dynamic error bond - ) map_diff (error, dynamic) + add_bond_in_map_of_bonds static dynamic error bond) + map_diff (error, dynamic) in (*check if it is seen for the first time, if not update the contact map, and raise an event*) - let error, event_list = - collect_events static error map_diff event_list - in + let error, event_list = collect_events static error map_diff event_list in error, dynamic, (precondition, event_list) let apply_event_list _static dynamic error _event_list = let event_list = [] in error, dynamic, event_list - let apply_one_side_effect - _static dynamic error - _ _ precondition - = - error, dynamic, (precondition,[]) (* this domain ignores side effects *) + let apply_one_side_effect _static dynamic error _ _ precondition = + error, dynamic, (precondition, []) + (* this domain ignores side effects *) let stabilize _static dynamic error = error, dynamic, () - - let export _static dynamic error kasa_state = - error, dynamic, kasa_state + let export _static dynamic error kasa_state = error, dynamic, kasa_state let print ?dead_rules _static dynamic error _loggers = let _ = dead_rules in error, dynamic, () - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects end diff --git a/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.mli b/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.mli index 9e7e210768..3fc22cc143 100644 --- a/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.mli +++ b/core/KaSa_rep/reachability_analysis/dynamic_contact_map_domain.mli @@ -17,4 +17,4 @@ (** This domain tracks which rules can be applied, and warns other domains at the first application of a rule *) -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/parallel_bonds.ml b/core/KaSa_rep/reachability_analysis/parallel_bonds.ml index a019e11ec5..81c7208af8 100644 --- a/core/KaSa_rep/reachability_analysis/parallel_bonds.ml +++ b/core/KaSa_rep/reachability_analysis/parallel_bonds.ml @@ -19,9 +19,7 @@ let local_trace = false -module Domain = -struct - +module Domain = struct (* the type of the struct that contains all static information as in the previous version of the analysis *) @@ -39,33 +37,30 @@ struct which rules can contain parallel bonds in their lhs *) (*************************************************************************) - type static_information = - { - global_static_information : Analyzer_headers.global_static_information; - local_static_information : Parallel_bonds_static.local_static_information - } + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + local_static_information: Parallel_bonds_static.local_static_information; + } (*--------------------------------------------------------------*) (* One map: for each tuple: Yes, No, Maybe. - - Yes: to say that when the sites x and y are bound with sites of - the good type, then they are bound to the same B. - - No: to say that when the sites x and y are bound with sites of the good - type, then they are never bound to the same B. - - Maybe: both cases may happen.*) - - type local_dynamic_information = - { - dummy: unit; - store_value: - bool Usual_domains.flat_lattice - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.t - } - - type dynamic_information = - { - local : local_dynamic_information ; - global : Analyzer_headers.global_dynamic_information; - } + - Yes: to say that when the sites x and y are bound with sites of + the good type, then they are bound to the same B. + - No: to say that when the sites x and y are bound with sites of the good + type, then they are never bound to the same B. + - Maybe: both cases may happen.*) + + type local_dynamic_information = { + dummy: unit; + store_value: + bool Usual_domains.flat_lattice + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.t; + } + + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } (** Static information: Explain how to extract the handler for kappa expressions from a value @@ -75,13 +70,9 @@ struct (*global static information*) let get_global_static_information static = static.global_static_information - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static - let get_kappa_handler static = lift Analyzer_headers.get_kappa_handler static - let get_compil static = lift Analyzer_headers.get_cc_code static let get_action_binding static = @@ -90,18 +81,12 @@ struct let get_local_static_information static = static.local_static_information let set_local_static_information local static = - { - static with - local_static_information = local - } + { static with local_static_information = local } let get_rule parameter error static r_id = let compil = get_compil static in - let error, rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameter - error - r_id + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameter error r_id compil.Cckappa_sig.rules in error, rule @@ -109,162 +94,149 @@ struct (*static information*) let get_tuples_of_interest static = - (get_local_static_information - static).Parallel_bonds_static.store_tuples_of_interest + (get_local_static_information static) + .Parallel_bonds_static.store_tuples_of_interest let set_tuples_of_interest bonds static = set_local_static_information { (get_local_static_information static) with - Parallel_bonds_static.store_tuples_of_interest = bonds + Parallel_bonds_static.store_tuples_of_interest = bonds; } static let get_closure static = - (get_local_static_information - static).Parallel_bonds_static.store_closure + (get_local_static_information static).Parallel_bonds_static.store_closure let set_closure closure static = - set_local_static_information - { - (get_local_static_information static) with - Parallel_bonds_static.store_closure = closure - } - static + set_local_static_information + { + (get_local_static_information static) with + Parallel_bonds_static.store_closure = closure; + } + static let get_rule_double_bonds_rhs static = - (get_local_static_information - static).Parallel_bonds_static.store_rule_double_bonds_rhs + (get_local_static_information static) + .Parallel_bonds_static.store_rule_double_bonds_rhs let set_rule_double_bonds_rhs bonds static = set_local_static_information { (get_local_static_information static) with - Parallel_bonds_static.store_rule_double_bonds_rhs = bonds + Parallel_bonds_static.store_rule_double_bonds_rhs = bonds; } static let get_fst_site_create_parallel_bonds_rhs static = - (get_local_static_information - static).Parallel_bonds_static.store_fst_site_create_parallel_bonds_rhs + (get_local_static_information static) + .Parallel_bonds_static.store_fst_site_create_parallel_bonds_rhs let set_fst_site_create_parallel_bonds_rhs l static = set_local_static_information { (get_local_static_information static) with - Parallel_bonds_static.store_fst_site_create_parallel_bonds_rhs = l + Parallel_bonds_static.store_fst_site_create_parallel_bonds_rhs = l; } static let get_snd_site_create_parallel_bonds_rhs static = - (get_local_static_information - static).Parallel_bonds_static.store_snd_site_create_parallel_bonds_rhs + (get_local_static_information static) + .Parallel_bonds_static.store_snd_site_create_parallel_bonds_rhs let set_snd_site_create_parallel_bonds_rhs l static = set_local_static_information { (get_local_static_information static) with - Parallel_bonds_static.store_snd_site_create_parallel_bonds_rhs = l + Parallel_bonds_static.store_snd_site_create_parallel_bonds_rhs = l; } static let get_rule_double_bonds_lhs static = - (get_local_static_information - static).Parallel_bonds_static.store_rule_double_bonds_lhs + (get_local_static_information static) + .Parallel_bonds_static.store_rule_double_bonds_lhs let set_rule_double_bonds_lhs bonds static = set_local_static_information { (get_local_static_information static) with - Parallel_bonds_static.store_rule_double_bonds_lhs = bonds + Parallel_bonds_static.store_rule_double_bonds_lhs = bonds; } static -(*map tuple to sites*) + (*map tuple to sites*) let get_tuple_to_sites static = - (get_local_static_information - static).Parallel_bonds_static.store_tuple_to_sites + (get_local_static_information static) + .Parallel_bonds_static.store_tuple_to_sites let set_tuple_to_sites tuple static = set_local_static_information { (get_local_static_information static) with - Parallel_bonds_static.store_tuple_to_sites = tuple + Parallel_bonds_static.store_tuple_to_sites = tuple; } static let get_sites_to_tuple static = - (get_local_static_information - static).Parallel_bonds_static.store_sites_to_tuple + (get_local_static_information static) + .Parallel_bonds_static.store_sites_to_tuple let set_sites_to_tuple sites static = set_local_static_information { (get_local_static_information static) with - Parallel_bonds_static.store_sites_to_tuple = sites + Parallel_bonds_static.store_sites_to_tuple = sites; } static (*global dynamic information*) let get_global_dynamic_information dynamic = dynamic.global - let get_local_dynamic_information dynamic = dynamic.local + let set_local_dynamic_information local dynamic = { dynamic with local } + let set_global_dynamic_information global dynamic = { dynamic with global } - let set_local_dynamic_information local dynamic = - { - dynamic with local = local - } + (*dynamic information*) - let set_global_dynamic_information global dynamic = - { - dynamic with global = global - } - -(*dynamic information*) - - let get_value dynamic = - (get_local_dynamic_information dynamic).store_value + let get_value dynamic = (get_local_dynamic_information dynamic).store_value let set_value value dynamic = set_local_dynamic_information - { - (get_local_dynamic_information dynamic) with - store_value = value - } dynamic + { (get_local_dynamic_information dynamic) with store_value = value } + dynamic (*--------------------------------------------------------------*) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (****************************************************************) (*rule*) @@ -276,23 +248,23 @@ struct (*a set of rules that has a potential double binding or potential non double binding on the lhs*) let store_result = get_rule_double_bonds_lhs static in let error, store_result = - Parallel_bonds_static.collect_rule_double_bonds_lhs - parameters error rule_id rule store_result + Parallel_bonds_static.collect_rule_double_bonds_lhs parameters error + rule_id rule store_result in let static = set_rule_double_bonds_lhs store_result static in (*------------------------------------------------------*) (*a set of rules that has a potential double bindings on the rhs*) let store_result = get_rule_double_bonds_rhs static in let error, store_result = - Parallel_bonds_static.collect_rule_double_bonds_rhs - parameters error rule_id rule store_result + Parallel_bonds_static.collect_rule_double_bonds_rhs parameters error + rule_id rule store_result in let static = set_rule_double_bonds_rhs store_result static in error, static -(****************************************************************) -(*rules*) -(****************************************************************) + (****************************************************************) + (*rules*) + (****************************************************************) let apply_closure_to_tuples_of_interest parameter error tuples_of_interest = let error, array = @@ -301,104 +273,86 @@ struct in let error, array = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.fold - (fun tuple (error, array) -> - let ((ag,_,_,_,_),_) = tuple in - let error, old = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameter error - ag array - in - let old = - match old with - | Some a -> a - | None -> [] - in - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set parameter error ag (tuple::old) array - ) - tuples_of_interest - (error, array) + (fun tuple (error, array) -> + let (ag, _, _, _, _), _ = tuple in + let error, old = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameter error ag array + in + let old = + match old with + | Some a -> a + | None -> [] + in + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameter error ag (tuple :: old) array) + tuples_of_interest (error, array) in let add_single parameter error proof key tuples_of_interest map = let error, tuples_of_interest = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.add_when_not_in - parameter error - key - tuples_of_interest + parameter error key tuples_of_interest in let error, old = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.find_default_without_logs - parameter error - [] - key - map + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map + .find_default_without_logs parameter error [] key map in let error, map = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.add_or_overwrite - parameter error - key - (proof::old) - map + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map + .add_or_overwrite parameter error key (proof :: old) map in error, (tuples_of_interest, map) in let add parameter error proof p1 p2 tuples_of_interest map = let error, (tuples_of_interest, map) = - add_single - parameter error proof - (p1,p2) - tuples_of_interest map + add_single parameter error proof (p1, p2) tuples_of_interest map in - add_single - parameter error proof - (p2,p1) - tuples_of_interest map + add_single parameter error proof (p2, p1) tuples_of_interest map in let error, (tuples_of_interest, map) = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold parameter error - (fun parameter error agent list (tuples_of_interest,map) -> - let rec aux list (error, (tuples_of_interest,map)) = - match list with - | [] -> error, (tuples_of_interest,map) - | h::t -> - let p1,p2 = h in - let (_,site1,site1_,state1,state1_) = p1 in - let (agent2,site2,site2_,state2,state2_) = p2 in - let error, tuples_of_interest = - List.fold_left - (fun (error, (tuples_of_interest,map)) (p1',p2') -> - let (_,site1',site1_',_,state1_') = p1' in - let (agent2',site2',site2_',_,state2_') = p2' in - if agent2=agent2' && site1 = site1' && site2 = site2' - then - add parameter error - (site1, site2, state1, state2, h, (p1',p2')) - (agent,site1_,site1_',state1_,state1_') - (agent2,site2_,site2_',state2_,state2_') - tuples_of_interest map - else - error, (tuples_of_interest,map)) - - (error, (tuples_of_interest,map)) t in - aux t (error, tuples_of_interest) - in - aux list (error, (tuples_of_interest,map))) - array (tuples_of_interest, - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty) + (fun parameter error agent list (tuples_of_interest, map) -> + let rec aux list (error, (tuples_of_interest, map)) = + match list with + | [] -> error, (tuples_of_interest, map) + | h :: t -> + let p1, p2 = h in + let _, site1, site1_, state1, state1_ = p1 in + let agent2, site2, site2_, state2, state2_ = p2 in + let error, tuples_of_interest = + List.fold_left + (fun (error, (tuples_of_interest, map)) (p1', p2') -> + let _, site1', site1_', _, state1_' = p1' in + let agent2', site2', site2_', _, state2_' = p2' in + if agent2 = agent2' && site1 = site1' && site2 = site2' then + add parameter error + (site1, site2, state1, state2, h, (p1', p2')) + (agent, site1_, site1_', state1_, state1_') + (agent2, site2_, site2_', state2_, state2_') + tuples_of_interest map + else + error, (tuples_of_interest, map)) + (error, (tuples_of_interest, map)) + t + in + aux t (error, tuples_of_interest) + in + aux list (error, (tuples_of_interest, map))) + array + ( tuples_of_interest, + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty ) in - error, (tuples_of_interest,map) + error, (tuples_of_interest, map) let scan_rules static dynamic error = let parameters = get_parameter static in let compil = get_compil static in let error, static = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun _ error rule_id rule static -> - scan_rule - static dynamic error rule_id rule.Cckappa_sig.e_rule_c_rule - ) compil.Cckappa_sig.rules static + scan_rule static dynamic error rule_id rule.Cckappa_sig.e_rule_c_rule) + compil.Cckappa_sig.rules static in (*------------------------------------------------------*) (*A(x!1, y), B(x!1, y): first site is an action binding*) @@ -406,28 +360,26 @@ struct let lift_map error s = Ckappa_sig.Rule_map_and_set.Map.fold (fun _ big_store (error, set) -> - Parallel_bonds_static.project_away_ag_id_and_convert_into_set - parameters error big_store set) + Parallel_bonds_static.project_away_ag_id_and_convert_into_set + parameters error big_store set) s (error, Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty) in let error, store_result1 = - lift_map error (get_rule_double_bonds_lhs static) in + lift_map error (get_rule_double_bonds_lhs static) + in let error, store_result2 = - lift_map error (get_rule_double_bonds_rhs static) in + lift_map error (get_rule_double_bonds_rhs static) + in let error, store_result = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.union - parameters error store_result1 store_result2 + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.union parameters + error store_result1 store_result2 in - let error, (store_result,map) = + let error, (store_result, map) = apply_closure_to_tuples_of_interest parameters error store_result in - let static = - set_tuples_of_interest store_result static - in - let static = - set_closure map static - in + let static = set_tuples_of_interest store_result static in + let static = set_closure map static in (*------------------------------------------------------*) let tuples_of_interest = store_result in let store_action_binding = get_action_binding static in @@ -447,8 +399,7 @@ struct (*map tuples to sites*) let tuples_of_interest = get_tuples_of_interest static in let error, store_result = - Parallel_bonds_static.collect_tuple_to_sites - parameters error + Parallel_bonds_static.collect_tuple_to_sites parameters error tuples_of_interest in let static = set_tuple_to_sites store_result static in @@ -457,10 +408,8 @@ struct let tuple_to_sites = get_tuple_to_sites static in let store_sites_to_tuple = get_sites_to_tuple static in let error, store_result = - Parallel_bonds_static.collect_sites_to_tuple - parameters error - tuple_to_sites - store_sites_to_tuple + Parallel_bonds_static.collect_sites_to_tuple parameters error + tuple_to_sites store_sites_to_tuple in let static = set_sites_to_tuple store_result static in error, static, dynamic @@ -478,153 +427,113 @@ struct { dummy = (); store_value = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty; } in let init_global_dynamic_information = - { - global = dynamic; - local = init_local_dynamic_information ; - } + { global = dynamic; local = init_local_dynamic_information } in let error, static, dynamic = - scan_rules - init_global_static_information - init_global_dynamic_information error + scan_rules init_global_static_information init_global_dynamic_information + error in error, static, dynamic, [] - let add_rules_tuples_into_wake_up_relation parameters error - rule_tuples wake_up = + let add_rules_tuples_into_wake_up_relation parameters error rule_tuples + wake_up = Ckappa_sig.Rule_map_and_set.Map.fold (fun rule_id map (error, wake_up) -> - Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.fold - (fun _ list (error, wake_up) -> - List.fold_left (fun (error, wake_up) (u, v) -> - let (_, agent_type, site_type1, site_type2, _, _) = u in - let (_, agent_type', site_type1', site_type2', _, _) = v in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type - site_type1 - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type - site_type2 - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type' - site_type1' - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type' - site_type2' - rule_id - wake_up - in - error, wake_up - ) (error, wake_up) list - ) map (error, wake_up) - ) rule_tuples (error, wake_up) + Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.fold + (fun _ list (error, wake_up) -> + List.fold_left + (fun (error, wake_up) (u, v) -> + let _, agent_type, site_type1, site_type2, _, _ = u in + let _, agent_type', site_type1', site_type2', _, _ = v in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type site_type1 rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type site_type2 rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type' site_type1' rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type' site_type2' rule_id wake_up + in + error, wake_up) + (error, wake_up) list) + map (error, wake_up)) + rule_tuples (error, wake_up) - let add_rules_tuples_into_wake_up_relation' parameters error - store_map wake_up = + let add_rules_tuples_into_wake_up_relation' parameters error store_map wake_up + = Ckappa_sig.Rule_map_and_set.Map.fold (fun rule_id map (error, wake_up) -> - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.fold - (fun (_, ((agent_type, site_type1, site_type2, _, _), - (agent_type', site_type1', site_type2', _, _))) - _b (error, wake_up) -> - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type - site_type1 - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type - site_type2 - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type' - site_type1' - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type' - site_type2' - rule_id - wake_up - in - error, wake_up - ) map (error, wake_up) - ) store_map (error, wake_up ) + Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.fold + (fun ( _, + ( (agent_type, site_type1, site_type2, _, _), + (agent_type', site_type1', site_type2', _, _) ) ) _b + (error, wake_up) -> + let error, wake_up = + Common_static.add_dependency_site_rule parameters error agent_type + site_type1 rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error agent_type + site_type2 rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type' site_type1' rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type' site_type2' rule_id wake_up + in + error, wake_up) + map (error, wake_up)) + store_map (error, wake_up) (* fold over all the rules, all the tuples of interest, all the sites in - these tuples, and apply the function Common_static.add_dependency_site_rule - to update the wake_up relation *) - let complete_wake_up_relation static error wake_up = - let parameters = get_parameter static in - (*fst site created a parallel bonds*) - let store_rule_double_bonds_rhs = - get_rule_double_bonds_rhs static in - let store_rule_double_bonds_lhs = - get_rule_double_bonds_lhs static in - (*----------------------------------------------------*) - let store_fst_site_create_parallel_bonds_rhs = - get_fst_site_create_parallel_bonds_rhs static in - let store_snd_site_create_parallel_bonds_rhs = - get_snd_site_create_parallel_bonds_rhs static in - (*----------------------------------------------------*) - let error, wake_up = - add_rules_tuples_into_wake_up_relation' - parameters error - store_rule_double_bonds_rhs - wake_up - in - let error, wake_up = - add_rules_tuples_into_wake_up_relation' - parameters error - store_rule_double_bonds_lhs - wake_up - in - (*----------------------------------------------------*) - let error, wake_up = + these tuples, and apply the function Common_static.add_dependency_site_rule + to update the wake_up relation *) + let complete_wake_up_relation static error wake_up = + let parameters = get_parameter static in + (*fst site created a parallel bonds*) + let store_rule_double_bonds_rhs = get_rule_double_bonds_rhs static in + let store_rule_double_bonds_lhs = get_rule_double_bonds_lhs static in + (*----------------------------------------------------*) + let store_fst_site_create_parallel_bonds_rhs = + get_fst_site_create_parallel_bonds_rhs static + in + let store_snd_site_create_parallel_bonds_rhs = + get_snd_site_create_parallel_bonds_rhs static + in + (*----------------------------------------------------*) + let error, wake_up = + add_rules_tuples_into_wake_up_relation' parameters error + store_rule_double_bonds_rhs wake_up + in + let error, wake_up = + add_rules_tuples_into_wake_up_relation' parameters error + store_rule_double_bonds_lhs wake_up + in + (*----------------------------------------------------*) + let error, wake_up = add_rules_tuples_into_wake_up_relation parameters error - store_fst_site_create_parallel_bonds_rhs - wake_up - in - (*----------------------------------------------------*) - let error, wake_up = + store_fst_site_create_parallel_bonds_rhs wake_up + in + (*----------------------------------------------------*) + let error, wake_up = add_rules_tuples_into_wake_up_relation parameters error - store_snd_site_create_parallel_bonds_rhs - wake_up - in - error, wake_up + store_snd_site_create_parallel_bonds_rhs wake_up + in + error, wake_up (***************************************************************) (*a map of parallel bonds in the initial states, if the set @@ -633,16 +542,13 @@ struct let compute_value_init static dynamic error init_state = let parameters = get_parameter static in - let tuples_of_interest = - get_tuples_of_interest static - in + let tuples_of_interest = get_tuples_of_interest static in let kappa_handler = get_kappa_handler static in (*value of parallel and non parallel bonds*) let store_result = get_value dynamic in let error, store_result = - Parallel_bonds_init.collect_parallel_or_not_bonds_init - parameters kappa_handler error - tuples_of_interest init_state store_result + Parallel_bonds_init.collect_parallel_or_not_bonds_init parameters + kappa_handler error tuples_of_interest init_state store_result in let dynamic = set_value store_result dynamic in error, dynamic @@ -652,34 +558,28 @@ struct let add_initial_state static dynamic error species = let event_list = [] in (*parallel bonds in the initial states*) - let error, dynamic = - compute_value_init static dynamic error species - in + let error, dynamic = compute_value_init static dynamic error species in error, dynamic, event_list (*************************************************************) (* if a parallel bound occurs on the lhs, check that this is possible *) - let common_scan parameters error tuples_of_interest store_value list = + let common_scan parameters error tuples_of_interest store_value list = let rec scan list error = - match - list - with + match list with | [] -> error, true | (tuple, parallel_or_not) :: tail -> let pair = Parallel_bonds_type.project2 tuple in let error, value = match - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.find_option_without_logs - parameters error - pair - store_value + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map + .find_option_without_logs parameters error pair store_value with (*if we do not find the pair on the lhs inside the result, then return undefined if this is a tuple of interest, Any if this is not; if there is a double bound then returns its value.*) | error, None -> if - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.mem - pair tuples_of_interest + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.mem pair + tuples_of_interest then error, Usual_domains.Undefined else @@ -687,19 +587,18 @@ struct | error, Some v -> error, v in (*matching the value on the lhs*) - match value with + (match value with | Usual_domains.Undefined -> error, false (*if the value in the result is different than the value on the lhs, then returns false*) | Usual_domains.Val b when b <> parallel_or_not -> error, false (*otherwise continue until the rest of the list*) - | Usual_domains.Val _ - | Usual_domains.Any -> scan tail error + | Usual_domains.Val _ | Usual_domains.Any -> scan tail error) in scan list error (*************************************************************) - let is_enabled static dynamic error (rule_id:Ckappa_sig.c_rule_id) + let is_enabled static dynamic error (rule_id : Ckappa_sig.c_rule_id) precondition = let parameters = get_parameter static in let tuples_of_interest = get_tuples_of_interest static in @@ -707,14 +606,12 @@ struct (*look into the lhs, whether or not there exists a double bound.*) let store_rule_has_parallel_bonds_lhs = get_rule_double_bonds_lhs static in let error, parallel_map = - match Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs - parameters error - rule_id - store_rule_has_parallel_bonds_lhs + match + Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters + error rule_id store_rule_has_parallel_bonds_lhs with | error, None -> - error, - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty + error, Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty | error, Some s -> error, s in let list = @@ -726,20 +623,20 @@ struct let error, bool = common_scan parameters error tuples_of_interest store_value list in - if bool - then error, dynamic, Some precondition - else error, dynamic, None + if bool then + error, dynamic, Some precondition + else + error, dynamic, None (***********************************************************) let maybe_reachable static dynamic error flag pattern precondition = - (* non parallel bonds in a pattern can be maps to parallel ones through morphisms *) - (* thus when the flag is Morphisms with ignore non parallel bonds *) + (* non parallel bonds in a pattern can be maps to parallel ones through morphisms *) + (* thus when the flag is Morphisms with ignore non parallel bonds *) let parameters = get_parameter static in let tuples_of_interest = get_tuples_of_interest static in let error, parallel_map = - Parallel_bonds_static.collect_double_bonds_in_pattern - parameters error + Parallel_bonds_static.collect_double_bonds_in_pattern parameters error pattern in let list = @@ -747,27 +644,25 @@ struct parallel_map in let list = - match - flag - with + match flag with | Analyzer_headers.Morphisms -> List.fold_left - (fun list (a,b) -> - if b - then (a,b)::list - else list) + (fun list (a, b) -> + if b then + (a, b) :: list + else + list) [] (List.rev list) - | Analyzer_headers.Embeddings -> - list + | Analyzer_headers.Embeddings -> list in let store_value = get_value dynamic in let error, bool = common_scan parameters error tuples_of_interest store_value list in - if bool - then error, dynamic, Some precondition + if bool then + error, dynamic, Some precondition else - error, dynamic, None + error, dynamic, None (***************************************************************) (* when one bond is created, check in the precondition, whether the two @@ -782,10 +677,10 @@ struct let necessarily_double idx idy (x, y) map = Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.mem (idx, (x, y)) - map || - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.mem - (idy, (y, x)) map + || Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.mem + (idy, (y, x)) + map type pos = Fst | Snd @@ -799,14 +694,11 @@ struct in let error, store_pair_bind_map = match - Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs - parameters error - rule_id - store_site_create_parallel_bonds_rhs + Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters + error rule_id store_site_create_parallel_bonds_rhs with | error, None -> - error, - Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.empty + error, Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.empty | error, Some m -> error, m in let store_rule_double_bonds_rhs = get_rule_double_bonds_rhs static in @@ -814,10 +706,8 @@ struct rhs*) let error, rule_double_bonds_rhs_map = match - Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs - parameters error - rule_id - store_rule_double_bonds_rhs + Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters + error rule_id store_rule_double_bonds_rhs with | error, None -> error, Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty @@ -826,316 +716,323 @@ struct (*-----------------------------------------------------------*) Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.fold (fun (_, _) parallel_list (error, dynamic, precondition, store_result) -> - let error, dynamic, precondition, store_result = - List.fold_left - (fun - (error, dynamic, precondition, store_result) (z, t) -> - let (agent_id, agent_type, site_type1, site_type2, state1, - state2) = z - in - let (agent_id', agent_type', site_type1', site_type2', - state1', state2') = t - in - let z' = Parallel_bonds_type.project z in - let t' = Parallel_bonds_type.project t in - let - site_specified, - site_specified', - state_specified, - state_specified', - site_unspecified, - site_unspecified', - state_unspecified, - state_unspecified' = - match pos with - | Fst -> - site_type1, site_type1', state1, state1', - site_type2, site_type2', state2, state2' - | Snd -> - site_type2, site_type2', state2, state2', - site_type1, site_type1', state1, state1' - in - if - necessarily_double - agent_id - agent_id' - (z', t') - rule_double_bonds_rhs_map - then - (error, dynamic, precondition, store_result) - else - (*check the agent_type, and site_type1*) - let error, old_value = - match - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.find_option_without_logs - parameters error - (agent_id, (z', t')) - store_result - with - | error, None -> - error, Usual_domains.Undefined - | error, Some value -> error, value - in - (*------------------------------------------------------*) - (*get a list of potential states of the second site*) - let error, dynamic, precondition, state_list = - Communication.get_state_of_site_in_postcondition - get_global_static_information - get_global_dynamic_information - set_global_dynamic_information - error static dynamic - (rule_id, rule) - agent_id (*A*) - site_unspecified - precondition - in - let error, dynamic, precondition, state_list' = - Communication.get_state_of_site_in_postcondition - get_global_static_information - get_global_dynamic_information - set_global_dynamic_information - error static dynamic - (rule_id,rule) - agent_id' (*B*) - site_unspecified' - precondition - in - let error, dynamic, precondition, store_result = - match state_list, state_list' with - | [], _ | _, [] -> - let error, () = - Exception.warn parameters error __POS__ - ~message: "empty list in potential states in post condition" Exit () - in - error, dynamic, precondition, store_result - | _::_::_, _::_::_ - | [_], _ | _, [_] -> (*general case*) - let error, potential_list = - List.fold_left - (fun (error, current_list) pre_state -> - List.fold_left - (fun (error, current_list) pre_state' -> - let tuple = - match pos with - | Fst -> - (agent_id, agent_type, - site_specified, site_unspecified, - state_specified, pre_state ), - (agent_id',agent_type', - site_specified',site_unspecified', - state_specified',pre_state') - | Snd -> - (agent_id, agent_type, - site_unspecified, site_specified, - pre_state, state_specified ), - (agent_id', agent_type', site_unspecified',site_specified', + let error, dynamic, precondition, store_result = + List.fold_left + (fun (error, dynamic, precondition, store_result) (z, t) -> + let agent_id, agent_type, site_type1, site_type2, state1, state2 = + z + in + let ( agent_id', + agent_type', + site_type1', + site_type2', + state1', + state2' ) = + t + in + let z' = Parallel_bonds_type.project z in + let t' = Parallel_bonds_type.project t in + let ( site_specified, + site_specified', + state_specified, + state_specified', + site_unspecified, + site_unspecified', + state_unspecified, + state_unspecified' ) = + match pos with + | Fst -> + ( site_type1, + site_type1', + state1, + state1', + site_type2, + site_type2', + state2, + state2' ) + | Snd -> + ( site_type2, + site_type2', + state2, + state2', + site_type1, + site_type1', + state1, + state1' ) + in + if + necessarily_double agent_id agent_id' (z', t') + rule_double_bonds_rhs_map + then + error, dynamic, precondition, store_result + else ( + (*check the agent_type, and site_type1*) + let error, old_value = + match + Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map + .find_option_without_logs parameters error + (agent_id, (z', t')) + store_result + with + | error, None -> error, Usual_domains.Undefined + | error, Some value -> error, value + in + (*------------------------------------------------------*) + (*get a list of potential states of the second site*) + let error, dynamic, precondition, state_list = + Communication.get_state_of_site_in_postcondition + get_global_static_information get_global_dynamic_information + set_global_dynamic_information error static dynamic + (rule_id, rule) agent_id (*A*) + site_unspecified precondition + in + let error, dynamic, precondition, state_list' = + Communication.get_state_of_site_in_postcondition + get_global_static_information get_global_dynamic_information + set_global_dynamic_information error static dynamic + (rule_id, rule) agent_id' (*B*) + site_unspecified' precondition + in + let error, dynamic, precondition, store_result = + match state_list, state_list' with + | [], _ | _, [] -> + let error, () = + Exception.warn parameters error __POS__ + ~message: + "empty list in potential states in post condition" + Exit () + in + error, dynamic, precondition, store_result + | _ :: _ :: _, _ :: _ :: _ | [ _ ], _ | _, [ _ ] -> + (*general case*) + let error, potential_list = + List.fold_left + (fun (error, current_list) pre_state -> + List.fold_left + (fun (error, current_list) pre_state' -> + let tuple = + match pos with + | Fst -> + ( ( agent_id, + agent_type, + site_specified, + site_unspecified, + state_specified, + pre_state ), + ( agent_id', + agent_type', + site_specified', + site_unspecified', + state_specified', + pre_state' ) ) + | Snd -> + ( ( agent_id, + agent_type, + site_unspecified, + site_specified, + pre_state, + state_specified ), + ( agent_id', + agent_type', + site_unspecified', + site_specified', pre_state', - state_specified') - in - let potential_list = - tuple - :: current_list - in - error, potential_list - ) (error, current_list) state_list' - ) (error, []) state_list - in - (*------------------------------------------------------*) - (*fold over a potential list and compare with parallel - list*) - let error, dynamic, precondition, value = - List.fold_left - (fun (error, dynamic, precondition, value) (x', y') -> - let pre_state_other, pre_state_other' = - match pos with - | Fst -> - let (_, _, _, _, _, pre_state2) = x' in - let (_,_,_,_,_,pre_state2') = y' in - pre_state2,pre_state2' - | Snd -> - let (_, _, _, _, pre_state1, _) = x' in - let (_, _, _, _, pre_state1', _) = x' in - pre_state1,pre_state1' - in - (*check if the pre_state_other and pre_state_other' - are the good ones. - If yes -> Any - If no -> Undefined *) - begin - if - not - (pre_state_other = state_unspecified - && pre_state_other' = state_unspecified') - then - (* Not the good states *) - let new_value = - Usual_domains.lub value - Usual_domains.Undefined - in - error, dynamic, precondition, new_value - else - begin (* compatible states *) - let error, dynamic, precondition, update_value = - let error, closure_list = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.find_default_without_logs - parameters error - [] (z',t') closure - in - let error, dynamic, precondition, bool = - let rec aux error dynamic precondition l = - match l with - | [] -> - error, dynamic, precondition, false - | h::t -> - let - (site_bond_test, - site_bond_test', - state_bond_test, - state_bond_test', _,_) = h - in - - let error, b = - let rec aux2 error l = - match l with - [] -> error, false - | (site_clo_1', - _site_clo_2', - state_clo_1', - _state_clo_2',_,_)::tail - -> - if (* Could be optimized *) - site_bond_test = site_clo_1' && - state_bond_test = state_clo_1' - then - begin - if - necessarily_double - agent_id - agent_id' - ((agent_type, - site_bond_test, - site_specified, - state_bond_test, - state_specified) - , - (agent_type', - site_bond_test', - site_specified', - state_bond_test', - state_specified') - ) - rule_double_bonds_rhs_map - then - begin - let tuple = - (agent_type, - site_bond_test, - site_unspecified, - state_bond_test, - state_unspecified), - (agent_type', - site_bond_test', - site_unspecified', - state_bond_test', - state_unspecified') - in - match - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.find_default_without_logs - parameters - error - Usual_domains.Undefined - tuple - store_value - with - | error, - (Usual_domains.Val false |Usual_domains.Any) -> - aux2 error tail - | error, - (Usual_domains.Val true - |Usual_domains.Undefined) - -> error, true - end - else - aux2 error tail - end - else - aux2 error tail - in - aux2 error closure_list - in - if b then - error, dynamic, precondition, true - else aux error dynamic precondition t - in - aux error dynamic precondition closure_list - in - if bool - then - error, - dynamic, precondition, - Usual_domains.Val true - else - error, - dynamic, precondition, - Usual_domains.Any - in - let new_value = - Usual_domains.lub value - update_value - in - error, dynamic, precondition, new_value - end - end - ) (error, dynamic, precondition, old_value) potential_list - in - (*------------------------------------------------------*) - (*call the symmetric add *) - let error, store_result = - Parallel_bonds_type.add_symmetric_tuple_pair - (fun parameters error t map -> - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.add_or_overwrite - parameters error - t - value - map) - parameters - error - (z, t) - store_result - in - error, dynamic, precondition, store_result - in - error, dynamic, precondition, store_result - ) (error, dynamic, precondition, store_result) parallel_list - in - error, dynamic, precondition, store_result - ) store_pair_bind_map - (error, dynamic, precondition, - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty) - - let discover_a_new_pair_of_modify_sites - parameters error store_set modified_sites = + state_specified' ) ) + in + let potential_list = tuple :: current_list in + error, potential_list) + (error, current_list) state_list') + (error, []) state_list + in + (*------------------------------------------------------*) + (*fold over a potential list and compare with parallel + list*) + let error, dynamic, precondition, value = + List.fold_left + (fun (error, dynamic, precondition, value) (x', y') -> + let pre_state_other, pre_state_other' = + match pos with + | Fst -> + let _, _, _, _, _, pre_state2 = x' in + let _, _, _, _, _, pre_state2' = y' in + pre_state2, pre_state2' + | Snd -> + let _, _, _, _, pre_state1, _ = x' in + let _, _, _, _, pre_state1', _ = x' in + pre_state1, pre_state1' + in + (*check if the pre_state_other and pre_state_other' + are the good ones. + If yes -> Any + If no -> Undefined *) + if + not + (pre_state_other = state_unspecified + && pre_state_other' = state_unspecified') + then ( + (* Not the good states *) + let new_value = + Usual_domains.lub value Usual_domains.Undefined + in + error, dynamic, precondition, new_value + ) else ( + (* compatible states *) + let error, dynamic, precondition, update_value = + let error, closure_list = + Parallel_bonds_type + .PairAgentSitesStates_map_and_set + .Map + .find_default_without_logs parameters error [] + (z', t') closure + in + let error, dynamic, precondition, bool = + let rec aux error dynamic precondition l = + match l with + | [] -> error, dynamic, precondition, false + | h :: t -> + let ( site_bond_test, + site_bond_test', + state_bond_test, + state_bond_test', + _, + _ ) = + h + in + + let error, b = + let rec aux2 error l = + match l with + | [] -> error, false + | ( site_clo_1', + _site_clo_2', + state_clo_1', + _state_clo_2', + _, + _ ) + :: tail -> + if + (* Could be optimized *) + site_bond_test = site_clo_1' + && state_bond_test = state_clo_1' + then + if + necessarily_double agent_id + agent_id' + ( ( agent_type, + site_bond_test, + site_specified, + state_bond_test, + state_specified ), + ( agent_type', + site_bond_test', + site_specified', + state_bond_test', + state_specified' ) ) + rule_double_bonds_rhs_map + then ( + let tuple = + ( ( agent_type, + site_bond_test, + site_unspecified, + state_bond_test, + state_unspecified ), + ( agent_type', + site_bond_test', + site_unspecified', + state_bond_test', + state_unspecified' ) ) + in + match + Parallel_bonds_type + .PairAgentSitesStates_map_and_set + .Map + .find_default_without_logs + parameters error + Usual_domains.Undefined tuple + store_value + with + | ( error, + ( Usual_domains.Val false + | Usual_domains.Any ) ) -> + aux2 error tail + | ( error, + ( Usual_domains.Val true + | Usual_domains.Undefined ) ) + -> + error, true + ) else + aux2 error tail + else + aux2 error tail + in + aux2 error closure_list + in + if b then + error, dynamic, precondition, true + else + aux error dynamic precondition t + in + aux error dynamic precondition closure_list + in + if bool then + ( error, + dynamic, + precondition, + Usual_domains.Val true ) + else + error, dynamic, precondition, Usual_domains.Any + in + let new_value = + Usual_domains.lub value update_value + in + error, dynamic, precondition, new_value + )) + (error, dynamic, precondition, old_value) + potential_list + in + (*------------------------------------------------------*) + (*call the symmetric add *) + let error, store_result = + Parallel_bonds_type.add_symmetric_tuple_pair + (fun parameters error t map -> + Parallel_bonds_type.PairAgentsSitesStates_map_and_set + .Map + .add_or_overwrite parameters error t value map) + parameters error (z, t) store_result + in + error, dynamic, precondition, store_result + in + error, dynamic, precondition, store_result + )) + (error, dynamic, precondition, store_result) + parallel_list + in + error, dynamic, precondition, store_result) + store_pair_bind_map + ( error, + dynamic, + precondition, + Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty ) + + let discover_a_new_pair_of_modify_sites parameters error store_set + modified_sites = Parallel_bonds_type.PairAgentSite_map_and_set.Set.fold - (fun (x, y, z, t) (error, modified_sites) -> - List.fold_left - (fun (error, modified_sites) (agent,site) -> - Communication.add_site parameters error agent site modified_sites - ) - (error, modified_sites) - [x;y;z;t]) - store_set - (error,modified_sites) - -(*if it is not the first time it is apply then do not apply *) + (fun (x, y, z, t) (error, modified_sites) -> + List.fold_left + (fun (error, modified_sites) (agent, site) -> + Communication.add_site parameters error agent site modified_sites) + (error, modified_sites) [ x; y; z; t ]) + store_set (error, modified_sites) + + (*if it is not the first time it is apply then do not apply *) let can_we_prove_this_is_not_the_first_application precondition = - match - Communication.is_the_rule_applied_for_the_first_time precondition - with + match Communication.is_the_rule_applied_for_the_first_time precondition with | Usual_domains.Sure_value b -> - if b - then true - else false + if b then + true + else + false | Usual_domains.Maybe -> false let apply_rule static dynamic error rule_id precondition = @@ -1150,18 +1047,15 @@ struct let error, rule = get_rule parameters error static rule_id in match rule with | None -> - let error, () = - Exception.warn parameters error __POS__ Exit () - in + let error, () = Exception.warn parameters error __POS__ Exit () in error, dynamic, (precondition, event_list) | Some rule -> - let parameters = - Remanent_parameters.update_prefix parameters "\t\t" - in + let parameters = Remanent_parameters.update_prefix parameters "\t\t" in let dump_title () = - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff parameters + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) @@ -1172,7 +1066,7 @@ struct Loggers.print_newline (Remanent_parameters.get_logger parameters) in Loggers.print_newline (Remanent_parameters.get_logger parameters) - else + ) else () in (*------------------------------------------------------------------*) @@ -1192,247 +1086,210 @@ struct (*-----------------------------------------------------------*) (*combine two value above*) let bool = - if Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.is_empty + if + Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.is_empty store_value1 - && Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.is_empty - store_value2 + && Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.is_empty + store_value2 then false - else + else ( let () = dump_title () in true + ) in let error, store_value = Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.fold2 parameters error (fun parameters error x value store_result -> - let error, store_result = - Parallel_bonds_type.add_value_from_refined_tuple - parameters error x value store_result - in - error, store_result - ) + let error, store_result = + Parallel_bonds_type.add_value_from_refined_tuple parameters error + x value store_result + in + error, store_result) (fun parameters error x value store_result -> - let error, store_result = - Parallel_bonds_type.add_value_from_refined_tuple - parameters error - x value store_result - in - error, store_result - ) + let error, store_result = + Parallel_bonds_type.add_value_from_refined_tuple parameters error + x value store_result + in + error, store_result) (fun parameters error x value1 value2 store_result -> - let new_value = Usual_domains.lub value1 value2 in - let error, store_result = - Parallel_bonds_type.add_value_from_refined_tuple - parameters error - x new_value store_result - in - error, store_result - ) - store_value1 - store_value2 + let new_value = Usual_domains.lub value1 value2 in + let error, store_result = + Parallel_bonds_type.add_value_from_refined_tuple parameters error + x new_value store_result + in + error, store_result) + store_value1 store_value2 Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty in (*--------------------------------------------------------------*) (*if it belongs to non parallel bonds then false*) (*deal with creation*) let store_parallel_map = - if can_we_prove_this_is_not_the_first_application precondition - then + if can_we_prove_this_is_not_the_first_application precondition then (*it is not applied for the first time. Sure_value is true then compute the double bonds on the rhs*) get_rule_double_bonds_rhs static else - (*it is applied for the first time. - Sure_value is false then it is empty*) + (*it is applied for the first time. + Sure_value is false then it is empty*) Ckappa_sig.Rule_map_and_set.Map.empty in (*--------------------------------------------------------------*) let error, double_rhs_list = match Ckappa_sig.Rule_map_and_set.Map.find_option_without_logs parameters - error - rule_id - store_parallel_map + error rule_id store_parallel_map with | error, None -> - error, - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty + error, Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty | error, Some m -> error, m in let error, store_non_parallel = Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.fold - (fun (_,y) b (error, store_result) -> - if b then error, store_result - else - let error, store_result = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.add_or_overwrite - parameters error - y - (Usual_domains.Val false) - store_result - in - error, store_result - ) + (fun (_, y) b (error, store_result) -> + if b then + error, store_result + else ( + let error, store_result = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map + .add_or_overwrite parameters error y (Usual_domains.Val false) + store_result + in + error, store_result + )) double_rhs_list - (error, - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty) + (error, Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty) in (*--------------------------------------------------------------*) (*fold with store_value above*) let error, map_value = error, store_value in let bool = - if bool || - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.is_empty - store_non_parallel + if + bool + || Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.is_empty + store_non_parallel then bool - else - let () = dump_title () in true + else ( + let () = dump_title () in + true + ) in let store_result = get_value dynamic in let error, (store_set, store_result) = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.fold2 parameters error (fun parameters error x value (store_set, store_result) -> - Parallel_bonds_type.add_value_and_event - parameters error kappa_handler - x - value - store_set - store_result - ) + Parallel_bonds_type.add_value_and_event parameters error + kappa_handler x value store_set store_result) (fun parameters error x value (store_set, store_result) -> - Parallel_bonds_type.add_value_and_event parameters error - kappa_handler - x - value - store_set - store_result - ) + Parallel_bonds_type.add_value_and_event parameters error + kappa_handler x value store_set store_result) (fun parameters error x value1 value2 (store_set, store_result) -> - let new_value = Usual_domains.lub value1 value2 in - Parallel_bonds_type.add_value_and_event - parameters error kappa_handler - x - new_value - store_set - store_result - ) - map_value - store_non_parallel - (Parallel_bonds_type.PairAgentSite_map_and_set.Set.empty, - store_result) + let new_value = Usual_domains.lub value1 value2 in + Parallel_bonds_type.add_value_and_event parameters error + kappa_handler x new_value store_set store_result) + map_value store_non_parallel + (Parallel_bonds_type.PairAgentSite_map_and_set.Set.empty, store_result) in let dynamic = set_value store_result dynamic in (*---------------------------------------------------------------------*) (*check the new event*) - let error, modified_sites = - discover_a_new_pair_of_modify_sites - parameters error store_set modified_sites + let error, modified_sites = + discover_a_new_pair_of_modify_sites parameters error store_set + modified_sites in (*--------------------------------------------------------------*) (*if it belongs to parallel bonds then true*) let error, store_parallel = Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.fold (fun (x, y) b (error, store_result) -> - if b then - let pair = Parallel_bonds_type.project2 (x, y) in - let error, store_result = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.add_or_overwrite - parameters error - pair - (Usual_domains.Val true) - store_result - in - error, store_result - else error, store_result - ) + if b then ( + let pair = Parallel_bonds_type.project2 (x, y) in + let error, store_result = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map + .add_or_overwrite parameters error pair (Usual_domains.Val true) + store_result + in + error, store_result + ) else + error, store_result) double_rhs_list - (error, - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty) + (error, Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty) in (*--------------------------------------------------------------*) (*fold over the store_value and parallel bond value *) let bool = - if bool || - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.is_empty - store_parallel + if + bool + || Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.is_empty + store_parallel then bool - else - let () = dump_title () in true + else ( + let () = dump_title () in + true + ) in let store_result = get_value dynamic in let error, (store_set, store_result) = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.fold (fun x value (error, (store_set, store_result)) -> - Parallel_bonds_type.add_value_and_event parameters error - kappa_handler - x - value - store_set - store_result - ) + Parallel_bonds_type.add_value_and_event parameters error + kappa_handler x value store_set store_result) store_parallel (*get the store_set from the previous result*) (error, (store_set, store_result)) in let dynamic = set_value store_result dynamic in let error, modified_sites = - discover_a_new_pair_of_modify_sites - parameters error store_set modified_sites + discover_a_new_pair_of_modify_sites parameters error store_set + modified_sites in let () = - if bool && - (local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters) + if + bool + && (local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff + parameters) then Loggers.print_newline (Remanent_parameters.get_logger parameters) in let error, event_list = - Communication.fold_sites - parameters error + Communication.fold_sites parameters error (fun _ error s _ event_list -> - error, (Communication.Modified_sites s) :: event_list) - modified_sites - event_list + error, Communication.Modified_sites s :: event_list) + modified_sites event_list in error, dynamic, (precondition, event_list) (* events enable communication between domains. At this moment, the global domain does not collect information *) - let apply_one_side_effect - _static dynamic error - _ _ precondition - = - error, dynamic, (precondition,[]) (* this domain ignores side effects *) + let apply_one_side_effect _static dynamic error _ _ precondition = + error, dynamic, (precondition, []) + (* this domain ignores side effects *) (*-----------------------------------------------------------*) - - - let apply_event_list _static dynamic error _event_list = - error, dynamic, [] - - + let apply_event_list _static dynamic error _event_list = error, dynamic, [] (****************************************************************) - let stabilize _static dynamic error = error, dynamic, () - let print ?dead_rules static dynamic (error:Exception.method_handler) loggers = + let print ?dead_rules static dynamic (error : Exception.method_handler) + loggers = let _ = dead_rules in let kappa_handler = get_kappa_handler static in let parameters = get_parameter static in let log = loggers in (*-------------------------------------------------------*) let error = - if Remanent_parameters.get_dump_reachability_analysis_result - parameters - then + if Remanent_parameters.get_dump_reachability_analysis_result parameters + then ( let () = Loggers.fprintf log "------------------------------------------------------------\n"; @@ -1444,14 +1301,13 @@ struct let error = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.fold (fun tuple value error -> - Parallel_bonds_type.print_parallel_constraint - ~verbose:true - ~sparse:true - ~final_resul:true - ~dump_any:true parameters error kappa_handler tuple value - ) store_value error - in error - else + Parallel_bonds_type.print_parallel_constraint ~verbose:true + ~sparse:true ~final_resul:true ~dump_any:true parameters error + kappa_handler tuple value) + store_value error + in + error + ) else error in error, dynamic, () @@ -1459,345 +1315,284 @@ struct (***********************************************************) let export static dynamic error kasa_state = - let parameters = get_parameter static in - let kappa_handler = get_kappa_handler static in - let store_value = get_value dynamic in - let domain_name = "Parallel bonds" in - (*string * 'site_graph lemma list : head*) - let error, current_list = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.fold - (fun tuple value (error, current_list) -> - let (agent, site, site', _, _), - (agent'', site'', site''', _, _) = tuple - in - let t_precondition = Site_graphs.KaSa_site_graph.empty in - let error, agent_id, t_precondition = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler - agent - t_precondition - in - (*first pair*) - let error, t_precondition = - Site_graphs.KaSa_site_graph.add_bond_type - parameters error kappa_handler - agent_id - site - agent'' - site'' - t_precondition - in - (*second pair*) - let error, t_precondition = - Site_graphs.KaSa_site_graph.add_bond_type - parameters error kappa_handler - agent_id - site' - agent'' - site''' - t_precondition - in - (*--------------------------------------------------------*) - let error, t_same_self = - if agent = agent'' && site <> site'' && site' <> site''' - then - let error, t_same_self = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id - site - agent_id - site'' - t_precondition - in - error, Some t_same_self - else - error, None - in - (*--------------------------------------------------------*) - let error, agent_id'', t_same = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler - agent'' - t_precondition - in - (*--------------------------------------------------------*) - let error, t_distinct_self1 = - if agent = agent'' && site <> site'' && - site <> site' && site' <> site'' - then - let error, t_distinct_self1 = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id - site' - agent_id'' - site''' - t_same - in - let error, t_distinct_self1 = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id - site - agent_id - site'' - t_distinct_self1 - in - error, Some t_distinct_self1 - else error, None - in - (*--------------------------------------------------------*) - let error, t_same = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id - site - agent_id'' - site'' - t_same - in - (*--------------------------------------------------------*) - let error, t_distinct_self2 = - if agent = agent'' && - site' <> site''' && site' <> site && site <> site''' - then - let error, t_distinct_self2 = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id - site' - agent_id - site''' - t_same - in - error, Some t_distinct_self2 - else error, None - in - (*--------------------------------------------------------*) - let error, agent_id''', t_distinct = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler - agent'' - t_same - in - let error, t_distinct = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id - site' - agent_id''' - site''' - t_distinct - in - let error, t_same = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id - site' - agent_id'' - site''' - t_same - in - let list_same = - t_same :: (Parallel_bonds_type.cons_opt t_same_self []) in - let list_distinct = - t_distinct :: - (Parallel_bonds_type.cons_opt t_distinct_self1 - (Parallel_bonds_type.cons_opt t_distinct_self2 [])) - in - (*--------------------------------------------------------*) - if compare site site' > 0 - then error, current_list - else - (*--------------------------------------------------*) - match value with - | Usual_domains.Undefined -> error, current_list - | Usual_domains.Val true -> - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - begin - (*hyp*) - (*let string_version = - Site_graphs.KaSa_site_graph.get_string_version - t_precondition - in - let error, site_graph = - Ckappa_site_graph.site_graph_to_list - error string_version - in - let error, refinement = - Ckappa_site_graph.site_graph_list_to_list - error list_same - in - let lemma = - { - Public_data.hyp = site_graph; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in*) - (*internal constraint list*) - let refine = List.rev list_same in - let lemma_internal = - { - Public_data.hyp = t_precondition; - Public_data.refinement = refine; - } - in - let current_list = lemma_internal :: current_list in - error, current_list - end - | Remanent_parameters_sig.Natural_language -> - (*let string_version = - Site_graphs.KaSa_site_graph.get_string_version - t_same - in - let error, site_graph = - Ckappa_site_graph.site_graph_to_list error - string_version - in - (*hyp*) - let error, refinement = - Ckappa_site_graph.site_graph_list_to_list error list_same in - let lemma = - { - Public_data.hyp = site_graph; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in*) - (*internal constraint list*) - let refine = List.rev list_same in - let lemma_internal = - { - Public_data.hyp = t_same; - Public_data.refinement = refine - } - in - let current_list = lemma_internal :: current_list in - error, current_list - end - | Usual_domains.Val false -> - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - (*let string_version = - Site_graphs.KaSa_site_graph.get_string_version - t_precondition - in - let error, site_graph = - Ckappa_site_graph.site_graph_to_list error string_version in - let error, refinement = - Ckappa_site_graph.site_graph_list_to_list error list_distinct in - let lemma = - { - Public_data.hyp = site_graph; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in*) - (*internal constraint list*) - let refine = List.rev list_distinct in - let lemma_internal = - { - Public_data.hyp = t_precondition; - Public_data.refinement = refine - } - in - let current_list = lemma_internal :: current_list in - error, current_list - | Remanent_parameters_sig.Natural_language -> - (*let string_version = - Site_graphs.KaSa_site_graph.get_string_version - t_distinct - in - let error, site_graph = - Ckappa_site_graph.site_graph_to_list error string_version in - let error, refinement = - Ckappa_site_graph.site_graph_list_to_list error list_distinct in - let lemma = - { - Public_data.hyp = site_graph; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in*) - (*internal constraint list*) - let refine = List.rev list_distinct in - let lemma_internal = - { - Public_data.hyp = t_distinct; - Public_data.refinement = refine - } - in - let current_list = lemma_internal :: current_list in - error, current_list - end - | Usual_domains.Any -> - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - error, current_list - | Remanent_parameters_sig.Natural_language -> - (*let string_version = - Site_graphs.KaSa_site_graph.get_string_version - t_same - in - let error, site_graph = - Ckappa_site_graph.site_graph_to_list error string_version in - let error, refinement = - Ckappa_site_graph.site_graph_list_to_list error list_same in - let lemma = - { - Public_data.hyp = site_graph; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in*) - (*internal*) - let refine = List.rev list_same in - let lemma_internal = - { - Public_data.hyp = t_same; - Public_data.refinement = refine - } - in - let current_list = lemma_internal :: current_list in - (*----------------------------------------------*) - (*let string_version = - Site_graphs.KaSa_site_graph.get_string_version - t_distinct - in - let error, site_graph = - Ckappa_site_graph.site_graph_to_list error string_version in - let error, refinement = - Ckappa_site_graph.site_graph_list_to_list error list_distinct in - let lemma = - { - Public_data.hyp = site_graph; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in*) - (*internal constraint list*) - let refine = - List.rev - list_distinct - in - let lemma_internal = - {Public_data.hyp = t_distinct; - Public_data.refinement = refine} - in - let current_list = lemma_internal :: current_list in - error, current_list - ) store_value (error, []) (*name of domain*) - in - (*------------------------------------------------------------------*) - (*let constraint_list = Remanent_state.get_constraints_list kasa_state in + let parameters = get_parameter static in + let kappa_handler = get_kappa_handler static in + let store_value = get_value dynamic in + let domain_name = "Parallel bonds" in + (*string * 'site_graph lemma list : head*) + let error, current_list = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.fold + (fun tuple value (error, current_list) -> + let (agent, site, site', _, _), (agent'', site'', site''', _, _) = + tuple + in + let t_precondition = Site_graphs.KaSa_site_graph.empty in + let error, agent_id, t_precondition = + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler + agent t_precondition + in + (*first pair*) + let error, t_precondition = + Site_graphs.KaSa_site_graph.add_bond_type parameters error + kappa_handler agent_id site agent'' site'' t_precondition + in + (*second pair*) + let error, t_precondition = + Site_graphs.KaSa_site_graph.add_bond_type parameters error + kappa_handler agent_id site' agent'' site''' t_precondition + in + (*--------------------------------------------------------*) + let error, t_same_self = + if agent = agent'' && site <> site'' && site' <> site''' then ( + let error, t_same_self = + Site_graphs.KaSa_site_graph.add_bond parameters error + kappa_handler agent_id site agent_id site'' t_precondition + in + error, Some t_same_self + ) else + error, None + in + (*--------------------------------------------------------*) + let error, agent_id'', t_same = + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler + agent'' t_precondition + in + (*--------------------------------------------------------*) + let error, t_distinct_self1 = + if + agent = agent'' && site <> site'' && site <> site' + && site' <> site'' + then ( + let error, t_distinct_self1 = + Site_graphs.KaSa_site_graph.add_bond parameters error + kappa_handler agent_id site' agent_id'' site''' t_same + in + let error, t_distinct_self1 = + Site_graphs.KaSa_site_graph.add_bond parameters error + kappa_handler agent_id site agent_id site'' t_distinct_self1 + in + error, Some t_distinct_self1 + ) else + error, None + in + (*--------------------------------------------------------*) + let error, t_same = + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler + agent_id site agent_id'' site'' t_same + in + (*--------------------------------------------------------*) + let error, t_distinct_self2 = + if + agent = agent'' && site' <> site''' && site' <> site + && site <> site''' + then ( + let error, t_distinct_self2 = + Site_graphs.KaSa_site_graph.add_bond parameters error + kappa_handler agent_id site' agent_id site''' t_same + in + error, Some t_distinct_self2 + ) else + error, None + in + (*--------------------------------------------------------*) + let error, agent_id''', t_distinct = + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler + agent'' t_same + in + let error, t_distinct = + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler + agent_id site' agent_id''' site''' t_distinct + in + let error, t_same = + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler + agent_id site' agent_id'' site''' t_same + in + let list_same = + t_same :: Parallel_bonds_type.cons_opt t_same_self [] + in + let list_distinct = + t_distinct + :: Parallel_bonds_type.cons_opt t_distinct_self1 + (Parallel_bonds_type.cons_opt t_distinct_self2 []) + in + (*--------------------------------------------------------*) + if compare site site' > 0 then + error, current_list + else ( + (*--------------------------------------------------*) + match value with + | Usual_domains.Undefined -> error, current_list + | Usual_domains.Val true -> + (match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + (*hyp*) + (*let string_version = + Site_graphs.KaSa_site_graph.get_string_version + t_precondition + in + let error, site_graph = + Ckappa_site_graph.site_graph_to_list + error string_version + in + let error, refinement = + Ckappa_site_graph.site_graph_list_to_list + error list_same + in + let lemma = + { + Public_data.hyp = site_graph; + Public_data.refinement = refinement + } + in + let current_list = lemma :: current_list in*) + (*internal constraint list*) + let refine = List.rev list_same in + let lemma_internal = + { + Public_data.hyp = t_precondition; + Public_data.refinement = refine; + } + in + let current_list = lemma_internal :: current_list in + error, current_list + | Remanent_parameters_sig.Natural_language -> + (*let string_version = + Site_graphs.KaSa_site_graph.get_string_version + t_same + in + let error, site_graph = + Ckappa_site_graph.site_graph_to_list error + string_version + in + (*hyp*) + let error, refinement = + Ckappa_site_graph.site_graph_list_to_list error list_same in + let lemma = + { + Public_data.hyp = site_graph; + Public_data.refinement = refinement + } + in + let current_list = lemma :: current_list in*) + (*internal constraint list*) + let refine = List.rev list_same in + let lemma_internal = + { Public_data.hyp = t_same; Public_data.refinement = refine } + in + let current_list = lemma_internal :: current_list in + error, current_list) + | Usual_domains.Val false -> + (match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + (*let string_version = + Site_graphs.KaSa_site_graph.get_string_version + t_precondition + in + let error, site_graph = + Ckappa_site_graph.site_graph_to_list error string_version in + let error, refinement = + Ckappa_site_graph.site_graph_list_to_list error list_distinct in + let lemma = + { + Public_data.hyp = site_graph; + Public_data.refinement = refinement + } + in + let current_list = lemma :: current_list in*) + (*internal constraint list*) + let refine = List.rev list_distinct in + let lemma_internal = + { + Public_data.hyp = t_precondition; + Public_data.refinement = refine; + } + in + let current_list = lemma_internal :: current_list in + error, current_list + | Remanent_parameters_sig.Natural_language -> + (*let string_version = + Site_graphs.KaSa_site_graph.get_string_version + t_distinct + in + let error, site_graph = + Ckappa_site_graph.site_graph_to_list error string_version in + let error, refinement = + Ckappa_site_graph.site_graph_list_to_list error list_distinct in + let lemma = + { + Public_data.hyp = site_graph; + Public_data.refinement = refinement + } + in + let current_list = lemma :: current_list in*) + (*internal constraint list*) + let refine = List.rev list_distinct in + let lemma_internal = + { + Public_data.hyp = t_distinct; + Public_data.refinement = refine; + } + in + let current_list = lemma_internal :: current_list in + error, current_list) + | Usual_domains.Any -> + (match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + error, current_list + | Remanent_parameters_sig.Natural_language -> + (*let string_version = + Site_graphs.KaSa_site_graph.get_string_version + t_same + in + let error, site_graph = + Ckappa_site_graph.site_graph_to_list error string_version in + let error, refinement = + Ckappa_site_graph.site_graph_list_to_list error list_same in + let lemma = + { + Public_data.hyp = site_graph; + Public_data.refinement = refinement + } + in + let current_list = lemma :: current_list in*) + (*internal*) + let refine = List.rev list_same in + let lemma_internal = + { Public_data.hyp = t_same; Public_data.refinement = refine } + in + let current_list = lemma_internal :: current_list in + (*----------------------------------------------*) + (*let string_version = + Site_graphs.KaSa_site_graph.get_string_version + t_distinct + in + let error, site_graph = + Ckappa_site_graph.site_graph_to_list error string_version in + let error, refinement = + Ckappa_site_graph.site_graph_list_to_list error list_distinct in + let lemma = + { + Public_data.hyp = site_graph; + Public_data.refinement = refinement + } + in + let current_list = lemma :: current_list in*) + (*internal constraint list*) + let refine = List.rev list_distinct in + let lemma_internal = + { + Public_data.hyp = t_distinct; + Public_data.refinement = refine; + } + in + let current_list = lemma_internal :: current_list in + error, current_list) + )) + store_value (error, []) + (*name of domain*) + in + (*------------------------------------------------------------------*) + (*let constraint_list = Remanent_state.get_constraints_list kasa_state in let error, constraint_list = match constraint_list @@ -1810,22 +1605,23 @@ struct let kasa_state = Remanent_state.set_constraints_list pair_list kasa_state in*) - (*------------------------------------------------------------------*) - (*internal constraint list*) - let internal_constraints_list = - Remanent_state.get_internal_constraints_list kasa_state - in - let error, internal_constraints_list = - match internal_constraints_list with - | None -> - Exception.warn parameters error __POS__ Exit [] - | Some l -> error, l - in - let pair_list = - (domain_name, List.rev current_list) :: internal_constraints_list in - let kasa_state = - Remanent_state.set_internal_constraints_list pair_list kasa_state in - error, dynamic, kasa_state + (*------------------------------------------------------------------*) + (*internal constraint list*) + let internal_constraints_list = + Remanent_state.get_internal_constraints_list kasa_state + in + let error, internal_constraints_list = + match internal_constraints_list with + | None -> Exception.warn parameters error __POS__ Exit [] + | Some l -> error, l + in + let pair_list = + (domain_name, List.rev current_list) :: internal_constraints_list + in + let kasa_state = + Remanent_state.set_internal_constraints_list pair_list kasa_state + in + error, dynamic, kasa_state (*let export static dynamic error kasa_state = let error, dynamic, kasa_state = @@ -1879,9 +1675,6 @@ struct in error, dynamic, kasa_state*) - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects end diff --git a/core/KaSa_rep/reachability_analysis/parallel_bonds.mli b/core/KaSa_rep/reachability_analysis/parallel_bonds.mli index 623fdeb89a..72fb660e1a 100644 --- a/core/KaSa_rep/reachability_analysis/parallel_bonds.mli +++ b/core/KaSa_rep/reachability_analysis/parallel_bonds.mli @@ -17,5 +17,4 @@ (** Abstract domain to over-approximate the set of reachable views *) - -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/parallel_bonds_init.ml b/core/KaSa_rep/reachability_analysis/parallel_bonds_init.ml index e402abbda3..4a786f90eb 100644 --- a/core/KaSa_rep/reachability_analysis/parallel_bonds_init.ml +++ b/core/KaSa_rep/reachability_analysis/parallel_bonds_init.ml @@ -20,13 +20,12 @@ let local_trace = false (*parallel bonds in the initial states*) (******************************************************************) -let collect_parallel_or_not_bonds_init - parameters kappa_handler error tuple_of_interest init_state store_result = +let collect_parallel_or_not_bonds_init parameters kappa_handler error + tuple_of_interest init_state store_result = let tuple_of_interest = Some tuple_of_interest in let error, big_store = - Parallel_bonds_static.collect_double_bonds_in_pattern - parameters error ?tuple_of_interest init_state.Cckappa_sig.e_init_c_mixture + Parallel_bonds_static.collect_double_bonds_in_pattern parameters error + ?tuple_of_interest init_state.Cckappa_sig.e_init_c_mixture in - Parallel_bonds_static.project_away_ag_id - parameters kappa_handler error + Parallel_bonds_static.project_away_ag_id parameters kappa_handler error big_store store_result diff --git a/core/KaSa_rep/reachability_analysis/parallel_bonds_static.ml b/core/KaSa_rep/reachability_analysis/parallel_bonds_static.ml index 5c8e887ef7..d9aae943b4 100644 --- a/core/KaSa_rep/reachability_analysis/parallel_bonds_static.ml +++ b/core/KaSa_rep/reachability_analysis/parallel_bonds_static.ml @@ -16,182 +16,204 @@ let local_trace = false -type local_static_information = - { - (*rule has two bonds (parallel or not) on the lhs*) - store_rule_double_bonds_lhs : - (bool Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.t) - Ckappa_sig.Rule_map_and_set.Map.t ; - (*rule has two bonds (parallel or not) on the rhs*) - store_rule_double_bonds_rhs : (*use this*) - (bool Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.t) - Ckappa_sig.Rule_map_and_set.Map.t ; +type local_static_information = { + (*rule has two bonds (parallel or not) on the lhs*) + store_rule_double_bonds_lhs: + bool Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t; + (*rule has two bonds (parallel or not) on the rhs*) + store_rule_double_bonds_rhs: + (*use this*) + bool Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t; (*is a union set of double binding in the lhs and the rhs*) - store_tuples_of_interest: - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.t; - (* information of partial formation of parallel or non-parallel bonds in - rules *) - store_closure: - (Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state * - ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state)) * - ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_site_name *Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state)) - ) list - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.t; - - store_fst_site_create_parallel_bonds_rhs: - ((Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) - ) list - Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_snd_site_create_parallel_bonds_rhs: - ((Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) - ) list - Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.t - Ckappa_sig.Rule_map_and_set.Map.t; - (*A map from tuples -> sites (agent_type, site_name)*) - store_tuple_to_sites : - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.t - Parallel_bonds_type.PairAgentSite_map_and_set.Map.t; - (*a map from sites -> tuples *) - store_sites_to_tuple : - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.t - Parallel_bonds_type.AgentSite_map_and_set.Map.t - } + store_tuples_of_interest: + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.t; + (* information of partial formation of parallel or non-parallel bonds in + rules *) + store_closure: + (Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state + * ((Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state)) + * ((Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state))) + list + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.t; + store_fst_site_create_parallel_bonds_rhs: + ((Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state)) + list + Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_snd_site_create_parallel_bonds_rhs: + ((Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state)) + list + Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.t + Ckappa_sig.Rule_map_and_set.Map.t; + (*A map from tuples -> sites (agent_type, site_name)*) + store_tuple_to_sites: + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.t + Parallel_bonds_type.PairAgentSite_map_and_set.Map.t; + (*a map from sites -> tuples *) + store_sites_to_tuple: + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.t + Parallel_bonds_type.AgentSite_map_and_set.Map.t; +} (*******************************************************************) let init_local_static = { - store_tuples_of_interest = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty; + store_tuples_of_interest = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty; store_rule_double_bonds_rhs = Ckappa_sig.Rule_map_and_set.Map.empty; - store_fst_site_create_parallel_bonds_rhs = Ckappa_sig.Rule_map_and_set.Map.empty; - store_snd_site_create_parallel_bonds_rhs = Ckappa_sig.Rule_map_and_set.Map.empty; + store_fst_site_create_parallel_bonds_rhs = + Ckappa_sig.Rule_map_and_set.Map.empty; + store_snd_site_create_parallel_bonds_rhs = + Ckappa_sig.Rule_map_and_set.Map.empty; store_rule_double_bonds_lhs = Ckappa_sig.Rule_map_and_set.Map.empty; store_tuple_to_sites = Parallel_bonds_type.PairAgentSite_map_and_set.Map.empty; store_closure = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Map.empty; - store_sites_to_tuple = - Parallel_bonds_type.AgentSite_map_and_set.Map.empty; + store_sites_to_tuple = Parallel_bonds_type.AgentSite_map_and_set.Map.empty; } (*******************************************************************) -let collect_double_bonds_in_pattern - parameters error ?tuple_of_interest pattern = +let collect_double_bonds_in_pattern parameters error ?tuple_of_interest pattern + = let good_tuple = match tuple_of_interest with - | None -> (fun _ -> true) + | None -> fun _ -> true | Some t_set -> - (fun tuple -> - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.mem - (Parallel_bonds_type.project2 tuple) t_set - ) + fun tuple -> + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.mem + (Parallel_bonds_type.project2 tuple) + t_set in - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error agent_id_source bonds_map store_result -> - Ckappa_sig.Site_map_and_set.Map.fold - (fun site_type_source site_add - (error, store_result) -> - let error, - ((agent_type_source, site_type_source, state_source), - (agent_type_target, site_type_target, state_target)) = - (*translate_bond*) - Common_static.collect_fingerprint_of_bond - parameters error - site_add - agent_id_source - site_type_source - pattern.Cckappa_sig.views - in - Ckappa_sig.Site_map_and_set.Map.fold - (fun site_type_source' site_add' - (error, store_result) -> - (* the two bonds necessarily start from the same agent (id) *) - (* we check that they start from two different sites *) - (* and that they go into two agents with the same type *) - if site_type_source <> site_type_source' - && site_add.Cckappa_sig.agent_type = site_add'.Cckappa_sig.agent_type - then - let agent_id_target = site_add.Cckappa_sig.agent_index in - let agent_id_target' = site_add'.Cckappa_sig.agent_index in - let bool = - (* if the ids of the targets is the same, we have a parallel bond, other with it is a non parallel bond *) - agent_id_target = agent_id_target' - in - let error, - ((_,_,state_source'), - (_, site_type_target', state_target')) = - (*translate_bond*) - Common_static.collect_fingerprint_of_bond - parameters error - site_add' - agent_id_source - site_type_source' - pattern.Cckappa_sig.views + Ckappa_sig.Site_map_and_set.Map.fold + (fun site_type_source site_add (error, store_result) -> + let ( error, + ( (agent_type_source, site_type_source, state_source), + (agent_type_target, site_type_target, state_target) ) ) = + (*translate_bond*) + Common_static.collect_fingerprint_of_bond parameters error site_add + agent_id_source site_type_source pattern.Cckappa_sig.views + in + Ckappa_sig.Site_map_and_set.Map.fold + (fun site_type_source' site_add' (error, store_result) -> + (* the two bonds necessarily start from the same agent (id) *) + (* we check that they start from two different sites *) + (* and that they go into two agents with the same type *) + if + site_type_source <> site_type_source' + && site_add.Cckappa_sig.agent_type + = site_add'.Cckappa_sig.agent_type + then ( + let agent_id_target = site_add.Cckappa_sig.agent_index in + let agent_id_target' = site_add'.Cckappa_sig.agent_index in + let bool = + (* if the ids of the targets is the same, we have a parallel bond, other with it is a non parallel bond *) + agent_id_target = agent_id_target' + in + let ( error, + ( (_, _, state_source'), + (_, site_type_target', state_target') ) ) = + (*translate_bond*) + Common_static.collect_fingerprint_of_bond parameters error + site_add' agent_id_source site_type_source' + pattern.Cckappa_sig.views + in + (* the two target sites should also have different types *) + if site_type_target <> site_type_target' then ( + let tuple = + ( agent_id_source, + ( ( agent_type_source, + site_type_source, + site_type_source', + state_source, + state_source' ), + ( agent_type_target, + site_type_target, + site_type_target', + state_target, + state_target' ) ) ) in - (* the two target sites should also have different types *) - if site_type_target <> site_type_target' + if + (* only tuples of interest are interesting :-) *) + good_tuple tuple then - let tuple = - agent_id_source,((agent_type_source, site_type_source, site_type_source', state_source, state_source'), - (agent_type_target, - site_type_target, site_type_target', state_target, state_target')) - in - if (* only tuples of interest are interesting :-) *) - good_tuple tuple - then - Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.add - parameters error - tuple - bool - store_result - else - error, store_result + Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map + .add parameters error tuple bool store_result else error, store_result - else error, store_result - ) bonds_map (error, store_result) - ) bonds_map (error, store_result) - ) + ) else + error, store_result + ) else + error, store_result) + bonds_map (error, store_result)) + bonds_map (error, store_result)) pattern.Cckappa_sig.bonds Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.empty let project_away_ag_id_gen f parameters error big_store acc = Parallel_bonds_type.PairAgentsSitesStates_map_and_set.Map.fold (fun tuple value (error, acc) -> - f - parameters error - (Parallel_bonds_type.project2 tuple) - value - acc) + f parameters error (Parallel_bonds_type.project2 tuple) value acc) big_store (error, acc) let project_away_ag_id parameters _kappa_handler error big_store acc = let f parameters error tuple value acc = - Parallel_bonds_type.add_value - parameters error - tuple - (Usual_domains.Val value) - acc + Parallel_bonds_type.add_value parameters error tuple + (Usual_domains.Val value) acc in project_away_ag_id_gen f parameters error big_store acc -let project_away_ag_id_and_convert_into_set - parameters error big_store acc = +let project_away_ag_id_and_convert_into_set parameters error big_store acc = let f parameters error tuple _ acc = Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.add_when_not_in parameters error tuple acc @@ -202,24 +224,17 @@ let project_away_ag_id_and_convert_into_set (** Detect pair of bonds *) (****************************************************************) -let collect_rule_double_bonds_lhs - parameters error rule_id rule store_result = +let collect_rule_double_bonds_lhs parameters error rule_id rule store_result = let error, map = - collect_double_bonds_in_pattern - parameters error - rule.Cckappa_sig.rule_lhs + collect_double_bonds_in_pattern parameters error rule.Cckappa_sig.rule_lhs in - Ckappa_sig.Rule_map_and_set.Map.add - parameters error rule_id map store_result + Ckappa_sig.Rule_map_and_set.Map.add parameters error rule_id map store_result -let collect_rule_double_bonds_rhs - parameters error rule_id rule store_result = +let collect_rule_double_bonds_rhs parameters error rule_id rule store_result = let error, map = - collect_double_bonds_in_pattern - parameters error rule.Cckappa_sig.rule_rhs + collect_double_bonds_in_pattern parameters error rule.Cckappa_sig.rule_rhs in - Ckappa_sig.Rule_map_and_set.Map.add - parameters error rule_id map store_result + Ckappa_sig.Rule_map_and_set.Map.add parameters error rule_id map store_result (**************************************************************************) (*a map (A,x,y, B,z,t) -> (Ag_id, Ag_id) RuleIDMap to explain @@ -235,72 +250,79 @@ let collect_site_create_parallel_bonds_gen pos parameters error | Snd -> b in Ckappa_sig.Rule_map_and_set.Map.fold - (fun k set (error,map) -> - let error, new_set = - (*Parallel_bonds_type.PairAgentsSiteState_map_and_set.Set.fold*) - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold - (*A.x -> B.z; B.z -> A.x*) - (fun ((agent_id, agent_type, site_type, state), - (agent_id', agent_type', site_type', state')) (error,store_result) -> - let error, old_list = - match - Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.find_option_without_logs - parameters - error - ((agent_id, agent_type, site_type, state), - (agent_id', agent_type', site_type', state')) - store_result - with - | error, None -> error, [] - | error, Some l -> error, l - in - let error', new_list = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.fold_inv - (fun ((agent_type1, site_type1, site_type2, state1, state2), - (agent_type1', site_type1', site_type2', state1', state2')) - (error, current_list) -> - if - agent_type = agent_type1 && - site_type = pick pos site_type1 site_type2 && - agent_type' = agent_type1' && - site_type' = pick pos site_type1' site_type2' - then - (*A.x.B.z, B.z.A.x*) - let new_list = - ((agent_id, agent_type1, site_type1, site_type2, state1, state2), - (agent_id', agent_type1', site_type1', site_type2', state1', state2')) - :: current_list - in - error, new_list - else - error, current_list - ) store_parallel_bonds (error, old_list) - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error, store_result = - Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.add_or_overwrite - parameters - error - ((agent_id, agent_type, site_type, state), - (agent_id', agent_type', site_type', state')) - new_list - store_result - in - error, store_result - ) - set - (error, Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.empty) - in - Ckappa_sig.Rule_map_and_set.Map.add parameters error k new_set map) + (fun k set (error, map) -> + let error, new_set = + (*Parallel_bonds_type.PairAgentsSiteState_map_and_set.Set.fold*) + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold + (*A.x -> B.z; B.z -> A.x*) + (fun ( (agent_id, agent_type, site_type, state), + (agent_id', agent_type', site_type', state') ) + (error, store_result) -> + let error, old_list = + match + Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map + .find_option_without_logs parameters error + ( (agent_id, agent_type, site_type, state), + (agent_id', agent_type', site_type', state') ) + store_result + with + | error, None -> error, [] + | error, Some l -> error, l + in + let error', new_list = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.fold_inv + (fun ( (agent_type1, site_type1, site_type2, state1, state2), + (agent_type1', site_type1', site_type2', state1', state2') + ) (error, current_list) -> + if + agent_type = agent_type1 + && site_type = pick pos site_type1 site_type2 + && agent_type' = agent_type1' + && site_type' = pick pos site_type1' site_type2' + then ( + (*A.x.B.z, B.z.A.x*) + let new_list = + ( ( agent_id, + agent_type1, + site_type1, + site_type2, + state1, + state2 ), + ( agent_id', + agent_type1', + site_type1', + site_type2', + state1', + state2' ) ) + :: current_list + in + error, new_list + ) else + error, current_list) + store_parallel_bonds (error, old_list) + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, store_result = + Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map + .add_or_overwrite parameters error + ( (agent_id, agent_type, site_type, state), + (agent_id', agent_type', site_type', state') ) + new_list store_result + in + error, store_result) + set + (error, Parallel_bonds_type.PairAgentsSiteState_map_and_set.Map.empty) + in + Ckappa_sig.Rule_map_and_set.Map.add parameters error k new_set map) store_action_binding - (error,Ckappa_sig.Rule_map_and_set.Map.empty) + (error, Ckappa_sig.Rule_map_and_set.Map.empty) -let collect_fst_site_create_parallel_bonds = +let collect_fst_site_create_parallel_bonds = collect_site_create_parallel_bonds_gen Fst + let collect_snd_site_create_parallel_bonds = collect_site_create_parallel_bonds_gen Snd @@ -310,10 +332,8 @@ let collect_snd_site_create_parallel_bonds = (**************************************************************************) let collect_fst_site_create_parallel_bonds_rhs parameters error - store_action_binding store_parallel_bonds = - collect_fst_site_create_parallel_bonds - parameters error - store_action_binding + store_action_binding store_parallel_bonds = + collect_fst_site_create_parallel_bonds parameters error store_action_binding store_parallel_bonds (**************************************************************************) @@ -323,10 +343,7 @@ let collect_fst_site_create_parallel_bonds_rhs parameters error let collect_snd_site_create_parallel_bonds_rhs parameters error store_action_binding store_parallel_bonds = let error, store_result = - collect_snd_site_create_parallel_bonds - parameters - error - store_action_binding + collect_snd_site_create_parallel_bonds parameters error store_action_binding store_parallel_bonds in error, store_result @@ -337,19 +354,18 @@ let collect_snd_site_create_parallel_bonds_rhs parameters error *) (*******************************************************************) -let proj_first_site (a, b, _, _, _) = (a, b) -let proj_second_site (a, _, c, _, _) = (a, c) +let proj_first_site (a, b, _, _, _) = a, b +let proj_second_site (a, _, c, _, _) = a, c let collect_tuple_to_sites parameters error tuples_of_interest = Parallel_bonds_type.Partition_tuples_to_sites_map.monadic_partition_set (fun _ error (u, v) -> - error, - (proj_first_site u, proj_second_site u, - proj_first_site v, proj_second_site v) - ) - parameters - error - tuples_of_interest + ( error, + ( proj_first_site u, + proj_second_site u, + proj_first_site v, + proj_second_site v ) )) + parameters error tuples_of_interest (*******************************************************************) (*A map from sites -> tuples @@ -358,161 +374,135 @@ let collect_tuple_to_sites parameters error tuples_of_interest = (*******************************************************************) let compare_first_pair parameters error x tuple_set store_result = - let (agent_type_x, site_type_x) = x in (*A,x*) + let agent_type_x, site_type_x = x in + (*A,x*) Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.fold (fun (u, v) (error, store_result) -> - let (agent_type, site_type, _site_type', _state, _state') = u in - let (agent_type1, site_type1, _site_type1', _state1, _state1') = v in - if agent_type_x = agent_type && site_type_x = site_type - || agent_type_x = agent_type1 && site_type_x = site_type1 - then - let error', new_set = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.add_when_not_in - parameters error - (u, v) - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error, store_result = - Parallel_bonds_type.AgentSite_map_and_set.Map.add_or_overwrite - parameters error - x - new_set - store_result - in - error, store_result - else error, store_result - ) tuple_set (error, store_result) + let agent_type, site_type, _site_type', _state, _state' = u in + let agent_type1, site_type1, _site_type1', _state1, _state1' = v in + if + (agent_type_x = agent_type && site_type_x = site_type) + || (agent_type_x = agent_type1 && site_type_x = site_type1) + then ( + let error', new_set = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set + .add_when_not_in parameters error (u, v) + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error, store_result = + Parallel_bonds_type.AgentSite_map_and_set.Map.add_or_overwrite + parameters error x new_set store_result + in + error, store_result + ) else + error, store_result) + tuple_set (error, store_result) let compare_snd_pair parameters error y tuple_pair store_result = - let (agent_type_y, site_type_y) = y in (*A,x*) + let agent_type_y, site_type_y = y in + (*A,x*) Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.fold (fun (u, v) (error, store_result) -> - let (agent_type, _site_type, site_type', _state, _state') = u in - let (agent_type1, _site_type1, site_type1', _state1, _state1') = v in - if agent_type_y = agent_type && site_type_y = site_type' - || agent_type_y = agent_type1 && site_type_y = site_type1' - then - let error', new_set = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.add_when_not_in - parameters error - (u, v) - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error, store_result = - Parallel_bonds_type.AgentSite_map_and_set.Map.add_or_overwrite - parameters error - y - new_set - store_result - in - error, store_result - else error, store_result - ) tuple_pair (error, store_result) + let agent_type, _site_type, site_type', _state, _state' = u in + let agent_type1, _site_type1, site_type1', _state1, _state1' = v in + if + (agent_type_y = agent_type && site_type_y = site_type') + || (agent_type_y = agent_type1 && site_type_y = site_type1') + then ( + let error', new_set = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set + .add_when_not_in parameters error (u, v) + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error, store_result = + Parallel_bonds_type.AgentSite_map_and_set.Map.add_or_overwrite + parameters error y new_set store_result + in + error, store_result + ) else + error, store_result) + tuple_pair (error, store_result) (*map from sites to tuple *) let collect_sites_to_tuple parameters error map_of_sites store_result = Parallel_bonds_type.PairAgentSite_map_and_set.Map.fold (fun (x, y, _z, _t) tuple_set (error, store_result) -> - (*---------------------------------------------------------------*) - let error', store_result1 = - compare_first_pair parameters error - x - tuple_set - Parallel_bonds_type.AgentSite_map_and_set.Map.empty - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - (*---------------------------------------------------------------*) - let error, store_result2 = - compare_snd_pair parameters error - y - tuple_set - Parallel_bonds_type.AgentSite_map_and_set.Map.empty - in - (*---------------------------------------------------------------*) - let add_link parameters error x tuple_set store_result = - let error, old_set = - match - Parallel_bonds_type.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - x - store_result - with - | error, None -> - error, - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty - | error, Some s -> error, s - in - let error', new_set = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.union - parameters error - old_set - tuple_set - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error, store_result = - Parallel_bonds_type.AgentSite_map_and_set.Map.add_or_overwrite - parameters error - x - new_set - store_result - in - error, store_result - in - (*---------------------------------------------------------------*) - let error, store_result = - Parallel_bonds_type.AgentSite_map_and_set.Map.fold2 - parameters error - (fun parameters error elt tuple_set_x store_result -> - let error, store_result = - add_link parameters error elt tuple_set_x store_result - in - error, store_result - ) - (fun parameters error elt tuple_set_y store_result -> - let error, store_result = - add_link parameters error elt tuple_set_y store_result - in - error, store_result - ) - (fun parameters error elt tuple_set_x tuple_set_y store_result -> - let error', new_set = - Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.union - parameters error - tuple_set_x - tuple_set_y - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error, store_result = - add_link parameters error elt new_set store_result - in - error, store_result - ) - store_result1 - store_result2 - store_result - in - error, store_result - ) map_of_sites (error, store_result) + (*---------------------------------------------------------------*) + let error', store_result1 = + compare_first_pair parameters error x tuple_set + Parallel_bonds_type.AgentSite_map_and_set.Map.empty + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + (*---------------------------------------------------------------*) + let error, store_result2 = + compare_snd_pair parameters error y tuple_set + Parallel_bonds_type.AgentSite_map_and_set.Map.empty + in + (*---------------------------------------------------------------*) + let add_link parameters error x tuple_set store_result = + let error, old_set = + match + Parallel_bonds_type.AgentSite_map_and_set.Map + .find_option_without_logs parameters error x store_result + with + | error, None -> + ( error, + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.empty ) + | error, Some s -> error, s + in + let error', new_set = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.union + parameters error old_set tuple_set + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error, store_result = + Parallel_bonds_type.AgentSite_map_and_set.Map.add_or_overwrite + parameters error x new_set store_result + in + error, store_result + in + (*---------------------------------------------------------------*) + let error, store_result = + Parallel_bonds_type.AgentSite_map_and_set.Map.fold2 parameters error + (fun parameters error elt tuple_set_x store_result -> + let error, store_result = + add_link parameters error elt tuple_set_x store_result + in + error, store_result) + (fun parameters error elt tuple_set_y store_result -> + let error, store_result = + add_link parameters error elt tuple_set_y store_result + in + error, store_result) + (fun parameters error elt tuple_set_x tuple_set_y store_result -> + let error', new_set = + Parallel_bonds_type.PairAgentSitesStates_map_and_set.Set.union + parameters error tuple_set_x tuple_set_y + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let error, store_result = + add_link parameters error elt new_set store_result + in + error, store_result) + store_result1 store_result2 store_result + in + error, store_result) + map_of_sites (error, store_result) diff --git a/core/KaSa_rep/reachability_analysis/parallel_bonds_type.ml b/core/KaSa_rep/reachability_analysis/parallel_bonds_type.ml index 5c4b6f9a8c..9e32040a54 100644 --- a/core/KaSa_rep/reachability_analysis/parallel_bonds_type.ml +++ b/core/KaSa_rep/reachability_analysis/parallel_bonds_type.ml @@ -1,433 +1,443 @@ (* Time-stamp: *) -module PairAgentsSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) - -module PairAgentSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module PairAgentsSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) + +module PairAgentSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) (*parallel*) -module PairAgentsSitesStates_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - Ckappa_sig.c_agent_id * ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state)) - let compare = compare - let print _ _ = () - end)) - -module PairAgentSitesStates_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module PairAgentsSitesStates_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + Ckappa_sig.c_agent_id + * ((Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state)) + + let compare = compare + let print _ _ = () +end)) + +module PairAgentSitesStates_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) (*******************************************************************) (*a map from tuples to sites*) (*******************************************************************) -module PairAgentSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) - let compare = compare - let print _ _ = () - end)) +module PairAgentSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + + let compare = compare + let print _ _ = () +end)) module Partition_tuples_to_sites_map = Map_wrapper.Proj - (PairAgentSitesStates_map_and_set) (*set*) - (PairAgentSite_map_and_set) (*map*) - -module AgentSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) - let compare = compare - let print _ _ = () - end)) + (PairAgentSitesStates_map_and_set) + (*set*) + (PairAgentSite_map_and_set) +(*map*) + +module AgentSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name + + let compare = compare + let print _ _ = () +end)) (*******************************************************************) -module AgentsSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) - -module AgentsSitesStates_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_rule_id * Ckappa_sig.c_agent_id * - Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_state * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module AgentsSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + + let compare = compare + let print _ _ = () +end)) + +module AgentsSitesStates_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + Ckappa_sig.c_rule_id + * Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state + + let compare = compare + let print _ _ = () +end)) (*******************************************************************) let convert_pair parameters error kappa_handler pair = - let (agent,site) = pair in - let error, site = Handler.string_of_site_contact_map parameters error kappa_handler agent site in + let agent, site = pair in + let error, site = + Handler.string_of_site_contact_map parameters error kappa_handler agent site + in let error, agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent in error, (agent, site) let convert_single parameters error kappa_handler single = - let (agent,site,site',_,_) = single in + let agent, site, site', _, _ = single in let error, site = + Handler.string_of_site_contact_map parameters error kappa_handler agent site + in + let error, site' = Handler.string_of_site_contact_map parameters error kappa_handler agent - site + site' in - let error, site' = Handler.string_of_site_contact_map parameters error - kappa_handler agent site' in let error, agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent in error, (agent, site, site') let convert_tuple parameters error kappa_handler tuple = - let (agent,site,site',_,_),(agent'',site'',site''',_,_) = - tuple + let (agent, site, site', _, _), (agent'', site'', site''', _, _) = tuple in + let error, site = + Handler.string_of_site_contact_map parameters error kappa_handler agent site + in + let error, site' = + Handler.string_of_site_contact_map parameters error kappa_handler agent + site' in - let error, site = Handler.string_of_site_contact_map parameters error kappa_handler agent site in - let error, site' = Handler.string_of_site_contact_map parameters error kappa_handler agent site' in let error, agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent in - let error, site'' = Handler.string_of_site_contact_map parameters error kappa_handler agent'' site'' in - let error, site''' = Handler.string_of_site_contact_map parameters error kappa_handler agent'' site''' in + let error, site'' = + Handler.string_of_site_contact_map parameters error kappa_handler agent'' + site'' + in + let error, site''' = + Handler.string_of_site_contact_map parameters error kappa_handler agent'' + site''' + in let error, agent'' = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent'' in - error, (agent,site,site',agent'',site'',site''') + error, (agent, site, site', agent'', site'', site''') let convert_refined_tuple parameters error kappa_handler tuple = - let error, (agent,site,site',agent'',site'',site''') = + let error, (agent, site, site', agent'', site'', site''') = convert_tuple parameters error kappa_handler (snd tuple) in - error, - (Ckappa_sig.string_of_agent_id (fst tuple), agent,site,site', - agent'',site'',site''') + ( error, + ( Ckappa_sig.string_of_agent_id (fst tuple), + agent, + site, + site', + agent'', + site'', + site''' ) ) let cons_opt a l = - match a with None -> l - | Some a -> a::l - -let print_parallel_constraint - ?verbose:(verbose=true) - ?sparse:(sparse=false) - ?final_resul:(final_result=false) - ?dump_any:(dump_any=false) parameters error kappa_handler tuple value = - let modalite = if final_result then "are necessarily" else "may be" in + match a with + | None -> l + | Some a -> a :: l + +let print_parallel_constraint ?(verbose = true) ?(sparse = false) + ?final_resul:(final_result = false) ?(dump_any = false) parameters error + kappa_handler tuple value = + let modalite = + if final_result then + "are necessarily" + else + "may be" + in let prefix = Remanent_parameters.get_prefix parameters in - let error, (string_agent,string_site,string_site',string_agent'',string_site'',string_site''') = + let ( error, + ( string_agent, + string_site, + string_site', + string_agent'', + string_site'', + string_site''' ) ) = convert_tuple parameters error kappa_handler tuple in - let (agent,site,site',_,_),(agent'',site'',site''',_,_) = - tuple - in + let (agent, site, site', _, _), (agent'', site'', site''', _, _) = tuple in let t_precondition = Site_graphs.KaSa_site_graph.empty in let error, agent_id, t_precondition = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler - agent t_precondition + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler agent + t_precondition in let error, t_precondition = - Site_graphs.KaSa_site_graph.add_bond_type - parameters error kappa_handler + Site_graphs.KaSa_site_graph.add_bond_type parameters error kappa_handler agent_id site agent'' site'' t_precondition in let error, t_precondition = - Site_graphs.KaSa_site_graph.add_bond_type - parameters error kappa_handler + Site_graphs.KaSa_site_graph.add_bond_type parameters error kappa_handler agent_id site' agent'' site''' t_precondition in let error, t_same_self = - if agent = agent'' && site<>site'' && site'<>site''' - then + if agent = agent'' && site <> site'' && site' <> site''' then ( let error, t_same_self = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler agent_id site agent_id site'' t_precondition in error, Some t_same_self - else + ) else error, None in let error, agent_id'', t_same = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler - agent'' t_precondition + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler agent'' + t_precondition in let error, t_distinct_self1 = - if agent = agent'' && - site <> site'' && site <> site' && site' <> site'' - then + if agent = agent'' && site <> site'' && site <> site' && site' <> site'' + then ( let error, t_distinct_self1 = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id site' agent_id'' site''' t_same + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler + agent_id site' agent_id'' site''' t_same in let error, t_distinct_self1 = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler agent_id site agent_id site'' t_distinct_self1 in error, Some t_distinct_self1 - else + ) else error, None in let error, t_same = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id site agent_id'' site'' t_same + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler agent_id + site agent_id'' site'' t_same in let error, t_distinct_self2 = - if agent = agent'' && - site' <> site''' && site' <> site && site<>site''' - then + if agent = agent'' && site' <> site''' && site' <> site && site <> site''' + then ( let error, t_distinct_self2 = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler agent_id site' agent_id site''' t_same - in error, Some t_distinct_self2 - else + in + error, Some t_distinct_self2 + ) else error, None in let error, agent_id''', t_distinct = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler - agent'' t_same + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler agent'' + t_same in let error, t_distinct = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id site' agent_id''' site''' t_distinct + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler agent_id + site' agent_id''' site''' t_distinct in let error, t_same = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id site' agent_id'' site''' t_same - in - let list_same = - t_same::(cons_opt t_same_self []) + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler agent_id + site' agent_id'' site''' t_same in + let list_same = t_same :: cons_opt t_same_self [] in let list_distinct = - t_distinct:: - (cons_opt t_distinct_self1 - (cons_opt t_distinct_self2 [])) + t_distinct :: cons_opt t_distinct_self1 (cons_opt t_distinct_self2 []) in - if sparse && compare site site' > 0 - then error - else + if sparse && compare site site' > 0 then + error + else ( let error = match value with | Usual_domains.Val true -> - begin - match Remanent_parameters.get_backend_mode parameters - with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - begin + (match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error = + if verbose then ( + (*print hyp*) let error = - if verbose - then - (*print hyp*) - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters - error - t_precondition - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - " => " - in - error - else - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) "%s" prefix - in error - in - (*print the list of refinement*) - let error = Site_graphs.KaSa_site_graph.print_list - (Remanent_parameters.get_logger parameters) parameters error - kappa_handler - list_same + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error t_precondition in let () = - Loggers.print_newline + Loggers.fprintf (Remanent_parameters.get_logger parameters) + " => " in error - end - | Remanent_parameters_sig.Natural_language -> - if verbose then - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sWhen the agent %s has its site %s bound to the site %s of a %s, \ - and its site %s bound to the site %s of a %s, then both instances of %s %s the same." - prefix string_agent string_site string_site'' string_agent'' - string_site' string_site''' string_agent'' string_agent'' - modalite in error - else + ) else ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s" prefix in + error + ) + in + (*print the list of refinement*) + let error = + Site_graphs.KaSa_site_graph.print_list + (Remanent_parameters.get_logger parameters) + parameters error kappa_handler list_same + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error + | Remanent_parameters_sig.Natural_language -> + if verbose then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sWhen the agent %s has its site %s bound to the site %s of a \ + %s, and its site %s bound to the site %s of a %s, then both \ + instances of %s %s the same." + prefix string_agent string_site string_site'' string_agent'' + string_site' string_site''' string_agent'' string_agent'' + modalite + in + error + ) else ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" prefix + in + let error = + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error t_same + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error + )) + | Usual_domains.Val false -> + (match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error = + if verbose then ( let error = Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - t_same + (Remanent_parameters.get_logger parameters) + parameters error t_precondition in let () = - Loggers.print_newline + Loggers.fprintf (Remanent_parameters.get_logger parameters) + " => " in error - end - | Usual_domains.Val false -> - begin - match Remanent_parameters.get_backend_mode parameters - with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - begin - let error = - if verbose then - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters - error - t_precondition - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - " => " - in error - else - let () = Loggers.fprintf - (Remanent_parameters.get_logger - parameters) "%s" - (Remanent_parameters.get_prefix parameters) - in error - in - let error = - Site_graphs.KaSa_site_graph.print_list - (Remanent_parameters.get_logger parameters) parameters error - kappa_handler - list_distinct + ) else ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s" + (Remanent_parameters.get_prefix parameters) in + error + ) + in + let error = + Site_graphs.KaSa_site_graph.print_list + (Remanent_parameters.get_logger parameters) + parameters error kappa_handler list_distinct + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error + | Remanent_parameters_sig.Natural_language -> + let error = + if verbose then ( let () = - Loggers.print_newline + Loggers.fprintf (Remanent_parameters.get_logger parameters) + "%sWhen the agent %s has its site %s bound to the site %s of \ + a %s, and its site %s bound to the site %s of a %s, then \ + both instances of %s %s different." + prefix string_agent string_site string_site'' string_agent'' + string_site' string_site''' string_agent'' string_agent'' + modalite in error - end - | Remanent_parameters_sig.Natural_language -> - let error = - if verbose then - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sWhen the agent %s has its site %s bound to the site %s of a %s, \ - and its site %s bound to the site %s of a %s, then both instances of %s %s different." - prefix string_agent string_site string_site'' - string_agent'' string_site' string_site''' string_agent'' - string_agent'' modalite - in error - else - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters - error - t_distinct - in error - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in error - end + ) else ( + let error = + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error t_distinct + in + error + ) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error) | Usual_domains.Undefined -> error | Usual_domains.Any -> let error = if dump_any then - if verbose then + if verbose then ( let () = - match - Remanent_parameters.get_backend_mode parameters - with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> () + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + () | Remanent_parameters_sig.Natural_language -> Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%sWhen the agent %s has its site %s bound to the site %s of a %s, \ - and its site %s bound to the site %s of a %s, then both instances of %s may be different or not." - prefix string_agent string_site string_site'' - string_agent'' string_site' string_site''' string_agent'' - string_agent'' - in error - else + "%sWhen the agent %s has its site %s bound to the site %s \ + of a %s, and its site %s bound to the site %s of a %s, \ + then both instances of %s may be different or not." + prefix string_agent string_site string_site'' string_agent'' + string_site' string_site''' string_agent'' string_agent'' + in + error + ) else ( let error = Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - t_same + (Remanent_parameters.get_logger parameters) + parameters error t_same in let () = Loggers.print_newline @@ -435,48 +445,47 @@ let print_parallel_constraint in let error = Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - t_distinct + (Remanent_parameters.get_logger parameters) + parameters error t_distinct in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in error + ) else error in let () = - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - in error - in error + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error + in + error + ) (* add value used in parallel_bonds_static.ml, project_away_ag_id *) let add_value parameters error x value store_result = let error, old_value = match - PairAgentSitesStates_map_and_set.Map.find_option_without_logs - parameters error x store_result + PairAgentSitesStates_map_and_set.Map.find_option_without_logs parameters + error x store_result with | error, None -> error, Usual_domains.Undefined | error, Some v -> error, v in let new_value = Usual_domains.lub old_value value in - if compare new_value old_value = 0 - then + if compare new_value old_value = 0 then error, store_result - else + else ( (*check whether or not if this is a fresh value*) let error, store_result = - PairAgentSitesStates_map_and_set.Map.add_or_overwrite - parameters - error - x - new_value - store_result + PairAgentSitesStates_map_and_set.Map.add_or_overwrite parameters error x + new_value store_result in error, store_result + ) (*use at apply_gen*) @@ -484,70 +493,57 @@ let add_value_and_event parameters error kappa_handler x value store_set store_result = let error, old_value = match - PairAgentSitesStates_map_and_set.Map.find_option_without_logs - parameters error x store_result + PairAgentSitesStates_map_and_set.Map.find_option_without_logs parameters + error x store_result with | error, None -> error, Usual_domains.Undefined | error, Some v -> error, v in - let proj (a, b, _, _, _) = (a, b) in - let proj' (a, _, c, _, _) = (a, c) in + let proj (a, b, _, _, _) = a, b in + let proj' (a, _, c, _, _) = a, c in let pair (x, y) = proj x, proj' x, proj y, proj' y in let new_value = Usual_domains.lub old_value value in - if compare new_value old_value = 0 - then + if compare new_value old_value = 0 then error, (store_set, store_result) - else + else ( (*check whether or not if this is a fresh value*) let error = - if Remanent_parameters.get_dump_reachability_analysis_diff parameters - then - print_parallel_constraint - ~verbose:false - ~dump_any:true parameters error kappa_handler x value - else error + if Remanent_parameters.get_dump_reachability_analysis_diff parameters then + print_parallel_constraint ~verbose:false ~dump_any:true parameters error + kappa_handler x value + else + error in (*compute new value only when it is needed*) let error, store_result = - PairAgentSitesStates_map_and_set.Map.add_or_overwrite - parameters - error - x - new_value - store_result + PairAgentSitesStates_map_and_set.Map.add_or_overwrite parameters error x + new_value store_result in let error', new_set = - PairAgentSite_map_and_set.Set.add_when_not_in - parameters - error - (pair x) + PairAgentSite_map_and_set.Set.add_when_not_in parameters error (pair x) store_set in let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in error, (new_set, store_result) + ) -let project (_,b,c,d,e,f) = (b,c,d,e,f) -let get_id ((a,_,_,_,_,_),_) = a -let get_tuple (a,b) = project a, project b - +let project (_, b, c, d, e, f) = b, c, d, e, f +let get_id ((a, _, _, _, _, _), _) = a +let get_tuple (a, b) = project a, project b let project2 = snd let add_value_from_refined_tuple parameters error x = add_value parameters error (project2 x) -let swap_sites_in_tuple (a,b,s,s',st,st') = (a,b,s',s,st',st) +let swap_sites_in_tuple (a, b, s, s', st, st') = a, b, s', s, st', st -let add_symmetric_tuple_pair f parameters error (x,y) remanent = +let add_symmetric_tuple_pair f parameters error (x, y) remanent = let x' = swap_sites_in_tuple x in let y' = swap_sites_in_tuple y in List.fold_left (fun (error, remanent) t -> - f - parameters error (get_id t,get_tuple t) remanent - ) + f parameters error (get_id t, get_tuple t) remanent) (error, remanent) - [x,y;(*y,x;*)x',y';(*y',x'*)] + [ x, y; (*y,x;*) x', y' (*y',x'*) ] diff --git a/core/KaSa_rep/reachability_analysis/product.ml b/core/KaSa_rep/reachability_analysis/product.ml index cbc3e5c9c1..8ff106d36e 100644 --- a/core/KaSa_rep/reachability_analysis/product.ml +++ b/core/KaSa_rep/reachability_analysis/product.ml @@ -13,391 +13,319 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - module Product - (New_domain:Analyzer_domain_sig.Domain) - (Underlying_domain:Analyzer_domain_sig.Domain) = - - (struct - - type ('a, 'b) pair = - { - new_domain : 'a; - underlying_domain: 'b - } - - type static_information = - (New_domain.static_information, Underlying_domain.static_information) pair - - type local_dynamic_information = - (New_domain.local_dynamic_information, - Underlying_domain.local_dynamic_information) pair - - type dynamic_information = - { - local : local_dynamic_information; - global: Analyzer_headers.global_dynamic_information; - } - - let get_parameter static = Underlying_domain.get_parameter static.underlying_domain - - let get_global_dynamic_information dynamic = dynamic.global - - let set_global_dynamic_information gdynamic dynamic = - {dynamic with global = gdynamic} - - let smash_dynamic underlying_domain new_domain = - { - global = new_domain.New_domain.global; - local = - { - new_domain = new_domain.New_domain.local; - underlying_domain = underlying_domain.Underlying_domain.local - }} - - let underlying_domain_dynamic_information dynamic = - { - Underlying_domain.global = dynamic.global; - Underlying_domain.local = dynamic.local.underlying_domain - } - - let new_domain_dynamic_information underlying_dynamic global_dynamic = - { - New_domain.global = underlying_dynamic.Underlying_domain.global; - New_domain.local = global_dynamic.local.new_domain - } - - let initialize global_static_information global_dynamic_information error = - let error, underlying_domain_static_information, - underlying_domain_dynamic_information, event_list = - Underlying_domain.initialize - global_static_information - global_dynamic_information - error - in - let error, new_domain_static_information, new_domain_dynamic_information, event_list' = - New_domain.initialize - global_static_information - underlying_domain_dynamic_information.Underlying_domain.global - error - in - error, + (New_domain : Analyzer_domain_sig.Domain) + (Underlying_domain : Analyzer_domain_sig.Domain) : + Analyzer_domain_sig.Domain = struct + type ('a, 'b) pair = { new_domain: 'a; underlying_domain: 'b } + + type static_information = + (New_domain.static_information, Underlying_domain.static_information) pair + + type local_dynamic_information = + ( New_domain.local_dynamic_information, + Underlying_domain.local_dynamic_information ) + pair + + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } + + let get_parameter static = + Underlying_domain.get_parameter static.underlying_domain + + let get_global_dynamic_information dynamic = dynamic.global + + let set_global_dynamic_information gdynamic dynamic = + { dynamic with global = gdynamic } + + let smash_dynamic underlying_domain new_domain = + { + global = new_domain.New_domain.global; + local = + { + new_domain = new_domain.New_domain.local; + underlying_domain = underlying_domain.Underlying_domain.local; + }; + } + + let underlying_domain_dynamic_information dynamic = + { + Underlying_domain.global = dynamic.global; + Underlying_domain.local = dynamic.local.underlying_domain; + } + + let new_domain_dynamic_information underlying_dynamic global_dynamic = + { + New_domain.global = underlying_dynamic.Underlying_domain.global; + New_domain.local = global_dynamic.local.new_domain; + } + + let initialize global_static_information global_dynamic_information error = + let ( error, + underlying_domain_static_information, + underlying_domain_dynamic_information, + event_list ) = + Underlying_domain.initialize global_static_information + global_dynamic_information error + in + let ( error, + new_domain_static_information, + new_domain_dynamic_information, + event_list' ) = + New_domain.initialize global_static_information + underlying_domain_dynamic_information.Underlying_domain.global error + in + ( error, { - new_domain = new_domain_static_information; - underlying_domain = underlying_domain_static_information + new_domain = new_domain_static_information; + underlying_domain = underlying_domain_static_information; }, smash_dynamic underlying_domain_dynamic_information new_domain_dynamic_information, - List.fold_left (fun list a -> a :: list) event_list event_list' - - let complete_wake_up_relation static error wake_up = - let error, wake_up = - Underlying_domain.complete_wake_up_relation - static.underlying_domain error wake_up - in - New_domain.complete_wake_up_relation static.new_domain error wake_up + List.fold_left (fun list a -> a :: list) event_list event_list' ) - type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a - - type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b - - type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c - - type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd - - let add_initial_state static dynamic error initial_state = - let error, underlying_domain_dynamic, event_list = - Underlying_domain.add_initial_state - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - initial_state + let complete_wake_up_relation static error wake_up = + let error, wake_up = + Underlying_domain.complete_wake_up_relation static.underlying_domain error + wake_up + in + New_domain.complete_wake_up_relation static.new_domain error wake_up + + type 'a zeroary = + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a + + type ('a, 'b) unary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b + + type ('a, 'b, 'c) binary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c + + type ('a, 'b, 'c, 'd) ternary = + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd + + let add_initial_state static dynamic error initial_state = + let error, underlying_domain_dynamic, event_list = + Underlying_domain.add_initial_state static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error initial_state in let error, new_domain_dynamic, event_list' = - New_domain.add_initial_state - static.new_domain + New_domain.add_initial_state static.new_domain (new_domain_dynamic_information underlying_domain_dynamic dynamic) - error - initial_state + error initial_state in - error, - smash_dynamic underlying_domain_dynamic new_domain_dynamic, - List.fold_left (fun list a -> a :: list) event_list event_list' - (* be careful, the concatenation should be done in the correct order to - get a linear time complexity instead of a quadratic one*) - - (***********************************************************) - - let gen_predicate - underlying new_domain - static dynamic error a precondition = - let error, underlying_domain_dynamic_information, output_opt = - underlying - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - a - precondition - in - let new_domain_dynamic_information = - new_domain_dynamic_information - underlying_domain_dynamic_information - dynamic - in - match output_opt with - | None -> - error, - smash_dynamic - underlying_domain_dynamic_information - new_domain_dynamic_information, None - | Some precondition -> - let error, new_domain_dynamic_information, output_opt = - new_domain - static.new_domain - new_domain_dynamic_information - error - a - precondition - in - let dynamic = - smash_dynamic - underlying_domain_dynamic_information - new_domain_dynamic_information - in - error, - dynamic, - output_opt - - let is_enabled = - gen_predicate - Underlying_domain.is_enabled - New_domain.is_enabled - - let lift_arg f arg = - (fun static dynamic error -> f static dynamic error arg) - - let maybe_reachable static dynamic error arg = - gen_predicate - (lift_arg Underlying_domain.maybe_reachable arg) - (lift_arg New_domain.maybe_reachable arg) - static dynamic error - (***********************************************************) - - let apply_rule static dynamic error rule_id precondition = - let error, underlying_domain_dynamic_information, - (precondition, event_list) = - Underlying_domain.apply_rule - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - rule_id + ( error, + smash_dynamic underlying_domain_dynamic new_domain_dynamic, + List.fold_left (fun list a -> a :: list) event_list event_list' ) + (* be careful, the concatenation should be done in the correct order to + get a linear time complexity instead of a quadratic one*) + + (***********************************************************) + + let gen_predicate underlying new_domain static dynamic error a precondition = + let error, underlying_domain_dynamic_information, output_opt = + underlying static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error a precondition + in + let new_domain_dynamic_information = + new_domain_dynamic_information underlying_domain_dynamic_information + dynamic + in + match output_opt with + | None -> + ( error, + smash_dynamic underlying_domain_dynamic_information + new_domain_dynamic_information, + None ) + | Some precondition -> + let error, new_domain_dynamic_information, output_opt = + new_domain static.new_domain new_domain_dynamic_information error a precondition in - let error, new_domain_dynamic_information, (precondition', event_list') = - New_domain.apply_rule - static.new_domain - (new_domain_dynamic_information - underlying_domain_dynamic_information - dynamic) - error - rule_id - precondition + let dynamic = + smash_dynamic underlying_domain_dynamic_information + new_domain_dynamic_information in - error, - smash_dynamic - underlying_domain_dynamic_information + error, dynamic, output_opt + + let is_enabled = + gen_predicate Underlying_domain.is_enabled New_domain.is_enabled + + let lift_arg f arg static dynamic error = f static dynamic error arg + + let maybe_reachable static dynamic error arg = + gen_predicate + (lift_arg Underlying_domain.maybe_reachable arg) + (lift_arg New_domain.maybe_reachable arg) + static dynamic error + (***********************************************************) + + let apply_rule static dynamic error rule_id precondition = + let error, underlying_domain_dynamic_information, (precondition, event_list) + = + Underlying_domain.apply_rule static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error rule_id precondition + in + let error, new_domain_dynamic_information, (precondition', event_list') = + New_domain.apply_rule static.new_domain + (new_domain_dynamic_information underlying_domain_dynamic_information + dynamic) + error rule_id precondition + in + ( error, + smash_dynamic underlying_domain_dynamic_information new_domain_dynamic_information, - (precondition', - List.fold_left (fun list a -> a :: list) event_list event_list') - (* be careful, the concatenation should be done in the correct order to get - a linear time complexity instead of a quadratic one*) - - let apply_one_side_effect static dynamic error rule_id (target) precondition = - let error, underlying_domain_dynamic_information, - (precondition, event_list) = - Underlying_domain.apply_one_side_effect - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - rule_id - target - precondition - in - let error, new_domain_dynamic_information, (precondition', event_list') = - New_domain.apply_one_side_effect - static.new_domain - (new_domain_dynamic_information - underlying_domain_dynamic_information - dynamic) - error - rule_id - target - precondition - in - error, - smash_dynamic - underlying_domain_dynamic_information - new_domain_dynamic_information, - (precondition', - List.fold_left (fun list a -> a :: list) event_list event_list') - - - let apply_event_list static dynamic error event_list = - let error, underlying_domain_dynamic_information, event_list' = - Underlying_domain.apply_event_list - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - event_list - in - let error, new_domain_dynamic_information, event_list'' = - New_domain.apply_event_list - static.new_domain - (new_domain_dynamic_information - underlying_domain_dynamic_information - dynamic) - error - event_list - in - let event_list = - List.fold_left (fun list a -> a :: list) event_list' event_list'' in - (* be careful, the concatenation should be done in the correct order to - get a linear time complexity instead of a quadratic one*) - error, - smash_dynamic - underlying_domain_dynamic_information + ( precondition', + List.fold_left (fun list a -> a :: list) event_list event_list' ) ) + (* be careful, the concatenation should be done in the correct order to get + a linear time complexity instead of a quadratic one*) + + let apply_one_side_effect static dynamic error rule_id target precondition = + let error, underlying_domain_dynamic_information, (precondition, event_list) + = + Underlying_domain.apply_one_side_effect static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error rule_id target precondition + in + let error, new_domain_dynamic_information, (precondition', event_list') = + New_domain.apply_one_side_effect static.new_domain + (new_domain_dynamic_information underlying_domain_dynamic_information + dynamic) + error rule_id target precondition + in + ( error, + smash_dynamic underlying_domain_dynamic_information new_domain_dynamic_information, - event_list - - let stabilize static dynamic error = - let error, underlying_domain_dynamic_information, () = - Underlying_domain.stabilize - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - in - let error, new_domain_dynamic_information, () = - New_domain.stabilize - static.new_domain - (new_domain_dynamic_information - underlying_domain_dynamic_information - dynamic) - error - in - error, - smash_dynamic - underlying_domain_dynamic_information + ( precondition', + List.fold_left (fun list a -> a :: list) event_list event_list' ) ) + + let apply_event_list static dynamic error event_list = + let error, underlying_domain_dynamic_information, event_list' = + Underlying_domain.apply_event_list static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error event_list + in + let error, new_domain_dynamic_information, event_list'' = + New_domain.apply_event_list static.new_domain + (new_domain_dynamic_information underlying_domain_dynamic_information + dynamic) + error event_list + in + let event_list = + List.fold_left (fun list a -> a :: list) event_list' event_list'' + in + (* be careful, the concatenation should be done in the correct order to + get a linear time complexity instead of a quadratic one*) + ( error, + smash_dynamic underlying_domain_dynamic_information new_domain_dynamic_information, - () + event_list ) - let export static dynamic error kasa_state = - let error, underlying_domain_dynamic_information, kasa_state = - Underlying_domain.export - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - kasa_state - in - let error, new_domain_dynamic_information, kasa_state = - New_domain.export - static.new_domain - (new_domain_dynamic_information - underlying_domain_dynamic_information - dynamic) - error - kasa_state - in - error, - smash_dynamic - underlying_domain_dynamic_information + let stabilize static dynamic error = + let error, underlying_domain_dynamic_information, () = + Underlying_domain.stabilize static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error + in + let error, new_domain_dynamic_information, () = + New_domain.stabilize static.new_domain + (new_domain_dynamic_information underlying_domain_dynamic_information + dynamic) + error + in + ( error, + smash_dynamic underlying_domain_dynamic_information new_domain_dynamic_information, - kasa_state + () ) - let print ?dead_rules static dynamic error loggers = - let error, underlying_domain_dynamic_information, () = - Underlying_domain.print - ?dead_rules - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - error - loggers - in - let error, new_domain_dynamic_information, () = - New_domain.print - ?dead_rules - static.new_domain - (new_domain_dynamic_information - underlying_domain_dynamic_information - dynamic) - error - loggers - in - error, - smash_dynamic - underlying_domain_dynamic_information + let export static dynamic error kasa_state = + let error, underlying_domain_dynamic_information, kasa_state = + Underlying_domain.export static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error kasa_state + in + let error, new_domain_dynamic_information, kasa_state = + New_domain.export static.new_domain + (new_domain_dynamic_information underlying_domain_dynamic_information + dynamic) + error kasa_state + in + ( error, + smash_dynamic underlying_domain_dynamic_information new_domain_dynamic_information, - () - - let get_dead_rules static dynamic = - let dead_rules = - Underlying_domain.get_dead_rules - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - in - let dead_rules' = - New_domain.get_dead_rules - static.new_domain - (new_domain_dynamic_information - (underlying_domain_dynamic_information dynamic) - dynamic) - in - (fun parameter error r_id -> - let error, b1 = dead_rules parameter error r_id in - let error, b2 = dead_rules' parameter error r_id in - error, b1||b2) + kasa_state ) - let get_side_effects static dynamic = - let side_effects = - Underlying_domain.get_side_effects - static.underlying_domain - (underlying_domain_dynamic_information dynamic) - in - let side_effects' = - New_domain.get_side_effects - static.new_domain - (new_domain_dynamic_information - (underlying_domain_dynamic_information dynamic) + let print ?dead_rules static dynamic error loggers = + let error, underlying_domain_dynamic_information, () = + Underlying_domain.print ?dead_rules static.underlying_domain + (underlying_domain_dynamic_information dynamic) + error loggers + in + let error, new_domain_dynamic_information, () = + New_domain.print ?dead_rules static.new_domain + (new_domain_dynamic_information underlying_domain_dynamic_information dynamic) - in - (fun parameter error r_id -> - let error, side_effect1 = side_effects parameter error r_id in - let error, side_effect2 = side_effects' parameter error r_id in - match side_effect1, side_effect2 with - | None, output -> error, output - | output, None -> error, output - | Some _, Some _ -> - Exception.warn parameter error __POS__ Exit None) + error loggers + in + ( error, + smash_dynamic underlying_domain_dynamic_information + new_domain_dynamic_information, + () ) - end:Analyzer_domain_sig.Domain) + let get_dead_rules static dynamic = + let dead_rules = + Underlying_domain.get_dead_rules static.underlying_domain + (underlying_domain_dynamic_information dynamic) + in + let dead_rules' = + New_domain.get_dead_rules static.new_domain + (new_domain_dynamic_information + (underlying_domain_dynamic_information dynamic) + dynamic) + in + fun parameter error r_id -> + let error, b1 = dead_rules parameter error r_id in + let error, b2 = dead_rules' parameter error r_id in + error, b1 || b2 + + let get_side_effects static dynamic = + let side_effects = + Underlying_domain.get_side_effects static.underlying_domain + (underlying_domain_dynamic_information dynamic) + in + let side_effects' = + New_domain.get_side_effects static.new_domain + (new_domain_dynamic_information + (underlying_domain_dynamic_information dynamic) + dynamic) + in + fun parameter error r_id -> + let error, side_effect1 = side_effects parameter error r_id in + let error, side_effect2 = side_effects' parameter error r_id in + match side_effect1, side_effect2 with + | None, output -> error, output + | output, None -> error, output + | Some _, Some _ -> Exception.warn parameter error __POS__ Exit None +end diff --git a/core/KaSa_rep/reachability_analysis/product.mli b/core/KaSa_rep/reachability_analysis/product.mli index 49017cac9a..4527837d25 100644 --- a/core/KaSa_rep/reachability_analysis/product.mli +++ b/core/KaSa_rep/reachability_analysis/product.mli @@ -1,11 +1,9 @@ (** Functor to combine several abstract domains (with explicit communiaction among them) *) -module Product: - functor - (New_domain:Analyzer_domain_sig.Domain) -> - functor - (Underlying_domain:Analyzer_domain_sig.Domain) -> - Analyzer_domain_sig.Domain +module Product : functor + (New_domain : Analyzer_domain_sig.Domain) + (Underlying_domain : Analyzer_domain_sig.Domain) + -> Analyzer_domain_sig.Domain (** The functor is almost symmetric, but better time performances will be obtained by using New_domain as a single domain and UNderlying_domain as a diff --git a/core/KaSa_rep/reachability_analysis/rules_domain.ml b/core/KaSa_rep/reachability_analysis/rules_domain.ml index 4fca69b5cb..1fa5c76caf 100644 --- a/core/KaSa_rep/reachability_analysis/rules_domain.ml +++ b/core/KaSa_rep/reachability_analysis/rules_domain.ml @@ -15,31 +15,27 @@ let local_trace = false -module Domain = -struct - +module Domain = struct (* the type of the struct that contains all static information as in the previous version of the analysis *) - type static_information = - { - global_static_information : Analyzer_headers.global_static_information; - domain_static_information : unit (* no domain-specific static information *) - } + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + domain_static_information: unit; (* no domain-specific static information *) + } (*--------------------------------------------------------------------*) (* this array indicates whether a rule has already be applied, or not *) -(* This array is statically allocated *) -(* Why do you use extensive arrays ? *) + (* This array is statically allocated *) + (* Why do you use extensive arrays ? *) type local_dynamic_information = bool Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t - type dynamic_information = - { - local : local_dynamic_information ; - global : Analyzer_headers.global_dynamic_information ; - } + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } (*--------------------------------------------------------------------*) (** global static information. @@ -48,93 +44,79 @@ struct never updated. *) let get_global_static_information static = static.global_static_information - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static - let get_compil static = lift Analyzer_headers.get_cc_code static (*--------------------------------------------------------------------*) (** global dynamic information*) let get_global_dynamic_information dynamic = dynamic.global + let set_global_dynamic_information gdynamic dynamic = - {dynamic with global = gdynamic} + { dynamic with global = gdynamic } (** dead rule local dynamic information*) let get_dead_rule dynamic = dynamic.local - let set_dead_rule dead_rule dynamic = - { - dynamic with local = dead_rule - } + let set_dead_rule dead_rule dynamic = { dynamic with local = dead_rule } (*--------------------------------------------------------------------*) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (**************************************************************************) (** [get_scan_rule_set static] *) let initialize static dynamic error = let init_global_static_information = - { - global_static_information = static; - domain_static_information = (); - } + { global_static_information = static; domain_static_information = () } in let kappa_handler = Analyzer_headers.get_kappa_handler static in let parameters = Analyzer_headers.get_parameter static in let nrules = Handler.nrules parameters error kappa_handler in let error, init_dead_rule_array = - if nrules = 0 - then - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 + if nrules = 0 then + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create parameters error + 0 else - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.init - parameters error (nrules-1) - (fun _ error _ -> error, false) + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.init parameters error + (nrules - 1) (fun _ error _ -> error, false) in let init_global_dynamic_information = - { - global = dynamic; - local = init_dead_rule_array; - } + { global = dynamic; local = init_dead_rule_array } in error, init_global_static_information, init_global_dynamic_information, [] - let complete_wake_up_relation _static error wake_up = - error, wake_up + let complete_wake_up_relation _static error wake_up = error, wake_up let add_initial_state _static dynamic error _species = let event_list = [] in @@ -148,8 +130,9 @@ struct otherwise sure_value false. no maybe *) } - *) - let is_enabled static dynamic error (rule_id:Ckappa_sig.c_rule_id) precondition = + *) + let is_enabled static dynamic error (rule_id : Ckappa_sig.c_rule_id) + precondition = let parameters = get_parameter static in let bool_array = get_dead_rule dynamic in let error, bool = @@ -160,17 +143,13 @@ struct | Some false | None -> let error, precondition = Communication.the_rule_is_applied_for_the_first_time - (get_parameter static) - error - precondition + (get_parameter static) error precondition in error, dynamic, Some precondition | Some true -> let error, precondition = Communication.the_rule_is_not_applied_for_the_first_time - (get_parameter static) - error - precondition + (get_parameter static) error precondition in error, dynamic, Some precondition @@ -191,65 +170,58 @@ struct let compil = get_compil static in let error, rule_id_string = try Handler.string_of_rule parameters error compil rule_id - with - | _ -> - Exception.warn - parameters error __POS__ Exit (Ckappa_sig.string_of_rule_id rule_id) + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_rule_id rule_id) in (*print*) let error, dynamic = match - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error rule_id dead_rule_array with | error, Some false -> let error, dead_rule_array = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set - parameters error - rule_id - true - dead_rule_array + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set parameters error + rule_id true dead_rule_array in let dynamic = let log = Remanent_parameters.get_logger parameters in - if local_trace - || Remanent_parameters.get_trace parameters - || Remanent_parameters.get_dump_reachability_analysis_iteration parameters - then + if + local_trace + || Remanent_parameters.get_trace parameters + || Remanent_parameters.get_dump_reachability_analysis_iteration + parameters + then ( let () = Loggers.print_newline log in let () = - Loggers.fprintf log "\t\t%s is applied for the first time" rule_id_string + Loggers.fprintf log "\t\t%s is applied for the first time" + rule_id_string in let () = Loggers.print_newline log in dynamic - else + ) else dynamic in let dynamic = set_dead_rule dead_rule_array dynamic in error, dynamic | error, Some true -> error, dynamic - | error, None -> - Exception.warn parameters error __POS__ Exit dynamic + | error, None -> Exception.warn parameters error __POS__ Exit dynamic in error, dynamic, (precondition, event_list) (* events enable communication between domains. At this moment, the global domain does not collect information *) - let apply_one_side_effect - _static dynamic error - _ _ precondition - = - error, dynamic, (precondition,[]) (* this domain ignores side effects *) - + let apply_one_side_effect _static dynamic error _ _ precondition = + error, dynamic, (precondition, []) + (* this domain ignores side effects *) let apply_event_list _static dynamic error _event_list = let event_list = [] in error, dynamic, event_list - let stabilize _static dynamic error = - error, dynamic, () + let stabilize _static dynamic error = error, dynamic, () let export static dynamic error kasa_state = let parameters = get_parameter static in @@ -261,25 +233,26 @@ struct let compil = get_compil static in let array = get_dead_rule dynamic in let error, list = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun _parameters error i bool list -> - if bool then error, list - else - let error, info = - Handler.info_of_rule ~original ~with_rates:false parameters error compil i - in - let error, b1 = Handler.is_reverse parameters error compil i in - let error, b2 = Handler.has_no_label parameters error compil i in - let rule = Remanent_state.info_to_rule info in - let rule = - if b1 && b2 && hide_reverse_rule - then Handler.hide rule - else rule - in - error, rule::list - ) + if bool then + error, list + else ( + let error, info = + Handler.info_of_rule ~original ~with_rates:false parameters error + compil i + in + let error, b1 = Handler.is_reverse parameters error compil i in + let error, b2 = Handler.has_no_label parameters error compil i in + let rule = Remanent_state.info_to_rule info in + let rule = + if b1 && b2 && hide_reverse_rule then + Handler.hide rule + else + rule + in + error, rule :: list + )) array [] in error, dynamic, Remanent_state.set_dead_rules list kasa_state @@ -290,99 +263,104 @@ struct let parameters = get_parameter static in let result = get_dead_rule dynamic in let compiled = get_compil static in - if Remanent_parameters.get_dump_reachability_analysis_result parameters - then + if Remanent_parameters.get_dump_reachability_analysis_result parameters then ( let error, bool = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters - error - (fun _parameters error _k bool bool'-> error, bool && bool') - result - true + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error + (fun _parameters error _k bool bool' -> error, bool && bool') + result true in - if not bool then - let parameters = - Remanent_parameters.update_prefix parameters "" + if not bool then ( + let parameters = Remanent_parameters.update_prefix parameters "" in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "------------------------------------------------------------" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "------------------------------------------------------------" + in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "* There are some non applyable rules" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "------------------------------------------------------------" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.iter - parameters - error + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "------------------------------------------------------------" + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.iter parameters error (fun parameters error k bool -> - if bool - then - error - else - let error', rule_string = - try - Handler.string_of_rule parameters error compiled k ~with_ast:false - with - | _ -> - Exception.warn - parameters error __POS__ Exit (Ckappa_sig.string_of_rule_id k) - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s will never be applied." rule_string - in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - error) + if bool then + error + else ( + let error', rule_string = + try + Handler.string_of_rule parameters error compiled k + ~with_ast:false + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_rule_id k) + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s will never be applied." rule_string + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + error + )) result - else + ) else ( let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "------------------------------------------------------------" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "every rule may be applied" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in error - else + ) + ) else error let print ?dead_rules static dynamic error _loggers = let _ = dead_rules in - let error = - print_dead_rule - static - dynamic - error - in + let error = print_dead_rule static dynamic error in error, dynamic, () - let get_dead_rules _static dynamic = - (fun parameters error r_id -> - match - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters error r_id - (get_dead_rule dynamic) - with - | error, None -> - Exception.warn - parameters error - __POS__ Exit false - | error, Some b -> error, not b - ) - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects + let get_dead_rules _static dynamic parameters error r_id = + match + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error r_id + (get_dead_rule dynamic) + with + | error, None -> Exception.warn parameters error __POS__ Exit false + | error, Some b -> error, not b + + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects end diff --git a/core/KaSa_rep/reachability_analysis/rules_domain.mli b/core/KaSa_rep/reachability_analysis/rules_domain.mli index b8c9583fe6..bc3989aa40 100644 --- a/core/KaSa_rep/reachability_analysis/rules_domain.mli +++ b/core/KaSa_rep/reachability_analysis/rules_domain.mli @@ -17,4 +17,4 @@ (** This domain tracks which rules can be applied, and warns other domains at the first application of a rule *) -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/side_effects_domain.ml b/core/KaSa_rep/reachability_analysis/side_effects_domain.ml index 8ce42b7230..bdaf54fab0 100644 --- a/core/KaSa_rep/reachability_analysis/side_effects_domain.ml +++ b/core/KaSa_rep/reachability_analysis/side_effects_domain.ml @@ -14,33 +14,27 @@ * under the terms of the GNU Library General Public License *) let local_trace = false - let _ = local_trace -module Domain = -struct - +module Domain = struct (* the type of the struct that contains all static information as in the previous version of the analysis *) - type static_information = - { - global_static_information : Analyzer_headers.global_static_information; - domain_static_information : unit (* no domain-specific static information *) - } + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + domain_static_information: unit; (* no domain-specific static information *) + } - -(* This array is statically allocated *) -(* Why do you use extensive arrays ? *) + (* This array is statically allocated *) + (* Why do you use extensive arrays ? *) type local_dynamic_information = Ckappa_sig.side_effects Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.t - type dynamic_information = - { - local : local_dynamic_information ; - global : Analyzer_headers.global_dynamic_information ; - } + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } (*--------------------------------------------------------------------*) (** global static information. @@ -49,67 +43,61 @@ struct never updated. *) let get_global_static_information static = static.global_static_information - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static (*--------------------------------------------------------------------*) (** global dynamic information*) let get_global_dynamic_information dynamic = dynamic.global + let set_global_dynamic_information gdynamic dynamic = - {dynamic with global = gdynamic} + { dynamic with global = gdynamic } (** dead rule local dynamic information*) let get_side_effects dynamic = dynamic.local let set_side_effects side_effects dynamic = - { - dynamic with local = side_effects - } + { dynamic with local = side_effects } (*--------------------------------------------------------------------*) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (**************************************************************************) (** [get_scan_rule_set static] *) let initialize static dynamic error = let init_global_static_information = - { - global_static_information = static; - domain_static_information = (); - } + { global_static_information = static; domain_static_information = () } in let kappa_handler = Analyzer_headers.get_kappa_handler static in let parameters = Analyzer_headers.get_parameter static in @@ -118,57 +106,44 @@ struct Analyzer_headers.get_potential_side_effects_per_rule static in let error, init_dead_rule_array = - if nrules = 0 - then - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create - parameters error 0 + if nrules = 0 then + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.create parameters error + 0 else - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.init - parameters error (nrules-1) - (fun _ error r_id -> + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.init parameters error + (nrules - 1) (fun _ error r_id -> let error, side_effects = Ckappa_sig.Rule_map_and_set.Map.find_default_without_logs - parameters error - [] - r_id - potential_side_effects + parameters error [] r_id potential_side_effects in let error, map = List.fold_left - (fun (error,map) (source,target) -> - Ckappa_sig.AgentsSiteState_map_and_set.Map.add_or_overwrite - parameters error - source - target - map - ) + (fun (error, map) (source, target) -> + Ckappa_sig.AgentsSiteState_map_and_set.Map.add_or_overwrite + parameters error source target map) (error, Ckappa_sig.AgentsSiteState_map_and_set.Map.empty) side_effects in - error, - { - Ckappa_sig.not_seen_yet = map; - Ckappa_sig.seen = Ckappa_sig.AgentSiteState_map_and_set.Set.empty - }) + ( error, + { + Ckappa_sig.not_seen_yet = map; + Ckappa_sig.seen = + Ckappa_sig.AgentSiteState_map_and_set.Set.empty; + } )) in let init_global_dynamic_information = - { - global = dynamic; - local = init_dead_rule_array; - } + { global = dynamic; local = init_dead_rule_array } in error, init_global_static_information, init_global_dynamic_information, [] - let complete_wake_up_relation _static error wake_up = - error, wake_up + let complete_wake_up_relation _static error wake_up = error, wake_up let add_initial_state _static dynamic error _species = let event_list = [] in error, dynamic, event_list - let is_enabled _static dynamic error _rule_id precondition = - error, dynamic, Some precondition + error, dynamic, Some precondition (***********************************************************) @@ -178,83 +153,65 @@ struct (* Nothing to do in this domain *) let apply_rule _static dynamic error _rule_id precondition = - error, dynamic, (precondition,[]) + error, dynamic, (precondition, []) - let apply_one_side_effect - static dynamic error - r_id (source_opt,target) precondition - = + let apply_one_side_effect static dynamic error r_id (source_opt, target) + precondition = match source_opt with - | None -> error, dynamic, (precondition,[]) + | None -> error, dynamic, (precondition, []) | Some source -> let parameter = get_parameter static in let side_effects = get_side_effects dynamic in let error, side_effects_r_id = match - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameter error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameter error r_id side_effects with | error, None -> - Exception.warn parameter error __POS__ Exit Ckappa_sig.empty_side_effects + Exception.warn parameter error __POS__ Exit + Ckappa_sig.empty_side_effects | error, Some side_effects -> error, side_effects in let error, seen = - Ckappa_sig.AgentSiteState_map_and_set.Set.add_when_not_in - parameter error - target - side_effects_r_id.Ckappa_sig.seen + Ckappa_sig.AgentSiteState_map_and_set.Set.add_when_not_in parameter + error target side_effects_r_id.Ckappa_sig.seen in - if seen==side_effects_r_id.Ckappa_sig.seen then + if seen == side_effects_r_id.Ckappa_sig.seen then error, dynamic, (precondition, []) - else + else ( let error, not_seen_yet = - Ckappa_sig.AgentsSiteState_map_and_set.Map.remove - parameter error source side_effects_r_id.Ckappa_sig.not_seen_yet + Ckappa_sig.AgentsSiteState_map_and_set.Map.remove parameter error + source side_effects_r_id.Ckappa_sig.not_seen_yet in let error, side_effects = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set - parameter error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.set parameter error r_id - {Ckappa_sig.seen = seen; - Ckappa_sig.not_seen_yet = not_seen_yet} + { Ckappa_sig.seen; Ckappa_sig.not_seen_yet } side_effects in let dynamic = set_side_effects side_effects dynamic in - error, dynamic, (precondition,[]) - + error, dynamic, (precondition, []) + ) let apply_event_list _static dynamic error _event_list = let event_list = [] in error, dynamic, event_list - let stabilize _static dynamic error = - error, dynamic, () - - let export _static dynamic error kasa_state = - error, dynamic, kasa_state + let stabilize _static dynamic error = error, dynamic, () + let export _static dynamic error kasa_state = error, dynamic, kasa_state (**************************************************************************) - let print ?dead_rules _static dynamic error _loggers = let _ = dead_rules in error, dynamic, () - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static dynamic = - (fun parameters error r_id -> - match - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters error r_id - (get_side_effects dynamic) - with - | error, None -> - Exception.warn - parameters error - __POS__ Exit None - | error, Some b -> error, (Some b) - ) + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static dynamic parameters error r_id = + match + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error r_id + (get_side_effects dynamic) + with + | error, None -> Exception.warn parameters error __POS__ Exit None + | error, Some b -> error, Some b end diff --git a/core/KaSa_rep/reachability_analysis/side_effects_domain.mli b/core/KaSa_rep/reachability_analysis/side_effects_domain.mli index b8c9583fe6..bc3989aa40 100644 --- a/core/KaSa_rep/reachability_analysis/side_effects_domain.mli +++ b/core/KaSa_rep/reachability_analysis/side_effects_domain.mli @@ -17,4 +17,4 @@ (** This domain tracks which rules can be applied, and warns other domains at the first application of a rule *) -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.ml b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.ml index 00e9f1ff2c..1167cb8479 100644 --- a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.ml +++ b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.ml @@ -15,9 +15,7 @@ let local_trace = false -module Domain = -struct - +module Domain = struct (* the type of the struct that contains all static information as in the previous version of the analysis *) @@ -38,45 +36,41 @@ struct B *) (*************************************************************************) - type local_static_information = - { - store_basic_static_information: - Site_across_bonds_domain_static.basic_static_information; - dummy:unit; - } + type local_static_information = { + store_basic_static_information: + Site_across_bonds_domain_static.basic_static_information; + dummy: unit; + } - type static_information = - { - global_static_information : Analyzer_headers.global_static_information; - local_static_information : local_static_information - } + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + local_static_information: local_static_information; + } (*--------------------------------------------------------------*) (* A triple of maps : mvbdu_of_association_list - - One maps each such tuples (A,x,y,B,z,t) to a mvbdu with two variables - that describes the relation between the state of y and the state of t, - when both agents are connected via x and z. - - One maps each such tuples (A,x,y,B,z,t) to a mvbdu with one variables - that decribes the range of y when both agents are connected via x and - z. - - One maps each such tuples (A,x,y,B,z,t) to a mvbdu with one variables - that decribes the range of t when both agents are connected via x and - z. *) + - One maps each such tuples (A,x,y,B,z,t) to a mvbdu with two variables + that describes the relation between the state of y and the state of t, + when both agents are connected via x and z. + - One maps each such tuples (A,x,y,B,z,t) to a mvbdu with one variables + that decribes the range of y when both agents are connected via x and + z. + - One maps each such tuples (A,x,y,B,z,t) to a mvbdu with one variables + that decribes the range of t when both agents are connected via x and + z. *) (*--------------------------------------------------------------*) - type local_dynamic_information = - { - dumy: unit; - store_value : - Ckappa_sig.Views_bdu.mvbdu - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map.t; - } + type local_dynamic_information = { + dummy: unit; + store_value: + Ckappa_sig.Views_bdu.mvbdu + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map.t; + } - type dynamic_information = - { - local : local_dynamic_information ; - global : Analyzer_headers.global_dynamic_information ; - } + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } let domain_name = "Site accross bonds domain" @@ -86,38 +80,28 @@ struct handler is static and thus it should never updated. *) let get_global_static_information static = static.global_static_information - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static - let get_kappa_handler static = lift Analyzer_headers.get_kappa_handler static let get_potential_side_effects static = lift Analyzer_headers.get_potential_side_effects_per_rule static let get_compil static = lift Analyzer_headers.get_cc_code static - let get_views_rhs static = lift Analyzer_headers.get_views_rhs static - let get_views_lhs static = lift Analyzer_headers.get_views_lhs static let get_action_binding static = lift Analyzer_headers.get_action_binding static let get_modified_map static = lift Analyzer_headers.get_modified_map static - let get_bonds_rhs static = lift Analyzer_headers.get_bonds_rhs static - let get_bonds_lhs static = lift Analyzer_headers.get_bonds_lhs static let get_rule parameters error static r_id = let compil = get_compil static in - let error, rule = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get - parameters - error - r_id + let error, rule = + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.get parameters error r_id compil.Cckappa_sig.rules in error, rule @@ -127,11 +111,7 @@ struct let get_local_static_information static = static.local_static_information let set_local_static_information local static = - { - static with - local_static_information = local - } - + { static with local_static_information = local } (***************************************************************************) (*STATIC INFORMATION*) @@ -144,182 +124,206 @@ struct set_local_static_information { (get_local_static_information static) with - store_basic_static_information = domain - } static + store_basic_static_information = domain; + } + static (***************************************************************************) (*POTENTIAL TUPLE PAIR ON VIEWS*) (***************************************************************************) let get_potential_tuple_pair_views static = - (get_basic_static_information static).Site_across_bonds_domain_static.store_potential_tuple_pair_views + (get_basic_static_information static) + .Site_across_bonds_domain_static.store_potential_tuple_pair_views let set_potential_tuple_pair_views domain static = set_basic_static_information { (get_basic_static_information static) with - Site_across_bonds_domain_static.store_potential_tuple_pair_views = domain - } static + Site_across_bonds_domain_static.store_potential_tuple_pair_views = + domain; + } + static let get_potential_tuple_pair static = - (get_potential_tuple_pair_views - static).Site_across_bonds_domain_static.store_potential_tuple_pair + (get_potential_tuple_pair_views static) + .Site_across_bonds_domain_static.store_potential_tuple_pair let set_potential_tuple_pair r static = set_potential_tuple_pair_views { (get_potential_tuple_pair_views static) with - Site_across_bonds_domain_static.store_potential_tuple_pair = r - } static + Site_across_bonds_domain_static.store_potential_tuple_pair = r; + } + static let get_potential_tuple_pair_lhs static = - (get_potential_tuple_pair_views - static).Site_across_bonds_domain_static.store_potential_tuple_pair_lhs + (get_potential_tuple_pair_views static) + .Site_across_bonds_domain_static.store_potential_tuple_pair_lhs let set_potential_tuple_pair_lhs l static = set_potential_tuple_pair_views { (get_potential_tuple_pair_views static) with - Site_across_bonds_domain_static.store_potential_tuple_pair_lhs = l - } static + Site_across_bonds_domain_static.store_potential_tuple_pair_lhs = l; + } + static let get_potential_tuple_pair_rule_rhs static = - (get_potential_tuple_pair_views - static).Site_across_bonds_domain_static.store_potential_tuple_pair_rule_rhs + (get_potential_tuple_pair_views static) + .Site_across_bonds_domain_static.store_potential_tuple_pair_rule_rhs let set_potential_tuple_pair_rule_rhs r static = set_potential_tuple_pair_views { (get_potential_tuple_pair_views static) with - Site_across_bonds_domain_static.store_potential_tuple_pair_rule_rhs = r - } static + Site_across_bonds_domain_static.store_potential_tuple_pair_rule_rhs = r; + } + static (***************************************************************************) (*CREATED A NEW BINDING*) (***************************************************************************) let get_potential_tuple_pair_creation_bonds static = - (get_basic_static_information static).Site_across_bonds_domain_static.store_potential_tuple_pair_creation_bonds + (get_basic_static_information static) + .Site_across_bonds_domain_static.store_potential_tuple_pair_creation_bonds let set_potential_tuple_pair_creation_bonds domain static = set_basic_static_information { (get_basic_static_information static) with - Site_across_bonds_domain_static.store_potential_tuple_pair_creation_bonds = domain - } static + Site_across_bonds_domain_static + .store_potential_tuple_pair_creation_bonds = domain; + } + static let get_partition_created_bonds_map static = - (get_potential_tuple_pair_creation_bonds - static).Site_across_bonds_domain_static.store_partition_created_bonds_map + (get_potential_tuple_pair_creation_bonds static) + .Site_across_bonds_domain_static.store_partition_created_bonds_map let set_partition_created_bonds_map r static = set_potential_tuple_pair_creation_bonds { (get_potential_tuple_pair_creation_bonds static) with - Site_across_bonds_domain_static.store_partition_created_bonds_map = r - } static + Site_across_bonds_domain_static.store_partition_created_bonds_map = r; + } + static let get_partition_created_bonds_map_1 static = - (get_potential_tuple_pair_creation_bonds - static).Site_across_bonds_domain_static.store_partition_created_bonds_map_1 + (get_potential_tuple_pair_creation_bonds static) + .Site_across_bonds_domain_static.store_partition_created_bonds_map_1 let set_partition_created_bonds_map_1 r static = set_potential_tuple_pair_creation_bonds { (get_potential_tuple_pair_creation_bonds static) with - Site_across_bonds_domain_static.store_partition_created_bonds_map_1 = r - } static + Site_across_bonds_domain_static.store_partition_created_bonds_map_1 = r; + } + static let get_partition_created_bonds_map_2 static = - (get_potential_tuple_pair_creation_bonds - static).Site_across_bonds_domain_static.store_partition_created_bonds_map_2 + (get_potential_tuple_pair_creation_bonds static) + .Site_across_bonds_domain_static.store_partition_created_bonds_map_2 let set_partition_created_bonds_map_2 r static = set_potential_tuple_pair_creation_bonds { (get_potential_tuple_pair_creation_bonds static) with - Site_across_bonds_domain_static.store_partition_created_bonds_map_2 = r - } static + Site_across_bonds_domain_static.store_partition_created_bonds_map_2 = r; + } + static let get_rule_partition_created_bonds_map_1 static = - (get_potential_tuple_pair_creation_bonds - static).Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_1 + (get_potential_tuple_pair_creation_bonds static) + .Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_1 let set_rule_partition_created_bonds_map_1 r static = set_potential_tuple_pair_creation_bonds { (get_potential_tuple_pair_creation_bonds static) with - Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_1 = r - } static + Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_1 = + r; + } + static let get_rule_partition_created_bonds_map_2 static = - (get_potential_tuple_pair_creation_bonds - static).Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_2 + (get_potential_tuple_pair_creation_bonds static) + .Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_2 let set_rule_partition_created_bonds_map_2 r static = set_potential_tuple_pair_creation_bonds { (get_potential_tuple_pair_creation_bonds static) with - Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_2 = r - } static + Site_across_bonds_domain_static.store_rule_partition_created_bonds_map_2 = + r; + } + static -(***************************************************************************) -(*MODIFICATION*) -(***************************************************************************) + (***************************************************************************) + (*MODIFICATION*) + (***************************************************************************) let get_potential_tuple_pair_modification static = - (get_basic_static_information static).Site_across_bonds_domain_static.store_potential_tuple_pair_modification + (get_basic_static_information static) + .Site_across_bonds_domain_static.store_potential_tuple_pair_modification let set_potential_tuple_pair_modification domain static = set_basic_static_information { (get_basic_static_information static) with - Site_across_bonds_domain_static.store_potential_tuple_pair_modification = domain - } static + Site_across_bonds_domain_static.store_potential_tuple_pair_modification = + domain; + } + static let get_partition_modified_map_1 static = - (get_potential_tuple_pair_modification - static).Site_across_bonds_domain_static.store_partition_modified_map_1 + (get_potential_tuple_pair_modification static) + .Site_across_bonds_domain_static.store_partition_modified_map_1 let set_partition_modified_map_1 r static = set_potential_tuple_pair_modification { (get_potential_tuple_pair_modification static) with - Site_across_bonds_domain_static.store_partition_modified_map_1 = r - } static + Site_across_bonds_domain_static.store_partition_modified_map_1 = r; + } + static let get_partition_modified_map_2 static = - (get_potential_tuple_pair_modification - static).Site_across_bonds_domain_static.store_partition_modified_map_2 + (get_potential_tuple_pair_modification static) + .Site_across_bonds_domain_static.store_partition_modified_map_2 let set_partition_modified_map_2 r static = set_potential_tuple_pair_modification { (get_potential_tuple_pair_modification static) with - Site_across_bonds_domain_static.store_partition_modified_map_2 = r - } static + Site_across_bonds_domain_static.store_partition_modified_map_2 = r; + } + static let get_rule_partition_modified_map_1 static = - (get_potential_tuple_pair_modification - static).Site_across_bonds_domain_static.store_rule_partition_modified_map_1 + (get_potential_tuple_pair_modification static) + .Site_across_bonds_domain_static.store_rule_partition_modified_map_1 let set_rule_partition_modified_map_1 r static = set_potential_tuple_pair_modification { (get_potential_tuple_pair_modification static) with - Site_across_bonds_domain_static.store_rule_partition_modified_map_1 = r - } static + Site_across_bonds_domain_static.store_rule_partition_modified_map_1 = r; + } + static let get_rule_partition_modified_map_2 static = - (get_potential_tuple_pair_modification - static).Site_across_bonds_domain_static.store_rule_partition_modified_map_2 + (get_potential_tuple_pair_modification static) + .Site_across_bonds_domain_static.store_rule_partition_modified_map_2 let set_rule_partition_modified_map_2 r static = set_potential_tuple_pair_modification { (get_potential_tuple_pair_modification static) with - Site_across_bonds_domain_static.store_rule_partition_modified_map_2 = r - } static + Site_across_bonds_domain_static.store_rule_partition_modified_map_2 = r; + } + static (***************************************************************************) (** DYNAMIC INFORMATION*) @@ -328,9 +332,7 @@ struct let get_global_dynamic_information dynamic = dynamic.global let set_global_dynamic_information gdynamic dynamic = - { - dynamic with global = gdynamic - } + { dynamic with global = gdynamic } let get_mvbdu_handler dynamic = Analyzer_headers.get_mvbdu_handler (get_global_dynamic_information dynamic) @@ -338,71 +340,65 @@ struct let set_mvbdu_handler handler dynamic = { dynamic with - global = Analyzer_headers.set_mvbdu_handler handler - (get_global_dynamic_information dynamic) + global = + Analyzer_headers.set_mvbdu_handler handler + (get_global_dynamic_information dynamic); } let get_local_dynamic_information dynamic = dynamic.local - - let set_local_dynamic_information local dynamic = - { - dynamic with local = local - } - - let get_value dynamic = - (get_local_dynamic_information dynamic).store_value + let set_local_dynamic_information local dynamic = { dynamic with local } + let get_value dynamic = (get_local_dynamic_information dynamic).store_value let set_value value dynamic = set_local_dynamic_information - { - (get_local_dynamic_information dynamic) with - store_value = value - } dynamic + { (get_local_dynamic_information dynamic) with store_value = value } + dynamic - (** profiling *) - let get_log_info dynamic = - Analyzer_headers.get_log_info (get_global_dynamic_information dynamic) + (** profiling *) + let get_log_info dynamic = + Analyzer_headers.get_log_info (get_global_dynamic_information dynamic) - let set_log_info log_info dynamic = - { - dynamic with - global = Analyzer_headers.set_log_info log_info - (get_global_dynamic_information dynamic) - } + let set_log_info log_info dynamic = + { + dynamic with + global = + Analyzer_headers.set_log_info log_info + (get_global_dynamic_information dynamic); + } (***************************************************************************) (*TYPE*) (***************************************************************************) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (****************************************************************) (*RULE*) @@ -415,17 +411,11 @@ struct let store_bonds_rhs = get_bonds_rhs static in let store_potential_tuple_pair = get_potential_tuple_pair static in let error, store_potential_tuple_pair = - Site_across_bonds_domain_static.collect_potential_tuple_pair - parameters error kappa_handler - rule_id - store_bonds_rhs - store_views_rhs + Site_across_bonds_domain_static.collect_potential_tuple_pair parameters + error kappa_handler rule_id store_bonds_rhs store_views_rhs store_potential_tuple_pair in - let static = - set_potential_tuple_pair store_potential_tuple_pair - static - in + let static = set_potential_tuple_pair store_potential_tuple_pair static in (*------------------------------------------------------------*) (*potential tuple pair on the rhs depend on rule_id*) let store_potential_tuple_pair = get_potential_tuple_pair static in @@ -434,32 +424,25 @@ struct in let error, store_potential_tuple_pair_rule_rhs = Site_across_bonds_domain_static.collect_potential_tuple_pair_rule_rhs - parameters error - rule_id - store_potential_tuple_pair + parameters error rule_id store_potential_tuple_pair store_potential_tuple_pair_rule_rhs in - let static = set_potential_tuple_pair_rule_rhs - store_potential_tuple_pair_rule_rhs static + let static = + set_potential_tuple_pair_rule_rhs store_potential_tuple_pair_rule_rhs + static in (*------------------------------------------------------------*) (*potential tuple pair on lhs views *) let store_views_lhs = get_views_lhs static in let store_bonds_lhs = get_bonds_lhs static in - let store_potential_tuple_pair_lhs = - get_potential_tuple_pair_lhs static - in + let store_potential_tuple_pair_lhs = get_potential_tuple_pair_lhs static in let error, store_potential_tuple_pair_lhs = Site_across_bonds_domain_static.collect_potential_tuple_pair_lhs - parameters error kappa_handler - rule_id - store_bonds_lhs - store_views_lhs + parameters error kappa_handler rule_id store_bonds_lhs store_views_lhs store_potential_tuple_pair_lhs in let static = - set_potential_tuple_pair_lhs store_potential_tuple_pair_lhs - static + set_potential_tuple_pair_lhs store_potential_tuple_pair_lhs static in error, static @@ -472,54 +455,40 @@ struct let compil = get_compil static in let kappa_handler = get_kappa_handler static in let error, static = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters - error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error rule_id rule static -> - let error, static = - scan_rule - parameters error kappa_handler - rule_id - rule.Cckappa_sig.e_rule_c_rule - static - in - error, static - ) compil.Cckappa_sig.rules static + let error, static = + scan_rule parameters error kappa_handler rule_id + rule.Cckappa_sig.e_rule_c_rule static + in + error, static) + compil.Cckappa_sig.rules static in (*------------------------------------------------------------*) (*partition map with key is the pair of the bonds in the rhs*) let store_potential_tuple_pair = get_potential_tuple_pair static in let error, store_partition_created_bonds_map = Site_across_bonds_domain_static.collect_partition_created_bonds_map - parameters error - store_potential_tuple_pair + parameters error store_potential_tuple_pair in let static = - set_partition_created_bonds_map - store_partition_created_bonds_map - static + set_partition_created_bonds_map store_partition_created_bonds_map static in (*------------------------------------------------------------*) (*a site is modified explicitly*) let error, store_partition_modified_map_1 = Site_across_bonds_domain_static.collect_partition_modified_map_1 - parameters error - store_potential_tuple_pair + parameters error store_potential_tuple_pair in let static = - set_partition_modified_map_1 - store_partition_modified_map_1 - static + set_partition_modified_map_1 store_partition_modified_map_1 static in let error, store_partition_modified_map_2 = Site_across_bonds_domain_static.collect_partition_modified_map_2 - parameters error - store_potential_tuple_pair + parameters error store_potential_tuple_pair in let static = - set_partition_modified_map_2 - store_partition_modified_map_2 - static + set_partition_modified_map_2 store_partition_modified_map_2 static in (*------------------------------------------------------------*) (*potential tuple pair that are modified depend on rule_id*) @@ -531,13 +500,11 @@ struct in let error, store_rule_partition_modified_map_1 = Site_across_bonds_domain_static.collect_rule_partition_modified_map_1 - parameters error - store_potential_tuple_pair_rule_rhs + parameters error store_potential_tuple_pair_rule_rhs store_rule_partition_modified_map_1 in let static = - set_rule_partition_modified_map_1 - store_rule_partition_modified_map_1 + set_rule_partition_modified_map_1 store_rule_partition_modified_map_1 static in (*------------------------------------------------------------*) @@ -546,13 +513,11 @@ struct in let error, store_rule_partition_modified_map_2 = Site_across_bonds_domain_static.collect_rule_partition_modified_map_2 - parameters error - store_potential_tuple_pair_rule_rhs + parameters error store_potential_tuple_pair_rule_rhs store_rule_partition_modified_map_2 in let static = - set_rule_partition_modified_map_2 - store_rule_partition_modified_map_2 + set_rule_partition_modified_map_2 store_rule_partition_modified_map_2 static in (*------------------------------------------------------------*) @@ -564,12 +529,11 @@ struct in let error, store_partition_created_bonds_map_1 = Site_across_bonds_domain_static.collect_partition_created_bonds_map_1 - parameters error - store_partition_created_bonds_map + parameters error store_partition_created_bonds_map store_partition_created_bonds_map_1 in - let static = set_partition_created_bonds_map_1 - store_partition_created_bonds_map_1 + let static = + set_partition_created_bonds_map_1 store_partition_created_bonds_map_1 static in (* *) @@ -578,12 +542,11 @@ struct in let error, store_partition_created_bonds_map_2 = Site_across_bonds_domain_static.collect_partition_created_bonds_map_2 - parameters error - store_partition_created_bonds_map + parameters error store_partition_created_bonds_map store_partition_created_bonds_map_2 in - let static = set_partition_created_bonds_map_2 - store_partition_created_bonds_map_2 + let static = + set_partition_created_bonds_map_2 store_partition_created_bonds_map_2 static in (*------------------------------------------------------------*) @@ -592,11 +555,11 @@ struct in let error, store_rule_partition_created_bonds_map_1 = Site_across_bonds_domain_static.collect_rule_partition_created_bonds_map_1 - parameters error - store_potential_tuple_pair_rule_rhs + parameters error store_potential_tuple_pair_rule_rhs store_rule_partition_created_bonds_map_1 in - let static = set_rule_partition_created_bonds_map_1 + let static = + set_rule_partition_created_bonds_map_1 store_rule_partition_created_bonds_map_1 static in let store_rule_partition_created_bonds_map_2 = @@ -604,11 +567,11 @@ struct in let error, store_rule_partition_created_bonds_map_2 = Site_across_bonds_domain_static.collect_rule_partition_created_bonds_map_1 - parameters error - store_potential_tuple_pair_rule_rhs + parameters error store_potential_tuple_pair_rule_rhs store_rule_partition_created_bonds_map_2 in - let static = set_rule_partition_created_bonds_map_2 + let static = + set_rule_partition_created_bonds_map_2 store_rule_partition_created_bonds_map_2 static in (*------------------------------------------------------------*) @@ -616,17 +579,16 @@ struct let store_potential_tuple_pair_lhs = get_potential_tuple_pair_lhs static in let store_potential_tuple_pair_lhs = Ckappa_sig.Rule_map_and_set.Map.map - (Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.filter - (fun ((a,b,c,d,_),(a',b',c',d',_)) -> - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.mem - ((a,b,c,d),(a',b',c',d')) - store_potential_tuple_pair)) + (Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set + .filter (fun ((a, b, c, d, _), (a', b', c', d', _)) -> + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set + .mem + ((a, b, c, d), (a', b', c', d')) + store_potential_tuple_pair)) store_potential_tuple_pair_lhs in let static = - set_potential_tuple_pair_lhs - store_potential_tuple_pair_lhs - static + set_potential_tuple_pair_lhs store_potential_tuple_pair_lhs static in error, static, dynamic @@ -637,16 +599,16 @@ struct let initialize static dynamic error = let parameters = Analyzer_headers.get_parameter static in let log_info = Analyzer_headers.get_log_info dynamic in - let error, log_info = StoryProfiling.StoryStats.add_event parameters error - (StoryProfiling.Domain_initialization domain_name) - None log_info + let error, log_info = + StoryProfiling.StoryStats.add_event parameters error + (StoryProfiling.Domain_initialization domain_name) None log_info in let dynamic = Analyzer_headers.set_log_info log_info dynamic in let init_local_static_information = { store_basic_static_information = Site_across_bonds_domain_static.init_basic_static_information; - dummy = () + dummy = (); } in let init_global_static_information = @@ -657,27 +619,23 @@ struct in let init_local_dynamic_information = { - dumy = (); + dummy = (); store_value = - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map.empty; + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map + .empty; } in let init_global_dynamic_information = - { - global = dynamic; - local = init_local_dynamic_information; - } + { global = dynamic; local = init_local_dynamic_information } in let error, static, dynamic = - scan_rules - init_global_static_information - init_global_dynamic_information + scan_rules init_global_static_information init_global_dynamic_information error in let log_info = get_log_info dynamic in - let error, log_info = StoryProfiling.StoryStats.close_event parameters error - (StoryProfiling.Domain_initialization domain_name) - None log_info + let error, log_info = + StoryProfiling.StoryStats.close_event parameters error + (StoryProfiling.Domain_initialization domain_name) None log_info in let dynamic = set_log_info log_info dynamic in error, static, dynamic, [] @@ -690,49 +648,33 @@ struct wake_up = Ckappa_sig.Rule_map_and_set.Map.fold (fun rule_id tuple_pairs (error, wake_up) -> - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.fold - (fun (x, y) (error, wake_up) -> - let (agent_type, site_type1, site_type2, _) = x in - let (agent_type', site_type1', site_type2', _) = y in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type - site_type1 - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type - site_type2 - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type' - site_type1' - rule_id - wake_up - in - let error, wake_up = - Common_static.add_dependency_site_rule - parameters error - agent_type' - site_type2' - rule_id - wake_up - in - error, wake_up - ) tuple_pairs (error, wake_up) - ) rule_tuples (error, wake_up) + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.fold + (fun (x, y) (error, wake_up) -> + let agent_type, site_type1, site_type2, _ = x in + let agent_type', site_type1', site_type2', _ = y in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error agent_type + site_type1 rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error agent_type + site_type2 rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type' site_type1' rule_id wake_up + in + let error, wake_up = + Common_static.add_dependency_site_rule parameters error + agent_type' site_type2' rule_id wake_up + in + error, wake_up) + tuple_pairs (error, wake_up)) + rule_tuples (error, wake_up) (* fold over all the rules, all the tuples of interest, all the sites in these - tuples, and apply the function Common_static.add_dependency_site_rule to - update the wake_up relation *) + tuples, and apply the function Common_static.add_dependency_site_rule to + update the wake_up relation *) let complete_wake_up_relation static error wake_up = let parameters = get_parameter static in @@ -744,48 +686,43 @@ struct get_rule_partition_created_bonds_map_2 static in let store_rule_partition_modified_map_1 = - get_rule_partition_modified_map_1 static in + get_rule_partition_modified_map_1 static + in let store_rule_partition_modified_map_2 = - get_rule_partition_modified_map_2 static in - let store_potential_side_effects = - get_potential_side_effects static in + get_rule_partition_modified_map_2 static + in + let store_potential_side_effects = get_potential_side_effects static in (*----------------------------------------------------*) let error, wake_up = add_rules_tuples_into_wake_up_relation parameters error - store_rule_partition_created_bonds_map_1 - wake_up + store_rule_partition_created_bonds_map_1 wake_up in let error, wake_up = add_rules_tuples_into_wake_up_relation parameters error - store_rule_partition_created_bonds_map_2 - wake_up + store_rule_partition_created_bonds_map_2 wake_up in (*----------------------------------------------------*) (*dealing with site that is modified*) let error, wake_up = add_rules_tuples_into_wake_up_relation parameters error - store_rule_partition_modified_map_1 - wake_up + store_rule_partition_modified_map_1 wake_up in let error, wake_up = - add_rules_tuples_into_wake_up_relation parameters error - store_rule_partition_modified_map_2 - wake_up + add_rules_tuples_into_wake_up_relation parameters error + store_rule_partition_modified_map_2 wake_up in (*----------------------------------------------------*) (*dealing with side effects*) let error, wake_up = Ckappa_sig.Rule_map_and_set.Map.fold (fun rule_id list (error, wake_up) -> - List.fold_left (fun (error, wake_up) (_,(agent_type, site_type, _)) -> (* TO TO BETTER *) - Common_static.add_dependency_site_rule - parameters error - agent_type - site_type - rule_id - wake_up - ) (error, wake_up) list - ) store_potential_side_effects (error, wake_up) + List.fold_left + (fun (error, wake_up) (_, (agent_type, site_type, _)) -> + (* TO TO BETTER *) + Common_static.add_dependency_site_rule parameters error agent_type + site_type rule_id wake_up) + (error, wake_up) list) + store_potential_side_effects (error, wake_up) in error, wake_up @@ -793,8 +730,7 @@ struct let parameters = get_parameter global_static in let handler_bdu = get_mvbdu_handler dynamic in let error, handler_bdu, bdu_false = - Ckappa_sig.Views_bdu.mvbdu_false - parameters handler_bdu error + Ckappa_sig.Views_bdu.mvbdu_false parameters handler_bdu error in error, set_mvbdu_handler handler_bdu dynamic, bdu_false @@ -810,15 +746,11 @@ struct let views = species.Cckappa_sig.e_init_c_mixture.Cckappa_sig.views in let init = true in let error, store_views_init = - Common_static.collect_views_pattern_aux - ~init - parameters kappa_handler error - views - Ckappa_sig.Agent_id_map_and_set.Map.empty + Common_static.collect_views_pattern_aux ~init parameters kappa_handler + error views Ckappa_sig.Agent_id_map_and_set.Map.empty in let error, store_bonds_init = - Common_static.collect_bonds_pattern parameters error - views + Common_static.collect_bonds_pattern parameters error views species.Cckappa_sig.e_init_c_mixture.Cckappa_sig.bonds Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty in @@ -829,18 +761,12 @@ struct let error, dynamic, bdu_false = get_mvbdu_false static dynamic error in let handler = get_mvbdu_handler dynamic in let error, tuple_init = - Site_across_bonds_domain_static.build_potential_tuple_pair_set - parameters error kappa_handler - store_bonds_init - store_views_init + Site_across_bonds_domain_static.build_potential_tuple_pair_set parameters + error kappa_handler store_bonds_init store_views_init in let error, handler, store_result = Site_across_bonds_domain_static.collect_potential_tuple_pair_init - parameters - error bdu_false - handler kappa_handler - tuple_init - store_result + parameters error bdu_false handler kappa_handler tuple_init store_result in let dynamic = set_mvbdu_handler handler dynamic in let dynamic = set_value store_result dynamic in @@ -851,33 +777,32 @@ struct the constraints in the lhs are consistent *) (* For each bond in the lhs of the rule rule_id *) (* For each tuple (x,y) of interest that gives information about this kind of - bonds *) + bonds *) (* Fetch the state of the two other sites in the lhs and in the precondition - if they are not available (take the meet)*) + if they are not available (take the meet)*) (* Check that there exists at least one such pair of state in the image of - the pair (x,y) in dynamic *) + the pair (x,y) in dynamic *) (***************************************************************************) (*IS ENABLED *) (***************************************************************************) let build_mvbdu_range_list parameters error dynamic tuple mvbdu_value = - let ((_, _, _, _, pair_of_state2), - (_, _, _, _, pair_of_state2')) = tuple - in + let (_, _, _, _, pair_of_state2), (_, _, _, _, pair_of_state2') = tuple in let pair_list = - [Ckappa_sig.fst_site, pair_of_state2; - Ckappa_sig.snd_site, pair_of_state2'] + [ + Ckappa_sig.fst_site, pair_of_state2; + Ckappa_sig.snd_site, pair_of_state2'; + ] in let handler = get_mvbdu_handler dynamic in let error, handler, mvbdu = - Ckappa_sig.Views_bdu.mvbdu_of_range_list - parameters handler error pair_list + Ckappa_sig.Views_bdu.mvbdu_of_range_list parameters handler error + pair_list in (*intersection*) let error, handler, new_mvbdu = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error mvbdu mvbdu_value + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error mvbdu mvbdu_value in let dynamic = set_mvbdu_handler handler dynamic in error, dynamic, new_mvbdu @@ -887,22 +812,17 @@ struct match list with | [] -> error, true, dynamic | tuple :: tail -> - let proj (b,c,d,e,_) = (b,c,d,e) in + let proj (b, c, d, e, _) = b, c, d, e in let proj2 (x, y) = proj x, proj y in let tuple' = proj2 tuple in let error, mvbdu_value = - Site_across_bonds_domain_type.get_mvbdu_from_tuple_pair - parameters error - tuple' - bdu_false - store_value + Site_across_bonds_domain_type.get_mvbdu_from_tuple_pair parameters + error tuple' bdu_false store_value in let error, dynamic, new_mvbdu = - build_mvbdu_range_list parameters error dynamic - tuple mvbdu_value + build_mvbdu_range_list parameters error dynamic tuple mvbdu_value in - if Ckappa_sig.Views_bdu.equal new_mvbdu bdu_false - then + if Ckappa_sig.Views_bdu.equal new_mvbdu bdu_false then error, false, dynamic else scan tail dynamic error @@ -912,23 +832,20 @@ struct let whether_or_not_it_has_precondition parameters error bdu_false tuple_set dynamic precondition = let list = - Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.elements tuple_set + Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set + .elements tuple_set in let store_value = get_value dynamic in (*check if this pattern belong to the set of the patterns in the result*) let error, bool, dynamic = - common_scan - parameters error - bdu_false - dynamic - store_value - list + common_scan parameters error bdu_false dynamic store_value list in - if bool - then error, dynamic, Some precondition - else error, dynamic, None + if bool then + error, dynamic, Some precondition + else + error, dynamic, None - let is_enabled static dynamic error (rule_id:Ckappa_sig.c_rule_id) + let is_enabled static dynamic error (rule_id : Ckappa_sig.c_rule_id) precondition = let parameters = get_parameter static in let error, dynamic, bdu_false = get_mvbdu_false static dynamic error in @@ -936,16 +853,12 @@ struct not *) let store_potential_tuple_pair_lhs = get_potential_tuple_pair_lhs static in let error, tuple_set = - Common_map.get_rule_id_map_and_set - parameters error - rule_id - Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.empty - store_potential_tuple_pair_lhs + Common_map.get_rule_id_map_and_set parameters error rule_id + Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set + .empty store_potential_tuple_pair_lhs in - whether_or_not_it_has_precondition parameters error bdu_false - tuple_set - dynamic - precondition + whether_or_not_it_has_precondition parameters error bdu_false tuple_set + dynamic precondition (***************************************************************************) (*MAY BE REACHABLE*) @@ -953,122 +866,99 @@ struct (* the flag can be safely ignored for this abstract domain *) - let maybe_reachable static dynamic error _flag (pattern:Cckappa_sig.mixture) + let maybe_reachable static dynamic error _flag (pattern : Cckappa_sig.mixture) precondition = let parameters = get_parameter static in let kappa_handler = get_kappa_handler static in - let error, dynamic, bdu_false = - get_mvbdu_false static dynamic error in + let error, dynamic, bdu_false = get_mvbdu_false static dynamic error in let error, bonds_lhs = - Common_static.collect_bonds_pattern - parameters - error - pattern.Cckappa_sig.views - pattern.Cckappa_sig.bonds + Common_static.collect_bonds_pattern parameters error + pattern.Cckappa_sig.views pattern.Cckappa_sig.bonds Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty in let error, views_lhs = - Common_static.collect_views_pattern_aux - parameters kappa_handler error - pattern.Cckappa_sig.views - Ckappa_sig.Agent_id_map_and_set.Map.empty + Common_static.collect_views_pattern_aux parameters kappa_handler error + pattern.Cckappa_sig.views Ckappa_sig.Agent_id_map_and_set.Map.empty in let error, tuple_set = - Site_across_bonds_domain_static.build_potential_tuple_pair_set - parameters error kappa_handler - bonds_lhs views_lhs + Site_across_bonds_domain_static.build_potential_tuple_pair_set parameters + error kappa_handler bonds_lhs views_lhs in let store_potential_tuple_pair = get_potential_tuple_pair static in let tuple_set = Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.filter - (fun ((a,b,c,d,_),(a',b',c',d',_)) -> - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.mem ((a,b,c,d),(a',b',c',d')) - store_potential_tuple_pair) + (fun ((a, b, c, d, _), (a', b', c', d', _)) -> + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.mem + ((a, b, c, d), (a', b', c', d')) + store_potential_tuple_pair) tuple_set in - whether_or_not_it_has_precondition parameters error bdu_false - tuple_set - dynamic - precondition + whether_or_not_it_has_precondition parameters error bdu_false tuple_set + dynamic precondition (****************************************************************) let context rule_id agent_id site_type = - " rule "^(Ckappa_sig.string_of_rule_id rule_id)^ - " agent_id "^(Ckappa_sig.string_of_agent_id agent_id)^ - " site_type "^(Ckappa_sig.string_of_site_name site_type) + " rule " + ^ Ckappa_sig.string_of_rule_id rule_id + ^ " agent_id " + ^ Ckappa_sig.string_of_agent_id agent_id + ^ " site_type " + ^ Ckappa_sig.string_of_site_name site_type (***************************************************************************) (*APPLY RULE*) (***************************************************************************) - let check_association_list - parameters error bdu_false - pair - check - dynamic - = + let check_association_list parameters error bdu_false pair check dynamic = let store_result = get_value dynamic in let handler = get_mvbdu_handler dynamic in let error, handler, mvbdu = - Ckappa_sig.Views_bdu.mvbdu_of_association_list - parameters handler error check + Ckappa_sig.Views_bdu.mvbdu_of_association_list parameters handler error + check in let error, handler, bool = - Site_across_bonds_domain_type.check - parameters error bdu_false handler - pair - mvbdu - store_result + Site_across_bonds_domain_type.check parameters error bdu_false handler + pair mvbdu store_result in let dynamic = set_mvbdu_handler handler dynamic in error, dynamic, bool -(*there is an action binding in the domain of a rule*) - + (*there is an action binding in the domain of a rule*) - - let build_mvbdu_association_list parameters error bdu_false - kappa_handler dump_title bool modified_sites pair pair_list dynamic = + let build_mvbdu_association_list parameters error bdu_false kappa_handler + dump_title bool modified_sites pair pair_list dynamic = let store_result = get_value dynamic in let handler = get_mvbdu_handler dynamic in let error, handler, mvbdu = - Ckappa_sig.Views_bdu.mvbdu_of_association_list - parameters handler error pair_list + Ckappa_sig.Views_bdu.mvbdu_of_association_list parameters handler error + pair_list in let error, bool, handler, modified_sites, store_result = - Site_across_bonds_domain_type.add_link_and_check - parameters error bdu_false handler - kappa_handler - bool - dump_title - pair - mvbdu - modified_sites - store_result + Site_across_bonds_domain_type.add_link_and_check parameters error + bdu_false handler kappa_handler bool dump_title pair mvbdu + modified_sites store_result in let dynamic = set_value store_result dynamic in let dynamic = set_mvbdu_handler handler dynamic in error, bool, dynamic, modified_sites - let apply_rule_created_bonds static dynamic error bool dump_title rule_id - rule precondition modified_sites = - let parameters = get_parameter static in + let apply_rule_created_bonds static dynamic error bool dump_title rule_id rule + precondition modified_sites = + let parameters = get_parameter static in let kappa_handler = get_kappa_handler static in let error, dynamic, bdu_false = get_mvbdu_false static dynamic error in (*------------------------------------------------------*) (*let store_created_bonds = get_created_bonds static in*) let store_created_bonds = get_action_binding static in let error, created_bonds_set = - Common_map.get_rule_id_map_and_set parameters error - rule_id - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty - store_created_bonds + Common_map.get_rule_id_map_and_set parameters error rule_id + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty store_created_bonds in let error, created_bonds_set = Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold - (fun (t,u) (error,modified_sites) -> - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in - parameters error (u,t) modified_sites) + (fun (t, u) (error, modified_sites) -> + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.add_when_not_in + parameters error (u, t) modified_sites) created_bonds_set (error, created_bonds_set) in let store_partition_created_bonds_map = @@ -1078,140 +968,117 @@ struct let error, bool, dynamic, precondition, modified_sites = Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold (fun (t, u) (error, bool, dynamic, precondition, modified_sites) -> - let (agent_id_t, agent_type_t, site_type_t, state_t) = t in - let (agent_id_u, agent_type_u, site_type_u, state_u) = u in - let error, potential_tuple_pair_set = - match - Site_across_bonds_domain_type.PairAgentSiteState_map_and_set.Map.find_option_without_logs - parameters error - ((agent_type_t, site_type_t, state_t), - (agent_type_u, site_type_u, state_u)) - store_partition_created_bonds_map - with - | error, None -> - error, - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.empty - | error, Some s -> error, s - in - (*-----------------------------------------------------------*) - (*project the second site*) (*MOVE this function in static*) - let proj (_, _, d, _) = d in - let proj2 (x, y) = proj x, proj y in - let error, proj_potential_tuple_pair_set = - Site_across_bonds_domain_type.Proj_potential_tuple_pair_set.proj_set - proj2 - parameters - error - potential_tuple_pair_set - in - (*-----------------------------------------------------------*) - Site_across_bonds_domain_type.PairSite_map_and_set.Set.fold - (fun (site_type'_x, site_type'_y) - (error, bool, dynamic, precondition, modified_sites) -> - let error', dynamic, precondition, state'_list_x = - Communication.get_state_of_site_in_postcondition - get_global_static_information - get_global_dynamic_information - set_global_dynamic_information - error static dynamic - (rule_id, rule) - agent_id_t - site_type'_x - precondition - in - let error = - Exception.check_point - Exception.warn - parameters error error' - ~message:(context rule_id agent_id_t site_type'_x) - __POS__ Exit - in - let error', dynamic, precondition, state'_list_y = - Communication.get_state_of_site_in_postcondition - get_global_static_information - get_global_dynamic_information - set_global_dynamic_information - error static dynamic - (rule_id, rule) - agent_id_u - site_type'_y - precondition - in - let error = - Exception.check_point - Exception.warn - parameters error error' - ~message:(context rule_id agent_id_u site_type'_y) - __POS__ Exit - in - (*-----------------------------------------------------------*) - let error, bool, dynamic, precondition, modified_sites = - match state'_list_x, state'_list_y with - (* _::_::_, _::_::_ -> - (*we know for sure that none of the two sites have been - modified*) - error, bool, dynamic, precondition, modified_sites*) - | [], _ | _, [] -> - let error, () = - Exception.warn parameters error __POS__ - ~message: "empty list in potential states in post condition" Exit () - in - error, bool, dynamic, precondition, modified_sites - | _::_ , _::_ -> (*general case*) - List.fold_left - (fun + let agent_id_t, agent_type_t, site_type_t, state_t = t in + let agent_id_u, agent_type_u, site_type_u, state_u = u in + let error, potential_tuple_pair_set = + match + Site_across_bonds_domain_type.PairAgentSiteState_map_and_set.Map + .find_option_without_logs parameters error + ( (agent_type_t, site_type_t, state_t), + (agent_type_u, site_type_u, state_u) ) + store_partition_created_bonds_map + with + | error, None -> + ( error, + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set + .Set + .empty ) + | error, Some s -> error, s + in + (*-----------------------------------------------------------*) + (*project the second site*) + (*MOVE this function in static*) + let proj (_, _, d, _) = d in + let proj2 (x, y) = proj x, proj y in + let error, proj_potential_tuple_pair_set = + Site_across_bonds_domain_type.Proj_potential_tuple_pair_set.proj_set + proj2 parameters error potential_tuple_pair_set + in + (*-----------------------------------------------------------*) + Site_across_bonds_domain_type.PairSite_map_and_set.Set.fold + (fun (site_type'_x, site_type'_y) + (error, bool, dynamic, precondition, modified_sites) -> + let error', dynamic, precondition, state'_list_x = + Communication.get_state_of_site_in_postcondition + get_global_static_information get_global_dynamic_information + set_global_dynamic_information error static dynamic + (rule_id, rule) agent_id_t site_type'_x precondition + in + let error = + Exception.check_point Exception.warn parameters error error' + ~message:(context rule_id agent_id_t site_type'_x) + __POS__ Exit + in + let error', dynamic, precondition, state'_list_y = + Communication.get_state_of_site_in_postcondition + get_global_static_information get_global_dynamic_information + set_global_dynamic_information error static dynamic + (rule_id, rule) agent_id_u site_type'_y precondition + in + let error = + Exception.check_point Exception.warn parameters error error' + ~message:(context rule_id agent_id_u site_type'_y) + __POS__ Exit + in + (*-----------------------------------------------------------*) + let error, bool, dynamic, precondition, modified_sites = + match state'_list_x, state'_list_y with + (* _::_::_, _::_::_ -> + (*we know for sure that none of the two sites have been + modified*) + error, bool, dynamic, precondition, modified_sites*) + | [], _ | _, [] -> + let error, () = + Exception.warn parameters error __POS__ + ~message: + "empty list in potential states in post condition" Exit + () + in + error, bool, dynamic, precondition, modified_sites + | _ :: _, _ :: _ -> + (*general case*) + List.fold_left + (fun (error, bool, dynamic, precondition, modified_sites) + state'_x -> + List.fold_left + (fun (error, bool, dynamic, precondition, modified_sites) + state'_y -> + let pair_list = + [ + Ckappa_sig.fst_site, state'_x; + Ckappa_sig.snd_site, state'_y; + ] + in + let pair = + ( (agent_type_t, site_type_t, site_type'_x, state_t), + (agent_type_u, site_type_u, site_type'_y, state_u) + ) + in + let error, bool, dynamic, modified_sites = + build_mvbdu_association_list parameters error + bdu_false kappa_handler dump_title bool + modified_sites pair pair_list dynamic + in + error, bool, dynamic, precondition, modified_sites) (error, bool, dynamic, precondition, modified_sites) - state'_x -> - List.fold_left - (fun - (error, bool, dynamic, precondition, - modified_sites) state'_y -> - let pair_list = - [Ckappa_sig.fst_site, state'_x; - Ckappa_sig.snd_site, state'_y] - in - let pair = - (agent_type_t, site_type_t, site_type'_x, - state_t), - (agent_type_u, site_type_u, site_type'_y, - state_u) - in - let error, bool, dynamic, modified_sites = - build_mvbdu_association_list - parameters error - bdu_false - kappa_handler - dump_title - bool - modified_sites - pair - pair_list - dynamic - in - error, bool, dynamic, precondition, modified_sites - ) - (error, bool, dynamic, precondition, modified_sites) - state'_list_y - ) (error, bool, dynamic, precondition, modified_sites) - state'_list_x - in - error, bool, dynamic, precondition, modified_sites - ) proj_potential_tuple_pair_set - (error, bool, dynamic, precondition, modified_sites) - ) created_bonds_set - (error, bool, dynamic, precondition,modified_sites) + state'_list_y) + (error, bool, dynamic, precondition, modified_sites) + state'_list_x + in + error, bool, dynamic, precondition, modified_sites) + proj_potential_tuple_pair_set + (error, bool, dynamic, precondition, modified_sites)) + created_bonds_set + (error, bool, dynamic, precondition, modified_sites) in error, bool, dynamic, precondition, modified_sites (*a site is modified (explicitly)*) - let get_state_of_site_in_pre_post_condition_2 - error - static dynamic - agent_id_t - (site_type_x, agent_type_y, site_type_y) - site_type'_y - defined_in precondition = (*CHECK ME*) + let get_state_of_site_in_pre_post_condition_2 error static dynamic agent_id_t + (site_type_x, agent_type_y, site_type_y) site_type'_y defined_in + precondition = + (*CHECK ME*) let step = { Communication.site_out = site_type_x; @@ -1221,18 +1088,17 @@ struct in let path = { - Communication.defined_in = defined_in; + Communication.defined_in; path = { Communication.agent_id = agent_id_t; - Communication.relative_address = [step]; - Communication.site = site_type'_y} + Communication.relative_address = [ step ]; + Communication.site = site_type'_y; + }; } in let error, global_dynamic, precondition, state_list_lattice = - Communication.get_state_of_site - error - precondition + Communication.get_state_of_site error precondition (get_global_static_information static) (get_global_dynamic_information dynamic) path @@ -1244,41 +1110,33 @@ struct | Usual_domains.Any -> let parameter = get_parameter static in let error, () = - if Remanent_parameters.get_view_analysis parameter - then - Exception.warn - (get_parameter static) error __POS__ Exit () + if Remanent_parameters.get_view_analysis parameter then + Exception.warn (get_parameter static) error __POS__ Exit () else error, () in let kappa_handler = get_kappa_handler static in - Handler.state_list - parameter kappa_handler error agent_type_y site_type_y + Handler.state_list parameter kappa_handler error agent_type_y + site_type_y in let dynamic = set_global_dynamic_information global_dynamic dynamic in error, dynamic, precondition, state_list - - - let get_state_of_site_in_precondition_2 - error static dynamic rule - agent_id agent_type site - precondition = - + let get_state_of_site_in_precondition_2 error static dynamic rule agent_id + agent_type site precondition = let path = { Communication.defined_in = Communication.LHS rule; path = { - Communication.agent_id = agent_id; + Communication.agent_id; Communication.relative_address = []; - Communication.site = site} + Communication.site; + }; } in let error, global_dynamic, precondition, state_list_lattice = - Communication.get_state_of_site - error - precondition + Communication.get_state_of_site error precondition (get_global_static_information static) (get_global_dynamic_information dynamic) path @@ -1290,35 +1148,23 @@ struct | Usual_domains.Any -> let parameter = get_parameter static in let error, () = - if Remanent_parameters.get_view_analysis parameter - then - Exception.warn - (get_parameter static) error __POS__ Exit () + if Remanent_parameters.get_view_analysis parameter then + Exception.warn (get_parameter static) error __POS__ Exit () else error, () in let kappa_handler = get_kappa_handler static in - Handler.state_list - parameter kappa_handler error agent_type site + Handler.state_list parameter kappa_handler error agent_type site in let dynamic = set_global_dynamic_information global_dynamic dynamic in error, dynamic, precondition, state_list - - - let get_state_of_site_in_postcondition_2 - error static dynamic rule agent_id - (site_type_x, agent_type_y, site_type_y) site_type'_y - precondition = + let get_state_of_site_in_postcondition_2 error static dynamic rule agent_id + (site_type_x, agent_type_y, site_type_y) site_type'_y precondition = let defined_in = Communication.RHS rule in - get_state_of_site_in_pre_post_condition_2 - error static dynamic - agent_id + get_state_of_site_in_pre_post_condition_2 error static dynamic agent_id (site_type_x, agent_type_y, site_type_y) - site_type'_y - defined_in - precondition - + site_type'_y defined_in precondition type pos = Fst | Snd @@ -1327,268 +1173,234 @@ struct | Fst -> get_partition_modified_map_1 static | Snd -> get_partition_modified_map_2 static - let get_state_of_site_in_postcondition_gen - pos error static dynamic - rule agent_id_mod - (agent_type_x, site_type_x, site_type'_x, _) - (agent_type_y, site_type_y, site_type'_y, _) - precondition - = + let get_state_of_site_in_postcondition_gen pos error static dynamic rule + agent_id_mod (agent_type_x, site_type_x, site_type'_x, _) + (agent_type_y, site_type_y, site_type'_y, _) precondition = match pos with | Fst -> - get_state_of_site_in_postcondition_2 - error static dynamic - rule agent_id_mod - (site_type_x, agent_type_y, site_type_y) site_type'_y - precondition + get_state_of_site_in_postcondition_2 error static dynamic rule + agent_id_mod + (site_type_x, agent_type_y, site_type_y) + site_type'_y precondition | Snd -> - get_state_of_site_in_postcondition_2 - error static dynamic - rule agent_id_mod - (site_type_y, agent_type_x, site_type_x) site_type'_x - precondition - - + get_state_of_site_in_postcondition_2 error static dynamic rule + agent_id_mod + (site_type_y, agent_type_x, site_type_x) + site_type'_x precondition let get_potential_tuple_pair parameters error (agent, site) empty_map map = let error, result = match - Site_across_bonds_domain_type.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - (agent, site) - map + Site_across_bonds_domain_type.AgentSite_map_and_set.Map + .find_option_without_logs parameters error (agent, site) map with | error, None -> error, empty_map | error, Some s -> error, s in error, result - let apply_rule_modified_explicity_gen - ~pos bdu_false parameters error kappa_handler bool dump_title - static dynamic rule_id rule precondition modified_set modified_sites = + let apply_rule_modified_explicity_gen ~pos bdu_false parameters error + kappa_handler bool dump_title static dynamic rule_id rule precondition + modified_set modified_sites = let store_partition_modified_map = get_partition_modified pos static in (*------------------------------------------------------*) Ckappa_sig.AgentsSiteState_map_and_set.Set.fold (fun mod_tuple (error, bool, dynamic, precondition, modified_sites) -> - let (agent_id_mod, agent_type_mod, site_type_mod, state_mod) = - mod_tuple - in - let error, potential_tuple_pair_set = - get_potential_tuple_pair parameters error - (agent_type_mod, site_type_mod) - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.empty - store_partition_modified_map - in - (*-----------------------------------------------------------*) - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.fold - (fun (x, y) (error, bool, dynamic, precondition, modified_sites) -> - let (agent_type_x, site_type_x, site_type'_x, state_x) = x in - let (agent_type_y, site_type_y, site_type'_y, state_y) = y in - let error', dynamic, precondition, state'_list_other = - get_state_of_site_in_postcondition_gen - pos error static dynamic - (rule_id, rule) - agent_id_mod - x - y - precondition - in - let error', (agent_y, site_y) = - Site_across_bonds_domain_type.convert_single_without_state - parameters error' - kappa_handler - (agent_type_y, site_type_y) - in - let error', (agent_x, site_x) = - Site_across_bonds_domain_type.convert_single_without_state - parameters error' - kappa_handler - (agent_type_x, site_type_x) - in - let () = - if error' == error then () - else - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "\nWRONG TUPLE: !!! \n Rule %i agent_id_t: %i%s:%s( site_type_x: %i:%s), agent_type_y:%i:%s: (site_type_y:%i:%s) \n" - (Ckappa_sig.int_of_rule_id rule_id) - (Ckappa_sig.int_of_agent_id agent_id_mod) - (match pos with Fst -> "->" | Snd -> "<-") - agent_x - (Ckappa_sig.int_of_site_name site_type_x) - site_x - (Ckappa_sig.int_of_agent_name agent_type_y) - agent_y - (Ckappa_sig.int_of_site_name site_type_y) - site_y - in - let error = - Exception.check_point - Exception.warn - parameters error error' - ~message:(context rule_id agent_id_mod - (match pos with - | Fst -> site_type'_x - | Snd -> site_type'_x)) - __POS__ Exit - in - let error', dynamic, precondition, state_list_other = - let error, agent = - match - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_id_mod - rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs.Cckappa_sig.views - with - | error, None -> - Exception.warn parameters error __POS__ Exit Cckappa_sig.Ghost - | error, Some a -> error, a - in - match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Dead_agent _ -> - error, dynamic, precondition, [] - | Cckappa_sig.Agent _ -> - get_state_of_site_in_precondition_2 - error static dynamic - (rule_id, rule) - agent_id_mod agent_type_mod site_type_mod - precondition + let agent_id_mod, agent_type_mod, site_type_mod, state_mod = + mod_tuple + in + let error, potential_tuple_pair_set = + get_potential_tuple_pair parameters error + (agent_type_mod, site_type_mod) + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set + .empty store_partition_modified_map + in + (*-----------------------------------------------------------*) + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.fold + (fun (x, y) (error, bool, dynamic, precondition, modified_sites) -> + let agent_type_x, site_type_x, site_type'_x, state_x = x in + let agent_type_y, site_type_y, site_type'_y, state_y = y in + let error', dynamic, precondition, state'_list_other = + get_state_of_site_in_postcondition_gen pos error static dynamic + (rule_id, rule) agent_id_mod x y precondition + in + let error', (agent_y, site_y) = + Site_across_bonds_domain_type.convert_single_without_state + parameters error' kappa_handler + (agent_type_y, site_type_y) + in + let error', (agent_x, site_x) = + Site_across_bonds_domain_type.convert_single_without_state + parameters error' kappa_handler + (agent_type_x, site_type_x) + in + let () = + if error' == error then + () + else + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "\n\ + WRONG TUPLE: !!! \n\ + \ Rule %i agent_id_t: %i%s:%s( site_type_x: %i:%s), \ + agent_type_y:%i:%s: (site_type_y:%i:%s) \n" + (Ckappa_sig.int_of_rule_id rule_id) + (Ckappa_sig.int_of_agent_id agent_id_mod) + (match pos with + | Fst -> "->" + | Snd -> "<-") + agent_x + (Ckappa_sig.int_of_site_name site_type_x) + site_x + (Ckappa_sig.int_of_agent_name agent_type_y) + agent_y + (Ckappa_sig.int_of_site_name site_type_y) + site_y + in + let error = + Exception.check_point Exception.warn parameters error error' + ~message: + (context rule_id agent_id_mod + (match pos with + | Fst -> site_type'_x + | Snd -> site_type'_x)) + __POS__ Exit + in + let error', dynamic, precondition, state_list_other = + let error, agent = + match + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_id_mod + rule.Cckappa_sig.e_rule_c_rule.Cckappa_sig.rule_lhs + .Cckappa_sig.views + with + | error, None -> + Exception.warn parameters error __POS__ Exit Cckappa_sig.Ghost + | error, Some a -> error, a in - let error = - Exception.check_point - Exception.warn - parameters error error' - ~message:(context rule_id agent_id_mod site_type_mod) - __POS__ Exit + match agent with + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Dead_agent _ -> + error, dynamic, precondition, [] + | Cckappa_sig.Agent _ -> + get_state_of_site_in_precondition_2 error static dynamic + (rule_id, rule) agent_id_mod agent_type_mod site_type_mod + precondition + in + let error = + Exception.check_point Exception.warn parameters error error' + ~message:(context rule_id agent_id_mod site_type_mod) + __POS__ Exit + in + (*-----------------------------------------------------------*) + let error, bool, dynamic, precondition, modified_sites = + let not_modified = + match state'_list_other with + | [] | _ :: _ :: _ -> + true + (* we know for sure that the site has not been modified *) + | [ _ ] -> false in - (*-----------------------------------------------------------*) - let error, bool, dynamic, precondition, modified_sites = - let not_modified = - match state'_list_other with - | [] | _::_::_ -> true -(* we know for sure that the site has not been modified *) - - | [_] -> false - in - List.fold_left - (fun (error, bool, dynamic, precondition, modified_sites) - state'_other -> - let pair_list = + List.fold_left + (fun (error, bool, dynamic, precondition, modified_sites) + state'_other -> + let pair_list = + match pos with + | Fst -> + [ + Ckappa_sig.fst_site, state_mod; + Ckappa_sig.snd_site, state'_other; + ] + | Snd -> + [ + Ckappa_sig.fst_site, state'_other; + Ckappa_sig.snd_site, state_mod; + ] + in + let pair = + ( (agent_type_x, site_type_x, site_type'_x, state_x), + (agent_type_y, site_type_y, site_type'_y, state_y) ) + in + let check = + match state_list_other, pos with + | ([] | _ :: _ :: _), _ -> [] + | [ a ], Fst -> [ Ckappa_sig.fst_site, a ] + | [ a ], Snd -> [ Ckappa_sig.snd_site, a ] + in + let check = + if not_modified then ( match pos with | Fst -> - [Ckappa_sig.fst_site, state_mod; - Ckappa_sig.snd_site, state'_other] + (* to do: add info about the other site *) + (* if the bond between site_type_x and site_type_y + has not been created by the rule *) + (* this is the state before the modification *) + (* otherwise, nothing to check *) + (Ckappa_sig.snd_site, state'_other) :: check | Snd -> - [Ckappa_sig.fst_site, state'_other; - Ckappa_sig.snd_site, state_mod] - in - let pair = - (agent_type_x, site_type_x, site_type'_x,state_x), - (agent_type_y, site_type_y, site_type'_y,state_y) - in - let check = - match state_list_other,pos - with - ([] | _::_::_),_ -> [] - | [a],Fst -> - [Ckappa_sig.fst_site, a] - | [a],Snd -> - [Ckappa_sig.snd_site, a] - in - let check = - if not_modified - then - match pos with - | Fst -> - (* to do: add info about the other site *) - (* if the bond between site_type_x and site_type_y - has not been created by the rule *) - (* this is the state before the modification *) - (* otherwise, nothing to check *) - (Ckappa_sig.snd_site, state'_other)::check - | Snd -> - (* to do: add info about the other site *) - (* if the bond between site_type_x and site_type_y - has not been created by the rule *) - (* this is the state before the modification *) - (* this is the state before the modification *) - (Ckappa_sig.fst_site, state'_other)::check - else - check - in - let error, dynamic, unmodified_sites_ok = - check_association_list - parameters error bdu_false - pair - check - dynamic + (* to do: add info about the other site *) + (* if the bond between site_type_x and site_type_y + has not been created by the rule *) + (* this is the state before the modification *) + (* this is the state before the modification *) + (Ckappa_sig.fst_site, state'_other) :: check + ) else + check + in + let error, dynamic, unmodified_sites_ok = + check_association_list parameters error bdu_false pair check + dynamic + in + if unmodified_sites_ok then ( + let error, bool, dynamic, modified_sites = + build_mvbdu_association_list parameters error bdu_false + kappa_handler dump_title bool modified_sites pair + pair_list dynamic in - if unmodified_sites_ok - then - let error, bool, dynamic, modified_sites = - build_mvbdu_association_list - parameters error bdu_false - kappa_handler dump_title - bool - modified_sites - pair - pair_list - dynamic - in - error, bool, dynamic, precondition, modified_sites - else - error, bool, dynamic, precondition, modified_sites - ) - (error, bool, dynamic, precondition, modified_sites) - state'_list_other - in - error, bool, dynamic, precondition, modified_sites - ) - potential_tuple_pair_set - (error, bool, dynamic, precondition, modified_sites) - ) modified_set (error, bool, dynamic, precondition, modified_sites) + error, bool, dynamic, precondition, modified_sites + ) else + error, bool, dynamic, precondition, modified_sites) + (error, bool, dynamic, precondition, modified_sites) + state'_list_other + in + error, bool, dynamic, precondition, modified_sites) + potential_tuple_pair_set + (error, bool, dynamic, precondition, modified_sites)) + modified_set + (error, bool, dynamic, precondition, modified_sites) let apply_rule_modified_explicity static dynamic error bool dump_title rule_id rule precondition modified_sites = - let parameters = get_parameter static in + let parameters = get_parameter static in let kappa_handler = get_kappa_handler static in let error, dynamic, bdu_false = get_mvbdu_false static dynamic error in let store_modified_map = get_modified_map static in let error, modified_set = - Common_map.get_rule_id_map_and_set parameters - error - rule_id - Ckappa_sig.AgentsSiteState_map_and_set.Set.empty - store_modified_map + Common_map.get_rule_id_map_and_set parameters error rule_id + Ckappa_sig.AgentsSiteState_map_and_set.Set.empty store_modified_map in (*---------------------------------------------------------------*) let error, bool, dynamic, precondition, modified_sites = - apply_rule_modified_explicity_gen - ~pos:Fst bdu_false parameters error kappa_handler - bool dump_title static dynamic - rule_id rule precondition modified_set modified_sites + apply_rule_modified_explicity_gen ~pos:Fst bdu_false parameters error + kappa_handler bool dump_title static dynamic rule_id rule precondition + modified_set modified_sites in let error, bool, dynamic, precondition, modified_sites = - apply_rule_modified_explicity_gen - ~pos:Snd bdu_false parameters error kappa_handler bool dump_title - static dynamic - rule_id rule precondition modified_set modified_sites + apply_rule_modified_explicity_gen ~pos:Snd bdu_false parameters error + kappa_handler bool dump_title static dynamic rule_id rule precondition + modified_set modified_sites in error, bool, dynamic, precondition, modified_sites (*Apply rule in the case of side effects*) - let free_site_gen ~pos static dynamic error bool dump_title - agent' site_name' state' modified_sites = - let parameters = get_parameter static in + let free_site_gen ~pos static dynamic error bool dump_title agent' site_name' + state' modified_sites = + let parameters = get_parameter static in let kappa_handler = get_kappa_handler static in let store_partition_modified_map = get_partition_modified pos static in let error, potential_tuple_pair_set = - get_potential_tuple_pair - parameters error - (agent', site_name') + get_potential_tuple_pair parameters error (agent', site_name') Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.empty store_partition_modified_map in @@ -1596,104 +1408,84 @@ struct (*-----------------------------------------------------------*) Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.fold (fun (x, y) (error, bool, dynamic, modified_sites) -> - let handler = get_mvbdu_handler dynamic in - let result = get_value dynamic in - let error, mvbdu_opt = - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map.find_option_without_logs - parameters error - (x,y) - result - in - match mvbdu_opt with - | None -> error, bool, dynamic, modified_sites - | Some mvbdu -> - let var = - match pos with - | Fst -> Ckappa_sig.fst_site - | Snd -> Ckappa_sig.snd_site - in - let error, handler, cap = - Ckappa_sig.Views_bdu.mvbdu_of_association_list - parameters handler error - [var,state'] - in - let error, handler, redefine = - Ckappa_sig.Views_bdu.build_association_list - parameters handler error - [var, Ckappa_sig.dummy_state_index] - in - let error, handler, mvbdu_cap = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error - mvbdu - cap - in - let error, handler, mvbdu' = - Ckappa_sig.Views_bdu.mvbdu_redefine - parameters handler error - mvbdu_cap - redefine - in - (*check the freshness of the value *) - let error, bool, handler, modified_sites, result = - Site_across_bonds_domain_type.add_link_and_check - parameters error - bdu_false - handler - kappa_handler - bool - dump_title - (x,y) - mvbdu' - modified_sites - result - in - let dynamic = set_mvbdu_handler handler dynamic in - let dynamic = set_value result dynamic in - error, bool, dynamic, modified_sites - ) potential_tuple_pair_set (error, bool, dynamic, modified_sites) + let handler = get_mvbdu_handler dynamic in + let result = get_value dynamic in + let error, mvbdu_opt = + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map + .find_option_without_logs parameters error (x, y) result + in + match mvbdu_opt with + | None -> error, bool, dynamic, modified_sites + | Some mvbdu -> + let var = + match pos with + | Fst -> Ckappa_sig.fst_site + | Snd -> Ckappa_sig.snd_site + in + let error, handler, cap = + Ckappa_sig.Views_bdu.mvbdu_of_association_list parameters handler + error + [ var, state' ] + in + let error, handler, redefine = + Ckappa_sig.Views_bdu.build_association_list parameters handler error + [ var, Ckappa_sig.dummy_state_index ] + in + let error, handler, mvbdu_cap = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error mvbdu cap + in + let error, handler, mvbdu' = + Ckappa_sig.Views_bdu.mvbdu_redefine parameters handler error + mvbdu_cap redefine + in + (*check the freshness of the value *) + let error, bool, handler, modified_sites, result = + Site_across_bonds_domain_type.add_link_and_check parameters error + bdu_false handler kappa_handler bool dump_title (x, y) mvbdu' + modified_sites result + in + let dynamic = set_mvbdu_handler handler dynamic in + let dynamic = set_value result dynamic in + error, bool, dynamic, modified_sites) + potential_tuple_pair_set + (error, bool, dynamic, modified_sites) let free_site static dynamic error bool dump_title agent' site_name' state' modified_sites = let error, bool, dynamic, modified_sites = - free_site_gen - ~pos:Fst static dynamic error bool dump_title - agent' site_name' state' modified_sites + free_site_gen ~pos:Fst static dynamic error bool dump_title agent' + site_name' state' modified_sites in - free_site_gen - ~pos:Snd static dynamic error bool dump_title - agent' site_name' state' modified_sites + free_site_gen ~pos:Snd static dynamic error bool dump_title agent' + site_name' state' modified_sites let apply_rule static dynamic error rule_id precondition = - let parameters = get_parameter static in + let parameters = get_parameter static in let event_list = [] in (*-----------------------------------------------------------*) let error, rule = get_rule parameters error static rule_id in match rule with | None -> - let error, () = - Exception.warn parameters error __POS__ Exit () - in + let error, () = Exception.warn parameters error __POS__ Exit () in error, dynamic, (precondition, []) | Some rule -> (*------------------------------------------------------*) (*1.a bonds on the rhs: not sure you need this test, it will be covered by 1.c and 1.d *) (*------------------------------------------------------*) - (* let error, dynamic, precondition = - apply_rule_bonds_rhs - static dynamic error rule_id rule precondition - in*) + (* let error, dynamic, precondition = + apply_rule_bonds_rhs + static dynamic error rule_id rule precondition + in*) (*------------------------------------------------------*) (*1.b created bonds *) (*------------------------------------------------------*) - let parameters = - Remanent_parameters.update_prefix parameters "\t\t" - in + let parameters = Remanent_parameters.update_prefix parameters "\t\t" in let dump_title () = - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff parameters + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) @@ -1701,7 +1493,7 @@ struct (Remanent_parameters.get_prefix parameters) in Loggers.print_newline (Remanent_parameters.get_logger parameters) - else + ) else () in let error, modified_sites = @@ -1711,9 +1503,8 @@ struct let error, bool, dynamic, precondition, event_list, modified_sites = (* deal with create a binding sites *) let error, bool, dynamic, precondition, modified_sites = - apply_rule_created_bonds - static dynamic error false dump_title rule_id rule precondition - modified_sites + apply_rule_created_bonds static dynamic error false dump_title rule_id + rule precondition modified_sites in (*-----------------------------------------------------------*) (*new event*) @@ -1722,48 +1513,48 @@ struct (*-----------------------------------------------------------*) (*1.c a site is modified (explicitly) *) let error, bool, dynamic, precondition, modified_sites = - apply_rule_modified_explicity - static dynamic error bool dump_title rule_id rule precondition - modified_sites + apply_rule_modified_explicity static dynamic error bool dump_title + rule_id rule precondition modified_sites in (*-----------------------------------------------------------*) (*new event*) (*-----------------------------------------------------------*) (*1.d a site is modified by side effect *) let () = - if bool && - (local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters) - then - let () = Loggers.print_newline - (Remanent_parameters.get_logger parameters) in + if + bool + && (local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff + parameters) + then ( + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) in let error, event_list = - Communication.fold_sites - parameters error + Communication.fold_sites parameters error (fun _ error s _ event_list -> - error, (Communication.Modified_sites s) :: event_list) - modified_sites - event_list + error, Communication.Modified_sites s :: event_list) + modified_sites event_list in (*-----------------------------------------------------------*) error, dynamic, (precondition, event_list) -(***************************************************************************) -(* events enable communication between domains. At this moment, the - global domain does not collect information *) -(***************************************************************************) + (***************************************************************************) + (* events enable communication between domains. At this moment, the + global domain does not collect information *) + (***************************************************************************) - let apply_one_side_effect - static dynamic error - _ (_,(agent_name, site, state)) precondition - = + let apply_one_side_effect static dynamic error _ + (_, (agent_name, site, state)) precondition = let parameters = get_parameter static in let dump_title () = - if local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff parameters + then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) @@ -1771,53 +1562,49 @@ struct (Remanent_parameters.get_prefix parameters) in Loggers.print_newline (Remanent_parameters.get_logger parameters) - else + ) else () in let error, modified_sites = Communication.init_sites_working_list parameters error in let error, bool, dynamic, modified_sites = - free_site - static dynamic error false dump_title agent_name site state + free_site static dynamic error false dump_title agent_name site state modified_sites in let error, event_list = - Communication.fold_sites - parameters error + Communication.fold_sites parameters error (fun _ error s _ event_list -> - error, (Communication.Modified_sites s) :: event_list) - modified_sites - [] + error, Communication.Modified_sites s :: event_list) + modified_sites [] in let () = - if bool && - (local_trace || - Remanent_parameters.get_dump_reachability_analysis_diff parameters) - then - let () = Loggers.print_newline - (Remanent_parameters.get_logger parameters) in + if + bool + && (local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff parameters + ) + then ( + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) in - error, dynamic, (precondition,event_list) + error, dynamic, (precondition, event_list) (****************************************************************) (*APPLY A LIST OF EVENT*) - (****************************************************************) - - let apply_event_list _static dynamic error _event_list = - error, dynamic, [] + (****************************************************************) - let stabilize _static dynamic error = - error, dynamic, () + let apply_event_list _static dynamic error _event_list = error, dynamic, [] + let stabilize _static dynamic error = error, dynamic, () (****************************************************************) (*EXPORT*) (****************************************************************) - let export_aux - ?final_result:(final_result = false) - static dynamic error kasa_state = + let export_aux ?(final_result = false) static dynamic error kasa_state = let parameters = get_parameter static in let kappa_handler = get_kappa_handler static in let handler = get_mvbdu_handler dynamic in @@ -1826,121 +1613,103 @@ struct let error, (handler, current_list) = Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map.fold (fun tuple mvbdu (error, (handler, current_list)) -> - let (agent_type1, site_type1, site_type1', _), - (agent_type2, site_type2, site_type2', _) = tuple - in - let error, (agent1, site1, site1',_, agent2, site2, site2', _) = - Site_across_bonds_domain_type.convert_tuple parameters error - kappa_handler tuple - in - (*this test remove the relation: B.A*) - if compare (agent1,site1,site1') (agent2,site2,site2') > 0 - then error, (handler, current_list) - else - (*this test remove the relation when their states are not the - same: for instance: A(x~p), B(x~u)*) - let error, handler, non_relational = - if final_result - then - (*at the final result needs to check the non_relational - condition*) - Translation_in_natural_language.non_relational - parameters handler error mvbdu - else - (*other cases will by pass this test*) - error, handler, false - in - if non_relational - then error, (handler, current_list) - else - (*----------------------------------------------------*) - let error, handler, pair_list = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters handler error mvbdu - in - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - let pattern = Site_graphs.KaSa_site_graph.empty in - let error, agent_id1, pattern = - Site_graphs.KaSa_site_graph.add_agent - parameters - error - kappa_handler - agent_type1 - pattern - in - let error, agent_id2, pattern = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler - agent_type2 - pattern - in - let error, pattern = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler - agent_id1 - site_type1 - agent_id2 - site_type2 - pattern - in - (*---------------------------------------------------*) - (*internal constraint list*) - let error, refine = - Ckappa_site_graph.internal_pair_list_to_list - parameters error kappa_handler - pattern - agent_id1 - site_type1' - agent_id2 - site_type2' - pair_list - in - let lemma_internal = - { - Public_data.hyp = pattern; - Public_data.refinement = refine; - } - in - let current_list = lemma_internal :: current_list in - (*---------------------------------------------------*) - error, (handler, current_list) - | Remanent_parameters_sig.Natural_language -> - error, (handler, current_list) - ) store_value (error, (handler, [])) + let ( (agent_type1, site_type1, site_type1', _), + (agent_type2, site_type2, site_type2', _) ) = + tuple + in + let error, (agent1, site1, site1', _, agent2, site2, site2', _) = + Site_across_bonds_domain_type.convert_tuple parameters error + kappa_handler tuple + in + (*this test remove the relation: B.A*) + if compare (agent1, site1, site1') (agent2, site2, site2') > 0 then + error, (handler, current_list) + else ( + (*this test remove the relation when their states are not the + same: for instance: A(x~p), B(x~u)*) + let error, handler, non_relational = + if final_result then + (*at the final result needs to check the non_relational + condition*) + Translation_in_natural_language.non_relational parameters + handler error mvbdu + else + (*other cases will by pass this test*) + error, handler, false + in + if non_relational then + error, (handler, current_list) + else ( + (*----------------------------------------------------*) + let error, handler, pair_list = + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler + error mvbdu + in + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let pattern = Site_graphs.KaSa_site_graph.empty in + let error, agent_id1, pattern = + Site_graphs.KaSa_site_graph.add_agent parameters error + kappa_handler agent_type1 pattern + in + let error, agent_id2, pattern = + Site_graphs.KaSa_site_graph.add_agent parameters error + kappa_handler agent_type2 pattern + in + let error, pattern = + Site_graphs.KaSa_site_graph.add_bond parameters error + kappa_handler agent_id1 site_type1 agent_id2 site_type2 + pattern + in + (*---------------------------------------------------*) + (*internal constraint list*) + let error, refine = + Ckappa_site_graph.internal_pair_list_to_list parameters error + kappa_handler pattern agent_id1 site_type1' agent_id2 + site_type2' pair_list + in + let lemma_internal = + { Public_data.hyp = pattern; Public_data.refinement = refine } + in + let current_list = lemma_internal :: current_list in + (*---------------------------------------------------*) + error, (handler, current_list) + | Remanent_parameters_sig.Natural_language -> + error, (handler, current_list) + ) + )) + store_value + (error, (handler, [])) in (*------------------------------------------------------------------*) let dynamic = set_mvbdu_handler handler dynamic in (*------------------------------------------------------------------*) (*internal constraint list*) let internal_constraints_list = - Remanent_state.get_internal_constraints_list - kasa_state + Remanent_state.get_internal_constraints_list kasa_state in let error, internal_constraints_list = - match - internal_constraints_list - with - | None -> - Exception.warn parameters error __POS__ Exit [] + match internal_constraints_list with + | None -> Exception.warn parameters error __POS__ Exit [] | Some l -> error, l in let pair_list = - (domain_name, List.rev current_list) :: internal_constraints_list in + (domain_name, List.rev current_list) :: internal_constraints_list + in let kasa_state = - Remanent_state.set_internal_constraints_list pair_list kasa_state in + Remanent_state.set_internal_constraints_list pair_list kasa_state + in error, dynamic, kasa_state let export static dynamic error kasa_state = - export_aux ~final_result:true - static dynamic error kasa_state + export_aux ~final_result:true static dynamic error kasa_state (****************************************************************) (*PRINT*) (****************************************************************) - let print ?dead_rules static dynamic (error:Exception.method_handler) loggers = + let print ?dead_rules static dynamic (error : Exception.method_handler) + loggers = let _ = dead_rules in let parameters = get_parameter static in let kappa_handler = get_kappa_handler static in @@ -1949,7 +1718,7 @@ struct (*--------------------------------------------------------*) let error, handler = if Remanent_parameters.get_dump_reachability_analysis_result parameters - then + then ( let () = Loggers.fprintf log "------------------------------------------------------------"; @@ -1967,24 +1736,18 @@ struct let error, handler = Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Map.fold (fun (x, y) mvbdu (error, handler) -> - Site_across_bonds_domain_type.print_site_across_domain - ~verbose:true - ~sparse:true - ~final_result:true - ~dump_any:true parameters error kappa_handler handler - (x, y) - mvbdu - ) store_value (error, handler) + Site_across_bonds_domain_type.print_site_across_domain + ~verbose:true ~sparse:true ~final_result:true ~dump_any:true + parameters error kappa_handler handler (x, y) mvbdu) + store_value (error, handler) in error, handler - else error, handler + ) else + error, handler in let dynamic = set_mvbdu_handler handler dynamic in error, dynamic, () - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects end diff --git a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.mli b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.mli index f6431605d3..52dd5dd1b5 100644 --- a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.mli +++ b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain.mli @@ -17,5 +17,4 @@ (** Abstract domain to over-approximate the set of reachable views *) - -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_static.ml b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_static.ml index b3892b536f..d9c9a4d044 100644 --- a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_static.ml +++ b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_static.ml @@ -19,61 +19,57 @@ let local_trace = false (*type*) (* agent_ids makes sense only in the context of a given rule *) -type potential_tuple_pair_views = - { - store_potential_tuple_pair : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t; - store_potential_tuple_pair_lhs : - Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_potential_tuple_pair_rule_rhs : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - } - -type potential_tuple_pair_creation_bonds = - { - store_partition_created_bonds_map : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Site_across_bonds_domain_type.PairAgentSiteState_map_and_set.Map.t; - store_partition_created_bonds_map_1 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; - store_partition_created_bonds_map_2 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; - store_rule_partition_created_bonds_map_1 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_rule_partition_created_bonds_map_2 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - } - -type potential_tuple_pair_modification = - { - store_partition_modified_map_1 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; - store_partition_modified_map_2 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; - (**) - store_rule_partition_modified_map_1 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - store_rule_partition_modified_map_2 : - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t - Ckappa_sig.Rule_map_and_set.Map.t; - } - -type basic_static_information = - { - store_potential_tuple_pair_views : potential_tuple_pair_views; - store_potential_tuple_pair_creation_bonds : - potential_tuple_pair_creation_bonds; - store_potential_tuple_pair_modification : potential_tuple_pair_modification; - } +type potential_tuple_pair_views = { + store_potential_tuple_pair: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t; + store_potential_tuple_pair_lhs: + Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_potential_tuple_pair_rule_rhs: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; +} + +type potential_tuple_pair_creation_bonds = { + store_partition_created_bonds_map: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Site_across_bonds_domain_type.PairAgentSiteState_map_and_set.Map.t; + store_partition_created_bonds_map_1: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; + store_partition_created_bonds_map_2: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; + store_rule_partition_created_bonds_map_1: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_rule_partition_created_bonds_map_2: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; +} + +type potential_tuple_pair_modification = { + store_partition_modified_map_1: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; + store_partition_modified_map_2: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Site_across_bonds_domain_type.AgentSite_map_and_set.Map.t; + (**) + store_rule_partition_modified_map_1: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; + store_rule_partition_modified_map_2: + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.t + Ckappa_sig.Rule_map_and_set.Map.t; +} + +type basic_static_information = { + store_potential_tuple_pair_views: potential_tuple_pair_views; + store_potential_tuple_pair_creation_bonds: + potential_tuple_pair_creation_bonds; + store_potential_tuple_pair_modification: potential_tuple_pair_modification; +} (****************************************************************) (*Init*) @@ -83,10 +79,8 @@ let init_potential_tuple_pair_views = { store_potential_tuple_pair = Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.empty; - store_potential_tuple_pair_lhs = - Ckappa_sig.Rule_map_and_set.Map.empty; - store_potential_tuple_pair_rule_rhs = - Ckappa_sig.Rule_map_and_set.Map.empty; + store_potential_tuple_pair_lhs = Ckappa_sig.Rule_map_and_set.Map.empty; + store_potential_tuple_pair_rule_rhs = Ckappa_sig.Rule_map_and_set.Map.empty; } let init_potential_tuple_pair_creation_bonds = @@ -109,10 +103,8 @@ let init_potential_tuple_pair_modification = Site_across_bonds_domain_type.AgentSite_map_and_set.Map.empty; store_partition_modified_map_2 = Site_across_bonds_domain_type.AgentSite_map_and_set.Map.empty; - store_rule_partition_modified_map_1 = - Ckappa_sig.Rule_map_and_set.Map.empty; - store_rule_partition_modified_map_2 = - Ckappa_sig.Rule_map_and_set.Map.empty; + store_rule_partition_modified_map_1 = Ckappa_sig.Rule_map_and_set.Map.empty; + store_rule_partition_modified_map_2 = Ckappa_sig.Rule_map_and_set.Map.empty; } let init_basic_static_information = @@ -129,181 +121,167 @@ let init_basic_static_information = (*collect a set of tuple pair (A.x.y, B.z.t) on the rhs*) (***************************************************************) -let collect_tuple parameters error kappa_handler (agent_id, agent_type, site_type, state) - views_set current_list = +let collect_tuple parameters error kappa_handler + (agent_id, agent_type, site_type, state) views_set current_list = let error, b = Handler.is_counter parameters error kappa_handler agent_type site_type in - if b then error,current_list - else + if b then + error, current_list + else ( let error, site_map = - Common_map.get_agent_id parameters error - agent_id Ckappa_sig.Site_map_and_set.Map.empty - views_set + Common_map.get_agent_id parameters error agent_id + Ckappa_sig.Site_map_and_set.Map.empty views_set in Ckappa_sig.Site_map_and_set.Map.fold (fun site_type_v _pair_of_state_v (error, current_list) -> - if site_type <> site_type_v - then - let error, b = - Handler.is_counter parameters error kappa_handler agent_type site_type_v - in - if b then error,current_list - else - let list = - (agent_type, site_type, site_type_v, state) :: - current_list - in - error, list - else - error, current_list) - site_map - (error, current_list) - -let collect_tuples parameters error kappa_handler (agent_id, agent_type, site_type, state) - views_set current_list = + if site_type <> site_type_v then ( + let error, b = + Handler.is_counter parameters error kappa_handler agent_type + site_type_v + in + if b then + error, current_list + else ( + let list = + (agent_type, site_type, site_type_v, state) :: current_list + in + error, list + ) + ) else + error, current_list) + site_map (error, current_list) + ) + +let collect_tuples parameters error kappa_handler + (agent_id, agent_type, site_type, state) views_set current_list = let error, b = Handler.is_counter parameters error kappa_handler agent_type site_type in - if b then error,current_list - else + if b then + error, current_list + else ( let error, site_map = - Common_map.get_agent_id parameters error - agent_id Ckappa_sig.Site_map_and_set.Map.empty - views_set - in - Ckappa_sig.Site_map_and_set.Map.fold - (fun site_type_v pair_of_state_v (error, current_list) -> - if site_type <> site_type_v - then - let error, b = - Handler.is_counter parameters error kappa_handler agent_type - site_type_v - in - if b then error,current_list - else - let list = - (agent_type, site_type, site_type_v, state, pair_of_state_v) :: - current_list - in - error, list - else - error, current_list) - site_map - (error, current_list) + Common_map.get_agent_id parameters error agent_id + Ckappa_sig.Site_map_and_set.Map.empty views_set + in + Ckappa_sig.Site_map_and_set.Map.fold + (fun site_type_v pair_of_state_v (error, current_list) -> + if site_type <> site_type_v then ( + let error, b = + Handler.is_counter parameters error kappa_handler agent_type + site_type_v + in + if b then + error, current_list + else ( + let list = + (agent_type, site_type, site_type_v, state, pair_of_state_v) + :: current_list + in + error, list + ) + ) else + error, current_list) + site_map (error, current_list) + ) let store_set parameters error fst_list snd_list store_result = - List.fold_left (fun (error, store_result) x -> - List.fold_left (fun (error, store_result) y -> + List.fold_left + (fun (error, store_result) x -> + List.fold_left + (fun (error, store_result) y -> let error, store_result = - Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.add_when_not_in - parameters error - (x, y) - store_result + Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set + .add_when_not_in parameters error (x, y) store_result in - error, store_result - ) (error, store_result) snd_list - ) (error, store_result) fst_list + error, store_result) + (error, store_result) snd_list) + (error, store_result) fst_list (***************************************************************) (*POTENTIAL TUPLE PAIR*) (***************************************************************) -let collect_potential_tuple_pair parameters error kappa_handler - rule_id store_bonds_rhs store_views_rhs store_result = +let collect_potential_tuple_pair parameters error kappa_handler rule_id + store_bonds_rhs store_views_rhs store_result = let error, bonds_set = - Common_map.get_rule_id_map_and_set parameters error - rule_id - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty - store_bonds_rhs + Common_map.get_rule_id_map_and_set parameters error rule_id + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty store_bonds_rhs in let error, views_set = Common_map.get_rule_id_map_and_set parameters error rule_id - Ckappa_sig.Agent_id_map_and_set.Map.empty - store_views_rhs + Ckappa_sig.Agent_id_map_and_set.Map.empty store_views_rhs in Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold (fun (x, y) (error, store_result) -> - let error, fst_list = - collect_tuple - parameters error kappa_handler - x views_set [] - in - let error, snd_list = - collect_tuple - parameters error kappa_handler - y views_set [] - in - let error, store_result = - List.fold_left (fun (error, store_result) x -> - List.fold_left (fun (error, store_result) y -> - let error, store_result = - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.add_when_not_in - parameters error - (x, y) - store_result - in - error, store_result - ) (error, store_result) snd_list - ) (error, store_result) fst_list - in - error, store_result - ) bonds_set (error, store_result) + let error, fst_list = + collect_tuple parameters error kappa_handler x views_set [] + in + let error, snd_list = + collect_tuple parameters error kappa_handler y views_set [] + in + let error, store_result = + List.fold_left + (fun (error, store_result) x -> + List.fold_left + (fun (error, store_result) y -> + let error, store_result = + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set + .Set + .add_when_not_in parameters error (x, y) store_result + in + error, store_result) + (error, store_result) snd_list) + (error, store_result) fst_list + in + error, store_result) + bonds_set (error, store_result) let collect_potential_tuple_pair_rule_rhs parameters error rule_id store_potential_tuple_pair_rhs store_result = - Ckappa_sig.Rule_map_and_set.Map.add - parameters error - rule_id - store_potential_tuple_pair_rhs - store_result + Ckappa_sig.Rule_map_and_set.Map.add parameters error rule_id + store_potential_tuple_pair_rhs store_result -let build_potential_tuple_pair_set parameters error kappa_handler bonds_set views_map = +let build_potential_tuple_pair_set parameters error kappa_handler bonds_set + views_map = let error, tuple_set = Ckappa_sig.PairAgentsSiteState_map_and_set.Set.fold (fun (x, y) (error, store_result) -> - let error, fst_list = - collect_tuples - parameters error kappa_handler - x views_map [] - in - let error, snd_list = - collect_tuples - parameters error kappa_handler - y views_map [] - in - let error, store_result = - store_set parameters error fst_list snd_list store_result - in - error, store_result - ) bonds_set - (error, - Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.empty) + let error, fst_list = + collect_tuples parameters error kappa_handler x views_map [] + in + let error, snd_list = + collect_tuples parameters error kappa_handler y views_map [] + in + let error, store_result = + store_set parameters error fst_list snd_list store_result + in + error, store_result) + bonds_set + ( error, + Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set + .empty ) in error, tuple_set -let collect_potential_tuple_pair_lhs parameters error kappa_handler rule_id store_bonds_lhs - store_views_lhs store_result = +let collect_potential_tuple_pair_lhs parameters error kappa_handler rule_id + store_bonds_lhs store_views_lhs store_result = let error, bonds_lhs_set = - Common_map.get_rule_id_map_and_set parameters error - rule_id - Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty - store_bonds_lhs + Common_map.get_rule_id_map_and_set parameters error rule_id + Ckappa_sig.PairAgentsSiteState_map_and_set.Set.empty store_bonds_lhs in let error, views_lhs_map = - Common_map.get_rule_id_map_and_set parameters error - rule_id - Ckappa_sig.Agent_id_map_and_set.Map.empty - store_views_lhs + Common_map.get_rule_id_map_and_set parameters error rule_id + Ckappa_sig.Agent_id_map_and_set.Map.empty store_views_lhs in let error, pair_set = - build_potential_tuple_pair_set - parameters error kappa_handler - bonds_lhs_set views_lhs_map + build_potential_tuple_pair_set parameters error kappa_handler bonds_lhs_set + views_lhs_map in (*add the set of tuple to rule_id map*) - Ckappa_sig.Rule_map_and_set.Map.add - parameters error rule_id pair_set store_result + Ckappa_sig.Rule_map_and_set.Map.add parameters error rule_id pair_set + store_result (***************************************************************) (*CREATION*) @@ -313,46 +291,35 @@ let collect_potential_tuple_pair_lhs parameters error kappa_handler rule_id stor let collect_partition_created_bonds_map parameters error store_potential_tuple_pair_set = - Site_across_bonds_domain_type.Partition_created_bonds_map.monadic_partition_set + Site_across_bonds_domain_type.Partition_created_bonds_map + .monadic_partition_set (fun _parameters error (x, y) -> - error, - (Common_map.project_second_site x, - Common_map.project_second_site y) - ) - parameters - error - store_potential_tuple_pair_set - -let collect_partition_created_bonds_map_aux parameters error x - tuple_set store_result = + error, (Common_map.project_second_site x, Common_map.project_second_site y)) + parameters error store_potential_tuple_pair_set + +let collect_partition_created_bonds_map_aux parameters error x tuple_set + store_result = let error, old_set = match - Site_across_bonds_domain_type.AgentSite_map_and_set.Map.find_option_without_logs - parameters error - x - store_result + Site_across_bonds_domain_type.AgentSite_map_and_set.Map + .find_option_without_logs parameters error x store_result with | error, None -> - error, - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.empty + ( error, + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.empty + ) | error, Some s -> error, s in let error', new_set = Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.union - parameters - error - old_set - tuple_set + parameters error old_set tuple_set in let error = Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error, store_result = Site_across_bonds_domain_type.AgentSite_map_and_set.Map.add_or_overwrite - parameters error - x - new_set - store_result + parameters error x new_set store_result in error, store_result @@ -360,110 +327,87 @@ let collect_partition_created_bonds_map_1 parameters error store_partition_created_bonds_map store_result = Site_across_bonds_domain_type.PairAgentSiteState_map_and_set.Map.fold (fun (x, _) tuple_set (error, store_result) -> - collect_partition_created_bonds_map_aux parameters error - (Common_map.project_state x) - tuple_set - store_result - ) + collect_partition_created_bonds_map_aux parameters error + (Common_map.project_state x) + tuple_set store_result) store_partition_created_bonds_map (error, store_result) let collect_partition_created_bonds_map_2 parameters error store_partition_created_bonds_map store_result = Site_across_bonds_domain_type.PairAgentSiteState_map_and_set.Map.fold (fun (_, y) tuple_set (error, store_result) -> - collect_partition_created_bonds_map_aux parameters error - (Common_map.project_state y) - tuple_set - store_result - ) + collect_partition_created_bonds_map_aux parameters error + (Common_map.project_state y) + tuple_set store_result) store_partition_created_bonds_map (error, store_result) -let collect_rule_partition_aux parameters error rule_id - map store_result = +let collect_rule_partition_aux parameters error rule_id map store_result = let error, store_result = Site_across_bonds_domain_type.AgentSite_map_and_set.Map.fold (fun _pair_site tuple_set (error, store_result) -> - let error', old_set = - Common_map.get_rule_id_map_and_set parameters error - rule_id - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.empty - store_result - in - let error = - Exception.check_point Exception.warn parameters error - error __POS__ Exit - in - let error'', new_set = - Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set.union - parameters error' - old_set - tuple_set - in - let error = - Exception.check_point Exception.warn parameters error - error'' __POS__ Exit - in - let error, store_result = - Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite - parameters error - rule_id - new_set - store_result - in - error, store_result - ) map (error, store_result) + let error', old_set = + Common_map.get_rule_id_map_and_set parameters error rule_id + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set + .empty store_result + in + let error = + Exception.check_point Exception.warn parameters error error __POS__ + Exit + in + let error'', new_set = + Site_across_bonds_domain_type.PairAgentSitesState_map_and_set.Set + .union parameters error' old_set tuple_set + in + let error = + Exception.check_point Exception.warn parameters error error'' __POS__ + Exit + in + let error, store_result = + Ckappa_sig.Rule_map_and_set.Map.add_or_overwrite parameters error + rule_id new_set store_result + in + error, store_result) + map (error, store_result) in error, store_result let collect_rule_partition_created_bonds_map_1 parameters error store_rule_potential_tuple_pair_set_rhs store_result = - let error, store_result = - Ckappa_sig.Rule_map_and_set.Map.fold - (fun rule_id tuple_set (error, store_result) -> - let error, map1 = - Site_across_bonds_domain_type.Partition_modified_map.monadic_partition_set - (fun _ error (x, _) -> - error, (Common_map.project_second_site_state x) - ) - parameters - error - tuple_set - in - let error, store_result = - collect_rule_partition_aux - parameters error - rule_id - map1 - store_result - in - error, store_result - ) store_rule_potential_tuple_pair_set_rhs (error, store_result) - in - error, store_result + let error, store_result = + Ckappa_sig.Rule_map_and_set.Map.fold + (fun rule_id tuple_set (error, store_result) -> + let error, map1 = + Site_across_bonds_domain_type.Partition_modified_map + .monadic_partition_set + (fun _ error (x, _) -> + error, Common_map.project_second_site_state x) + parameters error tuple_set + in + let error, store_result = + collect_rule_partition_aux parameters error rule_id map1 store_result + in + error, store_result) + store_rule_potential_tuple_pair_set_rhs (error, store_result) + in + error, store_result let collect_rule_partition_created_bonds_map_2 parameters error store_rule_potential_tuple_pair_set_rhs store_result = let error, store_result = Ckappa_sig.Rule_map_and_set.Map.fold (fun rule_id tuple_set (error, store_result) -> - let error, map2 = - Site_across_bonds_domain_type.Partition_modified_map.monadic_partition_set - (fun _ error (_, y) -> - error, (Common_map.project_second_site_state y) - ) - parameters - error - tuple_set - in - let error, store_result = - collect_rule_partition_aux - parameters error - rule_id - map2 - store_result - in - error, store_result - ) store_rule_potential_tuple_pair_set_rhs (error, store_result) + let error, map2 = + Site_across_bonds_domain_type.Partition_modified_map + .monadic_partition_set + (fun _ error (_, y) -> + error, Common_map.project_second_site_state y) + parameters error tuple_set + in + let error, store_result = + collect_rule_partition_aux parameters error rule_id map2 store_result + in + error, store_result) + store_rule_potential_tuple_pair_set_rhs (error, store_result) in error, store_result @@ -476,90 +420,74 @@ let collect_partition_modified_map_1 parameters error (*agent_type, site_type, site_type', state*) Site_across_bonds_domain_type.Partition_modified_map.monadic_partition_set (fun _ error (x, _) -> error, Common_map.project_first_site_state x) - parameters - error - store_potential_tuple_pair_set + parameters error store_potential_tuple_pair_set let collect_partition_modified_map_2 parameters error store_potential_tuple_pair_set = (*agent_type, site_type, site_type', state*) Site_across_bonds_domain_type.Partition_modified_map.monadic_partition_set (fun _ error (_, y) -> error, Common_map.project_first_site_state y) - parameters - error - store_potential_tuple_pair_set + parameters error store_potential_tuple_pair_set let collect_rule_partition_modified_map_1 parameters error store_potential_tuple_pair_rule_rhs store_result = Ckappa_sig.Rule_map_and_set.Map.fold (fun rule_id tuple_set (error, store_result) -> - let error, map = - Site_across_bonds_domain_type.Partition_modified_map.monadic_partition_set - (fun _ error (x, _) -> error, Common_map.project_first_site_state x) - parameters - error - tuple_set - in - let error, store_result = - collect_rule_partition_aux - parameters error - rule_id - map - store_result - in - error, store_result - ) store_potential_tuple_pair_rule_rhs (error, store_result) + let error, map = + Site_across_bonds_domain_type.Partition_modified_map + .monadic_partition_set + (fun _ error (x, _) -> error, Common_map.project_first_site_state x) + parameters error tuple_set + in + let error, store_result = + collect_rule_partition_aux parameters error rule_id map store_result + in + error, store_result) + store_potential_tuple_pair_rule_rhs (error, store_result) let collect_rule_partition_modified_map_2 parameters error store_potential_tuple_pair_rule_rhs store_result = Ckappa_sig.Rule_map_and_set.Map.fold (fun rule_id tuple_set (error, store_result) -> - let error, map = - Site_across_bonds_domain_type.Partition_modified_map.monadic_partition_set - (fun _ error (_, y) -> error, Common_map.project_first_site_state y) - parameters - error - tuple_set - in - let error, store_result = - collect_rule_partition_aux - parameters error - rule_id - map - store_result - in - error, store_result - ) store_potential_tuple_pair_rule_rhs (error, store_result) + let error, map = + Site_across_bonds_domain_type.Partition_modified_map + .monadic_partition_set + (fun _ error (_, y) -> error, Common_map.project_first_site_state y) + parameters error tuple_set + in + let error, store_result = + collect_rule_partition_aux parameters error rule_id map store_result + in + error, store_result) + store_potential_tuple_pair_rule_rhs (error, store_result) (***************************************************************) (*INITIAL STATE*) (***************************************************************) -let collect_potential_tuple_pair_init - parameters error bdu_false handler kappa_handler - tuple_init - store_result = +let collect_potential_tuple_pair_init parameters error bdu_false handler + kappa_handler tuple_init store_result = Site_across_bonds_domain_type.PairAgentSitesPStates_map_and_set.Set.fold (fun (x, y) (error, handler, store_result) -> - let (agent_type, site_type1, site_type2, state1, pair_of_state2) = x in - let (agent_type', site_type1', site_type2', state1', pair_of_state2') = y in - let pair_list = - [(Ckappa_sig.fst_site, pair_of_state2); - (Ckappa_sig.snd_site, pair_of_state2')] - in - let error, handler, mvbdu = - Ckappa_sig.Views_bdu.mvbdu_of_range_list - parameters - handler error pair_list - in - let error, handler, store_result = - Site_across_bonds_domain_type.add_link - parameters error bdu_false handler - kappa_handler - ((agent_type, site_type1, site_type2, state1), - (agent_type', site_type1', site_type2', state1')) - mvbdu - store_result - in - error, handler, store_result - ) tuple_init (error, handler, store_result) + let agent_type, site_type1, site_type2, state1, pair_of_state2 = x in + let agent_type', site_type1', site_type2', state1', pair_of_state2' = y in + let pair_list = + [ + Ckappa_sig.fst_site, pair_of_state2; + Ckappa_sig.snd_site, pair_of_state2'; + ] + in + let error, handler, mvbdu = + Ckappa_sig.Views_bdu.mvbdu_of_range_list parameters handler error + pair_list + in + let error, handler, store_result = + Site_across_bonds_domain_type.add_link parameters error bdu_false + handler kappa_handler + ( (agent_type, site_type1, site_type2, state1), + (agent_type', site_type1', site_type2', state1') ) + mvbdu store_result + in + error, handler, store_result) + tuple_init + (error, handler, store_result) diff --git a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_type.ml b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_type.ml index 478fd712ac..13b8b9b765 100644 --- a/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_type.ml +++ b/core/KaSa_rep/reachability_analysis/site_across_bonds_domain_type.ml @@ -14,175 +14,177 @@ * under the terms of the GNU Library General Public License *) (*static views rhs/lhs*) -module AgentsSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * - Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module AgentsSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + + let compare = compare + let print _ _ = () +end)) (*static question mark*) -module AgentsSitesState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module AgentsSitesState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + + let compare = compare + let print _ _ = () +end)) (*views in initial state*) -module AgentsSitesStates_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name - * Ckappa_sig.c_site_name * Ckappa_sig.c_site_name - * Ckappa_sig.c_state * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module AgentsSitesStates_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state + + let compare = compare + let print _ _ = () +end)) (************************************************************) (*PAIR*) (*partition bonds/created bond rhs map*) -module PairAgentSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * - Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * - Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) - -module PairAgentSitesState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module PairAgentSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) + +module PairAgentSitesState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) (*collect tuple in the lhs*) -module PairAgentSitesStates_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) - -module PairAgentSitesPStates_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.pair_of_states) * - (Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.pair_of_states) - let compare = compare - let print _ _ = () - end)) +module PairAgentSitesStates_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) + +module PairAgentSitesPStates_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.pair_of_states) + * (Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.pair_of_states) + + let compare = compare + let print _ _ = () +end)) (*-----------------------------------------------------*) -module PairAgentsSiteState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name - * Ckappa_sig.c_site_name * - Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name - * Ckappa_sig.c_site_name * - Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) - -module PairAgentsSitesState_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) - -module PairAgentsSitesStates_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) * - (Ckappa_sig.c_agent_id * Ckappa_sig.c_agent_name * - Ckappa_sig.c_site_name * Ckappa_sig.c_site_name * - Ckappa_sig.c_state * Ckappa_sig.c_state) - let compare = compare - let print _ _ = () - end)) +module PairAgentsSiteState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) + +module PairAgentsSitesState_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) + +module PairAgentsSitesStates_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + * (Ckappa_sig.c_agent_id + * Ckappa_sig.c_agent_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_site_name + * Ckappa_sig.c_state + * Ckappa_sig.c_state) + + let compare = compare + let print _ _ = () +end)) (***************************************************************) (*Projection*) -module PairSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_site_name * - Ckappa_sig.c_site_name) - let compare = compare - let print _ _ = () - end)) +module PairSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = Ckappa_sig.c_site_name * Ckappa_sig.c_site_name + + let compare = compare + let print _ _ = () +end)) (*project second site*) module Proj_potential_tuple_pair_set = Map_wrapper.Proj - (PairAgentSitesState_map_and_set) (*potential tuple pair set*) - (PairSite_map_and_set) (*use to search the set in bonds rhs*) + (PairAgentSitesState_map_and_set) + (*potential tuple pair set*) + (PairSite_map_and_set) +(*use to search the set in bonds rhs*) module Partition_bonds_rhs_map = Map_wrapper.Proj @@ -195,237 +197,260 @@ module Partition_created_bonds_map = (PairAgentSiteState_map_and_set) (*partition modified map*) -module AgentSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) - let compare = compare - let print _ _ = () - end)) +module AgentSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name + + let compare = compare + let print _ _ = () +end)) module Partition_modified_map = - Map_wrapper.Proj - (PairAgentSitesState_map_and_set) - (AgentSite_map_and_set) - -module PairAgentSite_map_and_set = - Map_wrapper.Make - (SetMap.Make - (struct - type t = - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) - let compare = compare - let print _ _ = () - end)) + Map_wrapper.Proj (PairAgentSitesState_map_and_set) (AgentSite_map_and_set) + +module PairAgentSite_map_and_set = Map_wrapper.Make (SetMap.Make (struct + type t = + (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + + let compare = compare + let print _ _ = () +end)) (***************************************************************************) (*PRINT*) (***************************************************************************) let convert_single_without_state parameters error kappa_handler single = - let (agent, site) = single in - let error, site = Handler.string_of_site_contact_map parameters error kappa_handler agent site in + let agent, site = single in + let error, site = + Handler.string_of_site_contact_map parameters error kappa_handler agent site + in let error, agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent in error, (agent, site) let convert_single parameters error kappa_handler single = - let (agent, site, state) = single in - let error, state = Handler.string_of_state_fully_deciphered parameters error kappa_handler agent site state in - let error, site = Handler.string_of_site_contact_map parameters error kappa_handler agent site in + let agent, site, state = single in + let error, state = + Handler.string_of_state_fully_deciphered parameters error kappa_handler + agent site state + in + let error, site = + Handler.string_of_site_contact_map parameters error kappa_handler agent site + in let error, agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent in error, (agent, site, state) let convert_tuple parameters error kappa_handler tuple = - let (agent,site,site',state),(agent'',site'',site''',state'') = tuple in - let error, state = Handler.string_of_state_fully_deciphered parameters error kappa_handler agent site state in - let error, state'' = Handler.string_of_state_fully_deciphered parameters error kappa_handler agent'' site'' state'' in - let error, site = Handler.string_of_site_contact_map parameters error kappa_handler agent site in - let error, site' = Handler.string_of_site_contact_map parameters error kappa_handler agent site' in + let (agent, site, site', state), (agent'', site'', site''', state'') = + tuple + in + let error, state = + Handler.string_of_state_fully_deciphered parameters error kappa_handler + agent site state + in + let error, state'' = + Handler.string_of_state_fully_deciphered parameters error kappa_handler + agent'' site'' state'' + in + let error, site = + Handler.string_of_site_contact_map parameters error kappa_handler agent site + in + let error, site' = + Handler.string_of_site_contact_map parameters error kappa_handler agent + site' + in let error, agent = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent in - let error, site'' = Handler.string_of_site_contact_map parameters error kappa_handler agent'' site'' in - let error, site''' = Handler.string_of_site_contact_map parameters error kappa_handler agent'' site''' in + let error, site'' = + Handler.string_of_site_contact_map parameters error kappa_handler agent'' + site'' + in + let error, site''' = + Handler.string_of_site_contact_map parameters error kappa_handler agent'' + site''' + in let error, agent'' = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) + Handler.translate_agent ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameters error kappa_handler agent'' in - error, (agent,site,site', state, agent'',site'',site''', state'') + error, (agent, site, site', state, agent'', site'', site''', state'') (***************************************************************************) (*PROJECTION*) (***************************************************************************) -let project (_,b,c,d,_,_) = (b,c,d) -let project2 (x,y) = (project x,project y) +let project (_, b, c, d, _, _) = b, c, d +let project2 (x, y) = project x, project y (***************************************************************************) (*PRINT*) (***************************************************************************) -let print_site_across_domain - ?verbose:(_verbose=true) - ?sparse: (sparse = false) - ?final_result:(final_result = false) - ?dump_any:(_dump_any = false) parameters error kappa_handler handler tuple mvbdu = +let print_site_across_domain ?verbose:(_verbose = true) ?(sparse = false) + ?(final_result = false) ?dump_any:(_dump_any = false) parameters error + kappa_handler handler tuple mvbdu = let prefix = Remanent_parameters.get_prefix parameters in - let (agent_type1, site_type1, site_type1', _), - (agent_type2, site_type2, site_type2', _) = tuple in + let ( (agent_type1, site_type1, site_type1', _), + (agent_type2, site_type2, site_type2', _) ) = + tuple + in (*----------------------------------------------------*) (*state1 and state1' are a binding states*) - let error, (agent1, site1, site1',_, agent2, site2, site2', _) = + let error, (agent1, site1, site1', _, agent2, site2, site2', _) = convert_tuple parameters error kappa_handler tuple in - if sparse && compare (agent1,site1,site1') (agent2,site2,site2') > 0 - then error, handler - else + if sparse && compare (agent1, site1, site1') (agent2, site2, site2') > 0 then + error, handler + else ( (*only print the final_result in the case of final_result is set true*) let error, handler, non_relational = - if final_result - then + if final_result then (*at the final result needs to check the non_relational condition*) - Translation_in_natural_language.non_relational - parameters handler error mvbdu + Translation_in_natural_language.non_relational parameters handler error + mvbdu else (*other cases will by pass this test*) error, handler, false in - if non_relational - then error, handler - else + if non_relational then + error, handler + else ( (*----------------------------------------------------*) let error, handler, pair_list = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters handler error mvbdu + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler error mvbdu in (*----------------------------------------------------*) - match Remanent_parameters.get_backend_mode parameters - with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> let pattern = Site_graphs.KaSa_site_graph.empty in let error, agent_id1, pattern = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler agent_type1 pattern + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler + agent_type1 pattern in let error, agent_id2, pattern = - Site_graphs.KaSa_site_graph.add_agent - parameters error kappa_handler agent_type2 pattern + Site_graphs.KaSa_site_graph.add_agent parameters error kappa_handler + agent_type2 pattern in let error, pattern = - Site_graphs.KaSa_site_graph.add_bond - parameters error kappa_handler agent_id1 site_type1 agent_id2 site_type2 pattern + Site_graphs.KaSa_site_graph.add_bond parameters error kappa_handler + agent_id1 site_type1 agent_id2 site_type2 pattern in let error = (*do not print the precondition if it is not the final result*) - if final_result - then + if final_result then ( let error = Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - pattern + (Remanent_parameters.get_logger parameters) + parameters error pattern in let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) " => " in error - else error + ) else + error in - begin - match pair_list with - | [] -> - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "" - in - error, handler - | _::_ -> - let () = - if final_result - then + (match pair_list with + | [] -> + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "" + in + error, handler + | _ :: _ -> + let () = + if final_result then ( let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) + Loggers.print_newline + (Remanent_parameters.get_logger parameters) in - Loggers.fprintf (Remanent_parameters.get_logger parameters) "\t[" - else () - in - let error, _ = - List.fold_left - (fun (error, bool) l -> - match l with - | [siteone, state1; sitetwo, state2] when - siteone == Ckappa_sig.fst_site + Loggers.fprintf (Remanent_parameters.get_logger parameters) "\t[" + ) else + () + in + let error, _ = + List.fold_left + (fun (error, bool) l -> + match l with + | [ (siteone, state1); (sitetwo, state2) ] + when siteone == Ckappa_sig.fst_site && sitetwo == Ckappa_sig.snd_site -> - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - let () = - Loggers.fprintf - (Remanent_parameters.get_logger parameters) - (if bool then "\t\tv " else - if final_result then "\t\t " else "\t\t") - in - let error, pattern = - Site_graphs.KaSa_site_graph.add_state - parameters error kappa_handler - agent_id1 site_type1' state1 pattern - in - let error, pattern = - Site_graphs.KaSa_site_graph.add_state - parameters error kappa_handler - agent_id2 site_type2' state2 pattern - in - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - pattern - in - error, true - | _ -> Exception.warn parameters error __POS__ Exit bool - ) - (error, false) pair_list - in - let () = - if final_result - then - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = Loggers.fprintf - (Remanent_parameters.get_logger parameters) "\t]" in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - () - in - error, handler - end + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + (if bool then + "\t\tv " + else if final_result then + "\t\t " + else + "\t\t") + in + let error, pattern = + Site_graphs.KaSa_site_graph.add_state parameters error + kappa_handler agent_id1 site_type1' state1 pattern + in + let error, pattern = + Site_graphs.KaSa_site_graph.add_state parameters error + kappa_handler agent_id2 site_type2' state2 pattern + in + let error = + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error pattern + in + error, true + | _ -> Exception.warn parameters error __POS__ Exit bool) + (error, false) pair_list + in + let () = + if final_result then ( + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "\t]" + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger parameters) + in + () + ) + in + error, handler) | Remanent_parameters_sig.Natural_language -> let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%sWhenever the site %s of %s and the site %s of %s are bound \ together, then the site %s of %s and %s of %s can have the \ following respective states:" - prefix site1 agent1 site2 agent2 - site1' agent1 site2' agent2 in + prefix site1 agent1 site2 agent2 site1' agent1 site2' agent2 + in let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let prefix = prefix^"\t" in - List.fold_left (fun (error, handler) l -> + let prefix = prefix ^ "\t" in + List.fold_left + (fun (error, handler) l -> match l with - | [siteone, statex; sitetwo, statey] when - siteone == Ckappa_sig.fst_site - && sitetwo == Ckappa_sig.snd_site -> + | [ (siteone, statex); (sitetwo, statey) ] + when siteone == Ckappa_sig.fst_site + && sitetwo == Ckappa_sig.snd_site -> let error, (_, _, statex) = convert_single parameters error kappa_handler (agent_type1, site_type1, statex) @@ -435,28 +460,26 @@ let print_site_across_domain (agent_type2, site_type2, statey) in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) - "%s%s, %s\n" - prefix statex statey + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%s, %s\n" prefix statex statey in error, handler - | [] | _::_ -> - let error, () = - Exception.warn parameters error __POS__ Exit () - in - error, handler - ) (error, handler) pair_list + | [] | _ :: _ -> + let error, () = Exception.warn parameters error __POS__ Exit () in + error, handler) + (error, handler) pair_list + ) + ) (***************************************************************************) (***************************************************************************) -let get_mvbdu_from_tuple_pair parameters error tuple bdu_false store_value = +let get_mvbdu_from_tuple_pair parameters error tuple bdu_false store_value = let error, mvbdu_value = match - PairAgentSitesState_map_and_set.Map.find_option_without_logs - parameters error - tuple - store_value + PairAgentSitesState_map_and_set.Map.find_option_without_logs parameters + error tuple store_value with | error, None -> error, bdu_false | error, Some mvbdu -> error, mvbdu @@ -471,104 +494,86 @@ let add_link parameter error bdu_false handler kappa_handler pair mvbdu (*-----------------------------------------------------------*) (*new bdu, union*) let error, handler, new_bdu = - Ckappa_sig.Views_bdu.mvbdu_or - parameter handler error bdu_old mvbdu + Ckappa_sig.Views_bdu.mvbdu_or parameter handler error bdu_old mvbdu in (*print each step*) let error, handler = - if Remanent_parameters.get_dump_reachability_analysis_diff parameter - then - let parameter = Remanent_parameters.update_prefix parameter " " + if Remanent_parameters.get_dump_reachability_analysis_diff parameter then ( + let parameter = + Remanent_parameters.update_prefix parameter " " in - print_site_across_domain - ~verbose:false - ~dump_any:true parameter error kappa_handler handler pair mvbdu - else error, handler + print_site_across_domain ~verbose:false ~dump_any:true parameter error + kappa_handler handler pair mvbdu + ) else + error, handler in let error, store_result = - PairAgentSitesState_map_and_set.Map.add_or_overwrite - parameter error - pair - new_bdu - store_result + PairAgentSitesState_map_and_set.Map.add_or_overwrite parameter error pair + new_bdu store_result in error, handler, store_result let add_sites_from_tuples parameters error tuple modified_sites = - let (agent,site1,site2,_),(agent',site1',site2',_) = tuple in - List.fold_left - (fun (error, modified_sites) (agent,site) -> - Communication.add_site parameters error agent site modified_sites - ) - (error, modified_sites) - [agent,site1;agent,site2;agent',site1';agent',site2'] - -let check - parameters error bdu_false handler - pair - mvbdu - store_result - = + let (agent, site1, site2, _), (agent', site1', site2', _) = tuple in + List.fold_left + (fun (error, modified_sites) (agent, site) -> + Communication.add_site parameters error agent site modified_sites) + (error, modified_sites) + [ agent, site1; agent, site2; agent', site1'; agent', site2' ] + +let check parameters error bdu_false handler pair mvbdu store_result = let error, bdu_old = get_mvbdu_from_tuple_pair parameters error pair bdu_false store_result in let error, handler, new_bdu = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error bdu_old mvbdu + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu_old mvbdu in - if Ckappa_sig.Views_bdu.equal new_bdu bdu_false - then + if Ckappa_sig.Views_bdu.equal new_bdu bdu_false then error, handler, false else error, handler, true -let add_link_and_check parameter error bdu_false handler - kappa_handler bool dump_title x mvbdu modified_sites store_result = +let add_link_and_check parameter error bdu_false handler kappa_handler bool + dump_title x mvbdu modified_sites store_result = let error, bdu_old = get_mvbdu_from_tuple_pair parameter error x bdu_false store_result in (*-----------------------------------------------------------*) (*new bdu, union*) let error, handler, new_bdu = - Ckappa_sig.Views_bdu.mvbdu_or - parameter handler error bdu_old mvbdu + Ckappa_sig.Views_bdu.mvbdu_or parameter handler error bdu_old mvbdu in (*-----------------------------------------------------------*) (*check the freshness of the pair*) (*compare mvbdu and old mvbdu*) - if Ckappa_sig.Views_bdu.equal new_bdu bdu_old - then - error, bool, handler, modified_sites, store_result - else + if Ckappa_sig.Views_bdu.equal new_bdu bdu_old then + error, bool, handler, modified_sites, store_result + else ( (*-----------------------------------------------------------*) (*print each step*) - let error, handler = - if Remanent_parameters.get_dump_reachability_analysis_diff parameter - then - let parameter = Remanent_parameters.update_prefix parameter "\t\t" - in + let error, handler = + if Remanent_parameters.get_dump_reachability_analysis_diff parameter then ( + let parameter = Remanent_parameters.update_prefix parameter "\t\t" in let () = - if bool then () - else dump_title () + if bool then + () + else + dump_title () in - print_site_across_domain - ~verbose:false - ~dump_any:true parameter error kappa_handler handler x mvbdu - else error, handler + print_site_across_domain ~verbose:false ~dump_any:true parameter error + kappa_handler handler x mvbdu + ) else + error, handler in let error, store_result = - PairAgentSitesState_map_and_set.Map.add_or_overwrite - parameter error - x - new_bdu - store_result + PairAgentSitesState_map_and_set.Map.add_or_overwrite parameter error x + new_bdu store_result in let error', modified_sites = add_sites_from_tuples parameter error x modified_sites in let error = - Exception.check_point - Exception.warn parameter error error' - __POS__ Exit + Exception.check_point Exception.warn parameter error error' __POS__ Exit in error, true, handler, modified_sites, store_result + ) diff --git a/core/KaSa_rep/reachability_analysis/static_contact_map_domain.ml b/core/KaSa_rep/reachability_analysis/static_contact_map_domain.ml index 29cee0b9c7..9723d8b207 100644 --- a/core/KaSa_rep/reachability_analysis/static_contact_map_domain.ml +++ b/core/KaSa_rep/reachability_analysis/static_contact_map_domain.ml @@ -14,31 +14,25 @@ * under the terms of the GNU Library General Public License *) let local_trace = false - let _ = local_trace -module Domain = -struct +module Domain = struct + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + } - type static_information = - { - global_static_information : Analyzer_headers.global_static_information; - } type local_dynamic_information = unit - type dynamic_information = - { - local : local_dynamic_information ; - global : Analyzer_headers.global_dynamic_information - } + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } (**************************************************************************) (*local static information*) let get_global_static_information static = static.global_static_information - let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static (*--------------------------------------------------------------------*) @@ -47,80 +41,71 @@ struct let get_global_dynamic_information dynamic = dynamic.global let set_global_dynamic_information gdynamic dynamic = - {dynamic with global = gdynamic} - + { dynamic with global = gdynamic } (**************************************************************************) (*implementations*) let initialize static dynamic error = - let init_global_dynamic_information = - { - local = () ; - global = dynamic - } - in + let init_global_dynamic_information = { local = (); global = dynamic } in let parameter = Analyzer_headers.get_parameter static in let kappa_handler = Analyzer_headers.get_kappa_handler static in let init_global_static_information = - { - global_static_information = static; - } + { global_static_information = static } in let error, event_list = - Ckappa_sig.Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif.fold - parameter error - (fun _ error (i, (j , k)) (i', j', k') event_list -> - error, - Communication.See_a_new_bond - ((i,j,k),(i',j',k')) :: event_list) - kappa_handler.Cckappa_sig.dual [] + Ckappa_sig + .Agent_type_site_state_nearly_Inf_Int_Int_Int_storage_Imperatif_Imperatif_Imperatif + .fold parameter error + (fun _ error (i, (j, k)) (i', j', k') event_list -> + ( error, + Communication.See_a_new_bond ((i, j, k), (i', j', k')) :: event_list + )) + kappa_handler.Cckappa_sig.dual [] in - error, + ( error, init_global_static_information, - init_global_dynamic_information, event_list + init_global_dynamic_information, + event_list ) - let complete_wake_up_relation _static error wake_up = - error, wake_up + let complete_wake_up_relation _static error wake_up = error, wake_up (**************************************************************************) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd - + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (**************************************************************************) (*Implementation*) - let add_initial_state _static dynamic error _species = - error, dynamic, [] + let add_initial_state _static dynamic error _species = error, dynamic, [] (**************************************************************************) @@ -135,33 +120,24 @@ struct (**************************************************************************) let apply_rule _static dynamic error _rule_id precondition = - error, dynamic, (precondition, []) (* this domain ignores rule application *) - - - let apply_one_side_effect - _static dynamic error - _ _ precondition - = - error, dynamic, (precondition,[]) (* this domain ignores side effects *) + error, dynamic, (precondition, []) + (* this domain ignores rule application *) + let apply_one_side_effect _static dynamic error _ _ precondition = + error, dynamic, (precondition, []) + (* this domain ignores side effects *) let apply_event_list _static dynamic error _event_list = let event_list = [] in error, dynamic, event_list let stabilize _static dynamic error = error, dynamic, () - - let export _static dynamic error kasa_state = - error, dynamic, kasa_state - + let export _static dynamic error kasa_state = error, dynamic, kasa_state let print ?dead_rules _static dynamic error _loggers = let _ = dead_rules in error, dynamic, () - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects end diff --git a/core/KaSa_rep/reachability_analysis/static_contact_map_domain.mli b/core/KaSa_rep/reachability_analysis/static_contact_map_domain.mli index b733713752..17d165c5ce 100644 --- a/core/KaSa_rep/reachability_analysis/static_contact_map_domain.mli +++ b/core/KaSa_rep/reachability_analysis/static_contact_map_domain.mli @@ -17,5 +17,4 @@ (** Abstract domain to over-approximate the set of reachable views *) - -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/reachability_analysis/stochastic_classes.ml b/core/KaSa_rep/reachability_analysis/stochastic_classes.ml index c4f2099ea0..92b17541dc 100644 --- a/core/KaSa_rep/reachability_analysis/stochastic_classes.ml +++ b/core/KaSa_rep/reachability_analysis/stochastic_classes.ml @@ -17,102 +17,90 @@ let trace = false (**************************************************************************) (*TYPE*) -type stochastic_class = - { - stochastic_class : Ckappa_sig.c_site_name list Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t - } +type stochastic_class = { + stochastic_class: + Ckappa_sig.c_site_name list + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t; +} (****************************************************************************) (*RULE*) let scan_rule parameters error _handler rule _classes = let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 in (*Compute the stochastic class in the case there is a new agent is created in the rhs*) let error, stochastic_class_rhs = List.fold_left (fun (error, store_result) (agent_id, agent_type) -> - let error, agent = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_id - rule.Cckappa_sig.rule_rhs.Cckappa_sig.views - in - match agent with - | None - | Some Cckappa_sig.Unknown_agent _ - | Some Cckappa_sig.Ghost -> error, store_result - | Some Cckappa_sig.Dead_agent (agent,_,_,_) - | Some Cckappa_sig.Agent agent -> - let error, site_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ (error, current_list) -> - let site_list = site :: current_list in - error, site_list - ) agent.Cckappa_sig.agent_interface (error, []) - in - let error, old_list = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_result - with - | error, None -> error, [] - | error, Some l -> error, l - in - let new_list = List.concat [site_list; old_list] in - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_list - store_result - in - error, store_result - ) (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.creation + let error, agent = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_id + rule.Cckappa_sig.rule_rhs.Cckappa_sig.views + in + match agent with + | None | Some (Cckappa_sig.Unknown_agent _) | Some Cckappa_sig.Ghost -> + error, store_result + | Some (Cckappa_sig.Dead_agent (agent, _, _, _)) + | Some (Cckappa_sig.Agent agent) -> + let error, site_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _ (error, current_list) -> + let site_list = site :: current_list in + error, site_list) + agent.Cckappa_sig.agent_interface (error, []) + in + let error, old_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result + with + | error, None -> error, [] + | error, Some l -> error, l + in + let new_list = List.concat [ site_list; old_list ] in + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type new_list store_result + in + error, store_result) + (error, store_result) rule.Cckappa_sig.actions.Cckappa_sig.creation in (*compute the stochastic class *) let error, stochastic_classes = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id agent store_result -> - match agent with - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost -> error, store_result - | Cckappa_sig.Dead_agent (agent,_,_,_) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, site_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site _ (error, current_list) -> - let site_list = site :: current_list in - error, site_list - ) agent.Cckappa_sig.agent_interface (error, []) - in - let error, old_list = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type store_result - with - | error, None -> error, [] - | error, Some l -> error, l - in - let new_list = List.concat [site_list; old_list] in - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - new_list - store_result - in - error, store_result - ) rule.Cckappa_sig.rule_lhs.Cckappa_sig.views stochastic_class_rhs + match agent with + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost -> error, store_result + | Cckappa_sig.Dead_agent (agent, _, _, _) | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, site_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site _ (error, current_list) -> + let site_list = site :: current_list in + error, site_list) + agent.Cckappa_sig.agent_interface (error, []) + in + let error, old_list = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result + with + | error, None -> error, [] + | error, Some l -> error, l + in + let new_list = List.concat [ site_list; old_list ] in + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type new_list store_result + in + error, store_result) + rule.Cckappa_sig.rule_lhs.Cckappa_sig.views stochastic_class_rhs in - error, - { - stochastic_class = stochastic_classes; - } + error, { stochastic_class = stochastic_classes } (**************************************************************************) (*RULES*) @@ -123,25 +111,18 @@ let scan_rule parameters error _handler rule _classes = let get_nsites parameters error key handler = let error, get_nsites = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - key - handler.Cckappa_sig.sites + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters + error key handler.Cckappa_sig.sites in let error, sites_dic = match get_nsites with | None -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.Dictionary_of_sites.init()) + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_sites.init ()) | Some dic -> error, dic in let error, nsites = - Ckappa_sig.Dictionary_of_sites.last_entry - parameters - error - sites_dic + Ckappa_sig.Dictionary_of_sites.last_entry parameters error sites_dic in error, Ckappa_sig.next_site_name nsites @@ -151,82 +132,63 @@ let get_nsites parameters error key handler = let scan_rule_set parameters error handler rules = let nagents = handler.Cckappa_sig.nagents in let error, init_stochastic_class = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create_biggest_key parameters error nagents + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .create_biggest_key parameters error nagents in let error, init = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - let init_stochastic = - { - stochastic_class = init_stochastic_class - } - in + let init_stochastic = { stochastic_class = init_stochastic_class } in (*----------------------------------------------------------------------*) let error, stochastic_class = - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error _rule_id rule stochastic_class -> - (*-----------------------------------------------------------------*) - let error, map = - scan_rule - parameters - error - handler - rule.Cckappa_sig.e_rule_c_rule - init_stochastic - in - (*----------------------------------------------------------------*) - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error - (fun parameters error agent_type sites_list store_result -> - let error, nsites = - get_nsites - parameters - error - agent_type - handler + (*-----------------------------------------------------------------*) + let error, map = + scan_rule parameters error handler rule.Cckappa_sig.e_rule_c_rule + init_stochastic + in + (*----------------------------------------------------------------*) + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold + parameters error + (fun parameters error agent_type sites_list store_result -> + let error, nsites = + get_nsites parameters error agent_type handler + in + match sites_list with + | [] | [ _ ] -> error, store_result + | _ -> + (*getting an array in the old_result*) + let error, get_array = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_result in - match sites_list with - | [] | [_] -> error, store_result - | _ -> - (*getting an array in the old_result*) - let error, get_array = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_type - store_result - in - let error, array = - match get_array with - | None -> - Ckappa_sig.Site_union_find.create parameters error - (Ckappa_sig.int_of_site_name nsites) - | Some a -> error, a - in - (*compute the union for the list of site*) - let error, union_array = - Ckappa_sig.Site_union_find.union_list - parameters - error - array - sites_list - in - (*store*) - let error, store_result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters - error - agent_type - union_array - store_result - in error, store_result - ) map.stochastic_class stochastic_class - in error, store_result - ) rules init - in error, stochastic_class + let error, array = + match get_array with + | None -> + Ckappa_sig.Site_union_find.create parameters error + (Ckappa_sig.int_of_site_name nsites) + | Some a -> error, a + in + (*compute the union for the list of site*) + let error, union_array = + Ckappa_sig.Site_union_find.union_list parameters error array + sites_list + in + (*store*) + let error, store_result = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .set parameters error agent_type union_array store_result + in + error, store_result) + map.stochastic_class stochastic_class + in + error, store_result) + rules init + in + error, stochastic_class (************************************************************************) (*PRINT*) @@ -234,34 +196,34 @@ let scan_rule_set parameters error handler rules = let sprintf_array parameters error handler agent_type array = let acc = ref "[|" in let error = - Ckappa_sig.Site_union_find.iteri - parameters error + Ckappa_sig.Site_union_find.iteri parameters error (fun parameters error i site_type -> - let error, site_string = - try - Handler.string_of_site parameters error handler agent_type site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let _ = - acc := !acc ^ (* avoid this, this is very slow, Use Printf.fprintf directly *) - if Ckappa_sig.compare_site_name i Ckappa_sig.dummy_site_name - <> 0 - then Printf.sprintf "; %s:%s" - (Ckappa_sig.string_of_site_name site_type) - site_string - else - Printf.sprintf "%s:%s" - (Ckappa_sig.string_of_site_name site_type) - site_string - in - error - ) array in - error, - !acc ^ "|]" + let error, site_string = + try + Handler.string_of_site parameters error handler agent_type site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_type) + in + let _ = + acc := + !acc + ^ + (* avoid this, this is very slow, Use Printf.fprintf directly *) + if Ckappa_sig.compare_site_name i Ckappa_sig.dummy_site_name <> 0 + then + Printf.sprintf "; %s:%s" + (Ckappa_sig.string_of_site_name site_type) + site_string + else + Printf.sprintf "%s:%s" + (Ckappa_sig.string_of_site_name site_type) + site_string + in + error) + array + in + error, !acc ^ "|]" let print_array parameters error handler agent_type array = let error, output = sprintf_array parameters error handler agent_type array in @@ -269,44 +231,36 @@ let print_array parameters error handler agent_type array = error let print_stochastic_class parameters error handler result = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter - parameters + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.iter parameters error (fun parameters error agent_type array_site_type -> - let error = - if Remanent_parameters.get_do_stochastic_flow_of_information parameters - then - let parameters = - Remanent_parameters.update_prefix parameters "" - in - begin - if Remanent_parameters.get_trace parameters - then - let error = - let error, agent_string = - try - Handler.string_of_agent parameters error handler agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - let _ = - Printf.fprintf stdout "agent_type:%s:%s\n" - (Ckappa_sig.string_of_agent_name agent_type) - agent_string - in - error - in - let _ = print_string "site_type:" in - print_array parameters error handler agent_type array_site_type - else error - end - else - error - in - error) + let error = + if Remanent_parameters.get_do_stochastic_flow_of_information parameters + then ( + let parameters = Remanent_parameters.update_prefix parameters "" in + if Remanent_parameters.get_trace parameters then ( + let error = + let error, agent_string = + try Handler.string_of_agent parameters error handler agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + let _ = + Printf.fprintf stdout "agent_type:%s:%s\n" + (Ckappa_sig.string_of_agent_name agent_type) + agent_string + in + error + in + let _ = print_string "site_type:" in + print_array parameters error handler agent_type array_site_type + ) else + error + ) else + error + in + error) result (***************************************************************************) diff --git a/core/KaSa_rep/reachability_analysis/translation_in_natural_language.ml b/core/KaSa_rep/reachability_analysis/translation_in_natural_language.ml index d2a01fb6d1..6cad32707c 100644 --- a/core/KaSa_rep/reachability_analysis/translation_in_natural_language.ml +++ b/core/KaSa_rep/reachability_analysis/translation_in_natural_language.ml @@ -13,43 +13,48 @@ * under the terms of the GNU Library General Public License *) let trace = false - let _ = trace type token = | Range of Ckappa_sig.c_site_name * Ckappa_sig.c_state list - | Equiv of (Ckappa_sig.c_site_name * Ckappa_sig.c_state) * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) - | Imply of (Ckappa_sig.c_site_name * Ckappa_sig.c_state) * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) - | Partition of (Ckappa_sig.c_site_name * (Ckappa_sig.c_state * token list) list) - | No_known_translation of (Ckappa_sig.c_site_name * Ckappa_sig.c_state) list list + | Equiv of + (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + | Imply of + (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + | Partition of + (Ckappa_sig.c_site_name * (Ckappa_sig.c_state * token list) list) + | No_known_translation of + (Ckappa_sig.c_site_name * Ckappa_sig.c_state) list list type rename_sites = - (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - Ckappa_sig.Site_map_and_set.Map.elt -> - Exception.method_handler * Ckappa_sig.Site_map_and_set.Map.elt) + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.Site_map_and_set.Map.elt -> + Exception.method_handler * Ckappa_sig.Site_map_and_set.Map.elt (****************************************************************************) let non_relational parameters handler error mvbdu = let error, handler, list = - Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction parameters handler error mvbdu + Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction parameters handler error + mvbdu in let error, handler, mvbdu_true = Ckappa_sig.Views_bdu.mvbdu_true parameters handler error in let error, handler, recomposition = List.fold_left - (fun (error,handler,conjunct) term -> - Ckappa_sig.Views_bdu.mvbdu_and parameters handler error conjunct term - ) - (error, handler, mvbdu_true) list + (fun (error, handler, conjunct) term -> + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error conjunct term) + (error, handler, mvbdu_true) + list in - error, handler, - Ckappa_sig.Views_bdu.equal mvbdu recomposition + error, handler, Ckappa_sig.Views_bdu.equal mvbdu recomposition let try_partitioning parameters handler error - (rename_site_inverse:rename_sites) mvbdu = + (rename_site_inverse : rename_sites) mvbdu = let error, handler, mvbdu_true = Ckappa_sig.Views_bdu.mvbdu_true parameters handler error in @@ -57,718 +62,643 @@ let try_partitioning parameters handler error Ckappa_sig.Views_bdu.variables_list_of_mvbdu parameters handler error mvbdu in let error, handler, var_list = - Ckappa_sig.Views_bdu.extensional_of_variables_list - parameters handler error var_hconsed_list + Ckappa_sig.Views_bdu.extensional_of_variables_list parameters handler error + var_hconsed_list in let rec aux l (error, handler) = - match - l - with + match l with | [] -> error, handler, None | head :: tail -> let error', handler, singleton = - Ckappa_sig.Views_bdu.build_variables_list - parameters handler error [head] + Ckappa_sig.Views_bdu.build_variables_list parameters handler error + [ head ] in - let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit in let error_2, handler, mvbdu_ref = - Ckappa_sig.Views_bdu.mvbdu_project_abstract_away - parameters handler error mvbdu singleton + Ckappa_sig.Views_bdu.mvbdu_project_abstract_away parameters handler + error mvbdu singleton in - let error = Exception.check_point - Exception.warn parameters error error_2 __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error_2 __POS__ + Exit in let error_3, handler, proj_in = - Ckappa_sig.Views_bdu.mvbdu_project_keep_only - parameters handler error mvbdu singleton + Ckappa_sig.Views_bdu.mvbdu_project_keep_only parameters handler error + mvbdu singleton in - let error = Exception.check_point - Exception.warn parameters error error_3 __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error_3 __POS__ + Exit in let error_4, handler, list_asso = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters handler error proj_in + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler error + proj_in in - let error = Exception.check_point - Exception.warn parameters error error_4 __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error_4 __POS__ + Exit in let error_5, range = let rec aux2 list (error, output) = - match - list - with - | [] -> (error, output) - | [(x, i)] :: tail when x = head -> - aux2 tail (error, (i :: output)) - | _ :: tail ->(*TODO: bdu_ex*) - aux2 tail - (Exception.warn parameters error __POS__ Exit output) - in aux2 list_asso (error, []) + match list with + | [] -> error, output + | [ (x, i) ] :: tail when x = head -> aux2 tail (error, i :: output) + | _ :: tail -> + (*TODO: bdu_ex*) + aux2 tail (Exception.warn parameters error __POS__ Exit output) + in + aux2 list_asso (error, []) in - let error = Exception.check_point - Exception.warn parameters error error_5 __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error_5 __POS__ + Exit in - let rec aux3 list (error,handler,output) = - match - list - with + let rec aux3 list (error, handler, output) = + match list with | [] -> error, handler, Some output | h :: t -> - begin - let error_6, handler, select = - Ckappa_sig.Views_bdu.build_association_list - parameters handler error [head, h] - in - let error = Exception.check_point - Exception.warn parameters error error_6 __POS__ Exit - in - let error_7, handler, mvbdu_case = - Ckappa_sig.Views_bdu.mvbdu_redefine - parameters handler error mvbdu_true select - in - let error = Exception.check_point - Exception.warn parameters error error_7 __POS__ Exit - in - let error_8, handler, case = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error mvbdu_case mvbdu - in - let error = Exception.check_point - Exception.warn parameters error error_8 __POS__ Exit - in - let error_9, handler, bool = - non_relational parameters handler error case + let error_6, handler, select = + Ckappa_sig.Views_bdu.build_association_list parameters handler error + [ head, h ] + in + let error = + Exception.check_point Exception.warn parameters error error_6 + __POS__ Exit + in + let error_7, handler, mvbdu_case = + Ckappa_sig.Views_bdu.mvbdu_redefine parameters handler error + mvbdu_true select + in + let error = + Exception.check_point Exception.warn parameters error error_7 + __POS__ Exit + in + let error_8, handler, case = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error mvbdu_case + mvbdu + in + let error = + Exception.check_point Exception.warn parameters error error_8 + __POS__ Exit + in + let error_9, handler, bool = + non_relational parameters handler error case + in + let error = + Exception.check_point Exception.warn parameters error error_9 + __POS__ Exit + in + if bool then ( + let error_10, handler, away = + Ckappa_sig.Views_bdu.mvbdu_project_abstract_away parameters + handler error case singleton in - let error = Exception.check_point - Exception.warn parameters error error_9 __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error_10 + __POS__ Exit in - if bool - then - let error_10, handler, away = - Ckappa_sig.Views_bdu.mvbdu_project_abstract_away - parameters handler error case singleton + if Ckappa_sig.Views_bdu.equal away mvbdu_ref then + aux3 t (error, handler, output) + else ( + let error_11, handler, list = + Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction parameters + handler error away in - let error = Exception.check_point - Exception.warn parameters error error_10 __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error_11 + __POS__ Exit in - if - Ckappa_sig.Views_bdu.equal - away mvbdu_ref - then - aux3 t (error, handler, output) - else - let error_11, handler, list = - Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction - parameters handler error away - in - let error = Exception.check_point - Exception.warn parameters error error_11 __POS__ Exit - in - let error, handler, list = - List.fold_left - (fun (error, handler, list) elt -> - let error, handler, mvbdu_test = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error - mvbdu_ref elt - in - if Ckappa_sig.Views_bdu.equal - mvbdu_test mvbdu_ref - then error, handler, list - else - let error_12, handler, elt = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters handler error elt - in - let error = - Exception.check_point - Exception.warn parameters error error_12 - __POS__ Exit - in - begin - let error, var_list_opt = - match - elt - with - | [] | [] :: _ | ((_, _) :: _ :: _) :: _ -> - error, None - | [(a, b)] :: q -> - begin - let rec aux4 q output = - match q with - | [] -> error, Some (a, output) - | [(c, d)] :: q when c = a -> - aux4 q (d :: output) - | _ -> error, None - in aux4 q [b] - end - in - match var_list_opt with - | None -> - let error, () = - Exception.warn - parameters error __POS__ Exit () - in - error, handler, list - | Some (a, l) -> - let error', a' = - rename_site_inverse parameters error a - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - (error, handler, ((Range (a', l)) :: list)) - end) - (error, handler, []) - (List.rev list) - in - aux3 t (error, handler, ((h, list) :: output)) - else - error, handler, None - end + let error, handler, list = + List.fold_left + (fun (error, handler, list) elt -> + let error, handler, mvbdu_test = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error + mvbdu_ref elt + in + if Ckappa_sig.Views_bdu.equal mvbdu_test mvbdu_ref then + error, handler, list + else ( + let error_12, handler, elt = + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters + handler error elt + in + let error = + Exception.check_point Exception.warn parameters error + error_12 __POS__ Exit + in + let error, var_list_opt = + match elt with + | [] | [] :: _ | ((_, _) :: _ :: _) :: _ -> error, None + | [ (a, b) ] :: q -> + let rec aux4 q output = + match q with + | [] -> error, Some (a, output) + | [ (c, d) ] :: q when c = a -> aux4 q (d :: output) + | _ -> error, None + in + aux4 q [ b ] + in + match var_list_opt with + | None -> + let error, () = + Exception.warn parameters error __POS__ Exit () + in + error, handler, list + | Some (a, l) -> + let error', a' = + rename_site_inverse parameters error a + in + let error = + Exception.check_point Exception.warn parameters error + error' __POS__ Exit + in + error, handler, Range (a', l) :: list + )) + (error, handler, []) (List.rev list) + in + aux3 t (error, handler, (h, list) :: output) + ) + ) else + error, handler, None in let error_13, handler, output = aux3 range (error, handler, []) in let error = - Exception.check_point - Exception.warn parameters error error_13 __POS__ Exit + Exception.check_point Exception.warn parameters error error_13 __POS__ + Exit in - match output with + (match output with | None -> aux tail (error, handler) | Some l -> let error_14, head = rename_site_inverse parameters error head in - let error = Exception.check_point - Exception.warn parameters error error_14 __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error_14 __POS__ + Exit in - error, handler, Some (head, l) + error, handler, Some (head, l)) in aux var_list (error, handler) (****************************************************************************) -let translate parameters handler error (rename_site_inverse: rename_sites) +let translate parameters handler error (rename_site_inverse : rename_sites) mvbdu = let error, handler, list = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters handler error mvbdu + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler error mvbdu in let error, list = List.fold_left (fun (error, list) elt1 -> - let error, elt1 = - List.fold_left - (fun (error, list) (elt2, asso) -> - let error, elt2 = rename_site_inverse parameters error elt2 in - error, (elt2, asso) :: list - ) - (error, []) (List.rev elt1) - in - error, elt1::list) - (error, []) - (List.rev list) + let error, elt1 = + List.fold_left + (fun (error, list) (elt2, asso) -> + let error, elt2 = rename_site_inverse parameters error elt2 in + error, (elt2, asso) :: list) + (error, []) (List.rev elt1) + in + error, elt1 :: list) + (error, []) (List.rev list) in - if Remanent_parameters.get_post_processing parameters - then - begin - let error, handler, vars = - Ckappa_sig.Views_bdu.variables_list_of_mvbdu - parameters handler error mvbdu - in - let error, handler, var_list = - Ckappa_sig.Views_bdu.extensional_of_variables_list - parameters handler error vars - in - let error, var_list = + if Remanent_parameters.get_post_processing parameters then ( + let error, handler, vars = + Ckappa_sig.Views_bdu.variables_list_of_mvbdu parameters handler error + mvbdu + in + let error, handler, var_list = + Ckappa_sig.Views_bdu.extensional_of_variables_list parameters handler + error vars + in + let error, var_list = + List.fold_left + (fun (error, list) elt -> + let error, elt = rename_site_inverse parameters error elt in + error, elt :: list) + (error, []) (List.rev var_list) + in + match var_list with + | [] -> + error, (handler, No_known_translation list) + (* OK if the agent + has no sites *) + | [ x ] -> + let error, list = List.fold_left (fun (error, list) elt -> - let error, elt = rename_site_inverse parameters error elt in - error, elt::list) - (error, []) - (List.rev var_list) + match elt with + | [ (a, b) ] when a = x -> error, b :: list + | _ -> Exception.warn parameters error __POS__ Exit list) + (error, []) list in - match var_list with - | [] -> error, (handler, No_known_translation list) (* OK if the agent - has no sites *) - | [x] -> - let error, list = - List.fold_left - (fun (error, list) elt -> - match elt with - | [a, b] when a = x -> error, b :: list - | _ -> - Exception.warn - parameters error __POS__ Exit list) - (error, []) - list - in - error, (handler, Range (x, list)) - | [_; _] -> - begin - match list with - | [] | [_] -> - Exception.warn - parameters error __POS__ Exit - (handler, No_known_translation list) - | [[site1,state1; site2,state2]; [site1',state1'; site2',state2']] -> - begin - if site1 = site1' && site2 = site2' - then - if state1 > state1' - then - error, (handler, Equiv ((site1, state1), (site2, state2))) - else - error, (handler, Equiv ((site1, state1'), (site2, state2'))) - else - Exception.warn - parameters error __POS__ Exit - (handler, No_known_translation list) - end - | [[site1,state1; site2,state2]; - [site1',state1'; site2',state2']; - [site1'',state1'';site2'',state2'']] -> - begin - if site1 = site1' && site1 = site1'' && site2 = site2' && site2 = site2'' - then - if state1 = state1' - then - if state1 < state1'' - then error, - (handler, Imply ((site1, state1''), (site2, state2''))) - else error, - (handler, Imply ((site2, - if state2 = state2'' - then state2' - else state2) - , ((site1, state1)))) - else if state1 = state1'' - then - if state1 < state1' - then error, - (handler, Imply ((site1, state1'),(site2, state2'))) - else error, - (handler, Imply ((site2, - if state2 = state2' - then state2'' - else state2) - , (site1, state1))) - else if state1' = state1'' - then - if state1' < state1 - then - error, (handler, Imply ((site1, state1),(site2, state2))) - else - error, - (handler, Imply ((site2, - if state2 = state2'' - then state2' - else state2'') - , (site1, state1'))) - else error, (handler, No_known_translation list) - else - Exception.warn - parameters error __POS__ Exit - (handler, No_known_translation list) - end - | _ -> - begin - let error, handler, output = - try_partitioning - parameters - handler - error - rename_site_inverse - mvbdu - in - match - output - with - | None -> error, (handler, No_known_translation list) - | Some (var, l) -> - error, - (handler, - Partition ( - var, - l)) - end - end + error, (handler, Range (x, list)) + | [ _; _ ] -> + (match list with + | [] | [ _ ] -> + Exception.warn parameters error __POS__ Exit + (handler, No_known_translation list) + | [ + [ (site1, state1); (site2, state2) ]; + [ (site1', state1'); (site2', state2') ]; + ] -> + if site1 = site1' && site2 = site2' then + if state1 > state1' then + error, (handler, Equiv ((site1, state1), (site2, state2))) + else + error, (handler, Equiv ((site1, state1'), (site2, state2'))) + else + Exception.warn parameters error __POS__ Exit + (handler, No_known_translation list) + | [ + [ (site1, state1); (site2, state2) ]; + [ (site1', state1'); (site2', state2') ]; + [ (site1'', state1''); (site2'', state2'') ]; + ] -> + if + site1 = site1' && site1 = site1'' && site2 = site2' && site2 = site2'' + then + if state1 = state1' then + if state1 < state1'' then + error, (handler, Imply ((site1, state1''), (site2, state2''))) + else + ( error, + ( handler, + Imply + ( ( site2, + if state2 = state2'' then + state2' + else + state2 ), + (site1, state1) ) ) ) + else if state1 = state1'' then + if state1 < state1' then + error, (handler, Imply ((site1, state1'), (site2, state2'))) + else + ( error, + ( handler, + Imply + ( ( site2, + if state2 = state2' then + state2'' + else + state2 ), + (site1, state1) ) ) ) + else if state1' = state1'' then + if state1' < state1 then + error, (handler, Imply ((site1, state1), (site2, state2))) + else + ( error, + ( handler, + Imply + ( ( site2, + if state2 = state2'' then + state2' + else + state2'' ), + (site1, state1') ) ) ) + else + error, (handler, No_known_translation list) + else + Exception.warn parameters error __POS__ Exit + (handler, No_known_translation list) | _ -> - begin - let error, handler, output = - try_partitioning parameters handler error rename_site_inverse mvbdu - in - match - output - with - | None -> error, (handler, No_known_translation list) - | Some (var, l) -> - error, - (handler, - Partition (var, l)) - end - end - else + let error, handler, output = + try_partitioning parameters handler error rename_site_inverse mvbdu + in + (match output with + | None -> error, (handler, No_known_translation list) + | Some (var, l) -> error, (handler, Partition (var, l)))) + | _ -> + let error, handler, output = + try_partitioning parameters handler error rename_site_inverse mvbdu + in + (match output with + | None -> error, (handler, No_known_translation list) + | Some (var, l) -> error, (handler, Partition (var, l))) + ) else error, (handler, No_known_translation list) (*****************************************************************************) -let rec print ?beginning_of_sentence:(beggining=true) - ?prompt_agent_type:(prompt_agent_type=true) ?html_mode:(html_mode=false) +let rec print ?beginning_of_sentence:(beggining = true) + ?(prompt_agent_type = true) ?(html_mode = false) ~show_dep_with_dimmension_higher_than:dim_min parameters handler_kappa error agent_string agent_type agent_id translation t = - let tab = if html_mode then "
" else "\t" in - let endofline = if html_mode then "
\n" else "\n" in - let beginenumeration = if html_mode then "
    \n" else "" in - let endenumeration = if html_mode then "
\n" else "" in - let beginenum = if html_mode then "
  • " else "+" in - let endenum = if html_mode then "
    • \n" else "" in - let cap s = if beggining then Tools.capitalize s else s in - let in_agent s = if prompt_agent_type then "in agent "^s^" " else "" in - let in_agent_comma s = if prompt_agent_type then "in agent "^s^", " else "" in + let tab = + if html_mode then + "
    " + else + "\t" + in + let endofline = + if html_mode then + "
    \n" + else + "\n" + in + let beginenumeration = + if html_mode then + "
      \n" + else + "" + in + let endenumeration = + if html_mode then + "
    \n" + else + "" + in + let beginenum = + if html_mode then + "
  • " + else + "+" + in + let endenum = + if html_mode then + "
    • \n" + else + "" + in + let cap s = + if beggining then + Tools.capitalize s + else + s + in + let in_agent s = + if prompt_agent_type then + "in agent " ^ s ^ " " + else + "" + in + let in_agent_comma s = + if prompt_agent_type then + "in agent " ^ s ^ ", " + else + "" + in let log = Remanent_parameters.get_logger parameters in let error, () = - match - translation - with + match translation with | Range (site_type, state_list) -> - begin - if dim_min <= 1 - then - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - let error, t = - Site_graphs.KaSa_site_graph.add_site - parameters error handler_kappa - agent_id - site_type - t + if dim_min <= 1 then ( + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error, t = + Site_graphs.KaSa_site_graph.add_site parameters error handler_kappa + agent_id site_type t + in + let error = + Site_graphs.KaSa_site_graph.print log parameters error t + in + let () = Loggers.fprintf log " => " in + let should_use_bracket = + match state_list with + | [] | [ _ ] -> false + | _ :: _ -> true + in + let () = if should_use_bracket then Loggers.fprintf log "[ " in + let error, _bool = + List.fold_left + (fun (error, bool) state -> + let () = if bool then Loggers.fprintf log " v " in + let error, t = + Site_graphs.KaSa_site_graph.add_state parameters error + handler_kappa agent_id site_type state t + in + let error = + Site_graphs.KaSa_site_graph.print log parameters error t + in + error, true) + (error, false) state_list + in + let () = if should_use_bracket then Loggers.fprintf log " ]" in + let () = Loggers.print_newline log in + error, () + | Remanent_parameters_sig.Natural_language -> + let error', site_string = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type site_type + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let rec aux list error = + match list with + | [] -> Exception.warn parameters error __POS__ Exit () + | [ state ] -> + let error', state_string = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type site_type state in let error = - Site_graphs.KaSa_site_graph.print - log - parameters error - t - in - let () = - Loggers.fprintf log " => " - in - let should_use_bracket = - match - state_list - with - | [] | [_] -> false - | _::_ -> true - in - let () = - if - should_use_bracket - then - Loggers.fprintf log "[ " - in - let error, _bool = - List.fold_left - (fun (error, bool) state -> - let () = - if bool then - Loggers.fprintf log " v " - in - let error, t = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id site_type state t - in - let error = - Site_graphs.KaSa_site_graph.print - log parameters error - t - in - error, true) - (error, false) state_list - in - let () = - if - should_use_bracket - then - Loggers.fprintf log " ]" + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in - let () = Loggers.print_newline log in - error, () - | Remanent_parameters_sig.Natural_language -> - let error', site_string = - Handler.string_of_site_in_natural_language parameters error handler_kappa - agent_type - site_type + error, Loggers.fprintf log " and %s.%s" state_string endofline + | state :: tail -> + let error', state_string = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type site_type state in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let rec aux list error = - match list - with - | [] -> - Exception.warn parameters error __POS__ Exit () - | [state] -> - let error', state_string = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site_type - state - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - error, Loggers.fprintf log - " and %s.%s" state_string endofline - | state :: tail -> - let error', state_string = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site_type - state - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let () = - Loggers.fprintf log " %s," state_string - in - aux tail error + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in - match - state_list - with - | [] -> Exception.warn parameters error __POS__ Exit () - | [state] -> - let error', state_string = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site_type - state - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - error, - Loggers.fprintf - log - "%s%s %sis always %s.%s" - (Remanent_parameters.get_prefix parameters) - (cap site_string) - (in_agent agent_string) - state_string endofline - | [state1; state2] -> - let error', state_string1 = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site_type - state1 - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error', state_string2 = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site_type - state2 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error, Loggers.fprintf log - "%s%s %sranges over %s and %s.%s" - (Remanent_parameters.get_prefix parameters) - (cap site_string) - (in_agent agent_string) - state_string1 - state_string2 endofline - | list -> - let () = Loggers.fprintf log - "%s%s %sranges over" - (Remanent_parameters.get_prefix parameters) - (cap site_string) - (in_agent agent_string) - in - aux list error - end - else error,() - end - | Equiv ((site1,state1),(site2,state2)) -> - if dim_min <= 2 - then - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - let error, t' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id site1 state1 t - in - let error, t'' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id site2 state2 t - in - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - t' - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) " <=> " in - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - t'' - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - error, () - | Remanent_parameters_sig.Natural_language -> - let error', site_string1 = - Handler.string_of_site_in_natural_language parameters error handler_kappa - agent_type - site1 + let () = Loggers.fprintf log " %s," state_string in + aux tail error + in + (match state_list with + | [] -> Exception.warn parameters error __POS__ Exit () + | [ state ] -> + let error', state_string = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type site_type state in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in + ( error, + Loggers.fprintf log "%s%s %sis always %s.%s" + (Remanent_parameters.get_prefix parameters) + (cap site_string) (in_agent agent_string) state_string endofline + ) + | [ state1; state2 ] -> let error', state_string1 = Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site1 - state1 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let error', site_string2 = - Handler.string_of_site_in_natural_language - parameters error handler_kappa - agent_type site2 + handler_kappa agent_type site_type state1 in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in let error', state_string2 = Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site2 - state2 + handler_kappa agent_type site_type state2 in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit in - error, + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + ( error, + Loggers.fprintf log "%s%s %sranges over %s and %s.%s" + (Remanent_parameters.get_prefix parameters) + (cap site_string) (in_agent agent_string) state_string1 + state_string2 endofline ) + | list -> + let () = + Loggers.fprintf log "%s%s %sranges over" + (Remanent_parameters.get_prefix parameters) + (cap site_string) (in_agent agent_string) + in + aux list error) + ) else + error, () + | Equiv ((site1, state1), (site2, state2)) -> + if dim_min <= 2 then ( + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error, t' = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site1 state1 t + in + let error, t'' = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site2 state2 t + in + let error = + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error t' + in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) " <=> " + in + let error = + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error t'' + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error, () + | Remanent_parameters_sig.Natural_language -> + let error', site_string1 = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type site1 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error', state_string1 = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type site1 state1 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error', site_string2 = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type site2 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error', state_string2 = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type site2 state2 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + ( error, Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%s%s is %s, if and only if, %s is %s.%s" (Remanent_parameters.get_prefix parameters) (cap (in_agent_comma agent_string)) - site_string1 state_string1 site_string2 state_string2 endofline - end - else - error,() - | Imply ((site1,state1),(site2,state2)) -> - if dim_min <= 2 - then - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - let error, t = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id site1 state1 t - in - let error, t' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id site2 state2 t - in - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - t - in - let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) " => " in - let error = - Site_graphs.KaSa_site_graph.print - (Remanent_parameters.get_logger parameters) parameters error - t' - in - let () = - Loggers.print_newline (Remanent_parameters.get_logger parameters) - in - error, () - | Remanent_parameters_sig.Natural_language -> - let error', site_string1 = - Handler.string_of_site_in_natural_language - parameters error handler_kappa agent_type - site1 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let error', state_string1 = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site1 - state1 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let error', site_string2 = - Handler.string_of_site_in_natural_language - parameters error handler_kappa agent_type - site2 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - let error', state_string2 = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type - site2 - state2 - in - let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit - in - error, - Loggers.fprintf (Remanent_parameters.get_logger parameters) + site_string1 state_string1 site_string2 state_string2 endofline ) + ) else + error, () + | Imply ((site1, state1), (site2, state2)) -> + if dim_min <= 2 then ( + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error, t = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site1 state1 t + in + let error, t' = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site2 state2 t + in + let error = + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error t + in + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) " => " + in + let error = + Site_graphs.KaSa_site_graph.print + (Remanent_parameters.get_logger parameters) + parameters error t' + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + error, () + | Remanent_parameters_sig.Natural_language -> + let error', site_string1 = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type site1 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error', state_string1 = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type site1 state1 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error', site_string2 = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type site2 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + let error', state_string2 = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type site2 state2 + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + ( error, + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "%s%s%s is %s whenever %s is %s.%s" (Remanent_parameters.get_prefix parameters) (cap (in_agent_comma agent_string)) - site_string2 state_string2 site_string1 state_string1 endofline - end - else - error,() + site_string2 state_string2 site_string1 state_string1 endofline ) + ) else + error, () | Partition (v, list) -> (*let () = Loggers.fprintf log @@ -776,227 +706,180 @@ let rec print ?beginning_of_sentence:(beggining=true) (cap (in_agent_colon agent_string)) endofline in*) let error, site_string = - Handler.string_of_site_in_natural_language parameters error handler_kappa agent_type - v + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type v in let parameters = Remanent_parameters.update_prefix parameters tab in let error = List.fold_left - (fun error (a,list) -> - let error, parameters = - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Natural_language -> - let error, state_string = - Handler.string_of_state_fully_deciphered - parameters error handler_kappa agent_type - v a - in - let () = Loggers.fprintf log - "%swhen %s is equal to %s, then:%s%s" - (Remanent_parameters.get_prefix parameters) - site_string state_string endofline beginenumeration - in - let parameters = - Remanent_parameters.update_prefix parameters (tab ^ beginenum ^ " ") - in - error, parameters - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - error, parameters - in - let error, t' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id v a t - in - let error = - List.fold_left - (fun error token -> - let error = - print - ~beginning_of_sentence:false - ~prompt_agent_type:false - ~html_mode - ~show_dep_with_dimmension_higher_than:0 - parameters - handler_kappa - error - agent_string - agent_type - agent_id - token - t' - in - let () = Loggers.fprintf log "%s" endenum in - error) - error list - in - let () = - Loggers.fprintf log "%s" endenumeration - in - error) - error list - in error,() - | No_known_translation list -> - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - begin - let error = - Site_graphs.KaSa_site_graph.print - log parameters error - t + (fun error (a, list) -> + let error, parameters = + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Natural_language -> + let error, state_string = + Handler.string_of_state_fully_deciphered parameters error + handler_kappa agent_type v a + in + let () = + Loggers.fprintf log "%swhen %s is equal to %s, then:%s%s" + (Remanent_parameters.get_prefix parameters) + site_string state_string endofline beginenumeration + in + let parameters = + Remanent_parameters.update_prefix parameters + (tab ^ beginenum ^ " ") + in + error, parameters + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + error, parameters in - let prefix =" " in - let () = - Loggers.fprintf log " =>\n%s[\n" prefix + let error, t' = + Site_graphs.KaSa_site_graph.add_state parameters error + handler_kappa agent_id v a t in - let prefix' = prefix in - let prefix ="\t" in - let error, _bool = + let error = List.fold_left - (fun (error, bool) state_list -> - let () = - Loggers.fprintf log - "%s%s" prefix (if bool then "v " else " ") - in - let error, t' = - List.fold_left - (fun (error,t) (site,state) -> - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id site state t) - (error, t) - state_list - in - let error = - Site_graphs.KaSa_site_graph.print - log parameters error - t' - in - let () = Loggers.print_newline log in - (error,true) - ) - (error, false) - list + (fun error token -> + let error = + print ~beginning_of_sentence:false ~prompt_agent_type:false + ~html_mode ~show_dep_with_dimmension_higher_than:0 + parameters handler_kappa error agent_string agent_type + agent_id token t' + in + let () = Loggers.fprintf log "%s" endenum in + error) + error list in + let () = Loggers.fprintf log "%s" endenumeration in + error) + error list + in + error, () + | No_known_translation list -> + (match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error = Site_graphs.KaSa_site_graph.print log parameters error t in + let prefix = " " in + let () = Loggers.fprintf log " =>\n%s[\n" prefix in + let prefix' = prefix in + let prefix = "\t" in + let error, _bool = + List.fold_left + (fun (error, bool) state_list -> + let () = + Loggers.fprintf log "%s%s" prefix + (if bool then + "v " + else + " ") + in + let error, t' = + List.fold_left + (fun (error, t) (site, state) -> + Site_graphs.KaSa_site_graph.add_state parameters error + handler_kappa agent_id site state t) + (error, t) state_list + in + let error = + Site_graphs.KaSa_site_graph.print log parameters error t' + in + let () = Loggers.print_newline log in + error, true) + (error, false) list + in + let () = Loggers.fprintf log "%s]\n" prefix' in + error, () + | Remanent_parameters_sig.Natural_language -> + (match list with + | [] -> error, () + | head :: _ -> + let n = List.length head in + if n >= dim_min then ( let () = - Loggers.fprintf log "%s]\n" prefix' - in error, () - end - | Remanent_parameters_sig.Natural_language -> - begin - match list with - | [] -> error, () - | head :: _ -> - let n = List.length head in - if n >= dim_min - then - let () = - Loggers.fprintf log "%s%s" - (Remanent_parameters.get_prefix parameters) - (cap (in_agent_comma agent_string)) - in - let error,() = - let rec aux l error = - match - l - with - | [a, _] -> - let error, string = - Handler.string_of_site_in_natural_language - parameters error handler_kappa agent_type a - in - let () = - Loggers.fprintf log - ", and %s, " string - in - error,() - | [] -> - Exception.warn parameters error __POS__ Exit () - | (a, _) :: b -> - let error, string = - Handler.string_of_site_in_natural_language - parameters error handler_kappa agent_type a - in - let () = - Loggers.fprintf log ", %s" string - in - aux b error + Loggers.fprintf log "%s%s" + (Remanent_parameters.get_prefix parameters) + (cap (in_agent_comma agent_string)) + in + let error, () = + let rec aux l error = + match l with + | [ (a, _) ] -> + let error, string = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type a in - match - head - with - | [] | [_] -> - Exception.warn parameters error __POS__ Exit () - | (a , _) :: b -> - let error, string = - Handler.string_of_site_in_natural_language - parameters error handler_kappa agent_type - a - in - let () = - Loggers.fprintf log "%s" string - in - aux - b - error - in - let () = Loggers.fprintf log - "are entangled by the following %i-d relationship:%s" n endofline + let () = Loggers.fprintf log ", and %s, " string in + error, () + | [] -> Exception.warn parameters error __POS__ Exit () + | (a, _) :: b -> + let error, string = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type a + in + let () = Loggers.fprintf log ", %s" string in + aux b error + in + match head with + | [] | [ _ ] -> Exception.warn parameters error __POS__ Exit () + | (a, _) :: b -> + let error, string = + Handler.string_of_site_in_natural_language parameters error + handler_kappa agent_type a in - let parameters = Remanent_parameters.update_prefix parameters "\t" in - List.fold_left - (fun error l -> - let error, bool = - List.fold_left - (fun (error, bool) (site_type, state) -> - let error', site_string = - Handler.string_of_site parameters error handler_kappa - agent_type site_type - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - let error', state_string = - Handler.string_of_state_fully_deciphered parameters error - handler_kappa agent_type site_type state - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit in - (*---------------------------------------------*) - let () = - if bool - then Loggers.fprintf log "," - else Loggers.fprintf log - "%s%s(" - (Remanent_parameters.get_prefix parameters) - agent_string - in - let () = Loggers.fprintf log - "%s%s" site_string state_string - in - error,true - ) - (error,false) l - in - (*----------------------------------------------------*) - let () = - if bool - then Loggers.fprintf log ")%s" endofline - in error) - error - list, - () - else - error,() - end - end + let () = Loggers.fprintf log "%s" string in + aux b error + in + let () = + Loggers.fprintf log + "are entangled by the following %i-d relationship:%s" n + endofline + in + let parameters = + Remanent_parameters.update_prefix parameters "\t" + in + ( List.fold_left + (fun error l -> + let error, bool = + List.fold_left + (fun (error, bool) (site_type, state) -> + let error', site_string = + Handler.string_of_site parameters error handler_kappa + agent_type site_type + in + let error = + Exception.check_point Exception.warn parameters error + error' __POS__ Exit + in + let error', state_string = + Handler.string_of_state_fully_deciphered parameters + error handler_kappa agent_type site_type state + in + let error = + Exception.check_point Exception.warn parameters error + error' __POS__ Exit + in + (*---------------------------------------------*) + let () = + if bool then + Loggers.fprintf log "," + else + Loggers.fprintf log "%s%s(" + (Remanent_parameters.get_prefix parameters) + agent_string + in + let () = + Loggers.fprintf log "%s%s" site_string state_string + in + error, true) + (error, false) l + in + (*----------------------------------------------------*) + let () = if bool then Loggers.fprintf log ")%s" endofline in + error) + error list, + () ) + ) else + error, ())) in error @@ -1004,303 +887,219 @@ let rec print ?beginning_of_sentence:(beggining=true) (*TODO:convert views to json*) let rec convert_views_internal_constraints_list_aux - ~show_dep_with_dimmension_higher_than:dim_min - parameters handler_kappa error + ~show_dep_with_dimmension_higher_than:dim_min parameters handler_kappa error agent_string agent_type agent_id translation t current_list = let error, current_list = match translation with | Range (site_type, state_list) -> - begin - if dim_min <= 1 - then - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - (*hyp*) - (*-----------------------------------------------------*) - let error, t = - Site_graphs.KaSa_site_graph.add_site parameters - error handler_kappa agent_id site_type t - in - let error'', refinement = - List.fold_left (fun (error, c_list) state -> - let error', t' = - Site_graphs.KaSa_site_graph.add_state parameters - error handler_kappa agent_id site_type state t - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - error, t' :: c_list - ) (error, []) state_list - in - let lemma = - { - Public_data.hyp = t; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in - let error = - Exception.check_point - Exception.warn parameters error error'' - __POS__ Exit - in - error, current_list - | Remanent_parameters_sig.Natural_language -> - (*let _ = + if dim_min <= 1 then ( + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + (*hyp*) + (*-----------------------------------------------------*) + let error, t = + Site_graphs.KaSa_site_graph.add_site parameters error handler_kappa + agent_id site_type t + in + let error'', refinement = + List.fold_left + (fun (error, c_list) state -> + let error', t' = + Site_graphs.KaSa_site_graph.add_state parameters error + handler_kappa agent_id site_type state t + in + let error = + Exception.check_point Exception.warn parameters error error' + __POS__ Exit + in + error, t' :: c_list) + (error, []) state_list + in + let lemma = { Public_data.hyp = t; Public_data.refinement } in + let current_list = lemma :: current_list in + let error = + Exception.check_point Exception.warn parameters error error'' + __POS__ Exit + in + error, current_list + | Remanent_parameters_sig.Natural_language -> + (*let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "Natural_language\n" in*) - error, current_list - end - else - (*let _ = + error, current_list + ) else + (*let _ = Loggers.fprintf (Remanent_parameters.get_logger parameters) "test\n" in*) - error, current_list - end - | Equiv((site1, state1), (site2, state2)) -> - if dim_min <= 2 - then - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - let error', t' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id - site1 - state1 - t - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - (*--------------------------------------------------*) - let error''', t'' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id - site2 - state2 - t - in - let error = - Exception.check_point - Exception.warn parameters error error''' - __POS__ Exit - in - (*--------------------------------------------------*) - let lemma = - { - Public_data.hyp = t'; - Public_data.refinement = [t''] - } - in - let current_list = lemma :: current_list in - error, List.rev current_list - | Remanent_parameters_sig.Natural_language -> - error, current_list - end - else - error, current_list - | Imply((site1, state1), (site2, state2)) -> - if dim_min <= 2 - then - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - let error', t = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id - site1 - state1 - t - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - (*--------------------------------------------------*) - let error''', t' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id - site2 - state2 - t - in - let error = - Exception.check_point - Exception.warn parameters error error''' - __POS__ Exit - in - (*--------------------------------------------------*) - let lemma = - { - (*Remanent_state.hyp = site_graph ; - Remanent_state.refinement = [site_graph']*) - Public_data.hyp = t; - Public_data.refinement = [t'] - } - in - let current_list = lemma :: current_list in - error, List.rev current_list - | Remanent_parameters_sig.Natural_language -> - error, current_list - end - else - error, current_list + error, current_list + | Equiv ((site1, state1), (site2, state2)) -> + if dim_min <= 2 then ( + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error', t' = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site1 state1 t + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + (*--------------------------------------------------*) + let error''', t'' = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site2 state2 t + in + let error = + Exception.check_point Exception.warn parameters error error''' + __POS__ Exit + in + (*--------------------------------------------------*) + let lemma = + { Public_data.hyp = t'; Public_data.refinement = [ t'' ] } + in + let current_list = lemma :: current_list in + error, List.rev current_list + | Remanent_parameters_sig.Natural_language -> error, current_list + ) else + error, current_list + | Imply ((site1, state1), (site2, state2)) -> + if dim_min <= 2 then ( + match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error', t = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site1 state1 t + in + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in + (*--------------------------------------------------*) + let error''', t' = + Site_graphs.KaSa_site_graph.add_state parameters error handler_kappa + agent_id site2 state2 t + in + let error = + Exception.check_point Exception.warn parameters error error''' + __POS__ Exit + in + (*--------------------------------------------------*) + let lemma = + { + (*Remanent_state.hyp = site_graph ; + Remanent_state.refinement = [site_graph']*) + Public_data.hyp = t; + Public_data.refinement = [ t' ]; + } + in + let current_list = lemma :: current_list in + error, List.rev current_list + | Remanent_parameters_sig.Natural_language -> error, current_list + ) else + error, current_list | Partition (site_type, list) -> let error, current_list = - List.fold_left (fun (error, current_list) (state, list) -> + List.fold_left + (fun (error, current_list) (state, list) -> let error', t' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id - site_type state t + Site_graphs.KaSa_site_graph.add_state parameters error + handler_kappa agent_id site_type state t in let error = - Exception.check_point - Exception.warn parameters error error' + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error'', current_list = - List.fold_left (fun (error, current_list) token -> + List.fold_left + (fun (error, current_list) token -> convert_views_internal_constraints_list_aux - ~show_dep_with_dimmension_higher_than:0 - parameters - handler_kappa - error - agent_string - agent_type - agent_id - token - t' - current_list - ) (error, current_list) list + ~show_dep_with_dimmension_higher_than:0 parameters + handler_kappa error agent_string agent_type agent_id token + t' current_list) + (error, current_list) list in let error = - Exception.check_point - Exception.warn parameters error error'' + Exception.check_point Exception.warn parameters error error'' __POS__ Exit in (*let _ = - Loggers.fprintf (Remanent_parameters.get_logger parameters) "test1\n" - in*) - error, current_list - ) (error, current_list) list + Loggers.fprintf (Remanent_parameters.get_logger parameters) "test1\n" + in*) + error, current_list) + (error, current_list) list in error, current_list | No_known_translation list -> - begin - match Remanent_parameters.get_backend_mode parameters with - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Raw -> - begin - let error, current_list = - let error'', refinement = - List.fold_left - (fun (error, current_list) state_list -> - let error, t' = - List.fold_left - (fun (error, t') (site, state) -> - let error', t' = - Site_graphs.KaSa_site_graph.add_state - parameters error handler_kappa - agent_id site state t' - in - let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit - in - error, t') - (error, t) state_list - in - let refinement = t' :: current_list in - error, refinement - ) (error, []) list - in - let error = - Exception.check_point - Exception.warn parameters error error'' - __POS__ Exit - in - (*----------------------------------------*) - let lemma = - { - Public_data.hyp = t ; - Public_data.refinement = refinement - } - in - let current_list = lemma :: current_list in - error, current_list - in - error, current_list - end - | Remanent_parameters_sig.Natural_language -> + (match Remanent_parameters.get_backend_mode parameters with + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Raw -> + let error, current_list = + let error'', refinement = + List.fold_left + (fun (error, current_list) state_list -> + let error, t' = + List.fold_left + (fun (error, t') (site, state) -> + let error', t' = + Site_graphs.KaSa_site_graph.add_state parameters error + handler_kappa agent_id site state t' + in + let error = + Exception.check_point Exception.warn parameters error + error' __POS__ Exit + in + error, t') + (error, t) state_list + in + let refinement = t' :: current_list in + error, refinement) + (error, []) list + in + let error = + Exception.check_point Exception.warn parameters error error'' + __POS__ Exit + in + (*----------------------------------------*) + let lemma = { Public_data.hyp = t; Public_data.refinement } in + let current_list = lemma :: current_list in error, current_list - end + in + error, current_list + | Remanent_parameters_sig.Natural_language -> error, current_list) in error, current_list let convert_views_internal_constraints_list - ~show_dep_with_dimmension_higher_than:dim_min - parameters handler_kappa error + ~show_dep_with_dimmension_higher_than:dim_min parameters handler_kappa error agent_string agent_type translation current_list = let t = Site_graphs.KaSa_site_graph.empty in let error', agent_id, t = - Site_graphs.KaSa_site_graph.add_agent - parameters error handler_kappa agent_type t + Site_graphs.KaSa_site_graph.add_agent parameters error handler_kappa + agent_type t in let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ Exit in let error, t = match translation with - | Range (site,_) -> - Site_graphs.KaSa_site_graph.add_site - parameters error handler_kappa - agent_id - site t - | Equiv _ - | Imply _ - | Partition _ - | No_known_translation _ - -> error, t + | Range (site, _) -> + Site_graphs.KaSa_site_graph.add_site parameters error handler_kappa + agent_id site t + | Equiv _ | Imply _ | Partition _ | No_known_translation _ -> error, t in convert_views_internal_constraints_list_aux - ~show_dep_with_dimmension_higher_than:dim_min - parameters handler_kappa - error agent_string agent_type agent_id translation t current_list + ~show_dep_with_dimmension_higher_than:dim_min parameters handler_kappa error + agent_string agent_type agent_id translation t current_list (*****************************************************************************) -let print ?beginning_of_sentence:(beggining=true) ?prompt_agent_type:(prompt_agent_type=true) ?html_mode:(html_mode=false) - ~show_dep_with_dimmension_higher_than:dim_min - parameters handler_kappa error - agent_string agent_type translation - = +let print ?beginning_of_sentence:(beggining = true) ?(prompt_agent_type = true) + ?(html_mode = false) ~show_dep_with_dimmension_higher_than:dim_min + parameters handler_kappa error agent_string agent_type translation = let t = Site_graphs.KaSa_site_graph.empty in let error, id, t = - Site_graphs.KaSa_site_graph.add_agent - parameters error handler_kappa + Site_graphs.KaSa_site_graph.add_agent parameters error handler_kappa agent_type t in - print - ~beginning_of_sentence:beggining - ~prompt_agent_type ~html_mode - ~show_dep_with_dimmension_higher_than:dim_min - parameters handler_kappa error agent_string agent_type id translation t + print ~beginning_of_sentence:beggining ~prompt_agent_type ~html_mode + ~show_dep_with_dimmension_higher_than:dim_min parameters handler_kappa error + agent_string agent_type id translation t diff --git a/core/KaSa_rep/reachability_analysis/translation_in_natural_language.mli b/core/KaSa_rep/reachability_analysis/translation_in_natural_language.mli index 35e021976b..a73d5d8881 100644 --- a/core/KaSa_rep/reachability_analysis/translation_in_natural_language.mli +++ b/core/KaSa_rep/reachability_analysis/translation_in_natural_language.mli @@ -12,39 +12,46 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type token = - | Range of Ckappa_sig.c_site_name * Ckappa_sig.c_state list - | Equiv of (Ckappa_sig.c_site_name * Ckappa_sig.c_state) * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) - | Imply of (Ckappa_sig.c_site_name * Ckappa_sig.c_state) * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) - | Partition of (Ckappa_sig.c_site_name * (Ckappa_sig.c_state * token list) list) - | No_known_translation of (Ckappa_sig.c_site_name * Ckappa_sig.c_state) list list +type token = + | Range of Ckappa_sig.c_site_name * Ckappa_sig.c_state list + | Equiv of + (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + | Imply of + (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + * (Ckappa_sig.c_site_name * Ckappa_sig.c_state) + | Partition of + (Ckappa_sig.c_site_name * (Ckappa_sig.c_state * token list) list) + | No_known_translation of + (Ckappa_sig.c_site_name * Ckappa_sig.c_state) list list type rename_sites = - (Remanent_parameters_sig.parameters -> - Exception.method_handler -> - Ckappa_sig.Site_map_and_set.Map.elt -> - Exception.method_handler * Ckappa_sig.Site_map_and_set.Map.elt) + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + Ckappa_sig.Site_map_and_set.Map.elt -> + Exception.method_handler * Ckappa_sig.Site_map_and_set.Map.elt -val non_relational: +val non_relational : Remanent_parameters_sig.parameters -> Ckappa_sig.Views_bdu.handler -> - Exception.method_handler -> + Exception.method_handler -> Ckappa_sig.Views_bdu.mvbdu -> Exception.method_handler * Ckappa_sig.Views_bdu.handler * bool -val translate: Remanent_parameters_sig.parameters -> +val translate : + Remanent_parameters_sig.parameters -> Ckappa_sig.Views_bdu.handler -> Exception.method_handler -> rename_sites -> Ckappa_sig.Views_bdu.mvbdu -> Exception.method_handler * (Ckappa_sig.Views_bdu.handler * token) -val print: +val print : ?beginning_of_sentence:bool -> ?prompt_agent_type:bool -> ?html_mode:bool -> - show_dep_with_dimmension_higher_than:int - -> Remanent_parameters_sig.parameters -> + show_dep_with_dimmension_higher_than:int -> + Remanent_parameters_sig.parameters -> Cckappa_sig.kappa_handler -> Exception.method_handler -> string -> @@ -54,17 +61,17 @@ val print: val convert_views_internal_constraints_list : show_dep_with_dimmension_higher_than:int -> - Remanent_parameters_sig.parameters -> - Cckappa_sig.kappa_handler -> - Exception.method_handler -> - string -> - Ckappa_sig.c_agent_name -> - token -> - Site_graphs.KaSa_site_graph.t Public_data.lemma list -> - Exception.method_handler * - Site_graphs.KaSa_site_graph.t Public_data.lemma list + Remanent_parameters_sig.parameters -> + Cckappa_sig.kappa_handler -> + Exception.method_handler -> + string -> + Ckappa_sig.c_agent_name -> + token -> + Site_graphs.KaSa_site_graph.t Public_data.lemma list -> + Exception.method_handler + * Site_graphs.KaSa_site_graph.t Public_data.lemma list - (*show_dep_with_dimmension_higher_than:int -> +(*show_dep_with_dimmension_higher_than:int -> Remanent_parameters_sig.parameters -> Cckappa_sig.kappa_handler -> Exception.method_handler -> diff --git a/core/KaSa_rep/reachability_analysis/usual_domains.ml b/core/KaSa_rep/reachability_analysis/usual_domains.ml index 383730c2da..f8dc335f55 100644 --- a/core/KaSa_rep/reachability_analysis/usual_domains.ml +++ b/core/KaSa_rep/reachability_analysis/usual_domains.ml @@ -1,38 +1,22 @@ -type 'a bot_or_not = - | Bot - | Not_bot of 'a - -type maybe_bool = - | Sure_value of bool - | Maybe - -type 'a top_or_not = - | Top - | Not_top of 'a - -type 'a flat_lattice = - | Val of 'a - | Any - | Undefined +type 'a bot_or_not = Bot | Not_bot of 'a +type maybe_bool = Sure_value of bool | Maybe +type 'a top_or_not = Top | Not_top of 'a +type 'a flat_lattice = Val of 'a | Any | Undefined let lub a b = - match - a,b - with - | Undefined,_ -> b - | _,Undefined -> a - | Any, _ | _,Any -> Any - | Val x,Val y when x=y -> a - | Val _,Val _ -> Any + match a, b with + | Undefined, _ -> b + | _, Undefined -> a + | Any, _ | _, Any -> Any + | Val x, Val y when x = y -> a + | Val _, Val _ -> Any let glb_list a b = - match a, b with - | Undefined, _ - | _, Undefined -> Undefined - | Any, Val l - | Val l, Any -> Val l - | Any, Any -> Any - | Val l, Val l' -> - (*get the intersection of list*) - let l = Misc_sa.inter_list (fun a b -> compare a b) l l' in - Val l + match a, b with + | Undefined, _ | _, Undefined -> Undefined + | Any, Val l | Val l, Any -> Val l + | Any, Any -> Any + | Val l, Val l' -> + (*get the intersection of list*) + let l = Misc_sa.inter_list (fun a b -> compare a b) l l' in + Val l diff --git a/core/KaSa_rep/reachability_analysis/usual_domains.mli b/core/KaSa_rep/reachability_analysis/usual_domains.mli index d68e258cce..9dc04afce6 100644 --- a/core/KaSa_rep/reachability_analysis/usual_domains.mli +++ b/core/KaSa_rep/reachability_analysis/usual_domains.mli @@ -1,19 +1,9 @@ -type 'a bot_or_not = - | Bot - | Not_bot of 'a - -type maybe_bool = - | Sure_value of bool - | Maybe - -type 'a top_or_not = - | Top - | Not_top of 'a - -type 'a flat_lattice = - | Val of 'a - | Any - | Undefined +type 'a bot_or_not = Bot | Not_bot of 'a +type maybe_bool = Sure_value of bool | Maybe +type 'a top_or_not = Top | Not_top of 'a +type 'a flat_lattice = Val of 'a | Any | Undefined val lub : 'a flat_lattice -> 'a flat_lattice -> 'a flat_lattice -val glb_list : 'a list flat_lattice -> 'a list flat_lattice -> 'a list flat_lattice + +val glb_list : + 'a list flat_lattice -> 'a list flat_lattice -> 'a list flat_lattice diff --git a/core/KaSa_rep/reachability_analysis/views_domain.ml b/core/KaSa_rep/reachability_analysis/views_domain.ml index 163de232a4..2bffe88973 100644 --- a/core/KaSa_rep/reachability_analysis/views_domain.ml +++ b/core/KaSa_rep/reachability_analysis/views_domain.ml @@ -17,24 +17,20 @@ monolithic domain that collect everything (as in the previous analyzer).*) let domain_name = "View domain" - let local_trace = false -module Domain = -struct - +module Domain = struct (* the type of the struct that contains all static information as in the previous version of the analysis *) - type static_information = - { - global_static_information: Analyzer_headers.global_static_information; - domain_static_information: Bdu_static_views.bdu_analysis_static; - domain_static_information_pattern: - Bdu_static_views.bdu_analysis_static_pattern; - domain_static_information_covering_class: - Covering_classes_type.predicate_covering_classes; - } + type static_information = { + global_static_information: Analyzer_headers.global_static_information; + domain_static_information: Bdu_static_views.bdu_analysis_static; + domain_static_information_pattern: + Bdu_static_views.bdu_analysis_static_pattern; + domain_static_information_covering_class: + Covering_classes_type.predicate_covering_classes; + } (*--------------------------------------------------------------------*) (* put here the type of the struct that contains the rest of the @@ -42,25 +38,22 @@ struct module AgentCV_map_and_set = Covering_classes_type.AgentCV_map_and_set - type local_dynamic_information = - { - fixpoint_result : Ckappa_sig.Views_bdu.mvbdu AgentCV_map_and_set.Map.t; - domain_dynamic_information : Bdu_dynamic_views.bdu_analysis_dynamic; - subviews: unit option ; - ranges: - Ckappa_sig.Views_bdu.mvbdu Wrapped_modules.LoggedIntMap.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t option - ; - separating_edges: - (string * string) list Mods.IntMap.t option ; - transition_system_length: int list option ; - } - - type dynamic_information = - { - local : local_dynamic_information; - global : Analyzer_headers.global_dynamic_information - } + type local_dynamic_information = { + fixpoint_result: Ckappa_sig.Views_bdu.mvbdu AgentCV_map_and_set.Map.t; + domain_dynamic_information: Bdu_dynamic_views.bdu_analysis_dynamic; + subviews: unit option; + ranges: + Ckappa_sig.Views_bdu.mvbdu Wrapped_modules.LoggedIntMap.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t + option; + separating_edges: (string * string) list Mods.IntMap.t option; + transition_system_length: int list option; + } + + type dynamic_information = { + local: local_dynamic_information; + global: Analyzer_headers.global_dynamic_information; + } (*--------------------------------------------------------------------*) (** global static information. @@ -72,37 +65,28 @@ struct (** bdu analysis static in static information*) let set_domain_static domain static = - { - static with - domain_static_information = domain - } + { static with domain_static_information = domain } let _get_domain_static static = static.domain_static_information let set_domain_static_pattern domain static = - { - static with - domain_static_information_pattern = domain - } + { static with domain_static_information_pattern = domain } let get_domain_static_pattern static = static.domain_static_information_pattern let _get_store_proj_bdu_test_restriction_pattern static = - (get_domain_static_pattern - static).Bdu_static_views.store_proj_bdu_test_restriction_pattern + (get_domain_static_pattern static) + .Bdu_static_views.store_proj_bdu_test_restriction_pattern let lift f x = f (get_global_static_information x) - let get_parameter static = lift Analyzer_headers.get_parameter static - let get_kappa_handler static = lift Analyzer_headers.get_kappa_handler static let get_test_modif_map static = lift Analyzer_headers.get_test_modif_map static let get_compil static = lift Analyzer_headers.get_cc_code static - let get_agent_name static = lift Analyzer_headers.get_agent_name static let get_agent_name_from_pattern static = @@ -115,19 +99,24 @@ struct static.domain_static_information_covering_class let get_covering_classes static = - (get_predicate_covering_classes static).Covering_classes_type.store_covering_classes_predicate + (get_predicate_covering_classes static) + .Covering_classes_type.store_covering_classes_predicate let get_list_of_site_type_in_covering_classes static = - (get_predicate_covering_classes static).Covering_classes_type.store_list_of_site_type_in_covering_classes + (get_predicate_covering_classes static) + .Covering_classes_type.store_list_of_site_type_in_covering_classes let get_covering_classes_id static = - (get_predicate_covering_classes static).Covering_classes_type.store_covering_classes_id + (get_predicate_covering_classes static) + .Covering_classes_type.store_covering_classes_id let get_site_correspondence_array static = - (get_predicate_covering_classes static).Covering_classes_type.site_correspondence + (get_predicate_covering_classes static) + .Covering_classes_type.site_correspondence let get_remanent_triple static = - (get_predicate_covering_classes static).Covering_classes_type.store_remanent_triple + (get_predicate_covering_classes static) + .Covering_classes_type.store_remanent_triple (*--------------------------------------------------------------------*) (** global dynamic information*) @@ -135,7 +124,7 @@ struct let get_global_dynamic_information dynamic = dynamic.global let set_global_dynamic_information gdynamic dynamic = - {dynamic with global = gdynamic} + { dynamic with global = gdynamic } (** handler *) let get_mvbdu_handler dynamic = @@ -144,8 +133,9 @@ struct let set_mvbdu_handler handler dynamic = { dynamic with - global = Analyzer_headers.set_mvbdu_handler handler - (get_global_dynamic_information dynamic) + global = + Analyzer_headers.set_mvbdu_handler handler + (get_global_dynamic_information dynamic); } (** profiling *) @@ -155,18 +145,15 @@ struct let set_log_info log_info dynamic = { dynamic with - global = Analyzer_headers.set_log_info log_info - (get_global_dynamic_information dynamic) + global = + Analyzer_headers.set_log_info log_info + (get_global_dynamic_information dynamic); } (** local dynamic information*) let get_local_dynamic_information dynamic = dynamic.local - - let set_local_dynamic_information local dynamic = - { - dynamic with local = local - } + let set_local_dynamic_information local dynamic = { dynamic with local } (** fixpoint result local dynamic information*) let get_fixpoint_result dynamic = @@ -174,20 +161,15 @@ struct let set_fixpoint_result result dynamic = set_local_dynamic_information - { - (get_local_dynamic_information dynamic) with - fixpoint_result = result - } dynamic + { (get_local_dynamic_information dynamic) with fixpoint_result = result } + dynamic - let get_ranges dynamic = - (get_local_dynamic_information dynamic).ranges + let get_ranges dynamic = (get_local_dynamic_information dynamic).ranges let set_ranges ranges dynamic = set_local_dynamic_information - { - (get_local_dynamic_information dynamic) with - ranges = Some ranges - } dynamic + { (get_local_dynamic_information dynamic) with ranges = Some ranges } + dynamic let get_separating_transitions dynamic = (get_local_dynamic_information dynamic).separating_edges @@ -196,15 +178,17 @@ struct set_local_dynamic_information { (get_local_dynamic_information dynamic) with - separating_edges = Some sep_edges - } dynamic + separating_edges = Some sep_edges; + } + dynamic let set_transition_system_length lengths dynamic = set_local_dynamic_information { (get_local_dynamic_information dynamic) with - transition_system_length = Some lengths - } dynamic + transition_system_length = Some lengths; + } + dynamic (** bdu analysis dynamic in local dynamic information*) let get_domain_dynamic_information dynamic = @@ -214,11 +198,13 @@ struct set_local_dynamic_information { (get_local_dynamic_information dynamic) with - domain_dynamic_information = domain - } dynamic + domain_dynamic_information = domain; + } + dynamic let get_store_dual_contact_map dynamic = - (get_domain_dynamic_information dynamic).Bdu_dynamic_views.store_dual_contact_map + (get_domain_dynamic_information dynamic) + .Bdu_dynamic_views.store_dual_contact_map (****************************************************************) @@ -229,67 +215,57 @@ struct (**get type bdu_analysis_dynamic*) let get_store_proj_bdu_test_restriction static error = - let error, result_static = - get_bdu_analysis_static static error - in + let error, result_static = get_bdu_analysis_static static error in error, result_static.Bdu_static_views.store_proj_bdu_test_restriction let get_store_proj_bdu_creation_restriction static error = - let error, result_static = - get_bdu_analysis_static static error - in - error, - result_static.Bdu_static_views.store_proj_bdu_creation_restriction_map + let error, result_static = get_bdu_analysis_static static error in + ( error, + result_static.Bdu_static_views.store_proj_bdu_creation_restriction_map ) let get_store_proj_bdu_potential_restriction static error = - let error, result_static = - get_bdu_analysis_static static error - in - error, - result_static.Bdu_static_views.store_proj_bdu_potential_restriction_map + let error, result_static = get_bdu_analysis_static static error in + ( error, + result_static.Bdu_static_views.store_proj_bdu_potential_restriction_map ) let get_store_modif_list_restriction_map static error = - let error, result_static = - get_bdu_analysis_static static error - in + let error, result_static = get_bdu_analysis_static static error in error, result_static.Bdu_static_views.store_modif_list_restriction_map let get_site_to_renamed_site_list static error = - let error, result_static = - get_bdu_analysis_static static error - in + let error, result_static = get_bdu_analysis_static static error in error, result_static.Bdu_static_views.site_to_renamed_site_list (*--------------------------------------------------------------------*) type 'a zeroary = - static_information - -> dynamic_information - -> Exception.method_handler - -> Exception.method_handler * dynamic_information * 'a + static_information -> + dynamic_information -> + Exception.method_handler -> + Exception.method_handler * dynamic_information * 'a type ('a, 'b) unary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> Exception.method_handler * dynamic_information * 'b + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + Exception.method_handler * dynamic_information * 'b type ('a, 'b, 'c) binary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> Exception.method_handler * dynamic_information * 'c + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * dynamic_information * 'c type ('a, 'b, 'c, 'd) ternary = - static_information - -> dynamic_information - -> Exception.method_handler - -> 'a - -> 'b - -> 'c - -> Exception.method_handler * dynamic_information * 'd + static_information -> + dynamic_information -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * dynamic_information * 'd (*----------------------------------------------------------------------*) (*Instantiate of functions that store the static and dynamic information @@ -300,24 +276,18 @@ struct let parameters = get_parameter global_static in let handler_bdu = get_mvbdu_handler dynamic in let error, handler_bdu, bdu_false = - Ckappa_sig.Views_bdu.mvbdu_false - parameters handler_bdu error + Ckappa_sig.Views_bdu.mvbdu_false parameters handler_bdu error in - error, - set_mvbdu_handler handler_bdu dynamic, - bdu_false + error, set_mvbdu_handler handler_bdu dynamic, bdu_false (** the initial build for mvbdu_true*) let get_mvbdu_true global_static dynamic error = let parameters = get_parameter global_static in let handler_bdu = get_mvbdu_handler dynamic in let error, handler_bdu, bdu_true = - Ckappa_sig.Views_bdu.mvbdu_true - parameters handler_bdu error + Ckappa_sig.Views_bdu.mvbdu_true parameters handler_bdu error in - error, - set_mvbdu_handler handler_bdu dynamic, - bdu_true + error, set_mvbdu_handler handler_bdu dynamic, bdu_true (**************************************************************************) (** [scan_rule_set static] *) @@ -331,15 +301,8 @@ struct let log_info = get_log_info dynamic in let remanent_triple = get_remanent_triple static in let error, (handler_bdu, log_info, result) = - Bdu_static_views.scan_rule_set - parameters - log_info - handler_bdu - error - kappa_handler - compiled - potential_side_effects - remanent_triple + Bdu_static_views.scan_rule_set parameters log_info handler_bdu error + kappa_handler compiled potential_side_effects remanent_triple in let dynamic = set_log_info log_info dynamic in let dynamic = set_mvbdu_handler handler_bdu dynamic in @@ -348,10 +311,7 @@ struct (*pattern*) (*-----------------------------------------------------------------------*) let error, result = - Bdu_static_views.scan_rule_set_pattern - parameters - error - remanent_triple + Bdu_static_views.scan_rule_set_pattern parameters error remanent_triple compiled in let static = set_domain_static_pattern result static in @@ -368,17 +328,9 @@ struct let potential_side_effects = get_potential_side_effects static in let log_info = get_log_info dynamic in let error, (handler_bdu, log_info, store_result) = - Bdu_dynamic_views.scan_rule_set_dynamic - parameters - log_info - error - compiled - kappa_handler - handler_bdu - store_test_modif_map - covering_classes - covering_classes_id - potential_side_effects + Bdu_dynamic_views.scan_rule_set_dynamic parameters log_info error compiled + kappa_handler handler_bdu store_test_modif_map covering_classes + covering_classes_id potential_side_effects in let dynamic = set_log_info log_info dynamic in let dynamic = set_mvbdu_handler handler_bdu dynamic in @@ -390,9 +342,9 @@ struct let initialize static dynamic error = let parameters = Analyzer_headers.get_parameter static in let log_info = Analyzer_headers.get_log_info dynamic in - let error, log_info = StoryProfiling.StoryStats.add_event parameters error - (StoryProfiling.Domain_initialization domain_name) - None log_info + let error, log_info = + StoryProfiling.StoryStats.add_event parameters error + (StoryProfiling.Domain_initialization domain_name) None log_info in let compil = Analyzer_headers.get_cc_code static in let handler_kappa = Analyzer_headers.get_kappa_handler static in @@ -404,7 +356,8 @@ struct Bdu_static_views.init_bdu_analysis_static_pattern in let error, init_covering_class = - Covering_classes_main.scan_predicate_covering_classes parameters error handler_kappa compil + Covering_classes_main.scan_predicate_covering_classes parameters error + handler_kappa compil in let init_global_static = { @@ -415,7 +368,8 @@ struct } in let init_fixpoint = AgentCV_map_and_set.Map.empty in - let init_bdu_analysis_dynamic = Bdu_dynamic_views.init_bdu_analysis_dynamic + let init_bdu_analysis_dynamic = + Bdu_dynamic_views.init_bdu_analysis_dynamic in let init_global_dynamic = { @@ -424,11 +378,12 @@ struct { fixpoint_result = init_fixpoint; domain_dynamic_information = init_bdu_analysis_dynamic; - subviews = None ; - ranges = None ; - separating_edges = None ; - transition_system_length = None ; - }} + subviews = None; + ranges = None; + separating_edges = None; + transition_system_length = None; + }; + } in let error, init_static, init_dynamic = scan_rule_set_static init_global_static init_global_dynamic error @@ -437,36 +392,30 @@ struct scan_rule_set_dynamic init_static init_dynamic error in let log_info = get_log_info dynamic in - let error, log_info = StoryProfiling.StoryStats.close_event parameters error - (StoryProfiling.Domain_initialization domain_name) - None log_info + let error, log_info = + StoryProfiling.StoryStats.close_event parameters error + (StoryProfiling.Domain_initialization domain_name) None log_info in let dynamic = set_log_info log_info dynamic in error, static, dynamic, [] - let add_wake_up_common parameters error rule_id - (agent_type, cv_id) + let add_wake_up_common parameters error rule_id (agent_type, cv_id) store_list_of_site_type_in_covering_classes wake_up = let error, list_of_site_type = match Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, cv_id) + parameters error (agent_type, cv_id) store_list_of_site_type_in_covering_classes with | error, None -> error, [] | error, Some l -> error, l in let error, wake_up = - List.fold_left (fun (error, wake_up) site_type -> - Common_static.add_dependency_site_rule - parameters - error - agent_type - site_type - rule_id - wake_up - ) (error, wake_up) list_of_site_type + List.fold_left + (fun (error, wake_up) site_type -> + Common_static.add_dependency_site_rule parameters error agent_type + site_type rule_id wake_up) + (error, wake_up) list_of_site_type in error, wake_up @@ -481,15 +430,12 @@ struct let error, wake_up = Covering_classes_type.AgentsRuleCV_map_and_set.Map.fold (fun (_, agent_type, rule_id, cv_id) _ (error, wake_up) -> - let error, wake_up = - add_wake_up_common parameters error - rule_id - (agent_type, cv_id) - store_list_of_site_type_in_covering_classes - wake_up - in - error, wake_up - ) store_modif_list_restriction_map (error, wake_up) + let error, wake_up = + add_wake_up_common parameters error rule_id (agent_type, cv_id) + store_list_of_site_type_in_covering_classes wake_up + in + error, wake_up) + store_modif_list_restriction_map (error, wake_up) in let error, store_proj_bdu_potential_restriction_map = get_store_proj_bdu_potential_restriction static error @@ -497,18 +443,15 @@ struct let error, wake_up = Ckappa_sig.Rule_setmap.Map.fold (fun rule_id map (error, wake_up) -> - Covering_classes_type.AgentSiteCV_setmap.Map.fold - (fun (agent_type, _, cv_id) _ (error, wake_up) -> - let error, wake_up = - add_wake_up_common parameters error - rule_id - (agent_type, cv_id) - store_list_of_site_type_in_covering_classes - wake_up - in - error, wake_up - ) map (error, wake_up) - ) store_proj_bdu_potential_restriction_map (error, wake_up) + Covering_classes_type.AgentSiteCV_setmap.Map.fold + (fun (agent_type, _, cv_id) _ (error, wake_up) -> + let error, wake_up = + add_wake_up_common parameters error rule_id (agent_type, cv_id) + store_list_of_site_type_in_covering_classes wake_up + in + error, wake_up) + map (error, wake_up)) + store_proj_bdu_potential_restriction_map (error, wake_up) in let error, store_proj_bdu_test_restriction = get_store_proj_bdu_test_restriction static error @@ -516,18 +459,15 @@ struct let error, wake_up = Ckappa_sig.Rule_setmap.Map.fold (fun rule_id map (error, wake_up) -> - Covering_classes_type.AgentsCV_setmap.Map.fold - (fun (_, agent_type, cv_id) _ (error, wake_up) -> - let error, wake_up = - add_wake_up_common parameters error - rule_id - (agent_type, cv_id) - store_list_of_site_type_in_covering_classes - wake_up - in - error, wake_up - ) map (error, wake_up) - ) store_proj_bdu_test_restriction (error, wake_up) + Covering_classes_type.AgentsCV_setmap.Map.fold + (fun (_, agent_type, cv_id) _ (error, wake_up) -> + let error, wake_up = + add_wake_up_common parameters error rule_id (agent_type, cv_id) + store_list_of_site_type_in_covering_classes wake_up + in + error, wake_up) + map (error, wake_up)) + store_proj_bdu_test_restriction (error, wake_up) in error, wake_up @@ -540,87 +480,73 @@ struct (**************************************************************************) -let travel_in_site_correspondence parameters error cv_id site_correspondence = + let travel_in_site_correspondence parameters error cv_id site_correspondence = let error, site_correspondence = let rec aux list = match list with | [] -> Exception.warn parameters error __POS__ Exit [] | (h, list, _) :: _ when h = cv_id -> error, list | _ :: tail -> aux tail - in aux site_correspondence + in + aux site_correspondence in error, site_correspondence - -let get_site_correspondence parameters error agent_type site_correspondence = + let get_site_correspondence parameters error agent_type site_correspondence = let error, site_correspondence = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_type - site_correspondence + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get + parameters error agent_type site_correspondence with - | error, None -> - Exception.warn parameters error __POS__ Exit [] + | error, None -> Exception.warn parameters error __POS__ Exit [] | error, Some a -> error, a in error, site_correspondence -let get_list_of_sites_correspondence parameters error agent_type cv_id - site_correspondence = - let error, site_correspondence = - get_site_correspondence parameters error agent_type site_correspondence - in - let error, site_correspondence = + let get_list_of_sites_correspondence parameters error agent_type cv_id + site_correspondence = + let error, site_correspondence = + get_site_correspondence parameters error agent_type site_correspondence + in + let error, site_correspondence = travel_in_site_correspondence parameters error cv_id site_correspondence - in - error, site_correspondence - + in + error, site_correspondence -let get_list_of_sites_correspondence_map parameters error agent_type cv_id + let get_list_of_sites_correspondence_map parameters error agent_type cv_id site_correspondence = let error, cv_id_array_opt = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_type site_correspondence + parameters error agent_type site_correspondence in match cv_id_array_opt with | None -> let error, map1 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in let error, map2 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters + error 0 in - Exception.warn - parameters error __POS__ - Exit - (map1,map2) + Exception.warn parameters error __POS__ Exit (map1, map2) | Some cv_id_array -> - let error, pair_opt = + let error, pair_opt = Covering_classes_type.Cv_id_nearly_Inf_Int_storage_Imperatif.get - parameters - error - cv_id - cv_id_array + parameters error cv_id cv_id_array in - begin - match pair_opt with - | None -> - let error, map1 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 - in - let error, map2 = - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create parameters error 0 - in - Exception.warn - parameters error __POS__ - Exit - (map1,map2) - | Some (map1,map2) -> - error, (map1,map2) - end + (match pair_opt with + | None -> + let error, map1 = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + let error, map2 = + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.create + parameters error 0 + in + Exception.warn parameters error __POS__ Exit (map1, map2) + | Some (map1, map2) -> error, (map1, map2)) let dump_cv_label static error bool (agent_type, cv_id) = (*TODO: put title*) @@ -628,10 +554,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let handler_kappa = get_kappa_handler static in let site_correspondence = get_remanent_triple static in (*get_store_remanent_triple static error*) - if local_trace - || Remanent_parameters.get_trace parameters - || bool - then + if local_trace || Remanent_parameters.get_trace parameters || bool then ( let log = Remanent_parameters.get_logger parameters in let parameter_cv = Remanent_parameters.update_prefix parameters "Updating the views for" @@ -639,20 +562,14 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let prefix = Remanent_parameters.get_prefix parameter_cv in (*---------------------------------------------------------*) let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit + try Handler.string_of_agent parameters error handler_kappa agent_type + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_agent_name agent_type) in (*get a list of sites in a covering class *) let error, site_correspondence = - get_list_of_sites_correspondence parameters - error - agent_type - cv_id + get_list_of_sites_correspondence parameters error agent_type cv_id site_correspondence in let () = Loggers.print_newline log in @@ -660,56 +577,55 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error, _ = List.fold_left (fun (error, bool) site_type -> - let error, site_string = - try - Handler.string_of_site_update_views parameters error handler_kappa - agent_type site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - let () = - Loggers.fprintf log "%s%s" - (if bool then "," else "") - site_string - in - error, true) - (error, false) - site_correspondence + let error, site_string = + try + Handler.string_of_site_update_views parameters error + handler_kappa agent_type site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_type) + in + let () = + Loggers.fprintf log "%s%s" + (if bool then + "," + else + "") + site_string + in + error, true) + (error, false) site_correspondence in let () = Loggers.fprintf log ")" in - let () = Loggers.print_newline log in + let () = Loggers.print_newline log in error - else + ) else error (**************************************************************************) let discover_a_modify_sites parameters error covering_classes_modified_map - store_list_of_site_type_in_covering_classes - modified_sites = + store_list_of_site_type_in_covering_classes modified_sites = (*in a covering classes of modified site, return the list of list*) Covering_classes_type.AgentCV_map_and_set.Map.fold (fun (agent_type, cv_id) _rule_id_set (error, modified_sites) -> - let error, list_of_site_type = - match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, cv_id) - store_list_of_site_type_in_covering_classes - with - | error, None -> error, [] - | error, Some l -> error, l - in - List.fold_left (fun (error, modified_sites) site -> - Communication.add_site parameters error agent_type site - modified_sites - ) (error, modified_sites) list_of_site_type - ) covering_classes_modified_map (error, modified_sites) - - let updates_list2event_list ?title:(_title="") static dynamic error + let error, list_of_site_type = + match + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error (agent_type, cv_id) + store_list_of_site_type_in_covering_classes + with + | error, None -> error, [] + | error, Some l -> error, l + in + List.fold_left + (fun (error, modified_sites) site -> + Communication.add_site parameters error agent_type site + modified_sites) + (error, modified_sites) list_of_site_type) + covering_classes_modified_map (error, modified_sites) + + let updates_list2event_list ?title:(_title = "") static dynamic error event_list = let parameters = get_parameter static in (*a covering classses that contains modified sites*) @@ -724,89 +640,71 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id Communication.init_sites_working_list parameters error in let error, modified_sites = - discover_a_modify_sites - parameters - error + discover_a_modify_sites parameters error store_covering_classes_modification_update_full - store_list_of_site_type_in_covering_classes - modified_sites + store_list_of_site_type_in_covering_classes modified_sites in let error, event_list = - Communication.fold_sites - parameters error + Communication.fold_sites parameters error (fun _ error s _ event_list -> - error, (Communication.Modified_sites s) :: event_list - ) modified_sites event_list + error, Communication.Modified_sites s :: event_list) + modified_sites event_list in error, event_list (***************************************************************) let dump_view_diff static dynamic error (agent_type, cv_id) bdu_old bdu_union - = + = let parameters = get_parameter static in let handler_kappa = get_kappa_handler static in let site_correspondence = get_site_correspondence_array static in - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_diff parameters - || Remanent_parameters.get_trace parameters - then + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff parameters + || Remanent_parameters.get_trace parameters + then ( let prefix = Remanent_parameters.get_prefix parameters in let handler = get_mvbdu_handler dynamic in let error, handler, bdu_diff = - Ckappa_sig.Views_bdu.mvbdu_xor - parameters handler error bdu_old bdu_union + Ckappa_sig.Views_bdu.mvbdu_xor parameters handler error bdu_old + bdu_union in let dynamic = set_mvbdu_handler handler dynamic in (*-----------------------------------------------------------------*) let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit + try Handler.string_of_agent parameters error handler_kappa agent_type + with _ -> + Exception.warn parameters error __POS__ Exit (Ckappa_sig.string_of_agent_name agent_type) in (*------------------------------------------------------------------*) (*list of sites in a covering class*) - let error, (_,map2) = - get_list_of_sites_correspondence_map parameters error - agent_type - cv_id + let error, (_, map2) = + get_list_of_sites_correspondence_map parameters error agent_type cv_id site_correspondence in (*-------------------------------------------------------------------*) let log = Remanent_parameters.get_logger parameters in let error, dynamic = - if local_trace - || Remanent_parameters.get_trace parameters - then - let () = - Loggers.fprintf log - "%sINTENSIONAL DESCRIPTION:" prefix - in + if local_trace || Remanent_parameters.get_trace parameters then ( + let () = Loggers.fprintf log "%sINTENSIONAL DESCRIPTION:" prefix in let () = Loggers.print_newline log in (*print bdu different: this will print in a format of bdu*) - let () = - Ckappa_sig.Views_bdu.print parameters bdu_diff - in + let () = Ckappa_sig.Views_bdu.print parameters bdu_diff in (*print a list of relations: this will print in a format readable*) - let () = - Loggers.fprintf log - "%sEXTENSIONAL DESCRIPTION:" prefix - in + let () = Loggers.fprintf log "%sEXTENSIONAL DESCRIPTION:" prefix in let () = Loggers.print_newline log in error, dynamic - else + ) else error, dynamic in (*this is a function to convert a bdu of diff into a list. return a pair: (bdu, and a pair of (site, state) list of list)*) let handler = get_mvbdu_handler dynamic in let error, handler, list = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters handler error bdu_diff + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler error + bdu_diff in let dynamic = set_mvbdu_handler handler dynamic in (*----------------------------------------------------*) @@ -814,66 +712,57 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error = List.fold_left (fun error l -> - let error, bool = - List.fold_left - (fun (error, bool) (site_type, state) -> - let error, site_type = - match Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get - parameters error site_type map2 - with - | error, None -> - Exception.warn - parameters error __POS__ Exit - Ckappa_sig.dummy_site_name - | error, Some i -> error, i - in - (*----------------------------------------------------*) - let error, site_string = - try - Handler.string_of_site - parameters error handler_kappa - ~state agent_type site_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_site_name site_type) - in - (*-----------------------------------------------------*) - let () = - if bool - then - Loggers.fprintf log "," - else - Loggers.fprintf log - "\t\t%s%s(" prefix agent_string - in - let () = - Loggers.fprintf log - "%s" site_string - in - error, true - ) - (error, false) l - in - (*-----------------------------------------------------------*) - let () = - if bool - then - let () = - Loggers.fprintf log ")" in - Loggers.print_newline log - in error) + let error, bool = + List.fold_left + (fun (error, bool) (site_type, state) -> + let error, site_type = + match + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get + parameters error site_type map2 + with + | error, None -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_site_name + | error, Some i -> error, i + in + (*----------------------------------------------------*) + let error, site_string = + try + Handler.string_of_site parameters error handler_kappa + ~state agent_type site_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_site_name site_type) + in + (*-----------------------------------------------------*) + let () = + if bool then + Loggers.fprintf log "," + else + Loggers.fprintf log "\t\t%s%s(" prefix agent_string + in + let () = Loggers.fprintf log "%s" site_string in + error, true) + (error, false) l + in + (*-----------------------------------------------------------*) + let () = + if bool then ( + let () = Loggers.fprintf log ")" in + Loggers.print_newline log + ) + in + error) error list in let () = - if list = [] - then () + if list = [] then + () else Loggers.print_newline log in error, dynamic - else + ) else error, dynamic (**************************************************************************) @@ -886,91 +775,74 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error, bdu_old = match Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, cv_id) - store + parameters error (agent_type, cv_id) store with | error, None -> error, bdu_false | error, Some bdu -> error, bdu in let handler = get_mvbdu_handler dynamic in let error, handler, bdu_union = - Ckappa_sig.Views_bdu.mvbdu_or - parameters handler error bdu_old bdu + Ckappa_sig.Views_bdu.mvbdu_or parameters handler error bdu_old bdu in let dynamic = set_mvbdu_handler handler dynamic in let updates_list = [] in (*-----------------------------------------------------------*) let error, dynamic, _title, is_new_views, _updates_list = - if Ckappa_sig.Views_bdu.equal bdu_old bdu_union - then + if Ckappa_sig.Views_bdu.equal bdu_old bdu_union then error, dynamic, title, false, updates_list - else + else ( (*print different views*) let () = match title with | None -> () | Some s -> if - (local_trace - || Remanent_parameters.get_dump_reachability_analysis_diff - parameters - || Remanent_parameters.get_trace parameters) + local_trace + || Remanent_parameters.get_dump_reachability_analysis_diff + parameters + || Remanent_parameters.get_trace parameters then - if s = "" then Loggers.print_newline log - else + if s = "" then + Loggers.print_newline log + else ( let () = Loggers.fprintf log "\t%s" s in let () = Loggers.print_newline log in let () = Loggers.print_newline log in () + ) in let error, dynamic = - dump_view_diff - static - dynamic - error - (agent_type, cv_id) - bdu_old + dump_view_diff static dynamic error (agent_type, cv_id) bdu_old bdu_union in let error, store = Covering_classes_type.AgentCV_map_and_set.Map.add_or_overwrite - parameters error - (agent_type, cv_id) - bdu_union - store + parameters error (agent_type, cv_id) bdu_union store in let dynamic = set_fixpoint_result store dynamic in error, dynamic, None, true, (agent_type, cv_id) :: updates_list + ) in (*-----------------------------------------------------------------------*) (*add updates_list into event list*) - if is_new_views - then + if is_new_views then ( (*print*) let error, event_list = - updates_list2event_list - static - dynamic - error - event_list + updates_list2event_list static dynamic error event_list in error, dynamic, event_list - else + ) else error, dynamic, event_list (***************************************************************************) (*build bdu restriction for initial state *) let bdu_build static dynamic error - (pair_list: (Ckappa_sig.c_site_name * Ckappa_sig.c_state) list) = + (pair_list : (Ckappa_sig.c_site_name * Ckappa_sig.c_state) list) = let parameters = get_parameter static in let handler = get_mvbdu_handler dynamic in let error, handler, bdu_result = - Ckappa_sig.Views_bdu.mvbdu_of_association_list - parameters - handler - error + Ckappa_sig.Views_bdu.mvbdu_of_association_list parameters handler error pair_list in let dynamic = set_mvbdu_handler handler dynamic in @@ -982,69 +854,55 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let parameters = get_parameter static in let store_remanent_triple = get_remanent_triple static in let error, (dynamic, event_list) = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id agent (dynamic, event_list) -> - match agent with - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost -> error, (dynamic, event_list) - | Cckappa_sig.Dead_agent _ -> - Exception.warn - parameters error __POS__ Exit (dynamic, event_list) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - (*-------------------------------------------------------------*) - let error, (dynamic, event_list) = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error - agent_type - store_remanent_triple - with - | error, Some triple_list -> - let error, get_pair_list = - Bdu_static_views.get_pair_cv_map_with_missing_association_creation - parameters error agent triple_list - in - let error, (dynamic, event_list) = - List.fold_left (fun (error, (dynamic, event_list)) - (cv_id, map_res) -> - let error, pair_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site' state (error, current_list) -> - let pair_list = (site', state) :: current_list in - error, pair_list - ) map_res (error, []) - in - let error, dynamic, bdu_init = - bdu_build - static - dynamic - error - pair_list - in - (*----------------------------------------------------*) - let error, dynamic, event_list = - add_link - ~title:"Views in initial state:" - error - static - dynamic - (agent_type, cv_id) - bdu_init - event_list - in - error, (dynamic, event_list) - ) - (error, (dynamic, event_list)) - get_pair_list - in - error, (dynamic, event_list) - | error, None -> error, (dynamic, event_list) - in - error, (dynamic, event_list) - ) init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.views - (dynamic, []) + match agent with + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost -> + error, (dynamic, event_list) + | Cckappa_sig.Dead_agent _ -> + Exception.warn parameters error __POS__ Exit (dynamic, event_list) + | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + (*-------------------------------------------------------------*) + let error, (dynamic, event_list) = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type store_remanent_triple + with + | error, Some triple_list -> + let error, get_pair_list = + Bdu_static_views + .get_pair_cv_map_with_missing_association_creation parameters + error agent triple_list + in + let error, (dynamic, event_list) = + List.fold_left + (fun (error, (dynamic, event_list)) (cv_id, map_res) -> + let error, pair_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site' state (error, current_list) -> + let pair_list = (site', state) :: current_list in + error, pair_list) + map_res (error, []) + in + let error, dynamic, bdu_init = + bdu_build static dynamic error pair_list + in + (*----------------------------------------------------*) + let error, dynamic, event_list = + add_link ~title:"Views in initial state:" error static + dynamic (agent_type, cv_id) bdu_init event_list + in + error, (dynamic, event_list)) + (error, (dynamic, event_list)) + get_pair_list + in + error, (dynamic, event_list) + | error, None -> error, (dynamic, event_list) + in + error, (dynamic, event_list)) + init_state.Cckappa_sig.e_init_c_mixture.Cckappa_sig.views (dynamic, []) in error, dynamic, event_list @@ -1053,11 +911,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let add_initial_state static dynamic error init_state = let error, dynamic, event_list = - build_init_restriction - static - dynamic - error - init_state + build_init_restriction static dynamic error init_state in error, dynamic, event_list @@ -1074,39 +928,35 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error, dynamic, _ = Covering_classes_type.AgentsCV_setmap.Map.fold (fun (agent_id, agent_type, cv_id) bdu_test (error, dynamic, map) -> - (*------------------------------------------------------*) - (*for each (agent_id, cv_id) a bdu*) - let error, bdu_X = - match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters - error - (agent_type, cv_id) - fixpoint_result - with - | error, None -> error, bdu_false - | error, Some bdu -> error, bdu - in - (*----------------------------------------------------------------*) - (*bdu intersection*) - let handler = get_mvbdu_handler dynamic in - let error, handler, bdu_inter = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error bdu_test bdu_X - in - let dynamic = set_mvbdu_handler handler dynamic in - if Ckappa_sig.Views_bdu.equal bdu_inter bdu_false - then raise (False (error, dynamic)) - else - let error, map = - Covering_classes_type.AgentIDCV_map_and_set.Map.add parameters - error - (agent_id, cv_id) - bdu_inter - map - in - error, dynamic, map - ) proj_bdu_test_restriction + (*------------------------------------------------------*) + (*for each (agent_id, cv_id) a bdu*) + let error, bdu_X = + match + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error (agent_type, cv_id) + fixpoint_result + with + | error, None -> error, bdu_false + | error, Some bdu -> error, bdu + in + (*----------------------------------------------------------------*) + (*bdu intersection*) + let handler = get_mvbdu_handler dynamic in + let error, handler, bdu_inter = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu_test + bdu_X + in + let dynamic = set_mvbdu_handler handler dynamic in + if Ckappa_sig.Views_bdu.equal bdu_inter bdu_false then + raise (False (error, dynamic)) + else ( + let error, map = + Covering_classes_type.AgentIDCV_map_and_set.Map.add parameters + error (agent_id, cv_id) bdu_inter map + in + error, dynamic, map + )) + proj_bdu_test_restriction (error, dynamic, Covering_classes_type.AgentIDCV_map_and_set.Map.empty) in error, dynamic @@ -1116,32 +966,23 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let get_new_site_name parameters error site_name (*store_new_index_pair_map*) - map1 = + map1 = let error, new_site_name = match - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get - parameters - error - site_name - map1 + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get parameters + error site_name map1 with | error, None -> - Exception.warn - parameters error __POS__ Exit - Ckappa_sig.dummy_site_name + Exception.warn parameters error __POS__ Exit Ckappa_sig.dummy_site_name | error, Some i -> error, i in error, new_site_name (*MOVE?*) - let is_new_site_name parameters error site_name - map1 = + let is_new_site_name parameters error site_name map1 = match Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - site_name - map1 + parameters error site_name map1 with | error, None -> error, false | error, Some _ -> error, true @@ -1149,122 +990,91 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*****************************************************************) let step_list_empty _kappa_handler dynamic parameters error agent_id - agent_type site_name cv_list fixpoint_result - proj_bdu_test_restriction - bdu_false bdu_true - site_correspondence = + agent_type site_name cv_list fixpoint_result proj_bdu_test_restriction + bdu_false bdu_true site_correspondence = (*------------------------------------------------------------*) let error, dynamic, bdu = List.fold_left (fun (error, dynamic, bdu) cv_id -> - let error, (map1,_) = - get_list_of_sites_correspondence_map - parameters error - agent_type - cv_id - site_correspondence - in - let error, new_site_name = - get_new_site_name - parameters error site_name - map1 - in - (*--------------------------------------------------------------*) - (* fetch the bdu for the agent type and the cv_id in - the current state of the iteration *) - let error, bdu_X = - match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters - error - (agent_type, cv_id) - fixpoint_result - with - | error, None -> error, bdu_false - | error, Some bdu -> error, bdu - in - (*get bdu test*) - let error, bdu_test = - match - Covering_classes_type.AgentsCV_setmap.Map.find_option - (agent_id, agent_type, cv_id) - proj_bdu_test_restriction - with - | None -> error, bdu_true - | Some bdu -> error, bdu - in - (*Bdu_X and Bdu_test*) - let handler = Analyzer_headers.get_mvbdu_handler dynamic in - let error, handler, bdu_test_X = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error bdu_X bdu_test - in - (* compute the projection over new_site_name *) - let error, handler, singleton = - Ckappa_sig.Views_bdu.build_variables_list - parameters - handler - error - [new_site_name] - in - let error, handler, bdu_proj = - Ckappa_sig.Views_bdu.mvbdu_project_keep_only - parameters - handler - error - bdu_test_X - singleton - in - (* rename new_site_name into 1 *) - let error, handler, new_site_name_1 = - Ckappa_sig.Views_bdu.build_renaming_list - parameters - handler - error - [new_site_name, site_name] - in - let error, handler, bdu_renamed = - Ckappa_sig.Views_bdu.mvbdu_rename - parameters - handler - error - bdu_proj - new_site_name_1 - in - (* conjunction between bdu and bdu'*) - let error, handler, bdu = - Ckappa_sig.Views_bdu.mvbdu_and - parameters - handler - error - bdu - bdu_renamed - in - let dynamic = Analyzer_headers.set_mvbdu_handler handler dynamic in - error, dynamic, bdu) - (error, dynamic, bdu_true) - cv_list + let error, (map1, _) = + get_list_of_sites_correspondence_map parameters error agent_type + cv_id site_correspondence + in + let error, new_site_name = + get_new_site_name parameters error site_name map1 + in + (*--------------------------------------------------------------*) + (* fetch the bdu for the agent type and the cv_id in + the current state of the iteration *) + let error, bdu_X = + match + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error (agent_type, cv_id) + fixpoint_result + with + | error, None -> error, bdu_false + | error, Some bdu -> error, bdu + in + (*get bdu test*) + let error, bdu_test = + match + Covering_classes_type.AgentsCV_setmap.Map.find_option + (agent_id, agent_type, cv_id) + proj_bdu_test_restriction + with + | None -> error, bdu_true + | Some bdu -> error, bdu + in + (*Bdu_X and Bdu_test*) + let handler = Analyzer_headers.get_mvbdu_handler dynamic in + let error, handler, bdu_test_X = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu_X + bdu_test + in + (* compute the projection over new_site_name *) + let error, handler, singleton = + Ckappa_sig.Views_bdu.build_variables_list parameters handler error + [ new_site_name ] + in + let error, handler, bdu_proj = + Ckappa_sig.Views_bdu.mvbdu_project_keep_only parameters handler + error bdu_test_X singleton + in + (* rename new_site_name into 1 *) + let error, handler, new_site_name_1 = + Ckappa_sig.Views_bdu.build_renaming_list parameters handler error + [ new_site_name, site_name ] + in + let error, handler, bdu_renamed = + Ckappa_sig.Views_bdu.mvbdu_rename parameters handler error bdu_proj + new_site_name_1 + in + (* conjunction between bdu and bdu'*) + let error, handler, bdu = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu + bdu_renamed + in + let dynamic = Analyzer_headers.set_mvbdu_handler handler dynamic in + error, dynamic, bdu) + (error, dynamic, bdu_true) cv_list in (*---------------------------------------------------------------------*) let handler = Analyzer_headers.get_mvbdu_handler dynamic in let error, handler, list = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters - handler - error - bdu + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler error bdu in let dynamic = Analyzer_headers.set_mvbdu_handler handler dynamic in (*---------------------------------------------------------------------*) let error, state_list = List.fold_left (fun (error, output) list -> - match list with - | [_, state] -> (* the site name is fictitious, do not take it *) - error, state :: output - | _ -> - Exception.warn - parameters error __POS__ ~message:"state is empty" Exit output) + match list with + | [ (_, state) ] -> + (* the site name is fictitious, do not take it *) + error, state :: output + | _ -> + Exception.warn parameters error __POS__ ~message:"state is empty" + Exit output) (error, []) list in error, dynamic, Usual_domains.Val (List.rev state_list) @@ -1273,61 +1083,51 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*empty case of step list*) let precondition_empty_step_list kappa_handler parameters error dynamic - rule_id path store_agent_name - bdu_false bdu_true store_covering_classes_id - site_correspondence - fixpoint_result proj_bdu_test_restriction = + rule_id path store_agent_name bdu_false bdu_true store_covering_classes_id + site_correspondence fixpoint_result proj_bdu_test_restriction = let error, agent_type = - match Ckappa_sig.RuleAgent_map_and_set.Map.find_option_without_logs - parameters error - (rule_id, path.Communication.agent_id) - store_agent_name + match + Ckappa_sig.RuleAgent_map_and_set.Map.find_option_without_logs parameters + error + (rule_id, path.Communication.agent_id) + store_agent_name with | error, None -> - Exception.warn - parameters error __POS__ - ~message:"unknown agent type" - Exit - Ckappa_sig.dummy_agent_name + Exception.warn parameters error __POS__ ~message:"unknown agent type" + Exit Ckappa_sig.dummy_agent_name | error, Some a -> error, a in (*------------------------------------------------------------*) - (* let error, site_correspondence = - match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_type - site_correspondence - with - | error, None -> - Exception.warn parameters error __POS__ Exit [] - | error, Some l -> error, l - in*) + (* let error, site_correspondence = + match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get + parameters + error + agent_type + site_correspondence + with + | error, None -> + Exception.warn parameters error __POS__ Exit [] + | error, Some l -> error, l + in*) (* compute the list of cv_id documenting site_name *) let error, cv_list = - match Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters - error - (agent_type, path.Communication.site) (*site:v*) - store_covering_classes_id + match + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameters + error + (agent_type, path.Communication.site) (*site:v*) + store_covering_classes_id with | error, None -> - Exception.warn parameters error __POS__ + Exception.warn parameters error __POS__ ~message:"the site does not belong to the last agent type of a path" Exit [] | error, Some l -> error, l in (*---------------------------------------------------------------------*) let error, dynamic, new_answer = - step_list_empty - kappa_handler dynamic parameters error - path.Communication.agent_id - agent_type - path.Communication.site - cv_list - fixpoint_result - proj_bdu_test_restriction - bdu_false bdu_true + step_list_empty kappa_handler dynamic parameters error + path.Communication.agent_id agent_type path.Communication.site cv_list + fixpoint_result proj_bdu_test_restriction bdu_false bdu_true (*store_new_index_pair_map*) site_correspondence in @@ -1362,10 +1162,8 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*typing*) - let precondition_typing - parameters error kappa_handler rule_id step_list path - store_agent_name dual_contact_map - = + let precondition_typing parameters error kappa_handler rule_id step_list path + store_agent_name dual_contact_map = let rec aux acc error = match acc with | [] -> error, Usual_domains.Any @@ -1373,8 +1171,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error, agent_type = match Ckappa_sig.RuleAgent_map_and_set.Map.find_option_without_logs - parameters - error + parameters error (rule_id, path.Communication.agent_id) store_agent_name with @@ -1385,67 +1182,54 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*get state information from (agent_type, site)*) let error, state_dic = Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type, step.Communication.site_out) (*A.x*) kappa_handler.Cckappa_sig.states_dic) (fun error -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init())) + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) in (*---------------------------------------------------------*) (*Binding state: B.y*) let state = - Ckappa_sig.C_Lnk_type (step.Communication.agent_type_in, - step.Communication.site_in) + Ckappa_sig.C_Lnk_type + (step.Communication.agent_type_in, step.Communication.site_in) in (*check if whether or not state is defined*) let error, b = - Ckappa_sig.Dictionary_of_States.member - parameters - error - (Ckappa_sig.Binding state) - state_dic + Ckappa_sig.Dictionary_of_States.member parameters error + (Ckappa_sig.Binding state) state_dic in - if b - then + if b then ( (*-----------------------------------------------------*) (*state is defined*) let error, answer_contact_map = match - Ckappa_sig.Dictionary_of_States.allocate - parameters - error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Binding state) - () - Misc_sa.const_unit - state_dic + Ckappa_sig.Dictionary_of_States.allocate parameters error + Ckappa_sig.compare_unit_state_index (Ckappa_sig.Binding state) + () Misc_sa.const_unit state_dic with | error, None -> - Exception.warn - parameters error __POS__ Exit Usual_domains.Undefined + Exception.warn parameters error __POS__ Exit + Usual_domains.Undefined | error, Some (state, _, _, _) -> - match - Ckappa_sig.AgentSiteState_map_and_set.Map.find_option_without_logs - parameters - error - (agent_type, step.Communication.site_out, state) - dual_contact_map - with + (match + Ckappa_sig.AgentSiteState_map_and_set.Map + .find_option_without_logs parameters error + (agent_type, step.Communication.site_out, state) + dual_contact_map + with | error, None -> - Exception.warn - parameters error __POS__ Exit Usual_domains.Undefined - | error, Some _ -> (*recursive call*) aux tl error + Exception.warn parameters error __POS__ Exit + Usual_domains.Undefined + | error, Some _ -> (*recursive call*) aux tl error) in error, answer_contact_map - else + ) else (*state is not defined*) - Exception.warn - parameters error __POS__ Exit - Usual_domains.Undefined + Exception.warn parameters error __POS__ Exit Usual_domains.Undefined in aux step_list error @@ -1453,22 +1237,24 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*outside the pattern*) let get_tuple_pattern error path agent_type = - let error, - (agent_type', site_out, site_in, agent_type_in) = + let error, (agent_type', site_out, site_in, agent_type_in) = (*revert the path, and get the three cases*) match List.rev path.Communication.relative_address with - | [] -> (*return dummy*) - error, - (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_site_name, - Ckappa_sig.dummy_site_name, Ckappa_sig.dummy_agent_name) - | [x] -> + | [] -> + (*return dummy*) + ( error, + ( Ckappa_sig.dummy_agent_name, + Ckappa_sig.dummy_site_name, + Ckappa_sig.dummy_site_name, + Ckappa_sig.dummy_agent_name ) ) + | [ x ] -> (*agent_type' (h') is agent_type inside the pattern*) (*get information of the triple*) let site_in = x.Communication.site_in in let agent_type_in = x.Communication.agent_type_in in let site_out = x.Communication.site_out in error, (agent_type, site_out, site_in, agent_type_in) - | h::h'::_ -> + | h :: h' :: _ -> (*from h get the information of the triple (site_in, agent_type_in, site_out)*) (*get information of the triple*) @@ -1480,12 +1266,9 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id in error, (agent_type', site_out, site_in, agent_type_in) - let precondition_outside_pattern - parameters error dynamic kappa_handler path - agent_type (*agent_type inside the pattern*) - bdu_false bdu_true - _site_correspondence site_correspondence_map - store_covering_classes_id + let precondition_outside_pattern parameters error dynamic kappa_handler path + agent_type (*agent_type inside the pattern*) bdu_false bdu_true + _site_correspondence site_correspondence_map store_covering_classes_id fixpoint_result = (*get the information of the path, A - x - y - B - z @@ -1494,10 +1277,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id and (agent_type', site_in) is the information of the agent of the pattern *) let error, (agent_type', site_out, site_in, agent_type_in) = - get_tuple_pattern - error - path - agent_type + get_tuple_pattern error path agent_type in (*get the site path*) let site_path = path.Communication.site in @@ -1505,197 +1285,139 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (A.x:agent_type,site_out)*) let error, state_dic_A_x = Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_type', site_out) + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type', site_out) kappa_handler.Cckappa_sig.states_dic) (fun error -> - Exception.warn parameters error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init())) + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) in let error, state_dic_B_y = Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error - (agent_type_in, site_in) + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type_in, site_in) kappa_handler.Cckappa_sig.states_dic) (fun error -> - Exception.warn parameters error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init())) + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) in (*check binding state B,y *) let state_A_x = Ckappa_sig.C_Lnk_type (agent_type_in, site_in) in let error, b_A_x = - Ckappa_sig.Dictionary_of_States.member - parameters - error - (Ckappa_sig.Binding state_A_x) - state_dic_A_x + Ckappa_sig.Dictionary_of_States.member parameters error + (Ckappa_sig.Binding state_A_x) state_dic_A_x in let state_B_y = Ckappa_sig.C_Lnk_type (agent_type', site_out) in let error, b_B_y = - Ckappa_sig.Dictionary_of_States.member - parameters - error - (Ckappa_sig.Binding state_B_y) - state_dic_B_y + Ckappa_sig.Dictionary_of_States.member parameters error + (Ckappa_sig.Binding state_B_y) state_dic_B_y in - if b_A_x && b_B_y - then + if b_A_x && b_B_y then ( (*state is defined*) let error, (dynamic, new_answer) = match - Ckappa_sig.Dictionary_of_States.allocate - parameters - error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Binding state_B_y) - () - Misc_sa.const_unit - state_dic_B_y + Ckappa_sig.Dictionary_of_States.allocate parameters error + Ckappa_sig.compare_unit_state_index (Ckappa_sig.Binding state_B_y) + () Misc_sa.const_unit state_dic_B_y with - | error, None -> (*inconsistent*) + | error, None -> + (*inconsistent*) error, (dynamic, Usual_domains.Undefined) - | error, Some (state, _ ,_, _) -> + | error, Some (state, _, _, _) -> let error, cv_list = match Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters - error - (agent_type_in, site_path) + parameters error (agent_type_in, site_path) store_covering_classes_id with - | error, None -> - Exception.warn parameters error __POS__ Exit [] + | error, None -> Exception.warn parameters error __POS__ Exit [] | error, Some l -> error, l in let error, dynamic, bdu = - List.fold_left (fun (error, dynamic, bdu) cv_id -> - let error, (map1,_) = - get_list_of_sites_correspondence_map - parameters - error - agent_type_in - cv_id - site_correspondence_map - in - let error,b = - is_new_site_name - parameters - error - site_in - map1 + List.fold_left + (fun (error, dynamic, bdu) cv_id -> + let error, (map1, _) = + get_list_of_sites_correspondence_map parameters error + agent_type_in cv_id site_correspondence_map in + let error, b = is_new_site_name parameters error site_in map1 in let error, bdu_X = match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type_in, cv_id) - fixpoint_result + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error + (agent_type_in, cv_id) fixpoint_result with | error, None -> error, bdu_false | error, Some bdu -> error, bdu in let handler = Analyzer_headers.get_mvbdu_handler dynamic in let error, new_site_name_z = - get_new_site_name - parameters - error - site_path - map1 + get_new_site_name parameters error site_path map1 in let error, handler, singleton = - Ckappa_sig.Views_bdu.build_variables_list - parameters - handler - error - [new_site_name_z] + Ckappa_sig.Views_bdu.build_variables_list parameters handler + error [ new_site_name_z ] in let error, handler, new_bdu = - if b - then + if b then ( (*site y is in CV, *) let error, new_site_name_y = - get_new_site_name - parameters - error - site_in - map1 + get_new_site_name parameters error site_in map1 in let error, handler, mvbdu_B_y = - Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_association_list - parameters - handler - error - [ - new_site_name_y, - state - ] + Ckappa_sig.Views_bdu + .mvbdu_of_reverse_sorted_association_list parameters + handler error + [ new_site_name_y, state ] in - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu_X mvbdu_B_y - else + ) else error, handler, bdu_X in let error, handler, bdu_proj = - Ckappa_sig.Views_bdu.mvbdu_project_keep_only - parameters - handler - error - new_bdu - singleton + Ckappa_sig.Views_bdu.mvbdu_project_keep_only parameters + handler error new_bdu singleton in let error, handler, new_site_name_1 = - Ckappa_sig.Views_bdu.build_renaming_list - parameters - handler + Ckappa_sig.Views_bdu.build_renaming_list parameters handler error - [new_site_name_z, site_path] + [ new_site_name_z, site_path ] in let error, handler, bdu_renamed = - Ckappa_sig.Views_bdu.mvbdu_rename - parameters - handler - error - bdu_proj - new_site_name_1 + Ckappa_sig.Views_bdu.mvbdu_rename parameters handler error + bdu_proj new_site_name_1 in let error, handler, bdu = - Ckappa_sig.Views_bdu.mvbdu_and - parameters - handler - error - bdu + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu bdu_renamed in let dynamic = - Analyzer_headers.set_mvbdu_handler handler dynamic in - error, dynamic, bdu - ) (error, dynamic, bdu_true) cv_list + Analyzer_headers.set_mvbdu_handler handler dynamic + in + error, dynamic, bdu) + (error, dynamic, bdu_true) cv_list in let handler = Analyzer_headers.get_mvbdu_handler dynamic in let error, handler, list = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters - handler - error + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler error bdu in let dynamic = Analyzer_headers.set_mvbdu_handler handler dynamic in let error, state_list = - List.fold_left (fun (error, output) list -> + List.fold_left + (fun (error, output) list -> match list with - | [_, state] -> error, state :: output - | _ -> Exception.warn parameters error __POS__ Exit output - ) (error, []) list + | [ (_, state) ] -> error, state :: output + | _ -> Exception.warn parameters error __POS__ Exit output) + (error, []) list in error, (dynamic, Usual_domains.Val (List.rev state_list)) in error, (dynamic, new_answer) - else + ) else (*state is not defined*) Exception.warn parameters error __POS__ Exit (dynamic, Usual_domains.Undefined) @@ -1703,43 +1425,28 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*---------------------------------------------------------------*) (*inside the pattern*) - let precondition_inside_pattern - parameters error dynamic kappa_handler - path agent_type - aux rule - site_correspondence site_correspondence_map - store_covering_classes_id - fixpoint_result bdu_false bdu_true - = + let precondition_inside_pattern parameters error dynamic kappa_handler path + agent_type aux rule site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result bdu_false bdu_true = (*---------------------------------------------------------*) (*inside the pattern, check the binding information in the lhs of the current agent*) let error, output = - Communication.follow_path_inside_cc - parameters error kappa_handler - rule.Cckappa_sig.rule_lhs - path + Communication.follow_path_inside_cc parameters error kappa_handler + rule.Cckappa_sig.rule_lhs path in match output with - | Communication.Cannot_exist -> - error, (dynamic, Usual_domains.Undefined) + | Communication.Cannot_exist -> error, (dynamic, Usual_domains.Undefined) | Communication.May_exist _ -> (*-----------------------------------------------------*) let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters error dynamic kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic kappa_handler path + agent_type bdu_false bdu_true site_correspondence + site_correspondence_map store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' __POS__ + Exit in error, (dynamic, new_answer) (*--------------------------------------------------------*) @@ -1747,79 +1454,76 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*search inside this map which agent and site, A.x bind to.*) let next_path = { - Communication.site = path.Communication.site ; - Communication.agent_id = agent_id ; - Communication.relative_address = [];} + Communication.site = path.Communication.site; + Communication.agent_id; + Communication.relative_address = []; + } in let error, dynamic, new_answer = aux dynamic next_path in error, (dynamic, new_answer) (*-------------------------------------------------------------*) - let scan_bot - ~also_scan_top:(also_scan_top:bool) - pos parameters error elt string - = + let scan_bot ~(also_scan_top : bool) pos parameters error elt string = match elt with | Usual_domains.Undefined -> let error, () = - Exception.warn - parameters error pos - ~message:("bot generated while fetching the potential state of a site"^string) + Exception.warn parameters error pos + ~message: + ("bot generated while fetching the potential state of a site" + ^ string) Exit () - in error + in + error | Usual_domains.Any when also_scan_top -> let error, () = - Exception.warn - parameters error pos - ~message:("top generated while fetching the potential state of a site"^string) + Exception.warn parameters error pos + ~message: + ("top generated while fetching the potential state of a site" + ^ string) Exit () - in error - | Usual_domains.Val _ - | Usual_domains.Any -> error - - let scan_bot_warn - ~also_scan_top:(also_scan_top:bool) - (a,_,_,_) parameters error elt string - = + in + error + | Usual_domains.Val _ | Usual_domains.Any -> error + + let scan_bot_warn ~(also_scan_top : bool) (a, _, _, _) parameters error elt + string = let () = match elt with | Usual_domains.Undefined -> - if - Remanent_parameters.get_dump_reachability_analysis_wl - parameters - then - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s%sbot generated while fetching the potential state of a site %s" - (Remanent_parameters.get_prefix parameters) a string + if Remanent_parameters.get_dump_reachability_analysis_wl parameters then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%s%sbot generated while fetching the potential state of a site \ + %s" + (Remanent_parameters.get_prefix parameters) + a string in Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) | Usual_domains.Any when also_scan_top -> - if - Remanent_parameters.get_dump_reachability_analysis_wl - parameters - then + if Remanent_parameters.get_dump_reachability_analysis_wl parameters then ( let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%stop generated while fetching the potential state of a site %s" - (Remanent_parameters.get_prefix parameters) string in - Loggers.print_newline - (Remanent_parameters.get_logger parameters) - | Usual_domains.Val _ - | Usual_domains.Any -> () - in error - - let compute_pattern_navigation - parameters error kappa_handler - aux dynamic path rule step bdu_false bdu_true - site_correspondence site_correspondence_map + (Remanent_parameters.get_prefix parameters) + string + in + Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) + | Usual_domains.Val _ | Usual_domains.Any -> () + in + error + + let compute_pattern_navigation parameters error kappa_handler aux dynamic path + rule step bdu_false bdu_true site_correspondence site_correspondence_map store_covering_classes_id fixpoint_result = let error, agent = match Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - path.Communication.agent_id (*#1:A*) + parameters error path.Communication.agent_id (*#1:A*) rule.Cckappa_sig.rule_lhs.Cckappa_sig.views with | error, None -> @@ -1828,21 +1532,18 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id in let error, (dynamic, new_answer) = match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Dead_agent _ -> - Exception.warn - parameters error __POS__ Exit (dynamic, Usual_domains.Undefined) + Exception.warn parameters error __POS__ Exit + (dynamic, Usual_domains.Undefined) | Cckappa_sig.Agent agent -> let agent_type = agent.Cckappa_sig.agent_name in (*search inside the pattern, check whether or not it is out of the pattern or in the pattern.*) let error, (dynamic, new_answer) = match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters - error - step.Communication.site_out (*A.x: state*) + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters + error step.Communication.site_out (*A.x: state*) agent.Cckappa_sig.agent_interface with | error, None -> @@ -1852,29 +1553,17 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id target, take site and collect the information one has about the potential state of this site in agents of this type. *) let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type (*agent_type inside the pattern*) - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type (*agent_type inside the pattern*) + bdu_false bdu_true site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in let error = - scan_bot - ~also_scan_top:false __POS__ - parameters error - new_answer + scan_bot ~also_scan_top:false __POS__ parameters error new_answer " in precondition outside a pattern" in error, (dynamic, new_answer) @@ -1883,26 +1572,27 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id port whether or not it is free/bound?*) | error, Some port -> (*check if it is free?*) - match port.Cckappa_sig.site_free with + (match port.Cckappa_sig.site_free with | Some true -> (*then it is inconsistent, undefined*) let () = if - (local_trace - || Remanent_parameters.get_dump_reachability_analysis_wl - parameters - || Remanent_parameters.get_trace parameters) - then - let () = Loggers.fprintf + local_trace + || Remanent_parameters.get_dump_reachability_analysis_wl + parameters + || Remanent_parameters.get_trace parameters + then ( + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "Try to navigate through a free site: bottom reduction" in Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) in error, (dynamic, Usual_domains.Undefined) - | None - | Some false -> + | None | Some false -> (*it is not free, check if it is fully defined, or incompelete, by looking into the bonds on the lhs*) (*get the information of the agent partner *) @@ -1913,113 +1603,81 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let agent_type = agent.Cckappa_sig.agent_name in let site_x = step.Communication.site_out in (*looking into the bonds of the agent*) - match - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_id - rule.Cckappa_sig.rule_lhs.Cckappa_sig.bonds - with + (match + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_id + rule.Cckappa_sig.rule_lhs.Cckappa_sig.bonds + with | error, None -> (*it is incompelete, then it is outside the pattern*) let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in error, (dynamic, new_answer) | error, Some map -> - match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters - error - site_x - map - with + (match + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs + parameters error site_x map + with | error, None -> (*outside the pattern*) let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in error, (dynamic, new_answer) | error, Some site_add -> (*there is a bond, check the following pattern is it well defined*) - let agent_type' = site_add.Cckappa_sig.agent_type in (*B*) - let site_type' = site_add.Cckappa_sig.site in (*z?*) + let agent_type' = site_add.Cckappa_sig.agent_type in + (*B*) + let site_type' = site_add.Cckappa_sig.site in + (*z?*) (*if A.x is bound to B.x*) - if agent_type' = agent_type_partner && - site_type' = site_x_partner - then + if + agent_type' = agent_type_partner + && site_type' = site_x_partner + then ( (*inside the pattern*) let error', (dynamic, new_answer) = - precondition_inside_pattern - parameters error dynamic + precondition_inside_pattern parameters error dynamic kappa_handler path agent_type aux rule - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result - bdu_false + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result bdu_false bdu_true in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error + error' __POS__ Exit in error, (dynamic, new_answer) - else + ) else ( (*outsite the pattern*) let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error + error' __POS__ Exit in error, (dynamic, new_answer) + )))) in error, (dynamic, new_answer) in @@ -2027,42 +1685,34 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*------------------------------------------------------------*) - let compute_precondition_enable - error kappa_handler rule rule_id precondition - bdu_false bdu_true dual_contact_map store_agent_name - site_correspondence site_correspondence_map - store_covering_classes_id fixpoint_result proj_bdu_test_restriction = + let compute_precondition_enable error kappa_handler rule rule_id precondition + bdu_false bdu_true dual_contact_map store_agent_name site_correspondence + site_correspondence_map store_covering_classes_id fixpoint_result + proj_bdu_test_restriction = let precondition = Communication.refine_information_about_state_of_sites_in_precondition precondition - (fun parameters error dynamic (current_path:Communication.path) - former_answer -> + (fun + parameters + error + dynamic + (current_path : Communication.path) + former_answer + -> (*-----------------------------------------------------*) (*typing*) let error = - scan_bot - ~also_scan_top:false - __POS__ parameters error - former_answer + scan_bot ~also_scan_top:false __POS__ parameters error former_answer " from overlying domain" in let error, answer_contact_map = - precondition_typing - parameters - error - kappa_handler - rule_id - current_path.Communication.relative_address - current_path - store_agent_name - dual_contact_map + precondition_typing parameters error kappa_handler rule_id + current_path.Communication.relative_address current_path + store_agent_name dual_contact_map in let error = - scan_bot_warn - ~also_scan_top:false - __POS__ parameters error - answer_contact_map - " in the contact map" + scan_bot_warn ~also_scan_top:false __POS__ parameters error + answer_contact_map " in the contact map" in (*-----------------------------------------------------*) (* The output should be more precise than former_answer: @@ -2077,65 +1727,45 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*------------------------------------------------*) (*pattern navigation*) let error, (dynamic, new_answer) = - compute_pattern_navigation - parameters error kappa_handler - aux dynamic path rule - step - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + compute_pattern_navigation parameters error kappa_handler aux + dynamic path rule step bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - scan_bot - ~also_scan_top:false - __POS__ parameters error - new_answer - " while navigating" + scan_bot ~also_scan_top:false __POS__ parameters error + new_answer " while navigating" in let update_answer = - Usual_domains.glb_list new_answer former_answer in + Usual_domains.glb_list new_answer former_answer + in error, dynamic, update_answer (*--------------------------------------------------*) (*empty relative_adress*) | [] -> let error, dynamic, new_answer = - precondition_empty_step_list - kappa_handler - parameters - error - dynamic - rule_id - path - store_agent_name - bdu_false - bdu_true - store_covering_classes_id - site_correspondence_map - fixpoint_result - proj_bdu_test_restriction + precondition_empty_step_list kappa_handler parameters error + dynamic rule_id path store_agent_name bdu_false bdu_true + store_covering_classes_id site_correspondence_map + fixpoint_result proj_bdu_test_restriction in let error = - scan_bot - ~also_scan_top:false - __POS__ parameters error - new_answer - " while navigating (empty path)" + scan_bot ~also_scan_top:false __POS__ parameters error + new_answer " while navigating (empty path)" in (*do I need to do the intersection with former answer?*) let update_answer = - Usual_domains.glb_list new_answer former_answer in + Usual_domains.glb_list new_answer former_answer + in error, dynamic, update_answer in aux dynamic current_path in (*final intersection with contact map*) let update_answer = - Usual_domains.glb_list answer_contact_map new_answer in - error, dynamic, update_answer - ) + Usual_domains.glb_list answer_contact_map new_answer + in + error, dynamic, update_answer) in error, precondition @@ -2148,13 +1778,13 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let rules = compil.Cckappa_sig.rules in let error, rule = match - Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error rule_id rules + Ckappa_sig.Rule_nearly_Inf_Int_storage_Imperatif.unsafe_get parameters + error rule_id rules with | error, None -> let error, rule = Preprocess.empty_rule parameters error in - Exception.warn parameters error __POS__ - ~message:"unknown rule" Exit rule + Exception.warn parameters error __POS__ ~message:"unknown rule" Exit + rule | error, Some rule -> error, rule.Cckappa_sig.e_rule_c_rule in (*-----------------------------------------------------------*) @@ -2183,36 +1813,19 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*check the condition whether or not the bdu is enabled, do the intersection of bdu_test and bdu_X.*) let error, dynamic = - collect_bdu_enabled - parameters - error - dynamic - bdu_false - fixpoint_result + collect_bdu_enabled parameters error dynamic bdu_false fixpoint_result proj_bdu_test_restriction in (*-----------------------------------------------------*) (*get a set of sites in a covering class: later with state list*) let error, precondition = - compute_precondition_enable - error - kappa_handler - rule - rule_id - precondition - bdu_false - bdu_true - dual_contact_map - store_agent_name - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result - proj_bdu_test_restriction + compute_precondition_enable error kappa_handler rule rule_id + precondition bdu_false bdu_true dual_contact_map store_agent_name + site_correspondence site_correspondence_map store_covering_classes_id + fixpoint_result proj_bdu_test_restriction in error, (dynamic, precondition), true - with - False (error, dynamic) -> error, (dynamic, precondition), false + with False (error, dynamic) -> error, (dynamic, precondition), false (************************************************************) (*get contact_map from dynamic*) @@ -2225,8 +1838,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error, (dynamic, precondition), is_enable = is_enable_aux static dynamic error rule_id precondition in - if is_enable - then + if is_enable then error, dynamic, Some precondition else error, dynamic, None @@ -2235,19 +1847,13 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*Precondition inside pattern*) (***********************************************************) - let precondition_step_pattern - parameters error step aux dynamic - path pattern kappa_handler - bdu_false bdu_true - site_correspondence site_correspondence_map - store_covering_classes_id fixpoint_result - = + let precondition_step_pattern parameters error step aux dynamic path pattern + kappa_handler bdu_false bdu_true site_correspondence + site_correspondence_map store_covering_classes_id fixpoint_result = let error, agent = match Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - path.Communication.agent_id (*#1:A*) + parameters error path.Communication.agent_id (*#1:A*) pattern.Cckappa_sig.views with | error, None -> @@ -2256,204 +1862,143 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id in let error, (dynamic, new_answer) = match agent with - | Cckappa_sig.Ghost - | Cckappa_sig.Unknown_agent _ + | Cckappa_sig.Ghost | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Dead_agent _ -> - Exception.warn - parameters error __POS__ Exit (dynamic, Usual_domains.Undefined) + Exception.warn parameters error __POS__ Exit + (dynamic, Usual_domains.Undefined) | Cckappa_sig.Agent agent -> let agent_type = agent.Cckappa_sig.agent_name in (*search inside the pattern, check whether or not it is out of the pattern or in the pattern.*) let error, (dynamic, new_answer) = match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters - error - step.Communication.site_out (*A.x: state*) + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameters + error step.Communication.site_out (*A.x: state*) agent.Cckappa_sig.agent_interface with (*---------------------------------------------------------*) | error, None -> let error, (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - scan_bot - ~also_scan_top:false __POS__ - parameters error - new_answer + scan_bot ~also_scan_top:false __POS__ parameters error new_answer " in precondition outside a pattern" in error, (dynamic, new_answer) (*---------------------------------------------------------*) | error, Some port -> - match port.Cckappa_sig.site_free with + (match port.Cckappa_sig.site_free with | Some true -> let () = if - (local_trace - || - Remanent_parameters.get_dump_reachability_analysis_wl - parameters - || Remanent_parameters.get_trace parameters) - then - let () = Loggers.fprintf + local_trace + || Remanent_parameters.get_dump_reachability_analysis_wl + parameters + || Remanent_parameters.get_trace parameters + then ( + let () = + Loggers.fprintf (Remanent_parameters.get_logger parameters) "Try to navigate through a free site: bottom reduction" in Loggers.print_newline (Remanent_parameters.get_logger parameters) + ) in error, (dynamic, Usual_domains.Undefined) - | None - | Some false -> + | None | Some false -> let agent_type_partner = step.Communication.agent_type_in in let site_x_partner = step.Communication.site_in in let agent_id = path.Communication.agent_id in let site_x = step.Communication.site_out in (*---------------------------------------------------------*) - match - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters - error - agent_id - pattern.Cckappa_sig.bonds - with + (match + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_id pattern.Cckappa_sig.bonds + with | error, None -> let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ - Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in error, (dynamic, new_answer) (*---------------------------------------------------------*) | error, Some map -> - match - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameters - error - site_x - map - with + (match + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs + parameters error site_x map + with | error, None -> let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' __POS__ Exit + Exception.check_point Exception.warn parameters error error' + __POS__ Exit in error, (dynamic, new_answer) | error, Some site_add -> let agent_type' = site_add.Cckappa_sig.agent_type in let site_type' = site_add.Cckappa_sig.site in - if agent_type' = agent_type_partner && - site_type' = site_x_partner - then + if + agent_type' = agent_type_partner + && site_type' = site_x_partner + then ( let error, output = - Communication.follow_path_inside_cc - parameters error kappa_handler - pattern - path + Communication.follow_path_inside_cc parameters error + kappa_handler pattern path in match output with | Communication.Cannot_exist -> error, (dynamic, Usual_domains.Undefined) | Communication.May_exist _ -> let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error + error' __POS__ Exit in error, (dynamic, new_answer) | Communication.Located agent_id -> let next_path = { Communication.site = path.Communication.site; - Communication.agent_id = agent_id ; - Communication.relative_address = [] + Communication.agent_id; + Communication.relative_address = []; } in - let error, dynamic, new_answer = - aux dynamic next_path - in + let error, dynamic, new_answer = aux dynamic next_path in error, (dynamic, new_answer) - else + ) else ( let error', (dynamic, new_answer) = - precondition_outside_pattern - parameters - error - dynamic - kappa_handler - path - agent_type - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_outside_pattern parameters error dynamic + kappa_handler path agent_type bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - Exception.check_point - Exception.warn parameters error error' - __POS__ Exit + Exception.check_point Exception.warn parameters error + error' __POS__ Exit in error, (dynamic, new_answer) + )))) in error, (dynamic, new_answer) in @@ -2461,241 +2006,181 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (************************************************************************) - let build_bdu_test_pattern parameters error pattern - site_correspondence dynamic = - Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters error + let build_bdu_test_pattern parameters error pattern site_correspondence + dynamic = + Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters + error (fun parameters error _agent_id agent (dynamic, current_list) -> - match agent with - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent _ -> - Exception.warn - parameters error __POS__ - Exit (dynamic,current_list) - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let error, get_pair_list = - Bdu_static_views.get_pair_cv_map_with_restriction_views - parameters error agent site_correspondence - in - (*build bdu_test*) - let error, (dynamic, list) = - List.fold_left - (fun (error, (dynamic, current_list)) (_cv_id, map_res) -> - if - Ckappa_sig.Site_map_and_set.Map.is_empty - map_res - then error, (dynamic, current_list) - else - let error, pair_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site' state (error, current_list) -> - let pair_list = - (site', - (state.Cckappa_sig.min, state.Cckappa_sig.max)) - :: current_list - in - error, pair_list - ) map_res (error, []) - in - let handler = - Analyzer_headers.get_mvbdu_handler dynamic - in - let error, handler, bdu_test = - Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_range_list - parameters - handler error - pair_list - in - let dynamic = Analyzer_headers.set_mvbdu_handler handler dynamic - in - error, (dynamic, (agent_type, bdu_test) :: current_list) - ) (error, (dynamic, current_list)) get_pair_list - in - error, (dynamic, list) - ) pattern.Cckappa_sig.views (dynamic, []) - - let precondition_empty_aux parameters error path - pattern dynamic bdu_false bdu_true - site_correspondence site_correspondence_map - fixpoint_result cv_list - = + match agent with + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost + | Cckappa_sig.Dead_agent _ -> + Exception.warn parameters error __POS__ Exit (dynamic, current_list) + | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let error, get_pair_list = + Bdu_static_views.get_pair_cv_map_with_restriction_views parameters + error agent site_correspondence + in + (*build bdu_test*) + let error, (dynamic, list) = + List.fold_left + (fun (error, (dynamic, current_list)) (_cv_id, map_res) -> + if Ckappa_sig.Site_map_and_set.Map.is_empty map_res then + error, (dynamic, current_list) + else ( + let error, pair_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site' state (error, current_list) -> + let pair_list = + (site', (state.Cckappa_sig.min, state.Cckappa_sig.max)) + :: current_list + in + error, pair_list) + map_res (error, []) + in + let handler = Analyzer_headers.get_mvbdu_handler dynamic in + let error, handler, bdu_test = + Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_range_list + parameters handler error pair_list + in + let dynamic = + Analyzer_headers.set_mvbdu_handler handler dynamic + in + error, (dynamic, (agent_type, bdu_test) :: current_list) + )) + (error, (dynamic, current_list)) + get_pair_list + in + error, (dynamic, list)) + pattern.Cckappa_sig.views (dynamic, []) + + let precondition_empty_aux parameters error path pattern dynamic bdu_false + bdu_true site_correspondence site_correspondence_map fixpoint_result + cv_list = let error, (dynamic, list) = - build_bdu_test_pattern parameters error pattern - site_correspondence dynamic + build_bdu_test_pattern parameters error pattern site_correspondence + dynamic in (*--------------------------------------------------*) let error, dynamic, bdu = - List.fold_left (fun (error, dynamic, bdu) (agent_type, bdu_test) -> - List.fold_left (fun (error, dynamic, bdu) cv_id -> + List.fold_left + (fun (error, dynamic, bdu) (agent_type, bdu_test) -> + List.fold_left + (fun (error, dynamic, bdu) cv_id -> let site_name = path.Communication.site in - let error, (map1,_) = - get_list_of_sites_correspondence_map parameters error - agent_type cv_id site_correspondence_map + let error, (map1, _) = + get_list_of_sites_correspondence_map parameters error agent_type + cv_id site_correspondence_map in let error, new_site_name = - get_new_site_name - parameters error - site_name - map1 + get_new_site_name parameters error site_name map1 in let error, bdu_X = match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, cv_id) + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error (agent_type, cv_id) fixpoint_result with | error, None -> error, bdu_false | error, Some bdu -> error, bdu in - let handler = - Analyzer_headers.get_mvbdu_handler dynamic - in + let handler = Analyzer_headers.get_mvbdu_handler dynamic in let error, handler, bdu_test_X = - Ckappa_sig.Views_bdu.mvbdu_and - parameters - handler - error - bdu_X + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu_X bdu_test in let error, handler, singleton = - Ckappa_sig.Views_bdu.build_variables_list - parameters - handler - error - [new_site_name] + Ckappa_sig.Views_bdu.build_variables_list parameters handler + error [ new_site_name ] in let error, handler, bdu_proj = - Ckappa_sig.Views_bdu.mvbdu_project_keep_only - parameters - handler - error - bdu_test_X - singleton + Ckappa_sig.Views_bdu.mvbdu_project_keep_only parameters handler + error bdu_test_X singleton in (* rename new_site_name into 1 *) let error, handler, new_site_name_1 = - Ckappa_sig.Views_bdu.build_renaming_list - parameters - handler + Ckappa_sig.Views_bdu.build_renaming_list parameters handler error - [new_site_name, site_name] + [ new_site_name, site_name ] in let error, handler, bdu_renamed = - Ckappa_sig.Views_bdu.mvbdu_rename - parameters - handler - error - bdu_proj - new_site_name_1 + Ckappa_sig.Views_bdu.mvbdu_rename parameters handler error + bdu_proj new_site_name_1 in (* conjunction between bdu and bdu'*) let error, handler, bdu = - Ckappa_sig.Views_bdu.mvbdu_and - parameters - handler - error - bdu + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error bdu bdu_renamed in let dynamic = - Analyzer_headers.set_mvbdu_handler handler - dynamic + Analyzer_headers.set_mvbdu_handler handler dynamic in - error, dynamic, bdu - ) (error, dynamic, bdu) cv_list - ) (error, dynamic, bdu_true) list + error, dynamic, bdu) + (error, dynamic, bdu) cv_list) + (error, dynamic, bdu_true) list in let handler = Analyzer_headers.get_mvbdu_handler dynamic in let error, handler, list = - Ckappa_sig.Views_bdu.extensional_of_mvbdu - parameters - handler - error - bdu + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler error bdu in let dynamic = Analyzer_headers.set_mvbdu_handler handler dynamic in let error, state_lists = - List.fold_left (fun (error, output) list -> + List.fold_left + (fun (error, output) list -> match list with - | [_, state] -> error, state :: output - | _ -> Exception.warn - parameters error - __POS__ ~message:"state is empty" Exit output - ) (error, []) list + | [ (_, state) ] -> error, state :: output + | _ -> + Exception.warn parameters error __POS__ ~message:"state is empty" + Exit output) + (error, []) list in error, (dynamic, Usual_domains.Val (List.rev state_lists)) - let precondition_empty_pattern parameters error - path pattern dynamic bdu_false bdu_true - store_agent_name_from_pattern - site_correspondence site_correspondence_map - store_covering_classes_id fixpoint_result - = + let precondition_empty_pattern parameters error path pattern dynamic bdu_false + bdu_true store_agent_name_from_pattern site_correspondence + site_correspondence_map store_covering_classes_id fixpoint_result = let error, agent_type = match - Ckappa_sig.Agent_id_map_and_set.Map.find_option_without_logs - parameters error - path.Communication.agent_id - store_agent_name_from_pattern + Ckappa_sig.Agent_id_map_and_set.Map.find_option_without_logs parameters + error path.Communication.agent_id store_agent_name_from_pattern with | error, None -> - Exception.warn - parameters error __POS__ - ~message:"unknown agent type" - Exit - Ckappa_sig.dummy_agent_name + Exception.warn parameters error __POS__ ~message:"unknown agent type" + Exit Ckappa_sig.dummy_agent_name | error, Some a -> error, a in let error, site_correspondence = match Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get - parameters - error - agent_type - site_correspondence + parameters error agent_type site_correspondence with - | error, None -> - Exception.warn parameters error __POS__ Exit [] + | error, None -> Exception.warn parameters error __POS__ Exit [] | error, Some l -> error, l in let error, cv_list = match - Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs - parameters + Ckappa_sig.AgentSite_map_and_set.Map.find_option_without_logs parameters error (agent_type, path.Communication.site) store_covering_classes_id with | error, None -> - Exception.warn parameters error - __POS__ + Exception.warn parameters error __POS__ ~message:"the site does not belong to the last agent type of a path" Exit [] | error, Some l -> error, l in (*step list empty*) let error, (dynamic, new_answer) = - precondition_empty_aux - parameters error - path - pattern - dynamic - bdu_false - bdu_true - site_correspondence - site_correspondence_map - fixpoint_result + precondition_empty_aux parameters error path pattern dynamic bdu_false + bdu_true site_correspondence site_correspondence_map fixpoint_result cv_list in error, dynamic, new_answer (************************************************************************) - let maybe_reachable_aux static dynamic error (pattern: Cckappa_sig.mixture) + let maybe_reachable_aux static dynamic error (pattern : Cckappa_sig.mixture) precondition = let parameters = get_parameter static in (*-----------------------------------------------------------*) @@ -2707,9 +2192,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let dual_contact_map = get_store_dual_contact_map dynamic in let store_agent_name_from_pattern = get_agent_name_from_pattern static in let site_correspondence = get_remanent_triple static in - let site_correspondence_map = - get_site_correspondence_array static - in + let site_correspondence_map = get_site_correspondence_array static in let store_covering_classes_id = get_covering_classes_id static in (*---------------------------------------------------------*) (* Why an arbitrary patterns would be stored in that map *) @@ -2725,96 +2208,99 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id Ckappa_sig.Agent_id_quick_nearly_Inf_Int_storage_Imperatif.fold parameters error (fun parameters error _agent_id agent dynamic -> - match agent with - | Cckappa_sig.Unknown_agent _ - | Cckappa_sig.Ghost - | Cckappa_sig.Dead_agent (_, _, _, _) -> error, dynamic - | Cckappa_sig.Agent agent -> - let agent_type = agent.Cckappa_sig.agent_name in - let interface = agent.Cckappa_sig.agent_interface in - if Ckappa_sig.Site_map_and_set.Map.is_empty interface then - error, dynamic - else - let error, site_correspondence = - match - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.get - parameters error - agent_type - site_correspondence - with - | error, None -> - Exception.warn parameters error __POS__ Exit [] - | error, Some l -> error, l - in - let error, get_pair_list = - Bdu_static_views.get_pair_cv_map_with_restriction_views - parameters error - agent - site_correspondence - in - (*build bdu_test*) - let error, dynamic = - List.fold_left (fun (error, dynamic) (cv_id, map_res) -> - if Ckappa_sig.Site_map_and_set.Map.is_empty map_res - then error, dynamic - else - let error, pair_list = - Ckappa_sig.Site_map_and_set.Map.fold - (fun site' state (error, current_list) -> - let pair_list = - (site', - (state.Cckappa_sig.min, state.Cckappa_sig.max) - ) :: current_list in - error, pair_list - ) map_res (error, []) - in - let handler = get_mvbdu_handler dynamic in - let error, handler, bdu_test = - Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_range_list parameters handler error - pair_list - in - let dynamic = set_mvbdu_handler handler dynamic in - (*check bdu_test with bdu in result*) - let error, bdu_X = - match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_type, cv_id) - fixpoint_result - with - | error, None -> error, bdu_false - | error, Some bdu -> error, bdu - in - let handler = get_mvbdu_handler dynamic in - (*if it does not overlap then answer false, otherwise - continue*) - let error, handler, bdu_inter = - Ckappa_sig.Views_bdu.mvbdu_and - parameters handler error bdu_test bdu_X - in - let dynamic = set_mvbdu_handler handler dynamic in - (*check if it is overlap or not?*) - if Ckappa_sig.Views_bdu.equal bdu_inter bdu_false - then raise (False (error, dynamic)) - else - (*continue to iterate*) - error, dynamic - ) (error, dynamic) get_pair_list - in - error, dynamic - ) pattern.Cckappa_sig.views dynamic + match agent with + | Cckappa_sig.Unknown_agent _ | Cckappa_sig.Ghost + | Cckappa_sig.Dead_agent (_, _, _, _) -> + error, dynamic + | Cckappa_sig.Agent agent -> + let agent_type = agent.Cckappa_sig.agent_name in + let interface = agent.Cckappa_sig.agent_interface in + if Ckappa_sig.Site_map_and_set.Map.is_empty interface then + error, dynamic + else ( + let error, site_correspondence = + match + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .get parameters error agent_type site_correspondence + with + | error, None -> + Exception.warn parameters error __POS__ Exit [] + | error, Some l -> error, l + in + let error, get_pair_list = + Bdu_static_views.get_pair_cv_map_with_restriction_views + parameters error agent site_correspondence + in + (*build bdu_test*) + let error, dynamic = + List.fold_left + (fun (error, dynamic) (cv_id, map_res) -> + if Ckappa_sig.Site_map_and_set.Map.is_empty map_res then + error, dynamic + else ( + let error, pair_list = + Ckappa_sig.Site_map_and_set.Map.fold + (fun site' state (error, current_list) -> + let pair_list = + ( site', + (state.Cckappa_sig.min, state.Cckappa_sig.max) + ) + :: current_list + in + error, pair_list) + map_res (error, []) + in + let handler = get_mvbdu_handler dynamic in + let error, handler, bdu_test = + Ckappa_sig.Views_bdu + .mvbdu_of_reverse_sorted_range_list parameters handler + error pair_list + in + let dynamic = set_mvbdu_handler handler dynamic in + (*check bdu_test with bdu in result*) + let error, bdu_X = + match + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error + (agent_type, cv_id) fixpoint_result + with + | error, None -> error, bdu_false + | error, Some bdu -> error, bdu + in + let handler = get_mvbdu_handler dynamic in + (*if it does not overlap then answer false, otherwise + continue*) + let error, handler, bdu_inter = + Ckappa_sig.Views_bdu.mvbdu_and parameters handler + error bdu_test bdu_X + in + let dynamic = set_mvbdu_handler handler dynamic in + (*check if it is overlap or not?*) + if Ckappa_sig.Views_bdu.equal bdu_inter bdu_false then + raise (False (error, dynamic)) + else + (*continue to iterate*) + error, dynamic + )) + (error, dynamic) get_pair_list + in + error, dynamic + )) + pattern.Cckappa_sig.views dynamic in let precondition = Communication.refine_information_about_state_of_sites_in_precondition precondition - (fun parameters error (dynamic:Analyzer_headers.global_dynamic_information) - (current_path:Communication.path) - former_answer -> - let error = scan_bot - ~also_scan_top:false - __POS__ parameters error - former_answer - " from overlying domain" + (fun + parameters + error + (dynamic : Analyzer_headers.global_dynamic_information) + (current_path : Communication.path) + former_answer + -> + let error = + scan_bot ~also_scan_top:false __POS__ parameters error + former_answer " from overlying domain" in let error, answer_contact_map = let rec aux acc error = @@ -2823,8 +2309,8 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id | step :: tl -> let error, agent_type = match - Ckappa_sig.Agent_id_map_and_set.Map.find_option_without_logs - parameters error + Ckappa_sig.Agent_id_map_and_set.Map + .find_option_without_logs parameters error current_path.Communication.agent_id store_agent_name_from_pattern with @@ -2833,68 +2319,57 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id in let error, state_dic = Misc_sa.unsome - (Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.get - parameters - error + (Ckappa_sig + .Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .get parameters error (agent_type, step.Communication.site_out) kappa_handler.Cckappa_sig.states_dic) (fun error -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.Dictionary_of_States.init ())) + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.Dictionary_of_States.init ())) in let state = - Ckappa_sig.C_Lnk_type (step.Communication.agent_type_in, - step.Communication.site_in) + Ckappa_sig.C_Lnk_type + ( step.Communication.agent_type_in, + step.Communication.site_in ) in let error, b = - Ckappa_sig.Dictionary_of_States.member - parameters - error - (Ckappa_sig.Binding state) - state_dic + Ckappa_sig.Dictionary_of_States.member parameters error + (Ckappa_sig.Binding state) state_dic in - if b - then + if b then ( let error, answer_contact_map = - match Ckappa_sig.Dictionary_of_States.allocate - parameters - error - Ckappa_sig.compare_unit_state_index - (Ckappa_sig.Binding state) - () - Misc_sa.const_unit - state_dic + match + Ckappa_sig.Dictionary_of_States.allocate parameters + error Ckappa_sig.compare_unit_state_index + (Ckappa_sig.Binding state) () Misc_sa.const_unit + state_dic with | error, None -> Exception.warn parameters error __POS__ Exit Usual_domains.Undefined | error, Some (state, _, _, _) -> - match - Ckappa_sig.AgentSiteState_map_and_set.Map.find_option_without_logs - parameters - error - (agent_type, step.Communication.site_out, state) - dual_contact_map - with - | error, None -> Exception.warn - parameters error __POS__ Exit - Usual_domains.Undefined - | error, Some _ -> aux tl error + (match + Ckappa_sig.AgentSiteState_map_and_set.Map + .find_option_without_logs parameters error + (agent_type, step.Communication.site_out, state) + dual_contact_map + with + | error, None -> + Exception.warn parameters error __POS__ Exit + Usual_domains.Undefined + | error, Some _ -> aux tl error) in error, answer_contact_map - else + ) else Exception.warn parameters error __POS__ Exit Usual_domains.Undefined in aux current_path.Communication.relative_address error in let error = - scan_bot_warn - ~also_scan_top:false - __POS__ parameters error - answer_contact_map - " in the contact map" + scan_bot_warn ~also_scan_top:false __POS__ parameters error + answer_contact_map " in the contact map" in let error, dynamic, new_answer = let rec aux dynamic path = @@ -2902,24 +2377,14 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id match step_list with | step :: _ -> let error, (dynamic, new_answer) = - precondition_step_pattern - parameters error - step - aux dynamic path - pattern - kappa_handler - bdu_false - bdu_true - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_step_pattern parameters error step aux dynamic + path pattern kappa_handler bdu_false bdu_true + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - scan_bot ~also_scan_top:false - __POS__ parameters error - new_answer - " whie navigating" + scan_bot ~also_scan_top:false __POS__ parameters error + new_answer " whie navigating" in let update_answer = Usual_domains.glb_list new_answer former_answer @@ -2927,22 +2392,14 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id error, dynamic, update_answer | [] -> let error, dynamic, new_answer = - precondition_empty_pattern - parameters error - path pattern - dynamic - bdu_false bdu_true - store_agent_name_from_pattern - site_correspondence - site_correspondence_map - store_covering_classes_id - fixpoint_result + precondition_empty_pattern parameters error path pattern + dynamic bdu_false bdu_true store_agent_name_from_pattern + site_correspondence site_correspondence_map + store_covering_classes_id fixpoint_result in let error = - scan_bot ~also_scan_top:false - __POS__ parameters error - new_answer - " while navigating (empty path)" + scan_bot ~also_scan_top:false __POS__ parameters error + new_answer " while navigating (empty path)" in let update_answer = Usual_domains.glb_list new_answer former_answer @@ -2955,24 +2412,17 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let update_answer = Usual_domains.glb_list answer_contact_map new_answer in - error, dynamic, update_answer - ) + error, dynamic, update_answer) in error, (dynamic, precondition), true - with - False (error, dynamic) -> - error, (dynamic, precondition), false + with False (error, dynamic) -> error, (dynamic, precondition), false (* the flag can be safely ignored in this abstract domain *) - let maybe_reachable static dynamic error _flag pattern - precondition = + let maybe_reachable static dynamic error _flag pattern precondition = let error, (dynamic, precondition), maybe_reachable = - maybe_reachable_aux static dynamic error - pattern - precondition + maybe_reachable_aux static dynamic error pattern precondition in - if maybe_reachable - then + if maybe_reachable then error, dynamic, Some precondition else error, dynamic, None @@ -2982,22 +2432,23 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let compute_bdu_update_aux static dynamic error bdu_test list_a bdu_X = let parameters = get_parameter static in - let parameter_views = Remanent_parameters.update_prefix parameters "\t\t\t" + let parameter_views = + Remanent_parameters.update_prefix parameters "\t\t\t" in let handler = get_mvbdu_handler dynamic in let error, handler, bdu_inter = - Ckappa_sig.Views_bdu.mvbdu_and - parameter_views handler error bdu_X bdu_test + Ckappa_sig.Views_bdu.mvbdu_and parameter_views handler error bdu_X + bdu_test in (*redefine with modification list*) let error, handler, bdu_redefine = - Ckappa_sig.Views_bdu.mvbdu_redefine - parameter_views handler error bdu_inter list_a + Ckappa_sig.Views_bdu.mvbdu_redefine parameter_views handler error + bdu_inter list_a in (*do the union of bdu_redefine and bdu_X*) let error, handler, bdu_result = - Ckappa_sig.Views_bdu.mvbdu_or - parameter_views handler error bdu_redefine bdu_X + Ckappa_sig.Views_bdu.mvbdu_or parameter_views handler error bdu_redefine + bdu_X in let dynamic = set_mvbdu_handler handler dynamic in error, dynamic, bdu_result @@ -3016,37 +2467,37 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let parameters = get_parameter static in let handler = get_mvbdu_handler dynamic in let error, handler, bdu_result = - Ckappa_sig.Views_bdu.mvbdu_or - parameters handler error bdu_creation bdu_X + Ckappa_sig.Views_bdu.mvbdu_or parameters handler error bdu_creation bdu_X in let dynamic = set_mvbdu_handler handler dynamic in error, dynamic, bdu_result (***************************************************************) - let compute_bdu_update_side_effects static dynamic error bdu_test list_a bdu_X = + let compute_bdu_update_side_effects static dynamic error bdu_test list_a bdu_X + = let parameters = get_parameter static in - let parameter_views = Remanent_parameters.update_prefix parameters "\t\t\t" + let parameter_views = + Remanent_parameters.update_prefix parameters "\t\t\t" in let handler = get_mvbdu_handler dynamic in let error, handler, bdu_inter = - Ckappa_sig.Views_bdu.mvbdu_and - parameter_views handler error bdu_X bdu_test + Ckappa_sig.Views_bdu.mvbdu_and parameter_views handler error bdu_X + bdu_test in (*redefine with modification list*) let error, handler, bdu_redefine = - Ckappa_sig.Views_bdu.mvbdu_redefine - parameter_views handler error bdu_inter list_a + Ckappa_sig.Views_bdu.mvbdu_redefine parameter_views handler error + bdu_inter list_a in (*do the union of bdu_redefine and bdu_X*) let error, handler, bdu_result = - Ckappa_sig.Views_bdu.mvbdu_or - parameter_views handler error bdu_redefine bdu_X + Ckappa_sig.Views_bdu.mvbdu_or parameter_views handler error bdu_redefine + bdu_X in let dynamic = set_mvbdu_handler handler dynamic in error, dynamic, bdu_result - (****************************************************************) let compute_views_test_enabled static dynamic error rule_id event_list = @@ -3068,65 +2519,62 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*deal with views*) Covering_classes_type.AgentsCV_setmap.Map.fold (fun (agent_id, agent_type, cv_id) _ (error, dynamic, event_list) -> - let error, dynamic, bdu_false = - get_mvbdu_false static dynamic error in - let error, dynamic, bdu_true = get_mvbdu_true static dynamic error in - let error, store_modif_list_restriction_map = - get_store_modif_list_restriction_map static error - in - (*print*) - let error = - dump_cv_label - static - error - (Remanent_parameters.get_dump_reachability_analysis_diff - parameters) - (agent_type, cv_id) - in - (*-----------------------------------------------------*) - let store_result = get_fixpoint_result dynamic in - let error, bdu_X = - match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error (agent_type, cv_id) store_result - with - | error, None -> error, bdu_false - | error, Some bdu -> error, bdu - in - let error, bdu_test = - match Covering_classes_type.AgentsCV_setmap.Map.find_option - (agent_id, agent_type, cv_id) proj_bdu_test_restriction - with - | None -> error, bdu_true - | Some bdu -> error, bdu - in - let error, dynamic, bdu_update = - match - Covering_classes_type.AgentsRuleCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_id, agent_type, rule_id, cv_id) - store_modif_list_restriction_map - with - | error, None -> error, dynamic, bdu_X - | error, Some list_a -> - let error, dynamic, bdu_update = - compute_bdu_update_views static dynamic error bdu_test list_a - bdu_X - in - error, dynamic, bdu_update - in - let error, dynamic, event_list = - add_link - ~title:"" - error - static - dynamic - (agent_type, cv_id) - bdu_update - event_list - in - error, dynamic, event_list - ) proj_bdu_test_restriction (error, dynamic, event_list) + let error, dynamic, bdu_false = + get_mvbdu_false static dynamic error + in + let error, dynamic, bdu_true = get_mvbdu_true static dynamic error in + let error, store_modif_list_restriction_map = + get_store_modif_list_restriction_map static error + in + (*print*) + let error = + dump_cv_label static error + (Remanent_parameters.get_dump_reachability_analysis_diff + parameters) + (agent_type, cv_id) + in + (*-----------------------------------------------------*) + let store_result = get_fixpoint_result dynamic in + let error, bdu_X = + match + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error (agent_type, cv_id) + store_result + with + | error, None -> error, bdu_false + | error, Some bdu -> error, bdu + in + let error, bdu_test = + match + Covering_classes_type.AgentsCV_setmap.Map.find_option + (agent_id, agent_type, cv_id) + proj_bdu_test_restriction + with + | None -> error, bdu_true + | Some bdu -> error, bdu + in + let error, dynamic, bdu_update = + match + Covering_classes_type.AgentsRuleCV_map_and_set.Map + .find_option_without_logs parameters error + (agent_id, agent_type, rule_id, cv_id) + store_modif_list_restriction_map + with + | error, None -> error, dynamic, bdu_X + | error, Some list_a -> + let error, dynamic, bdu_update = + compute_bdu_update_views static dynamic error bdu_test list_a + bdu_X + in + error, dynamic, bdu_update + in + let error, dynamic, event_list = + add_link ~title:"" error static dynamic (agent_type, cv_id) + bdu_update event_list + in + error, dynamic, event_list) + proj_bdu_test_restriction + (error, dynamic, event_list) in error, dynamic, event_list @@ -3139,8 +2587,8 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id get_store_proj_bdu_creation_restriction static error in let error, bdu_creation_map = - match Ckappa_sig.Rule_setmap.Map.find_option rule_id - store_bdu_creation + match + Ckappa_sig.Rule_setmap.Map.find_option rule_id store_bdu_creation with | None -> error, Covering_classes_type.AgentCV_setmap.Map.empty | Some map -> error, map @@ -3149,32 +2597,29 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error, dynamic, event_list = Covering_classes_type.AgentCV_setmap.Map.fold (fun (agent_type, cv_id) bdu_creation (error, dynamic, event_list) -> - let error, dynamic, bdu_false = - get_mvbdu_false static dynamic error in - let fixpoint_result = get_fixpoint_result dynamic in - let error, bdu_X = - match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error (agent_type, cv_id) fixpoint_result - with - | error, None -> error, bdu_false - | error, Some bdu -> error, bdu - in - let error, dynamic, bdu_update = - compute_bdu_update_creation static dynamic error bdu_creation bdu_X - in - let error, dynamic, event_list = - add_link - ~title:"Dealing with creation" - error - static - dynamic - (agent_type, cv_id) - bdu_update - event_list - in - error, dynamic, event_list - ) bdu_creation_map (error, dynamic, event_list) + let error, dynamic, bdu_false = + get_mvbdu_false static dynamic error + in + let fixpoint_result = get_fixpoint_result dynamic in + let error, bdu_X = + match + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error (agent_type, cv_id) + fixpoint_result + with + | error, None -> error, bdu_false + | error, Some bdu -> error, bdu + in + let error, dynamic, bdu_update = + compute_bdu_update_creation static dynamic error bdu_creation bdu_X + in + let error, dynamic, event_list = + add_link ~title:"Dealing with creation" error static dynamic + (agent_type, cv_id) bdu_update event_list + in + error, dynamic, event_list) + bdu_creation_map + (error, dynamic, event_list) in error, dynamic, event_list @@ -3184,43 +2629,31 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*apply rules in different cases*) let can_we_prove_this_is_the_first_application precondition = - match - Communication.is_the_rule_applied_for_the_first_time precondition - with + match Communication.is_the_rule_applied_for_the_first_time precondition with | Usual_domains.Sure_value b -> - if b - then true - else false + if b then + true + else + false | Usual_domains.Maybe -> false let compute_views_enabled static dynamic error rule_id precondition = (*-----------------------------------------------------------------------*) (*deal with views*) let error, dynamic, event_list = - compute_views_test_enabled - static - dynamic - error - rule_id - [] + compute_views_test_enabled static dynamic error rule_id [] in (*-----------------------------------------------------------------------*) (*deal with creation*) let error, dynamic, event_list = let b = can_we_prove_this_is_the_first_application precondition in - if b - then + if b then ( (*if Sure_value is true then compute creation_enabled*) let error, dynamic, event_list = - compute_views_creation_enabled - static - dynamic - error - rule_id - event_list + compute_views_creation_enabled static dynamic error rule_id event_list in error, dynamic, event_list - else + ) else (*Sure_value is false*) error, dynamic, event_list in @@ -3234,19 +2667,13 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id in error, dynamic, (precondition, event_list) - let apply_one_side_effect - static dynamic error - _rule_id (_,(agent_name, site, state)) precondition - = + let apply_one_side_effect static dynamic error _rule_id + (_, (agent_name, site, state)) precondition = let parameters = get_parameter static in - let error, site_to_site_list = - get_site_to_renamed_site_list static error - in + let error, site_to_site_list = get_site_to_renamed_site_list static error in let error, site_list_opt = - Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif.unsafe_get - parameters error - (agent_name,site) - site_to_site_list + Ckappa_sig.Agent_type_site_nearly_Inf_Int_Int_storage_Imperatif_Imperatif + .unsafe_get parameters error (agent_name, site) site_to_site_list in let site_list = match site_list_opt with @@ -3256,70 +2683,66 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error, dynamic, event_list = List.fold_left (fun (error, dynamic, event_list) (cv_id, site') -> - let list_test = [site', state] in - let list_modif = [site', Ckappa_sig.dummy_state_index] in - let handler = get_mvbdu_handler dynamic in - let error, handler, bdu_test = - Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_association_list - parameters handler error list_test - in - let error, handler, list_modif = - Ckappa_sig.Views_bdu.build_association_list - parameters handler error list_modif - in - let dynamic = set_mvbdu_handler handler dynamic in - let fixpoint_result = get_fixpoint_result dynamic in - let error, dynamic, bdu_false = - get_mvbdu_false static dynamic error in - let error, bdu_X = - match - Covering_classes_type.AgentCV_map_and_set.Map.find_option_without_logs - parameters error - (agent_name, cv_id) + let list_test = [ site', state ] in + let list_modif = [ site', Ckappa_sig.dummy_state_index ] in + let handler = get_mvbdu_handler dynamic in + let error, handler, bdu_test = + Ckappa_sig.Views_bdu.mvbdu_of_reverse_sorted_association_list + parameters handler error list_test + in + let error, handler, list_modif = + Ckappa_sig.Views_bdu.build_association_list parameters handler error + list_modif + in + let dynamic = set_mvbdu_handler handler dynamic in + let fixpoint_result = get_fixpoint_result dynamic in + let error, dynamic, bdu_false = + get_mvbdu_false static dynamic error + in + let error, bdu_X = + match + Covering_classes_type.AgentCV_map_and_set.Map + .find_option_without_logs parameters error (agent_name, cv_id) fixpoint_result with | error, None -> error, bdu_false | error, Some bdu -> error, bdu in let error, dynamic, bdu_update = - compute_bdu_update_side_effects static dynamic error bdu_test list_modif - bdu_X + compute_bdu_update_side_effects static dynamic error bdu_test + list_modif bdu_X in let error, dynamic, event_list = - add_link - ~title:"Dealing with side effects" - error - static - dynamic - (agent_name, cv_id) - bdu_update - event_list + add_link ~title:"Dealing with side effects" error static dynamic + (agent_name, cv_id) bdu_update event_list in - error, dynamic, event_list - ) (error, dynamic, []) site_list + error, dynamic, event_list) + (error, dynamic, []) site_list in - error, dynamic, (precondition,event_list) + error, dynamic, (precondition, event_list) (**************************************************************************) (* events enable communication between domains. At this moment, the global domain does not collect information *) - let apply_event_list _static dynamic error _event_list = - error, dynamic, [] + let apply_event_list _static dynamic error _event_list = error, dynamic, [] (**************************************************************************) (*main print of fixpoint*) let print_bdu_update_map parameters error handler_kappa result = - AgentCV_map_and_set.Map.fold (fun (agent_type, cv_id) bdu_update error -> + AgentCV_map_and_set.Map.fold + (fun (agent_type, cv_id) bdu_update error -> let error', agent_string = Handler.string_of_agent parameters error handler_kappa agent_type in let error = - Exception.check_point Exception.warn - parameters error error' __POS__ Exit in + Exception.check_point Exception.warn parameters error error' __POS__ + Exit + in let () = - Loggers.fprintf (Remanent_parameters.get_logger parameters) + Loggers.fprintf + (Remanent_parameters.get_logger parameters) "agent_type:%i:%s:cv_id:%i" (Ckappa_sig.int_of_agent_name agent_type) agent_string @@ -3328,329 +2751,263 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - let () = - Ckappa_sig.Views_bdu.print - parameters bdu_update - in + let () = Ckappa_sig.Views_bdu.print parameters bdu_update in error) result error (**************************************************************************) - let smash_map decomposition - ~show_dep_with_dimmension_higher_than:_dim_min + let smash_map decomposition ~show_dep_with_dimmension_higher_than:_dim_min parameters handler error _handler_kappa (*store_new_index_pair_map*) - site_correspondence result = - let error',handler,mvbdu_true = - Ckappa_sig.Views_bdu.mvbdu_true - parameters handler error + site_correspondence result = + let error', handler, mvbdu_true = + Ckappa_sig.Views_bdu.mvbdu_true parameters handler error in - let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error' __POS__ Exit in Covering_classes_type.AgentCV_map_and_set.Map.fold - (fun (agent_type, cv_id) bdu (error,handler,output) -> - let error, handler, list = - decomposition parameters handler error bdu - in - let error, (_, map2) = - get_list_of_sites_correspondence_map - parameters error - agent_type cv_id - site_correspondence - in - let rename_site parameters error site_type = - let error, site_type = - match - Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get - parameters error - site_type - map2 - with - | error, None -> Exception.warn parameters error __POS__ Exit - Ckappa_sig.dummy_site_name_minus1 - | error, Some i -> error, i - in - error, site_type - in - List.fold_left - (fun (error, handler, output) bdu -> - begin - let error, handler, lvar = - Ckappa_sig.Views_bdu.variables_list_of_mvbdu - parameters handler error - bdu - in - (*list: ckappa_sig.c_site_name list*) - let error, handler, list = - Ckappa_sig.Views_bdu.extensional_of_variables_list - parameters handler error - lvar - in - (*asso take (key * key) list *) - let error, asso = - List.fold_left - (fun (error, list) i -> - let error, new_name = - rename_site parameters error i - in - error,(i, new_name) :: list) - (error, []) - (List.rev list) - in - let error, handler, hconsed_asso = - Ckappa_sig.Views_bdu.build_renaming_list - parameters handler error asso - in - let error,handler,renamed_mvbdu = - Ckappa_sig.Views_bdu.mvbdu_rename - parameters handler error bdu hconsed_asso - in - let error,handler,hconsed_vars = - Ckappa_sig.Views_bdu.variables_list_of_mvbdu - parameters handler error renamed_mvbdu - in - let error, cv_map_opt = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.unsafe_get - parameters error agent_type output - in - let error,cv_map = - match - cv_map_opt - with - | None -> - error, Wrapped_modules.LoggedIntMap.empty - | Some map -> error, map - in - let error, handler, cv_map' = - Ckappa_sig.Views_bdu.store_by_variables_list - Wrapped_modules.LoggedIntMap.find_default_without_logs - Wrapped_modules.LoggedIntMap.add_or_overwrite - mvbdu_true - Ckappa_sig.Views_bdu.mvbdu_and - parameters - handler - error - hconsed_vars - renamed_mvbdu - cv_map - in - let error,output = - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set - parameters error agent_type cv_map' - output - in - error, handler, output - end) - (error, handler, output) - list) + (fun (agent_type, cv_id) bdu (error, handler, output) -> + let error, handler, list = decomposition parameters handler error bdu in + let error, (_, map2) = + get_list_of_sites_correspondence_map parameters error agent_type cv_id + site_correspondence + in + let rename_site parameters error site_type = + let error, site_type = + match + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get + parameters error site_type map2 + with + | error, None -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_site_name_minus1 + | error, Some i -> error, i + in + error, site_type + in + List.fold_left + (fun (error, handler, output) bdu -> + let error, handler, lvar = + Ckappa_sig.Views_bdu.variables_list_of_mvbdu parameters handler + error bdu + in + (*list: ckappa_sig.c_site_name list*) + let error, handler, list = + Ckappa_sig.Views_bdu.extensional_of_variables_list parameters + handler error lvar + in + (*asso take (key * key) list *) + let error, asso = + List.fold_left + (fun (error, list) i -> + let error, new_name = rename_site parameters error i in + error, (i, new_name) :: list) + (error, []) (List.rev list) + in + let error, handler, hconsed_asso = + Ckappa_sig.Views_bdu.build_renaming_list parameters handler error + asso + in + let error, handler, renamed_mvbdu = + Ckappa_sig.Views_bdu.mvbdu_rename parameters handler error bdu + hconsed_asso + in + let error, handler, hconsed_vars = + Ckappa_sig.Views_bdu.variables_list_of_mvbdu parameters handler + error renamed_mvbdu + in + let error, cv_map_opt = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif + .unsafe_get parameters error agent_type output + in + let error, cv_map = + match cv_map_opt with + | None -> error, Wrapped_modules.LoggedIntMap.empty + | Some map -> error, map + in + let error, handler, cv_map' = + Ckappa_sig.Views_bdu.store_by_variables_list + Wrapped_modules.LoggedIntMap.find_default_without_logs + Wrapped_modules.LoggedIntMap.add_or_overwrite mvbdu_true + Ckappa_sig.Views_bdu.mvbdu_and parameters handler error + hconsed_vars renamed_mvbdu cv_map + in + let error, output = + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.set + parameters error agent_type cv_map' output + in + error, handler, output) + (error, handler, output) list) result (let error, agent_map = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.create parameters error 0 in - (error, handler, agent_map)) + error, handler, agent_map) (**************************************************************************) - let stabilise_bdu_update_map_gen_decomposition decomposition - ~smash:smash ~show_dep_with_dimmension_higher_than:dim_min - parameters handler error handler_kappa - site_correspondence - result = + let stabilise_bdu_update_map_gen_decomposition decomposition ~smash + ~show_dep_with_dimmension_higher_than:dim_min parameters handler error + handler_kappa site_correspondence result = let log = Remanent_parameters.get_logger parameters in - if - smash - then + if smash then ( let error', handler, output = - smash_map - decomposition - ~show_dep_with_dimmension_higher_than:dim_min - parameters handler error - handler_kappa - site_correspondence - result + smash_map decomposition ~show_dep_with_dimmension_higher_than:dim_min + parameters handler error handler_kappa site_correspondence result in - let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit in let error, (handler, list) = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters - error - (fun parameters error agent_type map (handler,list) -> - let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa - agent_type - with - | _ -> Exception.warn parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - (*-----------------------------------------------------------*) - Wrapped_modules.LoggedIntMap.fold - (fun _ mvbdu (error,(handler,list)) -> - let error, handler = - if local_trace || Remanent_parameters.get_trace parameters - then - let () = Loggers.fprintf log - "INTENSIONAL DESCRIPTION:" - in - let () = Loggers.print_newline log in - let () = - Ckappa_sig.Views_bdu.print - parameters mvbdu - in - let () = Loggers.fprintf log - "EXTENSIONAL DESCRIPTION:" - in - let () = Loggers.print_newline log in - error, handler - else - error, handler - in - let error, (handler, translation) = - Translation_in_natural_language.translate - parameters handler error (fun _ e i -> e, i) mvbdu - in - (*-------------------------------------------------------*) - error, - (handler, - (agent_string, agent_type, mvbdu,translation)::list) - ) - map - (error, (handler,list))) - output (handler,[]) + parameters error + (fun parameters error agent_type map (handler, list) -> + let error, agent_string = + try + Handler.string_of_agent parameters error handler_kappa + agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + (*-----------------------------------------------------------*) + Wrapped_modules.LoggedIntMap.fold + (fun _ mvbdu (error, (handler, list)) -> + let error, handler = + if local_trace || Remanent_parameters.get_trace parameters + then ( + let () = Loggers.fprintf log "INTENSIONAL DESCRIPTION:" in + let () = Loggers.print_newline log in + let () = Ckappa_sig.Views_bdu.print parameters mvbdu in + let () = Loggers.fprintf log "EXTENSIONAL DESCRIPTION:" in + let () = Loggers.print_newline log in + error, handler + ) else + error, handler + in + let error, (handler, translation) = + Translation_in_natural_language.translate parameters handler + error + (fun _ e i -> e, i) + mvbdu + in + (*-------------------------------------------------------*) + ( error, + ( handler, + (agent_string, agent_type, mvbdu, translation) :: list ) )) + map + (error, (handler, list))) + output (handler, []) in error, handler, List.rev list - else - begin - let error, (handler, list) = - Covering_classes_type.AgentCV_map_and_set.Map.fold - (fun (agent_type, cv_id) bdu_update (error,(handler,list)) -> - let error, agent_string = - try - Handler.string_of_agent parameters error handler_kappa - agent_type - with - | _ -> - Exception.warn - parameters error __POS__ Exit - (Ckappa_sig.string_of_agent_name agent_type) - in - (*-----------------------------------------------------------*) - let () = - if local_trace || Remanent_parameters.get_trace parameters - then - let () = - Loggers.fprintf log - "agent_type:%i:%s:cv_id:%i" - (Ckappa_sig.int_of_agent_name agent_type) - agent_string - (Covering_classes_type.int_of_cv_id cv_id) - in - Loggers.print_newline log - in - (*------------------------------------------------------------*) - let error, (_, map2) = - get_list_of_sites_correspondence_map parameters error - agent_type - cv_id - site_correspondence - in - (*-----------------------------------------------------------*) - let error, handler, list' = - decomposition parameters handler error bdu_update - in - (*-----------------------------------------------------------*) - let error, (handler, list) = - List.fold_left - (fun (error, (handler, list)) mvbdu -> - let error, handler = - if local_trace || - Remanent_parameters.get_trace parameters - then - let () = Loggers.fprintf log - "INTENSIONAL DESCRIPTION:" in - let () = Loggers.print_newline log in - let () = - Ckappa_sig.Views_bdu.print - parameters mvbdu - in - let () = Loggers.fprintf log - "EXTENSIONAL DESCRIPTION:" - in - let () = Loggers.print_newline log in - error, handler - else - error, handler - in - let rename_site parameters error site_type = - let error, site_type = - match Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif.get - parameters error site_type map2 - with - | error, None -> - Exception.warn - parameters error __POS__ Exit - Ckappa_sig.dummy_site_name_minus1 - | error, Some i -> error, i - in - error, site_type - in - let error, (handler, translation) = - Translation_in_natural_language.translate - parameters - handler - error - rename_site - mvbdu - in - (*----------------------------------------------------*) - error, - (handler, - (agent_string, agent_type, mvbdu,translation)::list) - ) - (error, (handler,list)) - list' - in - error, (handler,list)) - result (error, (handler,[])) - in error, handler, (List.rev list) - end - - let print_bdu_update_map_gen_decomposition decomposition - ~sort:sort ~smash:smash ~show_dep_with_dimmension_higher_than:dim_min - parameters handler error handler_kappa - site_correspondence result = + ) else ( + let error, (handler, list) = + Covering_classes_type.AgentCV_map_and_set.Map.fold + (fun (agent_type, cv_id) bdu_update (error, (handler, list)) -> + let error, agent_string = + try + Handler.string_of_agent parameters error handler_kappa + agent_type + with _ -> + Exception.warn parameters error __POS__ Exit + (Ckappa_sig.string_of_agent_name agent_type) + in + (*-----------------------------------------------------------*) + let () = + if local_trace || Remanent_parameters.get_trace parameters then ( + let () = + Loggers.fprintf log "agent_type:%i:%s:cv_id:%i" + (Ckappa_sig.int_of_agent_name agent_type) + agent_string + (Covering_classes_type.int_of_cv_id cv_id) + in + Loggers.print_newline log + ) + in + (*------------------------------------------------------------*) + let error, (_, map2) = + get_list_of_sites_correspondence_map parameters error agent_type + cv_id site_correspondence + in + (*-----------------------------------------------------------*) + let error, handler, list' = + decomposition parameters handler error bdu_update + in + (*-----------------------------------------------------------*) + let error, (handler, list) = + List.fold_left + (fun (error, (handler, list)) mvbdu -> + let error, handler = + if local_trace || Remanent_parameters.get_trace parameters + then ( + let () = Loggers.fprintf log "INTENSIONAL DESCRIPTION:" in + let () = Loggers.print_newline log in + let () = Ckappa_sig.Views_bdu.print parameters mvbdu in + let () = Loggers.fprintf log "EXTENSIONAL DESCRIPTION:" in + let () = Loggers.print_newline log in + error, handler + ) else + error, handler + in + let rename_site parameters error site_type = + let error, site_type = + match + Ckappa_sig.Site_type_nearly_Inf_Int_storage_Imperatif + .get parameters error site_type map2 + with + | error, None -> + Exception.warn parameters error __POS__ Exit + Ckappa_sig.dummy_site_name_minus1 + | error, Some i -> error, i + in + error, site_type + in + let error, (handler, translation) = + Translation_in_natural_language.translate parameters handler + error rename_site mvbdu + in + (*----------------------------------------------------*) + ( error, + ( handler, + (agent_string, agent_type, mvbdu, translation) :: list ) )) + (error, (handler, list)) + list' + in + error, (handler, list)) + result + (error, (handler, [])) + in + error, handler, List.rev list + ) + + let print_bdu_update_map_gen_decomposition decomposition ~sort ~smash + ~show_dep_with_dimmension_higher_than:dim_min parameters handler error + handler_kappa site_correspondence result = let error, handler, list = - stabilise_bdu_update_map_gen_decomposition decomposition - ~smash:smash ~show_dep_with_dimmension_higher_than:dim_min - parameters handler error handler_kappa - site_correspondence result + stabilise_bdu_update_map_gen_decomposition decomposition ~smash + ~show_dep_with_dimmension_higher_than:dim_min parameters handler error + handler_kappa site_correspondence result in let error, list = if sort then Tools_kasa.sort_list - (fun parameters error - (agent_string,agent_id,_,translation) - -> + (fun parameters error (agent_string, agent_id, _, translation) -> match translation with - | Translation_in_natural_language.Range (x,_) - -> + | Translation_in_natural_language.Range (x, _) -> let error, x = - Handler.string_of_site_contact_map - parameters error handler_kappa - agent_id x + Handler.string_of_site_contact_map parameters error + handler_kappa agent_id x in - error, (agent_string,x) + error, (agent_string, x) | Translation_in_natural_language.Equiv _ | Translation_in_natural_language.No_known_translation _ | Translation_in_natural_language.Partition _ - | Translation_in_natural_language.Imply _ -> error, (agent_string,"") - - ) + | Translation_in_natural_language.Imply _ -> + error, (agent_string, "")) parameters error list else error, list @@ -3659,12 +3016,10 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let error = List.fold_left (fun error (agent_string, agent_type, _, translation) -> - Translation_in_natural_language.print - ~show_dep_with_dimmension_higher_than:dim_min parameters - handler_kappa error agent_string agent_type translation - ) - error - list + Translation_in_natural_language.print + ~show_dep_with_dimmension_higher_than:dim_min parameters + handler_kappa error agent_string agent_type translation) + error list in error, handler @@ -3672,159 +3027,141 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*Print for NON-Relational properties*) let print_bdu_update_map_cartesian_abstraction parameters handler error - handler_kappa = - print_bdu_update_map_gen_decomposition - ~sort:true - ~smash:true + handler_kappa = + print_bdu_update_map_gen_decomposition ~sort:true ~smash:true ~show_dep_with_dimmension_higher_than:1 - Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction - parameters handler error handler_kappa + Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction parameters handler error + handler_kappa (*****************************************************************) (*Print for relational properties*) let print_bdu_update_map_cartesian_decomposition parameters handler error handler_kappa = - print_bdu_update_map_gen_decomposition - ~smash:true + print_bdu_update_map_gen_decomposition ~smash:true ~show_dep_with_dimmension_higher_than: (if - Remanent_parameters.get_hide_one_d_relations_from_cartesian_decomposition parameters - then 2 - else 1 - ) - Ckappa_sig.Views_bdu.mvbdu_full_cartesian_decomposition - parameters handler error handler_kappa + Remanent_parameters + .get_hide_one_d_relations_from_cartesian_decomposition parameters + then + 2 + else + 1) + Ckappa_sig.Views_bdu.mvbdu_full_cartesian_decomposition parameters handler + error handler_kappa (*****************************************************************) - let print_separating_edges - parameters handler error compil _handler_kappa list = + let print_separating_edges parameters handler error compil _handler_kappa list + = let log = Remanent_parameters.get_logger parameters in let () = Loggers.print_newline log in let () = Loggers.fprintf log - "------------------------------------------------------------" in + "------------------------------------------------------------" + in let () = Loggers.print_newline log in - let error, handler = - if Mods.IntMap.is_empty list then + let error, handler = + if Mods.IntMap.is_empty list then ( let () = Loggers.fprintf log "There may be no separating transitions" in error, handler - else - let () = Loggers.fprintf log "The following transitions are separating:" in + ) else ( + let () = + Loggers.fprintf log "The following transitions are separating:" + in let () = Loggers.print_newline log in let () = Loggers.print_newline log in let error = Mods.IntMap.fold (fun r_id l error -> - let error, r = - Handler.string_of_rule parameters error compil - (Ckappa_sig.rule_id_of_int r_id) - in - let () = - Loggers.fprintf log " * %s:" r - in - let () = Loggers.print_newline log in - let error = - List.fold_left - (fun error (s1,s2) -> - let () = - Loggers.fprintf log " %s -> %s" s1 s2 - in - let () = Loggers.print_newline log in - error) - error l - in - let () = Loggers.print_newline log in - error) + let error, r = + Handler.string_of_rule parameters error compil + (Ckappa_sig.rule_id_of_int r_id) + in + let () = Loggers.fprintf log " * %s:" r in + let () = Loggers.print_newline log in + let error = + List.fold_left + (fun error (s1, s2) -> + let () = Loggers.fprintf log " %s -> %s" s1 s2 in + let () = Loggers.print_newline log in + error) + error l + in + let () = Loggers.print_newline log in + error) list error in let () = Loggers.print_newline log in error, handler - in error, handler + ) + in + error, handler - let print_result_fixpoint_aux - parameters handler error handler_kappa + let print_result_fixpoint_aux parameters handler error handler_kappa (*store_new_index_pair_map*) - site_correspondence result = + site_correspondence result = let log = Remanent_parameters.get_logger parameters in - if Remanent_parameters.get_dump_reachability_analysis_result parameters - then + if Remanent_parameters.get_dump_reachability_analysis_result parameters then ( let error = - if local_trace - || (Remanent_parameters.get_trace parameters) - then - begin - let () = Loggers.fprintf log "" in - let () = Loggers.print_newline log in - let () = - Loggers.fprintf log - "------------------------------------------------------------" - in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log - "* Fixpoint iteration :" - in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log - "------------------------------------------------------------" - in - let () = - Loggers.print_newline log - in - let error = - print_bdu_update_map - parameters - error - handler_kappa - result - in - error - end - else error + if local_trace || Remanent_parameters.get_trace parameters then ( + let () = Loggers.fprintf log "" in + let () = Loggers.print_newline log in + let () = + Loggers.fprintf log + "------------------------------------------------------------" + in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log "* Fixpoint iteration :" in + let () = Loggers.print_newline log in + let () = + Loggers.fprintf log + "------------------------------------------------------------" + in + let () = Loggers.print_newline log in + let error = + print_bdu_update_map parameters error handler_kappa result + in + error + ) else + error in let () = Loggers.print_newline log in let () = Loggers.fprintf log - "------------------------------------------------------------" in + "------------------------------------------------------------" + in let () = Loggers.print_newline log in let () = Loggers.fprintf log "* Non relational properties:" in let () = Loggers.print_newline log in - let () = Loggers.fprintf log + let () = + Loggers.fprintf log "------------------------------------------------------------" in let () = Loggers.print_newline log in let error, handler = - print_bdu_update_map_cartesian_abstraction - parameters - handler - error - handler_kappa - site_correspondence - result + print_bdu_update_map_cartesian_abstraction parameters handler error + handler_kappa site_correspondence result in let () = Loggers.print_newline log in let () = Loggers.fprintf log - "------------------------------------------------------------" in + "------------------------------------------------------------" + in let () = Loggers.print_newline log in let () = Loggers.fprintf log "* Relational properties:" in let () = Loggers.print_newline log in - let () = Loggers.fprintf log + let () = + Loggers.fprintf log "------------------------------------------------------------" in let () = Loggers.print_newline log in let error, handler = - print_bdu_update_map_cartesian_decomposition - ~sort:false - parameters - handler - error - handler_kappa - site_correspondence - result + print_bdu_update_map_cartesian_decomposition ~sort:false parameters + handler error handler_kappa site_correspondence result in error, handler - else error, handler + ) else + error, handler (************************************************************************) @@ -3836,29 +3173,26 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let handler = get_mvbdu_handler dynamic in let compil = get_compil static in let error, handler = - if local_trace - || Remanent_parameters.get_compute_separating_transitions parameters - then - match get_separating_transitions dynamic - with + if + local_trace + || Remanent_parameters.get_compute_separating_transitions parameters + then ( + match get_separating_transitions dynamic with | None -> error, handler | Some l -> print_separating_edges parameters handler error compil kappa_handler l - else + ) else error, handler in let error, handler = - if local_trace - || Remanent_parameters.get_dump_reachability_analysis_result parameters + if + local_trace + || Remanent_parameters.get_dump_reachability_analysis_result parameters then - print_result_fixpoint_aux - parameters - handler - error - kappa_handler - site_correspondence - fixpoint_result - else error, handler + print_result_fixpoint_aux parameters handler error kappa_handler + site_correspondence fixpoint_result + else + error, handler in let dynamic = set_mvbdu_handler handler dynamic in error, dynamic, () @@ -3874,57 +3208,56 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let parameters = get_parameter static in let error, dynamic = (* local traces *) - if Remanent_parameters.get_compute_local_traces parameters - || Remanent_parameters.get_compute_separating_transitions parameters - then + if + Remanent_parameters.get_compute_local_traces parameters + || Remanent_parameters.get_compute_separating_transitions parameters + then ( let handler_kappa = get_kappa_handler static in let handler = get_mvbdu_handler dynamic in let compil = get_compil static in let site_correspondence = get_site_correspondence_array static in let error, handler, output = smash_map - (fun _parameters handler error a -> error, handler, [a]) - parameters handler error - ~show_dep_with_dimmension_higher_than:1 - handler_kappa - site_correspondence + (fun _parameters handler error a -> error, handler, [ a ]) + parameters handler error ~show_dep_with_dimmension_higher_than:1 + handler_kappa site_correspondence (get_fixpoint_result dynamic) in let error, log_info, handler, bridges, transition_systems_length = - if Remanent_parameters.get_compute_separating_transitions parameters - && - Remanent_parameters.get_use_macrotransitions_in_local_traces parameters - then + if + Remanent_parameters.get_compute_separating_transitions parameters + && Remanent_parameters.get_use_macrotransitions_in_local_traces + parameters + then ( let parameters' = Remanent_parameters.set_use_macrotransitions_in_local_traces - parameters - false + parameters false in let error, log_info, handler, bridges, _ = Agent_trace.agent_trace parameters' (get_log_info dynamic) error - dead_rules handler (get_global_static_information static) handler_kappa compil - output + dead_rules handler + (get_global_static_information static) + handler_kappa compil output in let parameters' = - Remanent_parameters.set_compute_separating_transitions - parameters + Remanent_parameters.set_compute_separating_transitions parameters false in let error, log_info, handler, _, transition_systems_length = - Agent_trace.agent_trace parameters' log_info error - dead_rules handler (get_global_static_information static) handler_kappa compil - output + Agent_trace.agent_trace parameters' log_info error dead_rules + handler + (get_global_static_information static) + handler_kappa compil output in error, log_info, handler, bridges, transition_systems_length - else - Agent_trace.agent_trace - parameters (get_log_info dynamic) error - dead_rules handler (get_global_static_information static) handler_kappa compil - output + ) else + Agent_trace.agent_trace parameters (get_log_info dynamic) error + dead_rules handler + (get_global_static_information static) + handler_kappa compil output in - let dynamic = - match bridges - with + let dynamic = + match bridges with | None -> dynamic | Some bridges -> set_separating_transitions bridges dynamic in @@ -3935,7 +3268,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id set_transition_system_length transition_system_length dynamic in error, set_mvbdu_handler handler (set_log_info log_info dynamic) - else + ) else error, dynamic in let error, dynamic, () = @@ -3943,7 +3276,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id in error, dynamic, () -(*-----------------------------------------------*) + (*-----------------------------------------------*) let export_contact_map static dynamic error kasa_state = match get_ranges dynamic with @@ -3956,171 +3289,141 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id (*-----------------------------------------------*) let error, (handler, contact_map) = Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.fold - parameters - error + parameters error (fun parameters error ag_type site_map (handler, contact_map) -> - let error, contact_map = - Preprocess.declare_agent parameters error ag_type contact_map - in - Wrapped_modules.LoggedIntMap.fold - (fun _ mvbdu (error,(handler, contact_map)) -> - let error, handler, list_of_states = - Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters - handler error mvbdu + let error, contact_map = + Preprocess.declare_agent parameters error ag_type contact_map + in + Wrapped_modules.LoggedIntMap.fold + (fun _ mvbdu (error, (handler, contact_map)) -> + let error, handler, list_of_states = + Ckappa_sig.Views_bdu.extensional_of_mvbdu parameters handler + error mvbdu + in + match list_of_states with + | [] -> error, (handler, contact_map) + | [ (site_type, _) ] :: _ -> + let error, contact_map = + Preprocess.declare_site parameters error ag_type site_type + contact_map + in + let error, site = + Handler.translate_site parameters error kappa_handler + ag_type site_type in - match list_of_states with - | [] -> error, (handler, contact_map) - | [site_type,_] ::_ -> - begin - let error, contact_map = - Preprocess.declare_site parameters error ag_type - site_type contact_map + (match site with + | Ckappa_sig.Internal _ -> + let error, contact_map = + List.fold_left + (fun (error, contact_map) l -> + match l with + | [ (site_type', state) ] when site_type' = site_type + -> + Preprocess.add_internal_state_in_contact_map + parameters error (ag_type, site_type) state + contact_map + | [] | _ :: _ -> + Exception.warn parameters error __POS__ Exit + contact_map) + (error, contact_map) list_of_states in - let error, site = - Handler.translate_site parameters error kappa_handler - ag_type site_type + error, (handler, contact_map) + | Ckappa_sig.Counter _ -> error, (handler, contact_map) + | Ckappa_sig.Binding _ -> + let error, contact_map = + List.fold_left + (fun (error, contact_map) l -> + match l with + | [ (site_type', state) ] when site_type' = site_type + -> + if state = Ckappa_sig.state_index_of_int 0 then + (* we ignore free sites *) + error, contact_map + else ( + let error, dual = + Handler.dual parameters error kappa_handler + ag_type site_type state + in + match dual with + | None -> + Exception.warn parameters error __POS__ Exit + contact_map + | Some (ag_type', site_type', _) -> + Preprocess.add_link_in_contact_map parameters + error (ag_type, site_type) + (ag_type', site_type') contact_map + ) + | [] | _ :: _ -> + Exception.warn parameters error __POS__ Exit + contact_map) + (error, contact_map) list_of_states in - match site with - | Ckappa_sig.Internal _ -> - let error, contact_map = - List.fold_left - (fun (error, contact_map) l -> - match l with - | [site_type',state] - when site_type' = site_type -> - Preprocess.add_internal_state_in_contact_map - parameters error - (ag_type,site_type) state contact_map - | [] | _::_ -> - Exception.warn - parameters error __POS__ Exit - contact_map) - (error, contact_map) list_of_states - in - error, (handler, contact_map) - | Ckappa_sig.Counter _ -> - error, (handler, contact_map) - | Ckappa_sig.Binding _ -> - let error, contact_map = - List.fold_left - (fun (error, contact_map) l -> - match l with - | [site_type',state] - when site_type' = site_type -> - if state = Ckappa_sig.state_index_of_int 0 - then (* we ignore free sites *) - error, contact_map - else - begin - let error, dual = - Handler.dual parameters error - kappa_handler ag_type site_type state - in - match dual with - | None -> - Exception.warn - parameters error __POS__ Exit contact_map - | Some (ag_type', site_type', _ ) -> - Preprocess.add_link_in_contact_map - parameters error - (ag_type,site_type) (ag_type',site_type') - contact_map - end - | [] | _::_ -> - Exception.warn - parameters error __POS__ Exit - contact_map) - (error, contact_map) list_of_states - in - error, (handler, contact_map) - end - | _::_ -> - Exception.warn - parameters error __POS__ Exit (handler, contact_map) - ) - site_map - (error, (handler, contact_map)) - ) - ranges - (handler, contact_map) + error, (handler, contact_map)) + | _ :: _ -> + Exception.warn parameters error __POS__ Exit + (handler, contact_map)) + site_map + (error, (handler, contact_map))) + ranges (handler, contact_map) in let dynamic = set_mvbdu_handler handler dynamic in let kasa_state = - Remanent_state.set_internal_contact_map - Public_data.Medium contact_map kasa_state + Remanent_state.set_internal_contact_map Public_data.Medium contact_map + kasa_state in error, dynamic, kasa_state - let export_relation_properties_aux - ~sort:sort - ~smash:smash - ~show_dep_with_dimmension_higher_than:dim_min - decomposition - domain_name - parameters dynamic error handler_kappa - site_correspondence fixpoint_result kasa_state = + let export_relation_properties_aux ~sort ~smash + ~show_dep_with_dimmension_higher_than:dim_min decomposition domain_name + parameters dynamic error handler_kappa site_correspondence fixpoint_result + kasa_state = let handler = get_mvbdu_handler dynamic in (*convert result to list*) let error', handler, list = - stabilise_bdu_update_map_gen_decomposition - decomposition - ~smash:smash - ~show_dep_with_dimmension_higher_than:dim_min - parameters - handler - error - handler_kappa - site_correspondence - fixpoint_result + stabilise_bdu_update_map_gen_decomposition decomposition ~smash + ~show_dep_with_dimmension_higher_than:dim_min parameters handler error + handler_kappa site_correspondence fixpoint_result in - let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error' __POS__ Exit in (*store the information for relational properties*) let error', current_list = List.fold_left - (fun (error, current_list) - (agent_string, agent_type, _, translation) -> + (fun (error, current_list) (agent_string, agent_type, _, translation) -> let error', current_list = - Translation_in_natural_language.convert_views_internal_constraints_list - ~show_dep_with_dimmension_higher_than:dim_min - parameters - handler_kappa - error - agent_string - agent_type - translation + Translation_in_natural_language + .convert_views_internal_constraints_list + ~show_dep_with_dimmension_higher_than:dim_min parameters + handler_kappa error agent_string agent_type translation current_list in - let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error' __POS__ + Exit in - error, current_list - ) (error, []) list + error, current_list) + (error, []) list in - let error = Exception.check_point - Exception.warn parameters error error' __POS__ Exit + let error = + Exception.check_point Exception.warn parameters error error' __POS__ Exit in (*------------------------------------------------------------------*) let internal_constraints_list = - Remanent_state.get_internal_constraints_list kasa_state in + Remanent_state.get_internal_constraints_list kasa_state + in let error, internal_constraints_list = - match - internal_constraints_list - with - | None -> - Exception.warn parameters error __POS__ Exit [] + match internal_constraints_list with + | None -> Exception.warn parameters error __POS__ Exit [] | Some l -> error, l in let error, current_list = if sort then Tools_kasa.sort_list (fun parameters error lemma -> - Site_graphs.KaSa_site_graph.to_string - parameters error lemma.Public_data.hyp) - parameters - error - current_list + Site_graphs.KaSa_site_graph.to_string parameters error + lemma.Public_data.hyp) + parameters error current_list else error, current_list in @@ -4132,52 +3435,39 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id error, dynamic, kasa_state let export_relation_properties parameters dynamic error handler_kappa = - let domain_name = "Views domain - relational properties" in - export_relation_properties_aux - ~sort:false - ~smash:true + let domain_name = "Views domain - relational properties" in + export_relation_properties_aux ~sort:false ~smash:true ~show_dep_with_dimmension_higher_than: - (if - Remanent_parameters.get_hide_one_d_relations_from_cartesian_decomposition parameters - then 2 - else 1 - ) - Ckappa_sig.Views_bdu.mvbdu_full_cartesian_decomposition - domain_name + (if + Remanent_parameters + .get_hide_one_d_relations_from_cartesian_decomposition parameters + then + 2 + else + 1) + Ckappa_sig.Views_bdu.mvbdu_full_cartesian_decomposition domain_name parameters dynamic error handler_kappa let export_non_relation_properties parameters dynamic error handler_kappa = - let domain_name = "Views domain - non relational properties" in - export_relation_properties_aux - ~sort:true - ~smash:true + let domain_name = "Views domain - non relational properties" in + export_relation_properties_aux ~sort:true ~smash:true ~show_dep_with_dimmension_higher_than:1 - Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction - domain_name - parameters dynamic error handler_kappa + Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction domain_name parameters + dynamic error handler_kappa - let export_views_properties_aux - parameters error handler_kappa - site_correspondence fixpoint_result - dynamic - kasa_state = - (*non relational properties*) - let error, dynamic, kasa_state = - export_non_relation_properties - parameters dynamic error handler_kappa - site_correspondence - fixpoint_result - kasa_state - in - (*relational properties*) - let error, dynamic, kasa_state = - export_relation_properties - parameters dynamic error handler_kappa - site_correspondence - fixpoint_result - kasa_state - in - error, dynamic, kasa_state + let export_views_properties_aux parameters error handler_kappa + site_correspondence fixpoint_result dynamic kasa_state = + (*non relational properties*) + let error, dynamic, kasa_state = + export_non_relation_properties parameters dynamic error handler_kappa + site_correspondence fixpoint_result kasa_state + in + (*relational properties*) + let error, dynamic, kasa_state = + export_relation_properties parameters dynamic error handler_kappa + site_correspondence fixpoint_result kasa_state + in + error, dynamic, kasa_state let export_views_properties static dynamic error kasa_state = let parameters = get_parameter static in @@ -4185,12 +3475,8 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let site_correspondence = get_site_correspondence_array static in let fixpoint_result = get_fixpoint_result dynamic in let error, dynamic, kasa_state = - export_views_properties_aux - parameters error handler_kappa - site_correspondence - fixpoint_result - dynamic - kasa_state + export_views_properties_aux parameters error handler_kappa + site_correspondence fixpoint_result dynamic kasa_state in error, dynamic, kasa_state @@ -4205,28 +3491,27 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id parameters in let original = hide_reverse_rule in - let (error,l) = + let error, l = Mods.IntMap.fold - (fun i c (error,l) -> - let i = Ckappa_sig.rule_id_of_int i in - let error, info = - Handler.info_of_rule ~original ~with_rates:false parameters error compil i - in - let error, b1 = Handler.is_reverse parameters error compil i in - let error, b2 = Handler.has_no_label parameters error compil i in - let rule = Remanent_state.info_to_rule info in - let rule = - if b1 && b2 && hide_reverse_rule - then Handler.hide rule - else rule - in - error, (rule,c)::l) - map (error,[]) - in - let kasa_state = - Remanent_state.set_separating_transitions l - kasa_state + (fun i c (error, l) -> + let i = Ckappa_sig.rule_id_of_int i in + let error, info = + Handler.info_of_rule ~original ~with_rates:false parameters error + compil i + in + let error, b1 = Handler.is_reverse parameters error compil i in + let error, b2 = Handler.has_no_label parameters error compil i in + let rule = Remanent_state.info_to_rule info in + let rule = + if b1 && b2 && hide_reverse_rule then + Handler.hide rule + else + rule + in + error, (rule, c) :: l) + map (error, []) in + let kasa_state = Remanent_state.set_separating_transitions l kasa_state in error, dynamic, kasa_state let export_transition_system_length _static dynamic error kasa_state = @@ -4234,8 +3519,7 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id | None -> error, dynamic, kasa_state | Some l -> let kasa_state = - Remanent_state.set_transition_system_length l - kasa_state + Remanent_state.set_transition_system_length l kasa_state in error, dynamic, kasa_state @@ -4246,20 +3530,17 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id in (*export of (non)relational properties*) let error, dynamic, kasa_state = - export_views_properties - static dynamic error kasa_state + export_views_properties static dynamic error kasa_state in let error, dynamic, kasa_state = - export_separating_edges - static dynamic error kasa_state + export_separating_edges static dynamic error kasa_state in let error, dynamic, kasa_state = - export_transition_system_length - static dynamic error kasa_state + export_transition_system_length static dynamic error kasa_state in error, dynamic, kasa_state -(**************************************************************************) + (**************************************************************************) let stabilize static dynamic error = let dim_min = 2 in @@ -4269,18 +3550,13 @@ let get_list_of_sites_correspondence_map parameters error agent_type cv_id let result = get_fixpoint_result dynamic in let site_correspondence = get_site_correspondence_array static in let error, handler, ranges = - smash_map - Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction + smash_map Ckappa_sig.Views_bdu.mvbdu_cartesian_abstraction ~show_dep_with_dimmension_higher_than:dim_min parameters handler error - handler_kappa - site_correspondence result + handler_kappa site_correspondence result in let dynamic = set_ranges ranges dynamic in error, set_mvbdu_handler handler dynamic, () - let get_dead_rules _static _dynamic = - Analyzer_headers.dummy_dead_rules - - let get_side_effects _static _dynamic = - Analyzer_headers.dummy_side_effects + let get_dead_rules _static _dynamic = Analyzer_headers.dummy_dead_rules + let get_side_effects _static _dynamic = Analyzer_headers.dummy_side_effects end diff --git a/core/KaSa_rep/reachability_analysis/views_domain.mli b/core/KaSa_rep/reachability_analysis/views_domain.mli index 623fdeb89a..72fb660e1a 100644 --- a/core/KaSa_rep/reachability_analysis/views_domain.mli +++ b/core/KaSa_rep/reachability_analysis/views_domain.mli @@ -17,5 +17,4 @@ (** Abstract domain to over-approximate the set of reachable views *) - -module Domain:Analyzer_domain_sig.Domain +module Domain : Analyzer_domain_sig.Domain diff --git a/core/KaSa_rep/remanent_state/dune b/core/KaSa_rep/remanent_state/dune index 6e8de1c570..0b823fd43c 100644 --- a/core/KaSa_rep/remanent_state/dune +++ b/core/KaSa_rep/remanent_state/dune @@ -1,20 +1,41 @@ (library - (name kappa_kasa_remanent_state) - (libraries kappa_kasa_site_graphs kappa_symmetries kappa_profiling kappa_flow_analysis) - (flags (:standard -w @a - -open Kappa_terms - -open Kappa_grammar - -open Kappa_kasa_frontend - -open Kappa_logging - -open Kappa_kasa_kastor_toolset - -open Kappa_generic_toolset - -open Kappa_kasa_site_graphs - -open Kappa_symmetries - -open Kappa_parameters - -open Kappa_errors - -open Kappa_profiling - -open Kappa_mixtures - -open Kappa_flow_analysis - -open Kappa_mvbdu - -open Kappa_kasa_type_interface - ))) + (name kappa_kasa_remanent_state) + (libraries + kappa_kasa_site_graphs + kappa_symmetries + kappa_profiling + kappa_flow_analysis) + (flags + (:standard + -w + @a + -open + Kappa_terms + -open + Kappa_grammar + -open + Kappa_kasa_frontend + -open + Kappa_logging + -open + Kappa_kasa_kastor_toolset + -open + Kappa_generic_toolset + -open + Kappa_kasa_site_graphs + -open + Kappa_symmetries + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_profiling + -open + Kappa_mixtures + -open + Kappa_flow_analysis + -open + Kappa_mvbdu + -open + Kappa_kasa_type_interface))) diff --git a/core/KaSa_rep/remanent_state/remanent_state.ml b/core/KaSa_rep/remanent_state/remanent_state.ml index c52c6bd22c..be95f62869 100644 --- a/core/KaSa_rep/remanent_state/remanent_state.ml +++ b/core/KaSa_rep/remanent_state/remanent_state.ml @@ -16,35 +16,33 @@ (**********************) type compilation = Ast.parsing_compil - -type init = - | Compil of compilation - | Files of string list - -type initial_state = - (Primitives.alg_expr * Primitives.elementary_rule) list +type init = Compil of compilation | Files of string list +type initial_state = (Primitives.alg_expr * Primitives.elementary_rule) list type refined_compilation = - (Ckappa_sig.agent, Ckappa_sig.mixture, Ckappa_sig.mixture, string, - Ckappa_sig.mixture Ckappa_sig.rule) Ast.compil + ( Ckappa_sig.agent, + Ckappa_sig.mixture, + Ckappa_sig.mixture, + string, + Ckappa_sig.mixture Ckappa_sig.rule ) + Ast.compil type quark_map = Quark_type.quarks - type rule_id = int -type var_id = int +type var_id = int (**************) (* JSon labels*) (**************) let accuracy_string = "accuracy" -let site="site name" -let stateslist="states list" -let interface="interface" -let contactmap="contact map" +let site = "site name" +let stateslist = "states list" +let interface = "interface" +let contactmap = "contact map" let dead_rules = "dead rules" -let contactmaps="contact maps" -let influencemaps="influence maps" +let contactmaps = "contact maps" +let influencemaps = "influence maps" let separating_transitions = "separating transitions" let errors = "errors" let scc_contact_maps = "scc contact maps" @@ -54,18 +52,17 @@ let scc = "scc" type dead_rules = Public_data.dead_rules -let info_to_rule (s1,loc,direction,s2,id) = +let info_to_rule (s1, loc, direction, s2, id) = { - Public_data.rule_id = Ckappa_sig.int_of_rule_id id ; + Public_data.rule_id = Ckappa_sig.int_of_rule_id id; Public_data.rule_position = loc; - Public_data.rule_label = s1 ; - Public_data.rule_ast=s2; - Public_data.rule_direction=direction; - Public_data.rule_hidden=false; + Public_data.rule_label = s1; + Public_data.rule_ast = s2; + Public_data.rule_direction = direction; + Public_data.rule_hidden = false; } type dead_agents = Public_data.dead_agents - type separating_transitions = Public_data.separating_transitions (******************************************************************************) @@ -74,67 +71,47 @@ type separating_transitions = Public_data.separating_transitions (*********************) type interface = - (string option (* internal state *) * - Site_graphs.KaSa_site_graph.binding_state option (*binding state*) * - (int option * int option) option (*counter state*)) - Wrapped_modules.LoggedStringMap.t + (string option (* internal state *) + * Site_graphs.KaSa_site_graph.binding_state option (*binding state*) + * (int option * int option) option (*counter state*)) + Wrapped_modules.LoggedStringMap.t let interface_to_json = - Wrapped_modules.LoggedStringMap.to_json - ~lab_key:site ~lab_value:stateslist - JsonUtil.of_string - (fun (internal_opt, binding_opt, counter_opt) -> - JsonUtil.of_triple - ~lab1:Public_data.prop ~lab2:Public_data.bind ~lab3:Public_data.counter - (fun internal_opt -> - JsonUtil.of_option - (fun internal_state -> - JsonUtil.of_string internal_state - ) internal_opt - ) - (JsonUtil.of_option - Site_graphs.KaSa_site_graph.binding_state_to_json) - (fun counter_opt -> - JsonUtil.of_option - (JsonUtil.of_pair - ~lab1:Public_data.inf ~lab2:Public_data.sup - (JsonUtil.of_option JsonUtil.of_int) - (JsonUtil.of_option JsonUtil.of_int)) - counter_opt - ) - (internal_opt, binding_opt, counter_opt)) - - -let interface_of_json - = - Wrapped_modules.LoggedStringMap.of_json - ~lab_key:site ~lab_value:stateslist ~error_msg:interface - (*json -> elt*) - (fun json -> JsonUtil.to_string ~error_msg:site json) - (*json -> 'value*) - (JsonUtil.to_triple - ~lab1:Public_data.prop ~lab2:Public_data.bind - ~lab3:Public_data.counter - ~error_msg:"wrong binding state" - (JsonUtil.to_option - (JsonUtil.to_string ~error_msg:Public_data.prop) - - ) - (JsonUtil.to_option - Site_graphs.KaSa_site_graph.binding_state_of_json) - (JsonUtil.to_option - (JsonUtil.to_pair - ~lab1:Public_data.inf - ~lab2:Public_data.sup - ~error_msg:"wrong counter state" - (JsonUtil.to_option (JsonUtil.to_int ~error_msg:"wrong counter bound")) - (JsonUtil.to_option (JsonUtil.to_int ~error_msg:"wrong counter bound")) - ) - )) - -type agent = - string * (* agent name *) - interface + Wrapped_modules.LoggedStringMap.to_json ~lab_key:site ~lab_value:stateslist + JsonUtil.of_string (fun (internal_opt, binding_opt, counter_opt) -> + JsonUtil.of_triple ~lab1:Public_data.prop ~lab2:Public_data.bind + ~lab3:Public_data.counter + (fun internal_opt -> + JsonUtil.of_option + (fun internal_state -> JsonUtil.of_string internal_state) + internal_opt) + (JsonUtil.of_option Site_graphs.KaSa_site_graph.binding_state_to_json) + (fun counter_opt -> + JsonUtil.of_option + (JsonUtil.of_pair ~lab1:Public_data.inf ~lab2:Public_data.sup + (JsonUtil.of_option JsonUtil.of_int) + (JsonUtil.of_option JsonUtil.of_int)) + counter_opt) + (internal_opt, binding_opt, counter_opt)) + +let interface_of_json = + Wrapped_modules.LoggedStringMap.of_json ~lab_key:site ~lab_value:stateslist + ~error_msg:interface (*json -> elt*) + (fun json -> JsonUtil.to_string ~error_msg:site json) (*json -> 'value*) + (JsonUtil.to_triple ~lab1:Public_data.prop ~lab2:Public_data.bind + ~lab3:Public_data.counter ~error_msg:"wrong binding state" + (JsonUtil.to_option (JsonUtil.to_string ~error_msg:Public_data.prop)) + (JsonUtil.to_option Site_graphs.KaSa_site_graph.binding_state_of_json) + (JsonUtil.to_option + (JsonUtil.to_pair ~lab1:Public_data.inf ~lab2:Public_data.sup + ~error_msg:"wrong counter state" + (JsonUtil.to_option + (JsonUtil.to_int ~error_msg:"wrong counter bound")) + (JsonUtil.to_option + (JsonUtil.to_int ~error_msg:"wrong counter bound"))))) + +type agent = string * (* agent name *) + interface (***************************************************************************) @@ -146,7 +123,6 @@ let lemmas_list_of_json json = let lemmas_list_to_json l = Public_data.lemmas_list_to_json_gen interface_to_json l - (******************************************************************************) (******************************************************************************) @@ -155,25 +131,28 @@ let lemmas_list_to_json l = (****************************) type internal_influence_map = - Ckappa_sig.c_rule_id list * - Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t * Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t + Ckappa_sig.c_rule_id list + * Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t + * Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t type internal_contact_map = - (Ckappa_sig.c_state list * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) list) - Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t + (Ckappa_sig.c_state list + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) list) + Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_map_and_set.Map.t type internal_scc_decomposition = - ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)* - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)) list list + ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)) + list + list type ('static, 'dynamic) reachability_result = 'static * 'dynamic - type subviews_info = unit type flow = Ckappa_sig.Site_union_find.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t type internal_constraints_list = Site_graphs.KaSa_site_graph.t Public_data.poly_constraints_list @@ -184,132 +163,117 @@ type symmetric_sites = Symmetries.symmetries option type influence_edge = Quark_type.Labels.label_set_couple -type bidirectional_influence_map = - { - positive_influence_fwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - positive_influence_bwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - negative_influence_fwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - negative_influence_bwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - } - -type distance = - { - fwd: int ; - bwd: int ; - total: int - } - -type local_influence_map_blackboard = - { - blackboard_distance: distance option array; - blackboard_is_done: bool array; - blackboard_to_be_explored: bool array - } - -type ('static,'dynamic) state = - { - parameters : Remanent_parameters_sig.parameters ; - log_info : StoryProfiling.StoryStats.log_info ; - handler : Cckappa_sig.kappa_handler option ; - init : init ; - env : Model.t option option ; - contact_map_int : Contact_map.t option option; - init_state: initial_state option ; - compilation : compilation option ; - refined_compilation : refined_compilation option ; - c_compil : Cckappa_sig.compil option ; - quark_map: quark_map option ; - pos_of_rules_and_vars: Public_data.pos_of_rules_and_vars option; - internal_influence_map: internal_influence_map Public_data.AccuracyMap.t ; - influence_map : Public_data.influence_map Public_data.AccuracyMap.t ; - bidirectional_influence_map : - bidirectional_influence_map Public_data.AccuracyMap.t ; - local_influence_map_blackboard : - local_influence_map_blackboard option ; - internal_contact_map: internal_contact_map Public_data.AccuracyMap.t; - contact_map : Public_data.contact_map Public_data.AccuracyMap.t ; - internal_scc_decomposition: internal_scc_decomposition Public_data.AccuracyMap.t Public_data.AccuracyMap.t ; - scc_decomposition: - Public_data.scc Public_data.AccuracyMap.t - Public_data.AccuracyMap.t ; - signature : Signature.s option; - bdu_handler: Mvbdu_wrapper.Mvbdu.handler ; - reachability_state: ('static, 'dynamic) reachability_result option ; - subviews_info: subviews_info option ; - dead_rules: dead_rules option ; - dead_agents: dead_agents option ; - ode_flow: Ode_fragmentation_type.ode_frag option ; - ctmc_flow: flow option ; - errors : Exception.method_handler ; - internal_constraints_list : internal_constraints_list option; - constraints_list : constraints_list option; - symmetric_sites : symmetric_sites Public_data.AccuracyMap.t; - separating_transitions : separating_transitions option ; - transition_system_length : int list option ; - } +type bidirectional_influence_map = { + positive_influence_fwd: (Ckappa_sig.c_rule_id * influence_edge) list array; + positive_influence_bwd: (Ckappa_sig.c_rule_id * influence_edge) list array; + negative_influence_fwd: (Ckappa_sig.c_rule_id * influence_edge) list array; + negative_influence_bwd: (Ckappa_sig.c_rule_id * influence_edge) list array; +} + +type distance = { fwd: int; bwd: int; total: int } + +type local_influence_map_blackboard = { + blackboard_distance: distance option array; + blackboard_is_done: bool array; + blackboard_to_be_explored: bool array; +} + +type ('static, 'dynamic) state = { + parameters: Remanent_parameters_sig.parameters; + log_info: StoryProfiling.StoryStats.log_info; + handler: Cckappa_sig.kappa_handler option; + init: init; + env: Model.t option option; + contact_map_int: Contact_map.t option option; + init_state: initial_state option; + compilation: compilation option; + refined_compilation: refined_compilation option; + c_compil: Cckappa_sig.compil option; + quark_map: quark_map option; + pos_of_rules_and_vars: Public_data.pos_of_rules_and_vars option; + internal_influence_map: internal_influence_map Public_data.AccuracyMap.t; + influence_map: Public_data.influence_map Public_data.AccuracyMap.t; + bidirectional_influence_map: + bidirectional_influence_map Public_data.AccuracyMap.t; + local_influence_map_blackboard: local_influence_map_blackboard option; + internal_contact_map: internal_contact_map Public_data.AccuracyMap.t; + contact_map: Public_data.contact_map Public_data.AccuracyMap.t; + internal_scc_decomposition: + internal_scc_decomposition Public_data.AccuracyMap.t + Public_data.AccuracyMap.t; + scc_decomposition: + Public_data.scc Public_data.AccuracyMap.t Public_data.AccuracyMap.t; + signature: Signature.s option; + bdu_handler: Mvbdu_wrapper.Mvbdu.handler; + reachability_state: ('static, 'dynamic) reachability_result option; + subviews_info: subviews_info option; + dead_rules: dead_rules option; + dead_agents: dead_agents option; + ode_flow: Ode_fragmentation_type.ode_frag option; + ctmc_flow: flow option; + errors: Exception.method_handler; + internal_constraints_list: internal_constraints_list option; + constraints_list: constraints_list option; + symmetric_sites: symmetric_sites Public_data.AccuracyMap.t; + separating_transitions: separating_transitions option; + transition_system_length: int list option; +} let get_data state = - state.handler, state.dead_rules, state.separating_transitions, state.transition_system_length - + ( state.handler, + state.dead_rules, + state.separating_transitions, + state.transition_system_length ) let create_state ?errors ?env ?init_state ?reset parameters init = let error = - match - errors - with + match errors with | None -> Exception.empty_error_handler | Some error -> error in let error, handler_bdu = - if Mvbdu_wrapper.Mvbdu.is_init () - then + if Mvbdu_wrapper.Mvbdu.is_init () then ( match reset with - | Some true -> - Mvbdu_wrapper.Mvbdu.reset parameters error - | None | Some false -> - Mvbdu_wrapper.Mvbdu.get_handler parameters error - else + | Some true -> Mvbdu_wrapper.Mvbdu.reset parameters error + | None | Some false -> Mvbdu_wrapper.Mvbdu.get_handler parameters error + ) else Mvbdu_wrapper.Mvbdu.init parameters error in { - parameters = parameters; + parameters; log_info = StoryProfiling.StoryStats.init_log_info (); - handler = None ; - init = init ; - env = env ; + handler = None; + init; + env; contact_map_int = None; - init_state = init_state ; - compilation = None ; - refined_compilation = None ; - c_compil = None ; - quark_map = None ; - internal_influence_map = Public_data.AccuracyMap.empty ; - influence_map = Public_data.AccuracyMap.empty ; - bidirectional_influence_map = Public_data.AccuracyMap.empty ; - pos_of_rules_and_vars = None ; - local_influence_map_blackboard = None ; - internal_contact_map = Public_data.AccuracyMap.empty ; - internal_scc_decomposition = Public_data.AccuracyMap.empty ; - scc_decomposition = Public_data.AccuracyMap.empty ; - contact_map = Public_data.AccuracyMap.empty ; - signature = None ; - bdu_handler = handler_bdu ; - ode_flow = None ; - ctmc_flow = None ; - reachability_state = None ; - subviews_info = None ; - dead_rules = None ; - dead_agents = None ; - errors = error ; + init_state; + compilation = None; + refined_compilation = None; + c_compil = None; + quark_map = None; + internal_influence_map = Public_data.AccuracyMap.empty; + influence_map = Public_data.AccuracyMap.empty; + bidirectional_influence_map = Public_data.AccuracyMap.empty; + pos_of_rules_and_vars = None; + local_influence_map_blackboard = None; + internal_contact_map = Public_data.AccuracyMap.empty; + internal_scc_decomposition = Public_data.AccuracyMap.empty; + scc_decomposition = Public_data.AccuracyMap.empty; + contact_map = Public_data.AccuracyMap.empty; + signature = None; + bdu_handler = handler_bdu; + ode_flow = None; + ctmc_flow = None; + reachability_state = None; + subviews_info = None; + dead_rules = None; + dead_agents = None; + errors = error; internal_constraints_list = None; constraints_list = None; symmetric_sites = Public_data.AccuracyMap.empty; separating_transitions = None; - transition_system_length = None ; + transition_system_length = None; } (**************) @@ -317,44 +281,36 @@ let create_state ?errors ?env ?init_state ?reset parameters init = (**************) let annotate map = - Public_data.AccuracyMap.fold - (fun x y l -> (x,(x,y))::l) - map - [] + Public_data.AccuracyMap.fold (fun x y l -> (x, (x, y)) :: l) map [] let add_map get title label to_json state l = let map = get state in - if Public_data.AccuracyMap.is_empty map then l - else + if Public_data.AccuracyMap.is_empty map then + l + else ( let y = annotate (get state) in - (title, JsonUtil.of_list - (JsonUtil.of_pair - ~lab1:accuracy_string - ~lab2:label - Public_data.accuracy_to_json - (fun x -> - match to_json x with - | `Assoc [s,m] when s = label -> m - | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg title,x))) - ) - (List.rev y))::l + ( title, + JsonUtil.of_list + (JsonUtil.of_pair ~lab1:accuracy_string ~lab2:label + Public_data.accuracy_to_json (fun x -> + match to_json x with + | `Assoc [ (s, m) ] when s = label -> m + | x -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg title, x)))) + (List.rev y) ) + :: l + ) let get_map empty add of_json label json = let l = JsonUtil.to_list - (JsonUtil.to_pair - ~lab1:accuracy_string - ~lab2:label ~error_msg:"pair11" - Public_data.accuracy_of_json - (fun json -> - of_json - (`Assoc [label,json]))) + (JsonUtil.to_pair ~lab1:accuracy_string ~lab2:label ~error_msg:"pair11" + Public_data.accuracy_of_json (fun json -> + of_json (`Assoc [ label, json ]))) json in - List.fold_left - (fun map (x,y) -> add x (snd y) map) - empty l + List.fold_left (fun map (x, y) -> add x (snd y) map) empty l let get_contact_map_map state = state.contact_map let get_pos_of_rules_and_vars state = state.pos_of_rules_and_vars @@ -362,14 +318,14 @@ let get_influence_map_map state = state.influence_map let get_constraints_list state = state.constraints_list let set_pos_of_rules_and_vars l state = - {state with pos_of_rules_and_vars = Some l} + { state with pos_of_rules_and_vars = Some l } + let add_errors state l = - (errors, Exception_without_parameter.to_json state.errors)::l + (errors, Exception_without_parameter.to_json state.errors) :: l let add_contact_map_to_json state l = - add_map get_contact_map_map - contactmaps contactmap Public_data.contact_map_to_json - state l + add_map get_contact_map_map contactmaps contactmap + Public_data.contact_map_to_json state l (*************************************************) (*strongly connected component*) @@ -377,105 +333,88 @@ let add_contact_map_to_json state l = let get_scc_decomposition state = state.scc_decomposition let add_triple title label to_json = - JsonUtil.of_triple - ~lab1:accuracy_string - ~lab2:accuracy_scc - ~lab3:scc - Public_data.accuracy_to_json - Public_data.accuracy_to_json + JsonUtil.of_triple ~lab1:accuracy_string ~lab2:accuracy_scc ~lab3:scc + Public_data.accuracy_to_json Public_data.accuracy_to_json (fun - (l:(Public_data.accuracy_level * - Public_data.accuracy_level * Public_data.scc)) -> - match to_json l with - | `Assoc[s,m] when s = label -> m - | x -> raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg title,x))) + (l : + Public_data.accuracy_level + * Public_data.accuracy_level + * Public_data.scc) + -> + match to_json l with + | `Assoc [ (s, m) ] when s = label -> m + | x -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg title, x))) let add_list_triple title lable to_json = - JsonUtil.of_list - (add_triple title lable to_json) + JsonUtil.of_list (add_triple title lable to_json) let add_list_of_list_of_triple title lable to_json = - JsonUtil.of_list - (add_list_triple title lable to_json) + JsonUtil.of_list (add_list_triple title lable to_json) -let annotate_triple (map:Public_data.scc Public_data.AccuracyMap.t): - (Public_data.accuracy_level * Public_data.accuracy_level * - (Public_data.accuracy_level * Public_data.accuracy_level * - Public_data.scc)) list = - Public_data.AccuracyMap.fold - (fun x scc l -> - (x,x,(x,x,scc)) :: l - ) map [] +let annotate_triple (map : Public_data.scc Public_data.AccuracyMap.t) : + (Public_data.accuracy_level + * Public_data.accuracy_level + * (Public_data.accuracy_level + * Public_data.accuracy_level + * Public_data.scc)) + list = + Public_data.AccuracyMap.fold (fun x scc l -> (x, x, (x, x, scc)) :: l) map [] let annotate_map_triple - (map:Public_data.scc Public_data.AccuracyMap.t Public_data.AccuracyMap.t) = + (map : Public_data.scc Public_data.AccuracyMap.t Public_data.AccuracyMap.t) + = Public_data.AccuracyMap.fold (fun _ map l -> - let map = annotate_triple map in - map :: l - ) map [[]] + let map = annotate_triple map in + map :: l) + map [ [] ] let add_scc_map get title label to_json state - (l:(string * Yojson.Basic.t) list) = + (l : (string * Yojson.Basic.t) list) = let map = get state in - if Public_data.AccuracyMap.is_empty map then l - else + if Public_data.AccuracyMap.is_empty map then + l + else ( let y = annotate_map_triple (get state) in - (title, - (add_list_of_list_of_triple title label to_json) - (List.rev y)) :: l - -let add_scc_map_to_json state (l:(string * Yojson.Basic.t)list) - : (string * Yojson.Basic.t)list = - add_scc_map - get_scc_decomposition - scc_contact_map - scc_contact_maps - Public_data.scc_to_json - state l + (title, (add_list_of_list_of_triple title label to_json) (List.rev y)) :: l + ) + +let add_scc_map_to_json state (l : (string * Yojson.Basic.t) list) : + (string * Yojson.Basic.t) list = + add_scc_map get_scc_decomposition scc_contact_map scc_contact_maps + Public_data.scc_to_json state l let add_influence_map_to_json state l = - add_map get_influence_map_map - influencemaps Public_data.influencemap Public_data.influence_map_to_json - state l + add_map get_influence_map_map influencemaps Public_data.influencemap + Public_data.influence_map_to_json state l let add_dead_rules_to_json state l = - match - state.dead_rules - with + match state.dead_rules with | None -> l - | Some rules -> - (dead_rules , Public_data.dead_rules_to_json rules)::l + | Some rules -> (dead_rules, Public_data.dead_rules_to_json rules) :: l let add_refinements_lemmas_to_json state l = - match - get_constraints_list state - with + match get_constraints_list state with | None -> l | Some constraints -> - ( - Public_data.refinement_lemmas, - lemmas_list_to_json constraints - )::l + (Public_data.refinement_lemmas, lemmas_list_to_json constraints) :: l let get_separating_transitions state = state.separating_transitions + let set_separating_transitions l state = - {state with separating_transitions = Some l} + { state with separating_transitions = Some l } let add_separating_transitions state l = - match - get_separating_transitions state - with + match get_separating_transitions state with | None -> l | Some list -> - (separating_transitions, - Public_data.separating_transitions_to_json list)::l + (separating_transitions, Public_data.separating_transitions_to_json list) + :: l let get_transition_system_length state = state.transition_system_length + let set_transition_system_length l state = - {state with transition_system_length = Some l} + { state with transition_system_length = Some l } let to_json state = let l = [] in @@ -486,288 +425,249 @@ let to_json state = let l = add_contact_map_to_json state l in let l = add_scc_map_to_json state l in let l = add_separating_transitions state l in - ((`Assoc l): Yojson.Basic.t) + (`Assoc l : Yojson.Basic.t) -let of_json = - function - | `Assoc l as json-> +let of_json = function + | `Assoc l as json -> let errors = - try - Exception_without_parameter.of_json (List.assoc errors l) - with - | Not_found -> - raise (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "no error handler",json)) + try Exception_without_parameter.of_json (List.assoc errors l) + with Not_found -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "no error handler", json)) in let contact_maps = try get_map Public_data.AccuracyMap.empty Public_data.AccuracyMap.add - Public_data.contact_map_of_json - contactmap - (List.assoc contactmaps l) - with - | Not_found -> Public_data.AccuracyMap.empty + Public_data.contact_map_of_json contactmap (List.assoc contactmaps l) + with Not_found -> Public_data.AccuracyMap.empty in let influence_maps = try get_map Public_data.AccuracyMap.empty Public_data.AccuracyMap.add - Public_data.influence_map_of_json - Public_data.influencemap + Public_data.influence_map_of_json Public_data.influencemap (List.assoc influencemaps l) - with - | Not_found -> Public_data.AccuracyMap.empty + with Not_found -> Public_data.AccuracyMap.empty in let dead_rules = - try - Some (Public_data.dead_rules_of_json (List.assoc dead_rules l)) - with - | Not_found -> None + try Some (Public_data.dead_rules_of_json (List.assoc dead_rules l)) + with Not_found -> None in let constraints = try Some (lemmas_list_of_json (List.assoc Public_data.refinement_lemmas l)) - with - | Not_found -> None + with Not_found -> None in let separating_transitions = try - Some (Public_data.separating_transitions_of_json - (List.assoc separating_transitions l)) - with - | Not_found -> None + Some + (Public_data.separating_transitions_of_json + (List.assoc separating_transitions l)) + with Not_found -> None in - errors, contact_maps, influence_maps, dead_rules, constraints, separating_transitions + ( errors, + contact_maps, + influence_maps, + dead_rules, + constraints, + separating_transitions ) | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "remanent state",x)) + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "remanent state", x)) let do_event_gen f phase n state = let error, log_info = - f - state.parameters - state.errors - phase - n - state.log_info + f state.parameters state.errors phase n state.log_info in - {state with errors = error ; log_info = log_info} + { state with errors = error; log_info } let add_event x y = do_event_gen StoryProfiling.StoryStats.add_event x y - let close_event x y = do_event_gen StoryProfiling.StoryStats.close_event x y - -let set_parameters parameters state = {state with parameters = parameters} - +let set_parameters parameters state = { state with parameters } let get_parameters state = state.parameters - let get_init state = state.init - -let set_init_state init state = {state with init_state = Some init} - +let set_init_state init state = { state with init_state = Some init } let get_init_state state = state.init_state - -let set_env model state = {state with env = Some model} - +let set_env model state = { state with env = Some model } let get_env state = state.env (*contact map from kappa*) -let set_contact_map_int cm state = - {state with contact_map_int = Some cm} - +let set_contact_map_int cm state = { state with contact_map_int = Some cm } let get_contact_map_int state = state.contact_map_int let set_compilation compilation state = - {state with compilation = Some compilation} + { state with compilation = Some compilation } let get_compilation state = state.compilation - -let set_handler handler state = {state with handler = Some handler} - +let set_handler handler state = { state with handler = Some handler } let get_handler state = state.handler - -let set_c_compil c_compil state = {state with c_compil = Some c_compil} - +let set_c_compil c_compil state = { state with c_compil = Some c_compil } let get_c_compil state = state.c_compil let set_refined_compil refined_compil state = - {state with refined_compilation = Some refined_compil} + { state with refined_compilation = Some refined_compil } let get_refined_compil state = state.refined_compilation - -let set_errors errors state = {state with errors = errors } - +let set_errors errors state = { state with errors } let get_errors state = state.errors - -let set_quark_map quark_map state = - {state with quark_map = Some quark_map} - +let set_quark_map quark_map state = { state with quark_map = Some quark_map } let get_quark_map state = state.quark_map let set_contact_map accuracy map state = - {state with contact_map = - Public_data.AccuracyMap.add accuracy map state.contact_map} + { + state with + contact_map = Public_data.AccuracyMap.add accuracy map state.contact_map; + } let get_contact_map accuracy state = Public_data.AccuracyMap.find_option accuracy state.contact_map -let set_signature signature state = {state with signature = Some signature} - +let set_signature signature state = { state with signature = Some signature } let get_signature state = state.signature let set_influence_map accuracy map state = - {state with influence_map = - Public_data.AccuracyMap.add accuracy map state.influence_map} + { + state with + influence_map = Public_data.AccuracyMap.add accuracy map state.influence_map; + } let get_influence_map accuracy state = Public_data.AccuracyMap.find_option accuracy state.influence_map let set_bidirectional_influence_map accuracy map state = - {state with bidirectional_influence_map = - Public_data.AccuracyMap.add accuracy map state.bidirectional_influence_map} + { + state with + bidirectional_influence_map = + Public_data.AccuracyMap.add accuracy map state.bidirectional_influence_map; + } let get_bidirectional_influence_map accuracy state = Public_data.AccuracyMap.find_option accuracy state.bidirectional_influence_map - let set_local_influence_map_blackboard blackboard state = - {state with local_influence_map_blackboard = Some blackboard} + { state with local_influence_map_blackboard = Some blackboard } let get_local_influence_map_blackboard state = state.local_influence_map_blackboard let set_internal_influence_map accuracy map state = - {state - with internal_influence_map = - Public_data.AccuracyMap.add accuracy map state.internal_influence_map} + { + state with + internal_influence_map = + Public_data.AccuracyMap.add accuracy map state.internal_influence_map; + } let get_internal_influence_map accuracy state = Public_data.AccuracyMap.find_option accuracy state.internal_influence_map let set_internal_contact_map accuracy int_contact_map state = - {state - with internal_contact_map = - Public_data.AccuracyMap.add - accuracy int_contact_map state.internal_contact_map} + { + state with + internal_contact_map = + Public_data.AccuracyMap.add accuracy int_contact_map + state.internal_contact_map; + } let get_internal_contact_map accuracy state = Public_data.AccuracyMap.find_option accuracy state.internal_contact_map let set_internal_scc_decomposition accuracy accuracy' dec state = let old = - Public_data.AccuracyMap.find_default - Public_data.AccuracyMap.empty - accuracy state.internal_scc_decomposition + Public_data.AccuracyMap.find_default Public_data.AccuracyMap.empty accuracy + state.internal_scc_decomposition in - {state with - internal_scc_decomposition = - Public_data.AccuracyMap.add - accuracy - (Public_data.AccuracyMap.add accuracy' dec old) - state.internal_scc_decomposition + { + state with + internal_scc_decomposition = + Public_data.AccuracyMap.add accuracy + (Public_data.AccuracyMap.add accuracy' dec old) + state.internal_scc_decomposition; } let get_internal_scc_decomposition_map state = state.internal_scc_decomposition let get_internal_scc_decomposition accuracy accuracy' state = match - Public_data.AccuracyMap.find_option accuracy state.internal_scc_decomposition + Public_data.AccuracyMap.find_option accuracy + state.internal_scc_decomposition with | None -> None - | Some a -> - Public_data.AccuracyMap.find_option accuracy' a + | Some a -> Public_data.AccuracyMap.find_option accuracy' a let set_scc_decomposition accuracy accuracy' dec state = let old = - Public_data.AccuracyMap.find_default - Public_data.AccuracyMap.empty - accuracy state.scc_decomposition + Public_data.AccuracyMap.find_default Public_data.AccuracyMap.empty accuracy + state.scc_decomposition in - {state with - scc_decomposition = - Public_data.AccuracyMap.add - accuracy - (Public_data.AccuracyMap.add accuracy' dec old) - state.scc_decomposition + { + state with + scc_decomposition = + Public_data.AccuracyMap.add accuracy + (Public_data.AccuracyMap.add accuracy' dec old) + state.scc_decomposition; } let get_scc_decomposition accuracy accuracy' state = match - Public_data.AccuracyMap.find_option - accuracy state.scc_decomposition + Public_data.AccuracyMap.find_option accuracy state.scc_decomposition with | None -> None - | Some a -> - Public_data.AccuracyMap.find_option accuracy' a - + | Some a -> Public_data.AccuracyMap.find_option accuracy' a let get_reachability_result state = state.reachability_state let set_reachability_result reachability_state state = - {state with reachability_state = Some reachability_state} + { state with reachability_state = Some reachability_state } let get_dead_rules state = state.dead_rules let set_dead_rules dead_rules state = - {state with dead_rules = Some dead_rules} + { state with dead_rules = Some dead_rules } let get_dead_agents state = state.dead_agents let set_dead_agents dead_agents state = - {state with dead_agents = Some dead_agents} + { state with dead_agents = Some dead_agents } let get_subviews_info state = state.subviews_info let set_subviews_info subviews state = - {state with subviews_info = Some subviews} - -let set_bdu_handler bdu_handler state = - {state with bdu_handler = bdu_handler} + { state with subviews_info = Some subviews } +let set_bdu_handler bdu_handler state = { state with bdu_handler } let get_bdu_handler state = state.bdu_handler - -let set_ode_flow flow state = {state with ode_flow = Some flow} - +let set_ode_flow flow state = { state with ode_flow = Some flow } let get_ode_flow state = state.ode_flow - -let set_ctmc_flow flow state = {state with ctmc_flow = Some flow} - +let set_ctmc_flow flow state = { state with ctmc_flow = Some flow } let get_ctmc_flow state = state.ctmc_flow - let get_influence_map_map state = state.influence_map - let get_internal_contact_map_map state = state.internal_contact_map - let get_internal_influence_map_map state = state.internal_influence_map - let get_log_info state = state.log_info - -let set_log_info log state = {state with log_info = log} - -let get_internal_constraints_list state = - state.internal_constraints_list +let set_log_info log state = { state with log_info = log } +let get_internal_constraints_list state = state.internal_constraints_list let set_internal_constraints_list list state = - {state with internal_constraints_list = Some list} + { state with internal_constraints_list = Some list } let get_constraints_list state = state.constraints_list let set_constraints_list list state = - {state with constraints_list = Some list} - + { state with constraints_list = Some list } let get_symmetries accuracy state = Public_data.AccuracyMap.find_option accuracy state.symmetric_sites let set_symmetries accuracy partition state = { - state - with symmetric_sites = - Public_data.AccuracyMap.add - accuracy partition state.symmetric_sites + state with + symmetric_sites = + Public_data.AccuracyMap.add accuracy partition state.symmetric_sites; } -let info_to_agent (agent_name,pos,agent_id) = +let info_to_agent (agent_name, pos, agent_id) = { Public_data.agent_id = Ckappa_sig.int_of_agent_name agent_id; - Public_data.agent_ast = agent_name ; - Public_data.agent_position = pos + Public_data.agent_ast = agent_name; + Public_data.agent_position = pos; } diff --git a/core/KaSa_rep/remanent_state/remanent_state.mli b/core/KaSa_rep/remanent_state/remanent_state.mli index 7ae43a7171..3ede63057c 100644 --- a/core/KaSa_rep/remanent_state/remanent_state.mli +++ b/core/KaSa_rep/remanent_state/remanent_state.mli @@ -12,71 +12,62 @@ * under the terms of the GNU Library General Public License *) type compilation = Ast.parsing_compil - -type init = - Compil of compilation - | Files of string list - -type initial_state = - (Primitives.alg_expr * Primitives.elementary_rule) list +type init = Compil of compilation | Files of string list +type initial_state = (Primitives.alg_expr * Primitives.elementary_rule) list type internal_contact_map = - (Ckappa_sig.c_state list * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) list) - Ckappa_sig.Site_map_and_set.Map.t Ckappa_sig.Agent_map_and_set.Map.t + (Ckappa_sig.c_state list + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) list) + Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_map_and_set.Map.t type internal_scc_decomposition = - ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) * - (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)) - list list + ((Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name) + * (Ckappa_sig.c_agent_name * Ckappa_sig.c_site_name)) + list + list type quark_map = Quark_type.quarks - type rule_id = int -type var_id = int - +type var_id = int type dead_agents = Public_data.agent_kind list -val info_to_rule: - (string*Locality.t*Public_data.rule_direction*string*Ckappa_sig.c_rule_id) - -> Public_data.rule +val info_to_rule : + string * Loc.t * Public_data.rule_direction * string * Ckappa_sig.c_rule_id -> + Public_data.rule -val info_to_agent: - (string*Locality.t list*Ckappa_sig.c_agent_name) - -> Public_data.agent_kind +val info_to_agent : + string * Loc.t list * Ckappa_sig.c_agent_name -> Public_data.agent_kind type separating_transitions = Public_data.separating_transitions type refined_compilation = - (Ckappa_sig.agent, Ckappa_sig.mixture, Ckappa_sig.mixture, string, Ckappa_sig.mixture Ckappa_sig.rule) Ast.compil - -type distance = - { - fwd: int ; - bwd: int ; - total: int - } + ( Ckappa_sig.agent, + Ckappa_sig.mixture, + Ckappa_sig.mixture, + string, + Ckappa_sig.mixture Ckappa_sig.rule ) + Ast.compil +type distance = { fwd: int; bwd: int; total: int } -type local_influence_map_blackboard = - { - blackboard_distance: distance option array; - blackboard_is_done: bool array; - blackboard_to_be_explored: bool array - } +type local_influence_map_blackboard = { + blackboard_distance: distance option array; + blackboard_is_done: bool array; + blackboard_to_be_explored: bool array; +} type internal_influence_map = - Ckappa_sig.c_rule_id list * - Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t * - Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t - -type ('static,'dynamic) reachability_result = 'static * 'dynamic + Ckappa_sig.c_rule_id list + * Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t + * Quark_type.Labels.label_set_couple Ckappa_sig.PairRule_setmap.Map.t +type ('static, 'dynamic) reachability_result = 'static * 'dynamic type subviews_info = unit type flow = - Ckappa_sig.Site_union_find.t - Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t + Ckappa_sig.Site_union_find.t + Ckappa_sig.Agent_type_quick_nearly_Inf_Int_storage_Imperatif.t (*******************************************************************) @@ -84,14 +75,16 @@ type internal_constraints_list = Site_graphs.KaSa_site_graph.t Public_data.poly_constraints_list type agent = - string * (*agent name*) - (string option * Site_graphs.KaSa_site_graph.binding_state option * (int option * int option) option) - Wrapped_modules.LoggedStringMap.t + string + * (*agent name*) + (string option + * Site_graphs.KaSa_site_graph.binding_state option + * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t type constraints_list = agent list Public_data.poly_constraints_list val lemmas_list_to_json : constraints_list -> Yojson.Basic.t - val lemmas_list_of_json : Yojson.Basic.t -> constraints_list (*******************************************************************) @@ -102,252 +95,320 @@ type symmetric_sites = Symmetries.symmetries option type influence_edge = Quark_type.Labels.label_set_couple -type bidirectional_influence_map = - { - positive_influence_fwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - positive_influence_bwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - negative_influence_fwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - negative_influence_bwd: - (Ckappa_sig.c_rule_id * influence_edge) list array; - } +type bidirectional_influence_map = { + positive_influence_fwd: (Ckappa_sig.c_rule_id * influence_edge) list array; + positive_influence_bwd: (Ckappa_sig.c_rule_id * influence_edge) list array; + negative_influence_fwd: (Ckappa_sig.c_rule_id * influence_edge) list array; + negative_influence_bwd: (Ckappa_sig.c_rule_id * influence_edge) list array; +} type ('static, 'dynamic) state (*******************************************************************) -val to_json: ('static, 'dynamic) state -> Yojson.Basic.t - -val of_json: Yojson.Basic.t -> - Exception_without_parameter.method_handler * - Public_data.contact_map Public_data.AccuracyMap.t * - Public_data.influence_map Public_data.AccuracyMap.t * - Public_data.dead_rules option * - constraints_list option * - Public_data.separating_transitions option - -val create_state: - ?errors:Exception.method_handler -> ?env:Model.t option -> - ?init_state:initial_state -> ?reset:bool -> - Remanent_parameters_sig.parameters -> init -> ('static, 'dynamic) state - -val set_parameters: Remanent_parameters_sig.parameters -> ('static, 'dynamic) state -> ('static, 'dynamic) state +val to_json : ('static, 'dynamic) state -> Yojson.Basic.t + +val of_json : + Yojson.Basic.t -> + Exception_without_parameter.method_handler + * Public_data.contact_map Public_data.AccuracyMap.t + * Public_data.influence_map Public_data.AccuracyMap.t + * Public_data.dead_rules option + * constraints_list option + * Public_data.separating_transitions option + +val create_state : + ?errors:Exception.method_handler -> + ?env:Model.t option -> + ?init_state:initial_state -> + ?reset:bool -> + Remanent_parameters_sig.parameters -> + init -> + ('static, 'dynamic) state -val get_parameters: ('static, 'dynamic) state -> - Remanent_parameters_sig.parameters +val set_parameters : + Remanent_parameters_sig.parameters -> + ('static, 'dynamic) state -> + ('static, 'dynamic) state -val add_event: StoryProfiling.step_kind -> (unit -> int) option -> ('static, 'dynamic) state -> ('static, 'dynamic) state +val get_parameters : + ('static, 'dynamic) state -> Remanent_parameters_sig.parameters -val close_event: StoryProfiling.step_kind -> (unit -> int) option -> ('static, 'dynamic) state -> ('static, 'dynamic) state +val add_event : + StoryProfiling.step_kind -> + (unit -> int) option -> + ('static, 'dynamic) state -> + ('static, 'dynamic) state -val get_init: ('static, 'dynamic) state -> init +val close_event : + StoryProfiling.step_kind -> + (unit -> int) option -> + ('static, 'dynamic) state -> + ('static, 'dynamic) state -val get_env: ('static, 'dynamic) state -> Model.t option option +val get_init : ('static, 'dynamic) state -> init +val get_env : ('static, 'dynamic) state -> Model.t option option -val set_env: Model.t option -> ('static, 'dynamic) state -> ('static, 'dynamic) state +val set_env : + Model.t option -> ('static, 'dynamic) state -> ('static, 'dynamic) state -val get_init_state: ('static, 'dynamic) state -> initial_state option +val get_init_state : ('static, 'dynamic) state -> initial_state option -val set_init_state: +val set_init_state : initial_state -> ('static, 'dynamic) state -> ('static, 'dynamic) state (*contact map int*) -val get_contact_map_int: ('static, 'dynamic) state -> - Contact_map.t option option - -val set_contact_map_int: - Contact_map.t option -> ('static, 'dynamic) state -> - ('static, 'dynamic) state +val get_contact_map_int : + ('static, 'dynamic) state -> Contact_map.t option option -val set_compilation: compilation -> ('static, 'dynamic) state -> - ('static, 'dynamic) state +val set_contact_map_int : + Contact_map.t option -> ('static, 'dynamic) state -> ('static, 'dynamic) state -val get_compilation: ('static, 'dynamic) state -> compilation option +val set_compilation : + compilation -> ('static, 'dynamic) state -> ('static, 'dynamic) state -val set_handler: Cckappa_sig.kappa_handler -> ('static, 'compile) state -> ('static, 'compile) state +val get_compilation : ('static, 'dynamic) state -> compilation option -val get_handler: ('static, 'compile) state -> Cckappa_sig.kappa_handler option +val set_handler : + Cckappa_sig.kappa_handler -> + ('static, 'compile) state -> + ('static, 'compile) state -val set_refined_compil: refined_compilation -> ('static, 'compile) state -> ('static, 'compile) state +val get_handler : ('static, 'compile) state -> Cckappa_sig.kappa_handler option -val get_refined_compil: - ('static, 'compile) state - -> refined_compilation option +val set_refined_compil : + refined_compilation -> ('static, 'compile) state -> ('static, 'compile) state -val set_c_compil: Cckappa_sig.compil -> ('static, 'compile) state -> ('static, 'compile) state +val get_refined_compil : ('static, 'compile) state -> refined_compilation option -val get_c_compil: ('static, 'compile) state -> Cckappa_sig.compil option +val set_c_compil : + Cckappa_sig.compil -> ('static, 'compile) state -> ('static, 'compile) state -val get_errors: ('static, 'compile) state -> Exception.method_handler +val get_c_compil : ('static, 'compile) state -> Cckappa_sig.compil option +val get_errors : ('static, 'compile) state -> Exception.method_handler -val set_errors: Exception.method_handler -> ('static, 'compile) state -> ('static, 'compile) state +val set_errors : + Exception.method_handler -> + ('static, 'compile) state -> + ('static, 'compile) state -val set_internal_contact_map: - Public_data.accuracy_level -> internal_contact_map -> - ('static, 'compile) state -> ('static, 'compile) state +val set_internal_contact_map : + Public_data.accuracy_level -> + internal_contact_map -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_internal_contact_map: - Public_data.accuracy_level -> ('static, 'compile) state -> +val get_internal_contact_map : + Public_data.accuracy_level -> + ('static, 'compile) state -> internal_contact_map option -val get_internal_scc_decomposition: - Public_data.accuracy_level -> Public_data.accuracy_level -> - ('static, 'compile) state -> internal_scc_decomposition option +val get_internal_scc_decomposition : + Public_data.accuracy_level -> + Public_data.accuracy_level -> + ('static, 'compile) state -> + internal_scc_decomposition option -val get_internal_scc_decomposition_map: - ('static, 'compile) state -> internal_scc_decomposition Public_data.AccuracyMap.t Public_data.AccuracyMap.t +val get_internal_scc_decomposition_map : + ('static, 'compile) state -> + internal_scc_decomposition Public_data.AccuracyMap.t Public_data.AccuracyMap.t -val set_internal_scc_decomposition: - Public_data.accuracy_level -> Public_data.accuracy_level -> +val set_internal_scc_decomposition : + Public_data.accuracy_level -> + Public_data.accuracy_level -> internal_scc_decomposition -> - ('static, 'compile) state -> ('static, 'compile) state + ('static, 'compile) state -> + ('static, 'compile) state -val get_scc_decomposition: - Public_data.accuracy_level -> Public_data.accuracy_level -> - ('static, 'compile) state -> Public_data.scc option +val get_scc_decomposition : + Public_data.accuracy_level -> + Public_data.accuracy_level -> + ('static, 'compile) state -> + Public_data.scc option -val set_scc_decomposition: - Public_data.accuracy_level -> Public_data.accuracy_level -> +val set_scc_decomposition : + Public_data.accuracy_level -> + Public_data.accuracy_level -> Public_data.scc -> - ('static, 'compile) state -> ('static, 'compile) state + ('static, 'compile) state -> + ('static, 'compile) state -val set_contact_map: - Public_data.accuracy_level -> Public_data.contact_map -> - ('static, 'compile) state -> ('static, 'compile) state +val set_contact_map : + Public_data.accuracy_level -> + Public_data.contact_map -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_contact_map: - Public_data.accuracy_level -> ('static, 'compile) state -> +val get_contact_map : + Public_data.accuracy_level -> + ('static, 'compile) state -> Public_data.contact_map option -val set_signature: Signature.s -> ('static, 'compile) state -> ('static, 'compile) state +val set_signature : + Signature.s -> ('static, 'compile) state -> ('static, 'compile) state -val get_signature: ('static, 'compile) state -> Signature.s option +val get_signature : ('static, 'compile) state -> Signature.s option -val set_quark_map: quark_map -> ('static, 'compile) state -> ('static, 'compile) state +val set_quark_map : + quark_map -> ('static, 'compile) state -> ('static, 'compile) state -val get_quark_map: ('static, 'compile) state -> quark_map option +val get_quark_map : ('static, 'compile) state -> quark_map option -val set_pos_of_rules_and_vars: +val set_pos_of_rules_and_vars : Public_data.pos_of_rules_and_vars -> - ('static, 'compile) state -> ('static, 'compile) state + ('static, 'compile) state -> + ('static, 'compile) state -val get_pos_of_rules_and_vars: +val get_pos_of_rules_and_vars : ('static, 'compile) state -> Public_data.pos_of_rules_and_vars option -val set_internal_influence_map: - Public_data.accuracy_level -> internal_influence_map -> - ('static, 'compile) state -> ('static, 'compile) state +val set_internal_influence_map : + Public_data.accuracy_level -> + internal_influence_map -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_internal_influence_map: - Public_data.accuracy_level -> ('static, 'compile) state -> +val get_internal_influence_map : + Public_data.accuracy_level -> + ('static, 'compile) state -> internal_influence_map option -val set_influence_map: - Public_data.accuracy_level -> Public_data.influence_map -> - ('static, 'compile) state -> ('static, 'compile) state +val set_influence_map : + Public_data.accuracy_level -> + Public_data.influence_map -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_influence_map: - Public_data.accuracy_level -> ('static, 'compile) state -> +val get_influence_map : + Public_data.accuracy_level -> + ('static, 'compile) state -> Public_data.influence_map option -val set_bidirectional_influence_map: - Public_data.accuracy_level -> bidirectional_influence_map -> - ('static, 'compile) state -> ('static, 'compile) state +val set_bidirectional_influence_map : + Public_data.accuracy_level -> + bidirectional_influence_map -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_bidirectional_influence_map: - Public_data.accuracy_level -> ('static, 'compile) state -> +val get_bidirectional_influence_map : + Public_data.accuracy_level -> + ('static, 'compile) state -> bidirectional_influence_map option -val set_local_influence_map_blackboard: +val set_local_influence_map_blackboard : local_influence_map_blackboard -> - ('static, 'compile) state -> ('static, 'compile) state + ('static, 'compile) state -> + ('static, 'compile) state -val get_local_influence_map_blackboard: +val get_local_influence_map_blackboard : ('static, 'compile) state -> local_influence_map_blackboard option -val set_ode_flow: Ode_fragmentation_type.ode_frag -> ('static, 'compile) state -> ('static, 'compile) state - -val get_ode_flow: ('static, 'compile) state -> Ode_fragmentation_type.ode_frag option +val set_ode_flow : + Ode_fragmentation_type.ode_frag -> + ('static, 'compile) state -> + ('static, 'compile) state -val set_ctmc_flow: flow -> ('static, 'compile) state -> ('static, 'compile) state +val get_ode_flow : + ('static, 'compile) state -> Ode_fragmentation_type.ode_frag option -val get_ctmc_flow: ('static, 'compile) state -> flow option +val set_ctmc_flow : + flow -> ('static, 'compile) state -> ('static, 'compile) state -val get_bdu_handler: ('static, 'compile) state -> Mvbdu_wrapper.Mvbdu.handler +val get_ctmc_flow : ('static, 'compile) state -> flow option +val get_bdu_handler : ('static, 'compile) state -> Mvbdu_wrapper.Mvbdu.handler -val set_bdu_handler: Mvbdu_wrapper.Mvbdu.handler -> ('static, 'compile) state -> ('static, 'compile) state +val set_bdu_handler : + Mvbdu_wrapper.Mvbdu.handler -> + ('static, 'compile) state -> + ('static, 'compile) state -val set_reachability_result: ('static, 'compile) reachability_result -> ('static, 'compile) state -> ('static, 'compile) state +val set_reachability_result : + ('static, 'compile) reachability_result -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_reachability_result: ('static, 'compile) state -> ('static, 'compile) reachability_result option +val get_reachability_result : + ('static, 'compile) state -> ('static, 'compile) reachability_result option -val get_subviews_info: ('static, 'compile) state -> subviews_info option +val get_subviews_info : ('static, 'compile) state -> subviews_info option -val set_subviews_info: subviews_info -> ('static, 'compile) state -> ('static, 'compile) state +val set_subviews_info : + subviews_info -> ('static, 'compile) state -> ('static, 'compile) state -val get_dead_rules: ('static, 'compile) state -> Public_data.dead_rules option +val get_dead_rules : ('static, 'compile) state -> Public_data.dead_rules option -val set_dead_rules: - Public_data.dead_rules -> ('static, 'compile) state -> ('static, 'compile) state +val set_dead_rules : + Public_data.dead_rules -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_dead_agents: ('static, 'compile) state -> dead_agents option +val get_dead_agents : ('static, 'compile) state -> dead_agents option -val set_dead_agents: +val set_dead_agents : dead_agents -> ('static, 'compile) state -> ('static, 'compile) state -val get_influence_map_map: +val get_influence_map_map : ('static, 'compile) state -> Public_data.influence_map Public_data.AccuracyMap.t -val set_separating_transitions: - separating_transitions -> ('static, 'compile) state -> +val set_separating_transitions : + separating_transitions -> + ('static, 'compile) state -> ('static, 'compile) state -val get_separating_transitions: + +val get_separating_transitions : ('static, 'compile) state -> separating_transitions option -val set_transition_system_length: - int list -> ('static, 'compile) state -> - ('static, 'compile) state +val set_transition_system_length : + int list -> ('static, 'compile) state -> ('static, 'compile) state -val get_transition_system_length: - ('static, 'compile) state -> int list option +val get_transition_system_length : ('static, 'compile) state -> int list option -val get_contact_map_map: +val get_contact_map_map : ('static, 'compile) state -> Public_data.contact_map Public_data.AccuracyMap.t -val get_internal_influence_map_map: +val get_internal_influence_map_map : ('static, 'compile) state -> internal_influence_map Public_data.AccuracyMap.t -val get_internal_contact_map_map: +val get_internal_contact_map_map : ('static, 'compile) state -> internal_contact_map Public_data.AccuracyMap.t -val set_log_info: StoryProfiling.StoryStats.log_info -> ('static, 'compile) state -> ('static, 'compile) state +val set_log_info : + StoryProfiling.StoryStats.log_info -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_log_info: ('static, 'compile) state -> - StoryProfiling.StoryStats.log_info +val get_log_info : + ('static, 'compile) state -> StoryProfiling.StoryStats.log_info -val get_internal_constraints_list : ('static, 'compile) state -> - internal_constraints_list option +val get_internal_constraints_list : + ('static, 'compile) state -> internal_constraints_list option -val set_internal_constraints_list : internal_constraints_list -> ('static, 'compile) state -> ('static, 'compile) state +val set_internal_constraints_list : + internal_constraints_list -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_constraints_list : ('static, 'compile) state -> - constraints_list option +val get_constraints_list : ('static, 'compile) state -> constraints_list option -val set_constraints_list : constraints_list -> ('static, 'compile) state -> - ('static, 'compile) state +val set_constraints_list : + constraints_list -> ('static, 'compile) state -> ('static, 'compile) state val get_symmetries : - Public_data.accuracy_level -> ('static, 'compile) state -> symmetric_sites option + Public_data.accuracy_level -> + ('static, 'compile) state -> + symmetric_sites option val set_symmetries : - Public_data.accuracy_level -> symmetric_sites - -> ('static, 'compile) state -> ('static, 'compile) state + Public_data.accuracy_level -> + symmetric_sites -> + ('static, 'compile) state -> + ('static, 'compile) state -val get_data: +val get_data : ('static, 'compile) state -> - Cckappa_sig.kappa_handler option * Public_data.dead_rules option * - separating_transitions option * int list option + Cckappa_sig.kappa_handler option + * Public_data.dead_rules option + * separating_transitions option + * int list option diff --git a/core/KaSa_rep/sanity_test/dune b/core/KaSa_rep/sanity_test/dune index d4b7935a7b..c1cb46f0df 100644 --- a/core/KaSa_rep/sanity_test/dune +++ b/core/KaSa_rep/sanity_test/dune @@ -1,10 +1,17 @@ (tests - (names sanity_test) - (libraries num str kappa_mvbdu kappa_species_count_enumeration) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_kasa_kastor_toolset - -open Kappa_parameters - -open Kappa_errors - -open Kappa_mvbdu - -open Kappa_species_count_enumeration))) + (names sanity_test) + (libraries num str kappa_mvbdu kappa_species_count_enumeration) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_kasa_kastor_toolset + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_mvbdu + -open + Kappa_species_count_enumeration))) diff --git a/core/KaSa_rep/sanity_test/list_sanity.ml b/core/KaSa_rep/sanity_test/list_sanity.ml index f9b05aa317..28921f8d06 100644 --- a/core/KaSa_rep/sanity_test/list_sanity.ml +++ b/core/KaSa_rep/sanity_test/list_sanity.ml @@ -12,137 +12,123 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - -let rec safety_equal_list list_x list_y = +let rec safety_equal_list list_x list_y = match list_x.List_sig.value, list_y.List_sig.value with - | List_sig.Empty, List_sig.Empty -> true - | List_sig.Cons x, List_sig.Cons y -> - x.List_sig.variable = y.List_sig.variable - && x.List_sig.association = y.List_sig.association - && safety_equal_list x.List_sig.tail y.List_sig.tail - | List_sig.Empty,_ | _,List_sig.Empty -> false - + | List_sig.Empty, List_sig.Empty -> true + | List_sig.Cons x, List_sig.Cons y -> + x.List_sig.variable = y.List_sig.variable + && x.List_sig.association = y.List_sig.association + && safety_equal_list x.List_sig.tail y.List_sig.tail + | List_sig.Empty, _ | _, List_sig.Empty -> false -let rec safety_check_maximal_sharing (allocate_uniquely:('a,'b,'c,'d,'e) Sanity_test_sig.g) - error list handler = +let rec safety_check_maximal_sharing + (allocate_uniquely : ('a, 'b, 'c, 'd, 'e) Sanity_test_sig.g) error list + handler = let list_val = list.List_sig.value in match list_val with - | List_sig.Empty -> error,true,handler - | List_sig.Cons _ -> - (* check that list is uniquely represented in memory *) - let error,output = allocate_uniquely - error - compare + | List_sig.Empty -> error, true, handler + | List_sig.Cons _ -> + (* check that list is uniquely represented in memory *) + let error, output = + allocate_uniquely error compare (List_core.get_skeleton list_val) list_val - (fun key -> {List_sig.id = key; List_sig.value = list_val}) + (fun key -> { List_sig.id = key; List_sig.value = list_val }) handler - in - match output with - | None -> error,false,handler - | Some (_i,_asso,_asso_id,handler) -> - begin - match list_val with - | List_sig.Empty -> error,true,handler - | List_sig.Cons x -> - safety_check_maximal_sharing - allocate_uniquely - error - x.List_sig.tail - handler - end + in + (match output with + | None -> error, false, handler + | Some (_i, _asso, _asso_id, handler) -> + (match list_val with + | List_sig.Empty -> error, true, handler + | List_sig.Cons x -> + safety_check_maximal_sharing allocate_uniquely error x.List_sig.tail + handler)) let rec safety_check_increasing_nodes_aux error list var = match list.List_sig.value with - | List_sig.Empty -> error,true - | List_sig.Cons x -> - let new_var = x.List_sig.variable in - begin - match compare var new_var - with - | a when a<0 -> - safety_check_increasing_nodes_aux - error - x.List_sig.tail - new_var - | a when a>0 -> error,false - | _ -> error,false - end + | List_sig.Empty -> error, true + | List_sig.Cons x -> + let new_var = x.List_sig.variable in + (match compare var new_var with + | a when a < 0 -> + safety_check_increasing_nodes_aux error x.List_sig.tail new_var + | a when a > 0 -> error, false + | _ -> error, false) let safety_check_increasing_nodes error list = match list.List_sig.value with - | List_sig.Empty -> error,true - | List_sig.Cons x -> - safety_check_increasing_nodes_aux - error - x.List_sig.tail - x.List_sig.variable + | List_sig.Empty -> error, true + | List_sig.Cons x -> + safety_check_increasing_nodes_aux error x.List_sig.tail x.List_sig.variable let print_flag log bool = - if bool - then Printf.fprintf log "Yes" - else Printf.fprintf log "No" + if bool then + Printf.fprintf log "Yes" + else + Printf.fprintf log "No" -let sanity_check (allocate_uniquely:('a,'b,'c,'d,'e) Sanity_test_sig.g) error _log handler mvbdu = - let error,bool1 = - safety_check_increasing_nodes - error - mvbdu +let sanity_check (allocate_uniquely : ('a, 'b, 'c, 'd, 'e) Sanity_test_sig.g) + error _log handler mvbdu = + let error, bool1 = safety_check_increasing_nodes error mvbdu in + let error, bool2, dictionary = + safety_check_maximal_sharing allocate_uniquely error mvbdu handler in - let error,bool2,dictionary = - safety_check_maximal_sharing - allocate_uniquely - error - mvbdu - handler - in - error, dictionary, (bool1,bool2) + error, dictionary, (bool1, bool2) let add_string m1 m2 = - if m1 = "" then m2 - else if m2 = "" then m1 - else m1^" / "^m2 + if m1 = "" then + m2 + else if m2 = "" then + m1 + else + m1 ^ " / " ^ m2 let m = "Error during Hashed list sanity check!" + let m1true_instead_of_false = "List_sig.Nodes were not decreasing, which was not detected" + let m1false_instead_of_true = "List_sig.Nodes are detected to be not increasing, although they are" + let m2true_instead_of_false = "Representation in memory is not unique, but it was not detected" + let m2false_instead_of_true = "Representation in memory is detected to be non unique, although it is" -let test handler (b1,b2) bdu = - let error, mvbdu_handler,(c1,c2) = - sanity_check - handler.Sanity_test_sig.allocate_uniquely_association_list - handler.Sanity_test_sig.error - handler.Sanity_test_sig.output - handler.Sanity_test_sig.mvbdu_handler - bdu +let test handler (b1, b2) bdu = + let error, mvbdu_handler, (c1, c2) = + sanity_check handler.Sanity_test_sig.allocate_uniquely_association_list + handler.Sanity_test_sig.error handler.Sanity_test_sig.output + handler.Sanity_test_sig.mvbdu_handler bdu in let handler = - {handler with - Sanity_test_sig.error = error; - Sanity_test_sig.mvbdu_handler=mvbdu_handler} + { handler with Sanity_test_sig.error; Sanity_test_sig.mvbdu_handler } in - if c1 = b1 && c2 = b2 - then - handler,true,None + if c1 = b1 && c2 = b2 then + handler, true, None else - handler, - false, - Some - (add_string - begin - if c1 - then (if not b1 then m1true_instead_of_false else "") - else (if b1 then m1false_instead_of_true else "") - end - begin - if c2 - then (if not b2 then m2true_instead_of_false else "") - else (if b2 then m2false_instead_of_true else "") - end - ) + ( handler, + false, + Some + (add_string + (if c1 then + if not b1 then + m1true_instead_of_false + else + "" + else if b1 then + m1false_instead_of_true + else + "") + (if c2 then + if not b2 then + m2true_instead_of_false + else + "" + else if b2 then + m2false_instead_of_true + else + "")) ) diff --git a/core/KaSa_rep/sanity_test/map_test.ml b/core/KaSa_rep/sanity_test/map_test.ml index cda7dfade2..74bee91c16 100644 --- a/core/KaSa_rep/sanity_test/map_test.ml +++ b/core/KaSa_rep/sanity_test/map_test.ml @@ -3,15 +3,18 @@ module LIntS = Map_wrapper.Make (IntS) module CharS = Mods.CharSetMap module LCharS = Map_wrapper.Make (CharS) +let p i j = i = j -let p i j = i=j let proj i = - if i mod 2 = 0 then 'a' - else 'b' -let monaproj _ b i = b,proj i -module P = SetMap.Proj(IntS)(CharS) -module LP = Map_wrapper.Proj(LIntS)(LCharS) + if i mod 2 = 0 then + 'a' + else + 'b' +let monaproj _ b i = b, proj i + +module P = SetMap.Proj (IntS) (CharS) +module LP = Map_wrapper.Proj (LIntS) (LCharS) let map_test remanent parameters = let error0 = remanent.Sanity_test_sig.error in @@ -20,54 +23,64 @@ let map_test remanent parameters = let f3 = IntS.Map.add 2 4 f2 in let f4 = IntS.Map.add 6 8 f3 in let f5 = IntS.Map.add 10 12 f4 in - let error1,f1' = LIntS.Map.add parameters error0 2 4 IntS.Map.empty in - let f2' = IntS.Map.add 3 5 f1' in - let error2,f3' = LIntS.Map.overwrite parameters error1 2 4 f2' in - let error3,f4' = LIntS.Map.add_or_overwrite parameters error2 6 8 f3' in - let error4,_ = LIntS.Map.add parameters error3 2 9 f4' in - let error5,f5' = LIntS.Map.overwrite parameters error3 10 12 f4' in - let f = List.fold_left - (fun map (a,b) -> IntS.Map.add a b map) + let error1, f1' = LIntS.Map.add parameters error0 2 4 IntS.Map.empty in + let f2' = IntS.Map.add 3 5 f1' in + let error2, f3' = LIntS.Map.overwrite parameters error1 2 4 f2' in + let error3, f4' = LIntS.Map.add_or_overwrite parameters error2 6 8 f3' in + let error4, _ = LIntS.Map.add parameters error3 2 9 f4' in + let error5, f5' = LIntS.Map.overwrite parameters error3 10 12 f4' in + let f = + List.fold_left + (fun map (a, b) -> IntS.Map.add a b map) IntS.Map.empty - [1,[2;3];2,[3;4];5,[6;7];8,[12;13]] + [ 1, [ 2; 3 ]; 2, [ 3; 4 ]; 5, [ 6; 7 ]; 8, [ 12; 13 ] ] + in + let g = P.proj_map proj [] List.append f in + let g' = + CharS.Map.map List.rev + (P.proj_map proj [] (fun x y -> List.append (List.rev y) x) f) + in + let error6, h = + LP.monadic_proj_map monaproj parameters error5 [] + (fun _ a l l' -> a, List.append l l') + f + in + let error7, h' = + LP.monadic_proj_map monaproj parameters error6 [] + (fun _ a x y -> a, List.append (List.rev y) x) + f + in + let h' = LCharS.Map.map List.rev h' in + let error8, i = + LP.proj_map proj parameters error7 [] (fun l l' -> List.append l l') f in - let g = P.proj_map proj [] (List.append) f in - let g' = CharS.Map.map List.rev (P.proj_map proj [] (fun x y -> List.append (List.rev y) x) f) in - let error6,h = LP.monadic_proj_map - monaproj - parameters - error5 [] - (fun _ a l l' -> a,List.append l l') + let error9, i' = + LP.proj_map proj parameters error8 [] + (fun x y -> List.append (List.rev y) x) f in - let error7,h' = LP.monadic_proj_map monaproj parameters error6 [] (fun _ a x y -> a,List.append (List.rev y) x) f in - let h' = LCharS.Map.map List.rev h' in - let error8,i = LP.proj_map - proj - parameters - error7 [] - (fun l l' -> List.append l l') - f in - let error9,i' = LP.proj_map proj parameters error8 [] (fun x y -> List.append (List.rev y) x) f in - let i' = LCharS.Map.map List.rev i' in - ["map1",(fun remanent -> remanent, IntS.Map.equal p f1 f1',None); - "map2",(fun remanent -> remanent, LIntS.Map.equal p f2 f2',None); - "map3",(fun remanent -> remanent, IntS.Map.equal p f3 f3',None); - "map4",(fun remanent -> remanent, IntS.Map.equal p f4 f4',None); - "map5",(fun remanent -> remanent, IntS.Map.equal p f5 f5',None); - "nowarn_add",(fun remanent -> remanent, error1==error0,None); - "nowarn_overwrite",(fun remanent -> remanent, error2==error1,None); - "nowarn_overwrite_or_add",(fun remanent -> remanent, error3== error2,None); - "warn_add",(fun remanent -> remanent, not (error4 == error3),None); - "warn_overwrite",(fun remanent -> remanent, not (error5 == error4),None); - "nowarn_proj1",(fun remanent -> remanent, error6==error5,None); - "nowarn_proj2",(fun remanent -> remanent, error7==error6,None); - "nowarn_proj3",(fun remanent -> remanent, error8==error7,None); - "nowarn_proj4",(fun remanent -> remanent, error8==error9,None); - "proj1",(fun remanent -> remanent, CharS.Map.equal p g g',None); - "proj2",(fun remanent -> remanent, CharS.Map.equal p g h,None); - "proj3",(fun remanent -> remanent, CharS.Map.equal p g h',None); - "proj4",(fun remanent -> remanent, CharS.Map.find_default [] 'a' g = [3;4;12;13],None); - "proj5",(fun remanent -> remanent, CharS.Map.equal p i i',None); - "proj6",(fun remanent -> remanent, CharS.Map.equal p i g,None); + let i' = LCharS.Map.map List.rev i' in + [ + ("map1", fun remanent -> remanent, IntS.Map.equal p f1 f1', None); + ("map2", fun remanent -> remanent, LIntS.Map.equal p f2 f2', None); + ("map3", fun remanent -> remanent, IntS.Map.equal p f3 f3', None); + ("map4", fun remanent -> remanent, IntS.Map.equal p f4 f4', None); + ("map5", fun remanent -> remanent, IntS.Map.equal p f5 f5', None); + ("nowarn_add", fun remanent -> remanent, error1 == error0, None); + ("nowarn_overwrite", fun remanent -> remanent, error2 == error1, None); + ("nowarn_overwrite_or_add", fun remanent -> remanent, error3 == error2, None); + ("warn_add", fun remanent -> remanent, not (error4 == error3), None); + ("warn_overwrite", fun remanent -> remanent, not (error5 == error4), None); + ("nowarn_proj1", fun remanent -> remanent, error6 == error5, None); + ("nowarn_proj2", fun remanent -> remanent, error7 == error6, None); + ("nowarn_proj3", fun remanent -> remanent, error8 == error7, None); + ("nowarn_proj4", fun remanent -> remanent, error8 == error9, None); + ("proj1", fun remanent -> remanent, CharS.Map.equal p g g', None); + ("proj2", fun remanent -> remanent, CharS.Map.equal p g h, None); + ("proj3", fun remanent -> remanent, CharS.Map.equal p g h', None); + ( "proj4", + fun remanent -> + remanent, CharS.Map.find_default [] 'a' g = [ 3; 4; 12; 13 ], None ); + ("proj5", fun remanent -> remanent, CharS.Map.equal p i i', None); + ("proj6", fun remanent -> remanent, CharS.Map.equal p i g, None); ] diff --git a/core/KaSa_rep/sanity_test/mvbdu_sanity.ml b/core/KaSa_rep/sanity_test/mvbdu_sanity.ml index 7250f7006c..4b4b718b63 100644 --- a/core/KaSa_rep/sanity_test/mvbdu_sanity.ml +++ b/core/KaSa_rep/sanity_test/mvbdu_sanity.ml @@ -12,240 +12,251 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -let rec safety_equal_mvbdu_working_list working_list mvbdu_x mvbdu_y = - match mvbdu_x.Mvbdu_sig.value, mvbdu_y.Mvbdu_sig.value with - | Mvbdu_sig.Leaf a, Mvbdu_sig.Leaf b when a = b -> - begin - match working_list with - | [] -> true - | (a,b) :: tail -> safety_equal_mvbdu_working_list tail a b - end - | Mvbdu_sig.Node x, Mvbdu_sig.Node y -> - x.Mvbdu_sig.variable = y.Mvbdu_sig.variable && - x.Mvbdu_sig.upper_bound = y.Mvbdu_sig.upper_bound && - safety_equal_mvbdu_working_list - ((x.Mvbdu_sig.branch_false, y.Mvbdu_sig.branch_false) :: working_list) - x.Mvbdu_sig.branch_true - y.Mvbdu_sig.branch_true - | Mvbdu_sig.Leaf _,_ | _,Mvbdu_sig.Leaf _ -> false +let rec safety_equal_mvbdu_working_list working_list mvbdu_x mvbdu_y = + match mvbdu_x.Mvbdu_sig.value, mvbdu_y.Mvbdu_sig.value with + | Mvbdu_sig.Leaf a, Mvbdu_sig.Leaf b when a = b -> + (match working_list with + | [] -> true + | (a, b) :: tail -> safety_equal_mvbdu_working_list tail a b) + | Mvbdu_sig.Node x, Mvbdu_sig.Node y -> + x.Mvbdu_sig.variable = y.Mvbdu_sig.variable + && x.Mvbdu_sig.upper_bound = y.Mvbdu_sig.upper_bound + && safety_equal_mvbdu_working_list + ((x.Mvbdu_sig.branch_false, y.Mvbdu_sig.branch_false) :: working_list) + x.Mvbdu_sig.branch_true y.Mvbdu_sig.branch_true + | Mvbdu_sig.Leaf _, _ | _, Mvbdu_sig.Leaf _ -> false let safety_equal_mvbdu a b = safety_equal_mvbdu_working_list [] a b -let rec safety_equal_list list_x list_y = - match list_x.List_sig.value, list_y.List_sig.value with - | List_sig.Empty, List_sig.Empty -> true - | List_sig.Cons x, List_sig.Cons y -> - x.List_sig.variable = y.List_sig.variable && - x.List_sig.association = y.List_sig.association && - safety_equal_list x.List_sig.tail y.List_sig.tail - | List_sig.Empty,_ | _,List_sig.Empty -> false +let rec safety_equal_list list_x list_y = + match list_x.List_sig.value, list_y.List_sig.value with + | List_sig.Empty, List_sig.Empty -> true + | List_sig.Cons x, List_sig.Cons y -> + x.List_sig.variable = y.List_sig.variable + && x.List_sig.association = y.List_sig.association + && safety_equal_list x.List_sig.tail y.List_sig.tail + | List_sig.Empty, _ | _, List_sig.Empty -> false let rec safety_compare_nodes_working_list working_list = - match working_list with [] -> 0 - | (Mvbdu_sig.Leaf a,Mvbdu_sig.Leaf b)::tail -> - let cmp1 = compare a b in - if cmp1=0 - then - safety_compare_nodes_working_list tail - else - cmp1 - | (Mvbdu_sig.Leaf _ , _)::_ -> 1 - | (_ , Mvbdu_sig.Leaf _)::_ -> -1 - | (Mvbdu_sig.Node x,Mvbdu_sig.Node y)::_ -> - let cmp2 = compare x.Mvbdu_sig.variable y.Mvbdu_sig.variable in - if cmp2=0 - then - begin - let cmp3 = compare x.Mvbdu_sig.upper_bound y.Mvbdu_sig.upper_bound in - if cmp3 = 0 - then - safety_compare_nodes_working_list - ((x.Mvbdu_sig.branch_true.Mvbdu_sig.value, - y.Mvbdu_sig.branch_false.Mvbdu_sig.value) :: - (x.Mvbdu_sig.branch_false.Mvbdu_sig.value, - y.Mvbdu_sig.branch_false.Mvbdu_sig.value) :: working_list) - else - cmp3 - end + match working_list with + | [] -> 0 + | (Mvbdu_sig.Leaf a, Mvbdu_sig.Leaf b) :: tail -> + let cmp1 = compare a b in + if cmp1 = 0 then + safety_compare_nodes_working_list tail + else + cmp1 + | (Mvbdu_sig.Leaf _, _) :: _ -> 1 + | (_, Mvbdu_sig.Leaf _) :: _ -> -1 + | (Mvbdu_sig.Node x, Mvbdu_sig.Node y) :: _ -> + let cmp2 = compare x.Mvbdu_sig.variable y.Mvbdu_sig.variable in + if cmp2 = 0 then ( + let cmp3 = compare x.Mvbdu_sig.upper_bound y.Mvbdu_sig.upper_bound in + if cmp3 = 0 then + safety_compare_nodes_working_list + (( x.Mvbdu_sig.branch_true.Mvbdu_sig.value, + y.Mvbdu_sig.branch_false.Mvbdu_sig.value ) + :: ( x.Mvbdu_sig.branch_false.Mvbdu_sig.value, + y.Mvbdu_sig.branch_false.Mvbdu_sig.value ) + :: working_list) else - cmp2 + cmp3 + ) else + cmp2 -let safety_compare_nodes a b = safety_compare_nodes_working_list - [a.Mvbdu_sig.value, b.Mvbdu_sig.value] +let safety_compare_nodes a b = + safety_compare_nodes_working_list [ a.Mvbdu_sig.value, b.Mvbdu_sig.value ] -let rec safety_check_maximal_sharing_working_list (allocate_uniquely:('a,'b,'c,'d,'e) Sanity_test_sig.f) error working_list handler = +let rec safety_check_maximal_sharing_working_list + (allocate_uniquely : ('a, 'b, 'c, 'd, 'e) Sanity_test_sig.f) error + working_list handler = match working_list with - | [] -> error,true,handler - | mvbdu::tail -> - (* check that mvbdu is uniquely represented in memory *) - let error,output = - try - allocate_uniquely - error - compare - (Mvbdu_core.get_skeleton mvbdu.Mvbdu_sig.value) - (mvbdu.Mvbdu_sig.value) - (fun key -> {Mvbdu_sig.id=key;Mvbdu_sig.value=mvbdu.Mvbdu_sig.value}) - handler - with - _ -> error,None - in - match output with - | None -> error,false,handler - | Some (_i, _asso, _asso_id, handler) -> - begin - match mvbdu.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> - safety_check_maximal_sharing_working_list - allocate_uniquely error tail handler - | Mvbdu_sig.Node x -> - safety_check_maximal_sharing_working_list - allocate_uniquely error - (x.Mvbdu_sig.branch_true::x.Mvbdu_sig.branch_false::tail) handler - end + | [] -> error, true, handler + | mvbdu :: tail -> + (* check that mvbdu is uniquely represented in memory *) + let error, output = + try + allocate_uniquely error compare + (Mvbdu_core.get_skeleton mvbdu.Mvbdu_sig.value) + mvbdu.Mvbdu_sig.value + (fun key -> + { Mvbdu_sig.id = key; Mvbdu_sig.value = mvbdu.Mvbdu_sig.value }) + handler + with _ -> error, None + in + (match output with + | None -> error, false, handler + | Some (_i, _asso, _asso_id, handler) -> + (match mvbdu.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> + safety_check_maximal_sharing_working_list allocate_uniquely error tail + handler + | Mvbdu_sig.Node x -> + safety_check_maximal_sharing_working_list allocate_uniquely error + (x.Mvbdu_sig.branch_true :: x.Mvbdu_sig.branch_false :: tail) + handler)) let safety_check_maximal_sharing - (allocate_uniquely:('a,'b,'c,'d,'e) Sanity_test_sig.f) error mvbdu = - safety_check_maximal_sharing_working_list allocate_uniquely error [mvbdu] + (allocate_uniquely : ('a, 'b, 'c, 'd, 'e) Sanity_test_sig.f) error mvbdu = + safety_check_maximal_sharing_working_list allocate_uniquely error [ mvbdu ] let rec safety_check_maximaly_compressed_working_list error working_list = match working_list with - | [] -> error, true - | head :: tail -> - begin - match head.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> safety_check_maximaly_compressed_working_list error tail - | Mvbdu_sig.Node x -> - (* check that mvbdu is maximally compressed *) - if x.Mvbdu_sig.branch_true == x.Mvbdu_sig.branch_false - (*sibbling should be different*) - then error, false - else - match x.Mvbdu_sig.branch_false.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> - safety_check_maximaly_compressed_working_list error tail - | Mvbdu_sig.Node y -> - if x.Mvbdu_sig.branch_true == y.Mvbdu_sig.branch_true - (*successive true_sibbling should be different*) - then error, false - else - safety_check_maximaly_compressed_working_list - error (x.Mvbdu_sig.branch_false :: x.Mvbdu_sig.branch_true::tail) - end + | [] -> error, true + | head :: tail -> + (match head.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> + safety_check_maximaly_compressed_working_list error tail + | Mvbdu_sig.Node x -> + (* check that mvbdu is maximally compressed *) + if + x.Mvbdu_sig.branch_true == x.Mvbdu_sig.branch_false + (*sibbling should be different*) + then + error, false + else ( + match x.Mvbdu_sig.branch_false.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> + safety_check_maximaly_compressed_working_list error tail + | Mvbdu_sig.Node y -> + if + x.Mvbdu_sig.branch_true == y.Mvbdu_sig.branch_true + (*successive true_sibbling should be different*) + then + error, false + else + safety_check_maximaly_compressed_working_list error + (x.Mvbdu_sig.branch_false :: x.Mvbdu_sig.branch_true :: tail) + )) let safety_check_maximaly_compressed error mvbdu = - safety_check_maximaly_compressed_working_list error [mvbdu] + safety_check_maximaly_compressed_working_list error [ mvbdu ] let rec safety_check_increasing_nodes_working_list error working_list = match working_list with - | [] -> error, true - | (mvbdu, bool, var, bound) :: tail -> - begin - match mvbdu.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> safety_check_increasing_nodes_working_list error tail - | Mvbdu_sig.Node x -> - let new_var = x.Mvbdu_sig.variable in - begin - match compare var new_var - with - | a when a<0 -> - safety_check_increasing_nodes_working_list error - ((x.Mvbdu_sig.branch_false, false, new_var,x.Mvbdu_sig.upper_bound):: - (x.Mvbdu_sig.branch_true, true, new_var,x.Mvbdu_sig.upper_bound):: - tail) - | a when a>0 -> error,false - | _ -> - if bool - then error, false - else - let new_bound = x.Mvbdu_sig.upper_bound in - if compare bound new_bound >= 0 - then error,false - else - safety_check_increasing_nodes_working_list error - ((x.Mvbdu_sig.branch_false,false,new_var,new_bound):: - (x.Mvbdu_sig.branch_true,true,new_var,new_bound)::tail) - end - end + | [] -> error, true + | (mvbdu, bool, var, bound) :: tail -> + (match mvbdu.Mvbdu_sig.value with + | Mvbdu_sig.Leaf _ -> safety_check_increasing_nodes_working_list error tail + | Mvbdu_sig.Node x -> + let new_var = x.Mvbdu_sig.variable in + (match compare var new_var with + | a when a < 0 -> + safety_check_increasing_nodes_working_list error + ((x.Mvbdu_sig.branch_false, false, new_var, x.Mvbdu_sig.upper_bound) + :: (x.Mvbdu_sig.branch_true, true, new_var, x.Mvbdu_sig.upper_bound) + :: tail) + | a when a > 0 -> error, false + | _ -> + if bool then + error, false + else ( + let new_bound = x.Mvbdu_sig.upper_bound in + if compare bound new_bound >= 0 then + error, false + else + safety_check_increasing_nodes_working_list error + ((x.Mvbdu_sig.branch_false, false, new_var, new_bound) + :: (x.Mvbdu_sig.branch_true, true, new_var, new_bound) + :: tail) + ))) let safety_check_increasing_nodes error mvbdu = match mvbdu.Mvbdu_sig.value with - | Mvbdu_sig.Leaf _ -> error,true - | Mvbdu_sig.Node x -> - let new_var = x.Mvbdu_sig.variable in - let new_bound = x.Mvbdu_sig.upper_bound in - safety_check_increasing_nodes_working_list - error - [x.Mvbdu_sig.branch_false, false, new_var,new_bound; - x.Mvbdu_sig.branch_true, true, new_var, new_bound] + | Mvbdu_sig.Leaf _ -> error, true + | Mvbdu_sig.Node x -> + let new_var = x.Mvbdu_sig.variable in + let new_bound = x.Mvbdu_sig.upper_bound in + safety_check_increasing_nodes_working_list error + [ + x.Mvbdu_sig.branch_false, false, new_var, new_bound; + x.Mvbdu_sig.branch_true, true, new_var, new_bound; + ] let print_flag log bool = - if bool - then Printf.fprintf log "Yes" - else Printf.fprintf log "No" - -let sanity_check - (allocate_uniquely:('a,'b,'c,'d,'e) Sanity_test_sig.f) error _log - handler mvbdu = - let error,bool1 = safety_check_increasing_nodes error mvbdu in - let error,bool2,dictionary = - safety_check_maximal_sharing allocate_uniquely error mvbdu handler in - let error,bool3 = safety_check_maximaly_compressed error mvbdu in - error,dictionary,(bool1,bool2,bool3) + if bool then + Printf.fprintf log "Yes" + else + Printf.fprintf log "No" + +let sanity_check (allocate_uniquely : ('a, 'b, 'c, 'd, 'e) Sanity_test_sig.f) + error _log handler mvbdu = + let error, bool1 = safety_check_increasing_nodes error mvbdu in + let error, bool2, dictionary = + safety_check_maximal_sharing allocate_uniquely error mvbdu handler + in + let error, bool3 = safety_check_maximaly_compressed error mvbdu in + error, dictionary, (bool1, bool2, bool3) let add_string m1 m2 = - if m1 = "" then m2 - else if m2 = "" then m1 - else m1^" / "^m2 + if m1 = "" then + m2 + else if m2 = "" then + m1 + else + m1 ^ " / " ^ m2 let m = "Error during MVBDU sanity check!" + let m1true_instead_of_false = "Mvbdu_sig.Nodes/bounds were not decreasing, which was not detected" + let m1false_instead_of_true = "Mvbdu_sig.Nodes/bounds are detected to be not increasing, although they are" + let m2true_instead_of_false = "Representation in memory is not unique, but it was not detected" + let m2false_instead_of_true = "Representation in memory is detected to be non unique, although it is" -let m3true_instead_of_false = "MVBDU is not maximally compressed, which was not detected" -let m3false_instead_of_true = "MVBDU is maximally compressed, which was not detected" - -let test handler (b1,b2,b3) bdu = - let error,mvbdu_handler,(c1,c2,c3) = - sanity_check - handler.Sanity_test_sig.allocate_uniquely_mvbdu - handler.Sanity_test_sig.error - handler.Sanity_test_sig.output - handler.Sanity_test_sig.mvbdu_handler - bdu + +let m3true_instead_of_false = + "MVBDU is not maximally compressed, which was not detected" + +let m3false_instead_of_true = + "MVBDU is maximally compressed, which was not detected" + +let test handler (b1, b2, b3) bdu = + let error, mvbdu_handler, (c1, c2, c3) = + sanity_check handler.Sanity_test_sig.allocate_uniquely_mvbdu + handler.Sanity_test_sig.error handler.Sanity_test_sig.output + handler.Sanity_test_sig.mvbdu_handler bdu in let handler = - {handler with - Sanity_test_sig.error = error; - Sanity_test_sig.mvbdu_handler=mvbdu_handler} + { handler with Sanity_test_sig.error; Sanity_test_sig.mvbdu_handler } in - if c1 = b1 && c2 = b2 && c3=b3 - then + if c1 = b1 && c2 = b2 && c3 = b3 then handler, true, None else - handler, - false, - Some - (add_string - begin - if c1 - then (if not b1 then m1true_instead_of_false else "") - else (if b1 then m1false_instead_of_true else "") - end - (add_string - begin - if c2 - then (if not b2 then m2true_instead_of_false else "") - else (if b2 then m2false_instead_of_true else "") - end - begin - if c3 - then (if not b3 then m3true_instead_of_false else "") - else (if b3 then m3false_instead_of_true else "") - end) - ) + ( handler, + false, + Some + (add_string + (if c1 then + if not b1 then + m1true_instead_of_false + else + "" + else if b1 then + m1false_instead_of_true + else + "") + (add_string + (if c2 then + if not b2 then + m2true_instead_of_false + else + "" + else if b2 then + m2false_instead_of_true + else + "") + (if c3 then + if not b3 then + m3true_instead_of_false + else + "" + else if b3 then + m3false_instead_of_true + else + ""))) ) diff --git a/core/KaSa_rep/sanity_test/mvbdu_test.ml b/core/KaSa_rep/sanity_test/mvbdu_test.ml index 544afdbcc6..c7c16bb51a 100644 --- a/core/KaSa_rep/sanity_test/mvbdu_test.ml +++ b/core/KaSa_rep/sanity_test/mvbdu_test.ml @@ -12,83 +12,56 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -let build_without_and_with_compressing (allocate:('a,'b,'c,'d,'e) Sanity_test_sig.f) - error handler bdu_skel bdu_val = +let build_without_and_with_compressing + (allocate : ('a, 'b, 'c, 'd, 'e) Sanity_test_sig.f) error handler bdu_skel + bdu_val = let error, output = - Mvbdu_core.build_already_compressed_cell - allocate - error - handler - bdu_skel + Mvbdu_core.build_already_compressed_cell allocate error handler bdu_skel bdu_val in let error, handler, a', a'_id = match output with - | None -> - error, - handler, - {Mvbdu_sig.id = (-1); Mvbdu_sig.value = bdu_val}, - -1 - | Some (a_id,_,a',handler) -> - error, - handler, - a', - a_id - in - let error,output = - Mvbdu_core.compress_node - allocate - error - handler - bdu_val + | None -> + error, handler, { Mvbdu_sig.id = -1; Mvbdu_sig.value = bdu_val }, -1 + | Some (a_id, _, a', handler) -> error, handler, a', a_id in + let error, output = Mvbdu_core.compress_node allocate error handler bdu_val in match output with - | None -> - error, - handler, - a', - a'_id, - {Mvbdu_sig.id = (-1); Mvbdu_sig.value = bdu_val}, - (-1) - | Some (a''_id,_,a'',handler) -> - error, + | None -> + ( error, handler, a', a'_id, - a'', - a''_id + { Mvbdu_sig.id = -1; Mvbdu_sig.value = bdu_val }, + -1 ) + | Some (a''_id, _, a'', handler) -> error, handler, a', a'_id, a'', a''_id let bdu_test remanent parameters = let error = remanent.Sanity_test_sig.error in let allocate = remanent.Sanity_test_sig.allocate_mvbdu in - let (handler:('b,'a,'c,'d,'e,bool,int) Memo_sig.handler) = + let (handler : ('b, 'a, 'c, 'd, 'e, bool, int) Memo_sig.handler) = remanent.Sanity_test_sig.mvbdu_handler in let a_val = Mvbdu_sig.Leaf true in let b_val = Mvbdu_sig.Leaf false in - let error,(handler:('b,'a,'c,'d,'e,bool,int) Memo_sig.handler),a',(a'_id:int),a'',_a''_id = - build_without_and_with_compressing - allocate - error - handler - a_val - a_val - in - let error,handler,b',b'_id,b'',_b''_id = - build_without_and_with_compressing - allocate - error - handler - b_val - b_val + let ( error, + (handler : ('b, 'a, 'c, 'd, 'e, bool, int) Memo_sig.handler), + a', + (a'_id : int), + a'', + _a''_id ) = + build_without_and_with_compressing allocate error handler a_val a_val + in + let error, handler, b', b'_id, b'', _b''_id = + build_without_and_with_compressing allocate error handler b_val b_val in let c = Mvbdu_sig.Node { - Mvbdu_sig.variable = 1 ; + Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'; Mvbdu_sig.branch_false = b'; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in let c_val = @@ -97,24 +70,19 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'_id; Mvbdu_sig.branch_false = b'_id; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in - let error,handler,c',c'_id,c'',_c''_id = - build_without_and_with_compressing - allocate - error - handler - c_val - c + let error, handler, c', c'_id, c'', _c''_id = + build_without_and_with_compressing allocate error handler c_val c in let d = Mvbdu_sig.Node { - Mvbdu_sig.variable = 1 ; + Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'; Mvbdu_sig.branch_false = b'; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in let d_val = @@ -123,16 +91,11 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'_id; Mvbdu_sig.branch_false = b'_id; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in - let error,handler,d',_d'_id,d'',_d''_id = - build_without_and_with_compressing - allocate - error - handler - d_val - d + let error, handler, d', _d'_id, d'', _d''_id = + build_without_and_with_compressing allocate error handler d_val d in let e = Mvbdu_sig.Node @@ -140,7 +103,7 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'; Mvbdu_sig.branch_false = a'; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in let e_val = @@ -149,16 +112,11 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'_id; Mvbdu_sig.branch_false = a'_id; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in - let error,handler,e',_e'_id,e'',_e''_id = - build_without_and_with_compressing - allocate - error - handler - e_val - e + let error, handler, e', _e'_id, e'', _e''_id = + build_without_and_with_compressing allocate error handler e_val e in let f = Mvbdu_sig.Node @@ -166,26 +124,21 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'; Mvbdu_sig.branch_false = c'; - Mvbdu_sig.upper_bound = 1 + Mvbdu_sig.upper_bound = 1; } - in + let f_val = Mvbdu_sig.Node { Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = a'_id; Mvbdu_sig.branch_false = c'_id; - Mvbdu_sig.upper_bound = 1 + Mvbdu_sig.upper_bound = 1; } in - let error,handler,f',_f'_id,f'',_f''_id = - build_without_and_with_compressing - allocate - error - handler - f_val - f + let error, handler, f', _f'_id, f'', _f''_id = + build_without_and_with_compressing allocate error handler f_val f in let g = Mvbdu_sig.Node @@ -193,7 +146,7 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 2; Mvbdu_sig.branch_true = b'; Mvbdu_sig.branch_false = c'; - Mvbdu_sig.upper_bound = 1 + Mvbdu_sig.upper_bound = 1; } in let g_val = @@ -202,16 +155,11 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 2; Mvbdu_sig.branch_true = b'_id; Mvbdu_sig.branch_false = c'_id; - Mvbdu_sig.upper_bound = 1 + Mvbdu_sig.upper_bound = 1; } in - let error,handler,g',_g'_id,g'',_g''_id = - build_without_and_with_compressing - allocate - error - handler - g_val - g + let error, handler, g', _g'_id, g'', _g''_id = + build_without_and_with_compressing allocate error handler g_val g in let h = Mvbdu_sig.Node @@ -219,26 +167,21 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = b'; Mvbdu_sig.branch_false = c'; - Mvbdu_sig.upper_bound = 3 + Mvbdu_sig.upper_bound = 3; } - in + let h_val = Mvbdu_sig.Node { Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = b'_id; Mvbdu_sig.branch_false = c'_id; - Mvbdu_sig.upper_bound = 3 + Mvbdu_sig.upper_bound = 3; } in - let error,handler,h',_h'_id,h'',_h''_id = - build_without_and_with_compressing - allocate - error - handler - h_val - h + let error, handler, h', _h'_id, h'', _h''_id = + build_without_and_with_compressing allocate error handler h_val h in let i = Mvbdu_sig.Node @@ -246,7 +189,7 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = b'; Mvbdu_sig.branch_false = c'; - Mvbdu_sig.upper_bound = 0 + Mvbdu_sig.upper_bound = 0; } in let i_val = @@ -255,16 +198,11 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = b'_id; Mvbdu_sig.branch_false = c'_id; - Mvbdu_sig.upper_bound = 0 + Mvbdu_sig.upper_bound = 0; } in - let error,handler,i',_i'_id,i'',_i''_id = - build_without_and_with_compressing - allocate - error - handler - i_val - i + let error, handler, i', _i'_id, i'', _i''_id = + build_without_and_with_compressing allocate error handler i_val i in let j = Mvbdu_sig.Node @@ -272,7 +210,7 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = b'; Mvbdu_sig.branch_false = c'; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in let j_val = @@ -281,16 +219,11 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = b'_id; Mvbdu_sig.branch_false = c'_id; - Mvbdu_sig.upper_bound = 2 + Mvbdu_sig.upper_bound = 2; } in - let error,handler,j',_j'_id,j'',_j''_id = - build_without_and_with_compressing - allocate - error - handler - j_val - j + let error, handler, j', _j'_id, j'', _j''_id = + build_without_and_with_compressing allocate error handler j_val j in let k = Mvbdu_sig.Node @@ -298,7 +231,7 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = c'; Mvbdu_sig.branch_false = b'; - Mvbdu_sig.upper_bound = 0 + Mvbdu_sig.upper_bound = 0; } in let k_val = @@ -307,22 +240,19 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.branch_true = c'_id; Mvbdu_sig.branch_false = b'_id; - Mvbdu_sig.upper_bound = 0 + Mvbdu_sig.upper_bound = 0; } in - let error,handler,k',_k'_id,k'',_k''_id = - build_without_and_with_compressing - allocate - error - handler - k_val - k + let error, handler, k', _k'_id, k'', _k''_id = + build_without_and_with_compressing allocate error handler k_val k in let copy bdu = - { bdu with Mvbdu_sig.value = - match bdu.Mvbdu_sig.value with - | Mvbdu_sig.Node x -> Mvbdu_sig.Node x - | Mvbdu_sig.Leaf a -> Mvbdu_sig.Leaf a + { + bdu with + Mvbdu_sig.value = + (match bdu.Mvbdu_sig.value with + | Mvbdu_sig.Node x -> Mvbdu_sig.Node x + | Mvbdu_sig.Leaf a -> Mvbdu_sig.Leaf a); } in let copy_c = copy c' in @@ -332,7 +262,7 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.upper_bound = 1; Mvbdu_sig.branch_true = b'; - Mvbdu_sig.branch_false = copy_c + Mvbdu_sig.branch_false = copy_c; } in let l_val = @@ -341,379 +271,467 @@ let bdu_test remanent parameters = Mvbdu_sig.variable = 1; Mvbdu_sig.upper_bound = 1; Mvbdu_sig.branch_true = b'_id; - Mvbdu_sig.branch_false = copy_c.Mvbdu_sig.id + Mvbdu_sig.branch_false = copy_c.Mvbdu_sig.id; } in let f x y = match x y with - | error,(handler,Some a) -> error,handler,a - | error,(handler,None) -> - let error, a = - Exception.warn parameters error __POS__ Exit a' in - error, handler, a + | error, (handler, Some a) -> error, handler, a + | error, (handler, None) -> + let error, a = Exception.warn parameters error __POS__ Exit a' in + error, handler, a in let error, handler, l', _l'_id, l'', _l''_id = - build_without_and_with_compressing - allocate - error - handler - l_val - l + build_without_and_with_compressing allocate error handler l_val l in let error, handler, bmvbdu_true0 = - f (Boolean_mvbdu.boolean_mvbdu_true parameters handler error) parameters in + f (Boolean_mvbdu.boolean_mvbdu_true parameters handler error) parameters + in let error, handler, bmvbdu_false0 = - f (Boolean_mvbdu.boolean_mvbdu_false parameters handler error) parameters in + f (Boolean_mvbdu.boolean_mvbdu_false parameters handler error) parameters + in let error, handler, bmvbdu_true1 = - f (Boolean_mvbdu.boolean_mvbdu_constant_true - parameters handler error parameters) + f + (Boolean_mvbdu.boolean_mvbdu_constant_true parameters handler error + parameters) bmvbdu_true0 in let error, handler, bmvbdu_true2 = - f (Boolean_mvbdu.boolean_mvbdu_constant_true - parameters handler error parameters) + f + (Boolean_mvbdu.boolean_mvbdu_constant_true parameters handler error + parameters) + bmvbdu_false0 + in + let error, handler, bmvbdu_false1 = + f + (Boolean_mvbdu.boolean_mvbdu_constant_false parameters handler error + parameters) + bmvbdu_true0 + in + let error, handler, bmvbdu_false2 = + f + (Boolean_mvbdu.boolean_mvbdu_constant_false parameters handler error + parameters) + bmvbdu_false0 + in + let error, handler, bmvbdu_false3 = + f + (Boolean_mvbdu.boolean_mvbdu_or parameters handler error parameters + bmvbdu_false0) + bmvbdu_false0 + in + let error, handler, bmvbdu_true3 = + f + (Boolean_mvbdu.boolean_mvbdu_or parameters handler error parameters + bmvbdu_false0) + bmvbdu_true0 + in + let error, handler, bmvbdu_true4 = + f + (Boolean_mvbdu.boolean_mvbdu_or parameters handler error parameters + bmvbdu_true0) + bmvbdu_true0 + in + let error, handler, bmvbdu_true5 = + f + (Boolean_mvbdu.boolean_mvbdu_or parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false1 = - f (Boolean_mvbdu.boolean_mvbdu_constant_false - parameters handler error parameters) + let error, handler, bmvbdu_false4 = + f + (Boolean_mvbdu.boolean_mvbdu_and parameters handler error parameters + bmvbdu_false0) + bmvbdu_false0 + in + let error, handler, bmvbdu_false5 = + f + (Boolean_mvbdu.boolean_mvbdu_and parameters handler error parameters + bmvbdu_false0) + bmvbdu_true0 + in + let error, handler, bmvbdu_true6 = + f + (Boolean_mvbdu.boolean_mvbdu_and parameters handler error parameters + bmvbdu_true0) + bmvbdu_true0 + in + let error, handler, bmvbdu_false6 = + f + (Boolean_mvbdu.boolean_mvbdu_and parameters handler error parameters + bmvbdu_true0) + bmvbdu_false0 + in + let error, handler, bmvbdu_false7 = + f + (Boolean_mvbdu.boolean_mvbdu_xor parameters handler error parameters + bmvbdu_false0) + bmvbdu_false0 + in + let error, handler, bmvbdu_true7 = + f + (Boolean_mvbdu.boolean_mvbdu_xor parameters handler error parameters + bmvbdu_false0) + bmvbdu_true0 + in + let error, handler, bmvbdu_false8 = + f + (Boolean_mvbdu.boolean_mvbdu_xor parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_false2 = - f (Boolean_mvbdu.boolean_mvbdu_constant_false - parameters handler error parameters) + let error, handler, bmvbdu_true8 = + f + (Boolean_mvbdu.boolean_mvbdu_xor parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false3 = - f (Boolean_mvbdu.boolean_mvbdu_or - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true9 = + f + (Boolean_mvbdu.boolean_mvbdu_nand parameters handler error parameters + bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true3 = - f (Boolean_mvbdu.boolean_mvbdu_or - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true10 = + f + (Boolean_mvbdu.boolean_mvbdu_nand parameters handler error parameters + bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_true4 = - f (Boolean_mvbdu.boolean_mvbdu_or - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_false9 = + f + (Boolean_mvbdu.boolean_mvbdu_nand parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_true5 = - f (Boolean_mvbdu.boolean_mvbdu_or - parameters handler error parameters bmvbdu_true0) + let error, (handler : Boolean_mvbdu.handler), bmvbdu_true11 = + f + (Boolean_mvbdu.boolean_mvbdu_nand parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false4 = - f (Boolean_mvbdu.boolean_mvbdu_and - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true12 = + f + (Boolean_mvbdu.boolean_mvbdu_nsnd parameters handler error parameters + bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_false5 = - f (Boolean_mvbdu.boolean_mvbdu_and - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_false10 = + f + (Boolean_mvbdu.boolean_mvbdu_nsnd parameters handler error parameters + bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_true6 = - f (Boolean_mvbdu.boolean_mvbdu_and - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_false11 = + f + (Boolean_mvbdu.boolean_mvbdu_nsnd parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_false6 = - f (Boolean_mvbdu.boolean_mvbdu_and - parameters handler error parameters bmvbdu_true0) + let error, (handler : Boolean_mvbdu.handler), bmvbdu_true13 = + f + (Boolean_mvbdu.boolean_mvbdu_nsnd parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false7 = - f (Boolean_mvbdu.boolean_mvbdu_xor - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true14 = + f + (Boolean_mvbdu.boolean_mvbdu_nfst parameters handler error parameters + bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true7 = - f (Boolean_mvbdu.boolean_mvbdu_xor - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true15 = + f + (Boolean_mvbdu.boolean_mvbdu_nfst parameters handler error parameters + bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false8 = - f (Boolean_mvbdu.boolean_mvbdu_xor - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_false12 = + f + (Boolean_mvbdu.boolean_mvbdu_nfst parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_true8 = - f (Boolean_mvbdu.boolean_mvbdu_xor - parameters handler error parameters bmvbdu_true0) + let error, (handler : Boolean_mvbdu.handler), bmvbdu_false13 = + f + (Boolean_mvbdu.boolean_mvbdu_nfst parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true9 = - f (Boolean_mvbdu.boolean_mvbdu_nand - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_false14 = + f + (Boolean_mvbdu.boolean_mvbdu_snd parameters handler error parameters + bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true10 = - f (Boolean_mvbdu.boolean_mvbdu_nand - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true16 = + f + (Boolean_mvbdu.boolean_mvbdu_snd parameters handler error parameters + bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false9 = - f (Boolean_mvbdu.boolean_mvbdu_nand - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_true17 = + f + (Boolean_mvbdu.boolean_mvbdu_snd parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,(handler:Boolean_mvbdu.handler),bmvbdu_true11 = - f (Boolean_mvbdu.boolean_mvbdu_nand - parameters handler error parameters bmvbdu_true0) + let error, (handler : Boolean_mvbdu.handler), bmvbdu_false15 = + f + (Boolean_mvbdu.boolean_mvbdu_snd parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true12 = - f (Boolean_mvbdu.boolean_mvbdu_nsnd - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_false16 = + f + (Boolean_mvbdu.boolean_mvbdu_fst parameters handler error parameters + bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_false10 = - f (Boolean_mvbdu.boolean_mvbdu_nsnd - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_false17 = + f + (Boolean_mvbdu.boolean_mvbdu_fst parameters handler error parameters + bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false11 = - f (Boolean_mvbdu.boolean_mvbdu_nsnd - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_true18 = + f + (Boolean_mvbdu.boolean_mvbdu_fst parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,(handler:Boolean_mvbdu.handler),bmvbdu_true13 = - f (Boolean_mvbdu.boolean_mvbdu_nsnd - parameters handler error parameters bmvbdu_true0) + let error, (handler : Boolean_mvbdu.handler), bmvbdu_true19 = + f + (Boolean_mvbdu.boolean_mvbdu_fst parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true14 = - f (Boolean_mvbdu.boolean_mvbdu_nfst - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true20 = + f + (Boolean_mvbdu.boolean_mvbdu_nor parameters handler error parameters + bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true15 = - f (Boolean_mvbdu.boolean_mvbdu_nfst - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_false18 = + f + (Boolean_mvbdu.boolean_mvbdu_nor parameters handler error parameters + bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false12 = - f (Boolean_mvbdu.boolean_mvbdu_nfst - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_false19 = + f + (Boolean_mvbdu.boolean_mvbdu_nor parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,(handler:Boolean_mvbdu.handler),bmvbdu_false13 = - f (Boolean_mvbdu.boolean_mvbdu_nfst - parameters handler error parameters bmvbdu_true0) + let error, (handler : Boolean_mvbdu.handler), bmvbdu_false20 = + f + (Boolean_mvbdu.boolean_mvbdu_nor parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false14 = - f (Boolean_mvbdu.boolean_mvbdu_snd - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_false21 = + f + (Boolean_mvbdu.boolean_constant_bi_false parameters handler error + parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true16 = - f (Boolean_mvbdu.boolean_mvbdu_snd - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_false22 = + f + (Boolean_mvbdu.boolean_constant_bi_false parameters handler error + parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_true17 = - f (Boolean_mvbdu.boolean_mvbdu_snd - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_false23 = + f + (Boolean_mvbdu.boolean_constant_bi_false parameters handler error + parameters bmvbdu_true0) bmvbdu_true0 in - let error,(handler:Boolean_mvbdu.handler),bmvbdu_false15 = - f (Boolean_mvbdu.boolean_mvbdu_snd - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_false24 = + f + (Boolean_mvbdu.boolean_constant_bi_false parameters handler error + parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false16 = - f (Boolean_mvbdu.boolean_mvbdu_fst - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true21 = + f + (Boolean_mvbdu.boolean_constant_bi_true parameters handler error + parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_false17 = - f (Boolean_mvbdu.boolean_mvbdu_fst - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true22 = + f + (Boolean_mvbdu.boolean_constant_bi_true parameters handler error + parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_true18 = - f (Boolean_mvbdu.boolean_mvbdu_fst - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_true23 = + f + (Boolean_mvbdu.boolean_constant_bi_true parameters handler error + parameters bmvbdu_true0) bmvbdu_true0 in - let error,(handler:Boolean_mvbdu.handler),bmvbdu_true19 = - f (Boolean_mvbdu.boolean_mvbdu_fst - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_true24 = + f + (Boolean_mvbdu.boolean_constant_bi_true parameters handler error + parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true20 = - f (Boolean_mvbdu.boolean_mvbdu_nor - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true25 = + f + (Boolean_mvbdu.boolean_mvbdu_imply parameters handler error parameters + bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_false18 = - f (Boolean_mvbdu.boolean_mvbdu_nor - parameters handler error parameters bmvbdu_false0) + let error, handler, bmvbdu_true26 = + f + (Boolean_mvbdu.boolean_mvbdu_imply parameters handler error parameters + bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false19 = - f (Boolean_mvbdu.boolean_mvbdu_nor - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_true27 = + f + (Boolean_mvbdu.boolean_mvbdu_imply parameters handler error parameters + bmvbdu_true0) bmvbdu_true0 in - let error,(handler:Boolean_mvbdu.handler),bmvbdu_false20 = - f (Boolean_mvbdu.boolean_mvbdu_nor - parameters handler error parameters bmvbdu_true0) + let error, handler, bmvbdu_false25 = + f + (Boolean_mvbdu.boolean_mvbdu_imply parameters handler error parameters + bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false21 = - f (Boolean_mvbdu.boolean_constant_bi_false - parameters handler error parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_false22 = - f (Boolean_mvbdu.boolean_constant_bi_false - parameters handler error parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false23 = - f (Boolean_mvbdu.boolean_constant_bi_false - parameters handler error parameters bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_false24 = - f (Boolean_mvbdu.boolean_constant_bi_false - parameters handler error parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true21 = - f (Boolean_mvbdu.boolean_constant_bi_true - parameters handler error parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true22 = - f (Boolean_mvbdu.boolean_constant_bi_true - parameters handler error parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_true23 = - f (Boolean_mvbdu.boolean_constant_bi_true - parameters handler error parameters bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_true24 = - f (Boolean_mvbdu.boolean_constant_bi_true - parameters handler error parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true25 = - f (Boolean_mvbdu.boolean_mvbdu_imply - parameters handler error parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true26 = - f (Boolean_mvbdu.boolean_mvbdu_imply - parameters handler error parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_true27 = - f (Boolean_mvbdu.boolean_mvbdu_imply - parameters handler error parameters bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_false25 = - f (Boolean_mvbdu.boolean_mvbdu_imply - parameters handler error parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true28 = - f (Boolean_mvbdu.boolean_mvbdu_is_implied - parameters handler error parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_false26 = - f (Boolean_mvbdu.boolean_mvbdu_is_implied - parameters handler error parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_true29 = - f (Boolean_mvbdu.boolean_mvbdu_is_implied - parameters handler error parameters bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_true30 = - f (Boolean_mvbdu.boolean_mvbdu_is_implied - parameters handler error parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false27 = - f (Boolean_mvbdu.boolean_mvbdu_nimply - parameters handler error parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_false28 = - f (Boolean_mvbdu.boolean_mvbdu_nimply - parameters handler error parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false29 = - f (Boolean_mvbdu.boolean_mvbdu_nimply - parameters handler error parameters bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_true31 = - f (Boolean_mvbdu.boolean_mvbdu_nimply - parameters handler error parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_false30 = - f (Boolean_mvbdu.boolean_mvbdu_nis_implied - parameters handler error parameters bmvbdu_false0) bmvbdu_false0 in - let error,handler,bmvbdu_true32 = - f (Boolean_mvbdu.boolean_mvbdu_nis_implied - parameters handler error parameters bmvbdu_false0) bmvbdu_true0 in - let error,handler,bmvbdu_false31 = - f (Boolean_mvbdu.boolean_mvbdu_nis_implied - parameters handler error parameters bmvbdu_true0) bmvbdu_true0 in - let error,handler,bmvbdu_false32 = - f (Boolean_mvbdu.boolean_mvbdu_nis_implied - parameters handler error parameters bmvbdu_true0) bmvbdu_false0 in - let error,handler,bmvbdu_true33 = - f (Boolean_mvbdu.clean_head parameters error handler) e' in - let list = [4,1; 2,2; 1,3] in - let list' = [2,2; 4,1; 1,3] in - let error,(handler,list_a) = + let error, handler, bmvbdu_true28 = + f + (Boolean_mvbdu.boolean_mvbdu_is_implied parameters handler error + parameters bmvbdu_false0) + bmvbdu_false0 + in + let error, handler, bmvbdu_false26 = + f + (Boolean_mvbdu.boolean_mvbdu_is_implied parameters handler error + parameters bmvbdu_false0) + bmvbdu_true0 + in + let error, handler, bmvbdu_true29 = + f + (Boolean_mvbdu.boolean_mvbdu_is_implied parameters handler error + parameters bmvbdu_true0) + bmvbdu_true0 + in + let error, handler, bmvbdu_true30 = + f + (Boolean_mvbdu.boolean_mvbdu_is_implied parameters handler error + parameters bmvbdu_true0) + bmvbdu_false0 + in + let error, handler, bmvbdu_false27 = + f + (Boolean_mvbdu.boolean_mvbdu_nimply parameters handler error parameters + bmvbdu_false0) + bmvbdu_false0 + in + let error, handler, bmvbdu_false28 = + f + (Boolean_mvbdu.boolean_mvbdu_nimply parameters handler error parameters + bmvbdu_false0) + bmvbdu_true0 + in + let error, handler, bmvbdu_false29 = + f + (Boolean_mvbdu.boolean_mvbdu_nimply parameters handler error parameters + bmvbdu_true0) + bmvbdu_true0 + in + let error, handler, bmvbdu_true31 = + f + (Boolean_mvbdu.boolean_mvbdu_nimply parameters handler error parameters + bmvbdu_true0) + bmvbdu_false0 + in + let error, handler, bmvbdu_false30 = + f + (Boolean_mvbdu.boolean_mvbdu_nis_implied parameters handler error + parameters bmvbdu_false0) + bmvbdu_false0 + in + let error, handler, bmvbdu_true32 = + f + (Boolean_mvbdu.boolean_mvbdu_nis_implied parameters handler error + parameters bmvbdu_false0) + bmvbdu_true0 + in + let error, handler, bmvbdu_false31 = + f + (Boolean_mvbdu.boolean_mvbdu_nis_implied parameters handler error + parameters bmvbdu_true0) + bmvbdu_true0 + in + let error, handler, bmvbdu_false32 = + f + (Boolean_mvbdu.boolean_mvbdu_nis_implied parameters handler error + parameters bmvbdu_true0) + bmvbdu_false0 + in + let error, handler, bmvbdu_true33 = + f (Boolean_mvbdu.clean_head parameters error handler) e' + in + let list = [ 4, 1; 2, 2; 1, 3 ] in + let list' = [ 2, 2; 4, 1; 1, 3 ] in + let error, (handler, list_a) = List_algebra.build_list (Boolean_mvbdu.association_list_allocate parameters) - error - parameters - handler - list + error parameters handler list in - let error,(handler,list_b) = + let error, (handler, list_b) = List_algebra.build_sorted_list (Boolean_mvbdu.association_list_allocate parameters) - parameters - error - handler - list + parameters error handler list in - let error,(handler,list_c) = + let error, (handler, list_c) = List_algebra.build_reversed_sorted_list (Boolean_mvbdu.association_list_allocate parameters) - parameters - error - handler - list + parameters error handler list in - let error,(handler,list_a') = + let error, (handler, list_a') = List_algebra.build_list (Boolean_mvbdu.association_list_allocate parameters) - error - parameters - handler - list' + error parameters handler list' in - let error,(handler,list_b') = + let error, (handler, list_b') = List_algebra.build_sorted_list (Boolean_mvbdu.association_list_allocate parameters) - parameters - error - handler - list' + parameters error handler list' in - let error,(handler,list_c') = + let error, (handler, list_c') = List_algebra.build_reversed_sorted_list (Boolean_mvbdu.association_list_allocate parameters) - parameters - error - handler - list' + parameters error handler list' + in + let error, handler, mvbdu = + f (Boolean_mvbdu.redefine parameters error parameters handler l') list_a + in + let error, handler, l''' = + f (Boolean_mvbdu.clean_head parameters error handler) l'' in - let error,handler,mvbdu = - f (Boolean_mvbdu.redefine parameters error parameters handler l') list_a in - let error,handler,l''' = - f (Boolean_mvbdu.clean_head parameters error handler) l'' in let error = Boolean_mvbdu.print_boolean_mvbdu (Remanent_parameters.update_prefix parameters "l': ") - error - l'' + error l'' in let error = Boolean_mvbdu.print_boolean_mvbdu (Remanent_parameters.update_prefix parameters "l'': ") - error - l''' + error l''' in let error = Boolean_mvbdu.print_boolean_mvbdu (Remanent_parameters.update_prefix parameters "mvbdu:") - error - mvbdu + error mvbdu in let error = - Boolean_mvbdu.print_memo - error - handler + Boolean_mvbdu.print_memo error handler (Remanent_parameters.update_prefix parameters "Memoization tables:") in let handler_0 = handler in @@ -723,856 +741,1608 @@ let bdu_test remanent parameters = let error', _handler = Mvbdu_wrapper.Mvbdu.init parameters error in let b1 = Mvbdu_wrapper.Mvbdu.is_init () in let error'', _handler = Mvbdu_wrapper.Mvbdu.init parameters error' in - let b2,b3 = error==error',error'==error'' in + let b2, b3 = error == error', error' == error'' in let error = error'' in - let error,handler,bmvbdu_true0' = Mvbdu_wrapper.Mvbdu.mvbdu_true parameters handler error in - let error, handler, bmvbdu_false0' = Mvbdu_wrapper.Mvbdu.mvbdu_false parameters handler error in - let error, handler, bmvbdu_true1' = Mvbdu_wrapper.Mvbdu.mvbdu_unary_true parameters handler error bmvbdu_true0' in - let error, handler, bmvbdu_true2' = Mvbdu_wrapper.Mvbdu.mvbdu_unary_true parameters handler error bmvbdu_false0' in - let error,handler,bmvbdu_false1' = Mvbdu_wrapper.Mvbdu.mvbdu_unary_false parameters handler error bmvbdu_true0' in - let error,handler,bmvbdu_false2' = Mvbdu_wrapper.Mvbdu.mvbdu_unary_false parameters handler error bmvbdu_false0' in - let error,handler,bmvbdu_false3' = Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true3' = Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_true4' = Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true5' = Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_false4' = Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_false5' = Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_true6' = Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_false6' = Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_false7' = Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true7' = Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false8' = Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true8' = Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_true9' = Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true10' = Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false9' = Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true11' = Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_true12' = Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_false10' = Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false11' = Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true13' = Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_true14' = Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true15' = Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false12' = Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_false13' = Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_false14' = Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true16' = Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_true17' = Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_false15' = Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_false16' = Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_false17' = Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_true18' = Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true19' = Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_true20' = Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_false18' = Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false19' = Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_false20' = Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_false21' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_false22' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false23' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_false24' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_true21' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true22' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_true23' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true24' = Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_true25' = Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true26' = Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_true27' = Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_false25' = Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_true28' = Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_false26' = Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_true29' = Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true30' = Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_false27' = Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_false28' = Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false29' = Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_true31' = Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_true0' bmvbdu_false0' in - let error,handler,bmvbdu_false30' = Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_false0' bmvbdu_false0' in - let error,handler,bmvbdu_true32' = Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_false0' bmvbdu_true0' in - let error,handler,bmvbdu_false31' = Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_true0' bmvbdu_true0' in - let error,handler,bmvbdu_false32' = Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_true0' bmvbdu_false0' in - let list = [4,1; 2,2; 1,3] in - let list' = [2,2; 4,1; 1,3] in - let error,handler,list__a = Mvbdu_wrapper.Mvbdu.build_association_list parameters handler error list in - let error,handler,list__c = Mvbdu_wrapper.Mvbdu.build_reverse_sorted_association_list parameters handler error list in - let error,handler,list__a' =Mvbdu_wrapper.Mvbdu.build_association_list parameters handler error list' in - let error,handler,_list__b' = Mvbdu_wrapper.Mvbdu.build_sorted_association_list parameters handler error list' in - let error,_handler,_mvbdu = Mvbdu_wrapper.Mvbdu.mvbdu_redefine parameters handler error bmvbdu_true0' list__a in + let error, handler, bmvbdu_true0' = + Mvbdu_wrapper.Mvbdu.mvbdu_true parameters handler error + in + let error, handler, bmvbdu_false0' = + Mvbdu_wrapper.Mvbdu.mvbdu_false parameters handler error + in + let error, handler, bmvbdu_true1' = + Mvbdu_wrapper.Mvbdu.mvbdu_unary_true parameters handler error bmvbdu_true0' + in + let error, handler, bmvbdu_true2' = + Mvbdu_wrapper.Mvbdu.mvbdu_unary_true parameters handler error bmvbdu_false0' + in + let error, handler, bmvbdu_false1' = + Mvbdu_wrapper.Mvbdu.mvbdu_unary_false parameters handler error bmvbdu_true0' + in + let error, handler, bmvbdu_false2' = + Mvbdu_wrapper.Mvbdu.mvbdu_unary_false parameters handler error + bmvbdu_false0' + in + let error, handler, bmvbdu_false3' = + Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true3' = + Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true4' = + Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true5' = + Mvbdu_wrapper.Mvbdu.mvbdu_or parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false4' = + Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false5' = + Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true6' = + Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false6' = + Mvbdu_wrapper.Mvbdu.mvbdu_and parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false7' = + Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true7' = + Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false8' = + Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true8' = + Mvbdu_wrapper.Mvbdu.mvbdu_xor parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true9' = + Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true10' = + Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false9' = + Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true11' = + Mvbdu_wrapper.Mvbdu.mvbdu_nand parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true12' = + Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false10' = + Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false11' = + Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true13' = + Mvbdu_wrapper.Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true14' = + Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true15' = + Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false12' = + Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false13' = + Mvbdu_wrapper.Mvbdu.mvbdu_nfst parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false14' = + Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true16' = + Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true17' = + Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false15' = + Mvbdu_wrapper.Mvbdu.mvbdu_snd parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false16' = + Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false17' = + Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true18' = + Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true19' = + Mvbdu_wrapper.Mvbdu.mvbdu_fst parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true20' = + Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false18' = + Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false19' = + Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false20' = + Mvbdu_wrapper.Mvbdu.mvbdu_nor parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false21' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false22' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false23' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false24' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true21' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true22' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true23' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true24' = + Mvbdu_wrapper.Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true25' = + Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true26' = + Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true27' = + Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false25' = + Mvbdu_wrapper.Mvbdu.mvbdu_imply parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true28' = + Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false26' = + Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true29' = + Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true30' = + Mvbdu_wrapper.Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false27' = + Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false28' = + Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false29' = + Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_true31' = + Mvbdu_wrapper.Mvbdu.mvbdu_nimply parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let error, handler, bmvbdu_false30' = + Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_false0' + bmvbdu_false0' + in + let error, handler, bmvbdu_true32' = + Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_false0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false31' = + Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_true0' + bmvbdu_true0' + in + let error, handler, bmvbdu_false32' = + Mvbdu_wrapper.Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_true0' + bmvbdu_false0' + in + let list = [ 4, 1; 2, 2; 1, 3 ] in + let list' = [ 2, 2; 4, 1; 1, 3 ] in + let error, handler, list__a = + Mvbdu_wrapper.Mvbdu.build_association_list parameters handler error list + in + let error, handler, list__c = + Mvbdu_wrapper.Mvbdu.build_reverse_sorted_association_list parameters handler + error list + in + let error, handler, list__a' = + Mvbdu_wrapper.Mvbdu.build_association_list parameters handler error list' + in + let error, handler, _list__b' = + Mvbdu_wrapper.Mvbdu.build_sorted_association_list parameters handler error + list' + in + let error, _handler, _mvbdu = + Mvbdu_wrapper.Mvbdu.mvbdu_redefine parameters handler error bmvbdu_true0' + list__a + in - (* WRAPPED MVBDU OPTIMIZED *) + (* WRAPPED MVBDU OPTIMIZED *) let b0' = Mvbdu_wrapper.Optimized_Mvbdu.is_init () in let error_', _handler = Mvbdu_wrapper.Optimized_Mvbdu.init parameters error in let b1' = Mvbdu_wrapper.Optimized_Mvbdu.is_init () in - let error_'',handler = Mvbdu_wrapper.Optimized_Mvbdu.init parameters error_' in - let b2',b3' = error==error_',error_'==error_'' in + let error_'', handler = + Mvbdu_wrapper.Optimized_Mvbdu.init parameters error_' + in + let b2', b3' = error == error_', error_' == error_'' in let error = error_'' in - let error,handler,bmvbdu_true0'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_true parameters handler error in - let error, handler, bmvbdu_false0'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_false parameters handler error in - let error, handler, bmvbdu_true1'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_true parameters handler error bmvbdu_true0'' in - let error, handler, bmvbdu_true2'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_true parameters handler error bmvbdu_false0'' in - let error,handler,bmvbdu_false1'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_false parameters handler error bmvbdu_true0'' in - let error,handler,bmvbdu_false2'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_false parameters handler error bmvbdu_false0'' in - let error,handler,bmvbdu_false3'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true3'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true4'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true5'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false4'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false5'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true6'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false6'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false7'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true7'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false8'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true8'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true9'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true10'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false9'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true11'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true12'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false10'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false11'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true13'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true14'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true15'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false12'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false13'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false14'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true16'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true17'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false15'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false16'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false17'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true18'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true19'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true20'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false18'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false19'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false20'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false21'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false22'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false23'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false24'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true21'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true22'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true23'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true24'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true25'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true26'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true27'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false25'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true28'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false26'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true29'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true30'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false27'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false28'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false29'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_true31'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let error,handler,bmvbdu_false30'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_false0'' bmvbdu_false0'' in - let error,handler,bmvbdu_true32'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_false0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false31'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_true0'' bmvbdu_true0'' in - let error,handler,bmvbdu_false32'' = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error bmvbdu_true0'' bmvbdu_false0'' in - let list = [4,1; 2,2; 1,3] in - let list' = [2,2; 4,1; 1,3] in - let error,handler,list___a = Mvbdu_wrapper.Optimized_Mvbdu.build_association_list parameters handler error list in - let error,handler,_list___b = Mvbdu_wrapper.Optimized_Mvbdu.build_sorted_association_list parameters handler error list in - let error,handler,list___c = Mvbdu_wrapper.Optimized_Mvbdu.build_reverse_sorted_association_list parameters handler error list in - let error,handler,list___a' =Mvbdu_wrapper.Optimized_Mvbdu.build_association_list parameters handler error list' in - let error,handler,_list___b' =Mvbdu_wrapper.Optimized_Mvbdu.build_sorted_association_list parameters handler error list' in - let error,handler,_list___c' = Mvbdu_wrapper.Optimized_Mvbdu.build_reverse_sorted_association_list parameters handler error list' in - let error,_handler,_mvbdu = Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_redefine parameters handler error bmvbdu_true0'' list___a in + let error, handler, bmvbdu_true0'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_true parameters handler error + in + let error, handler, bmvbdu_false0'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_false parameters handler error + in + let error, handler, bmvbdu_true1'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_true parameters handler error + bmvbdu_true0'' + in + let error, handler, bmvbdu_true2'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_true parameters handler error + bmvbdu_false0'' + in + let error, handler, bmvbdu_false1'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_false parameters handler error + bmvbdu_true0'' + in + let error, handler, bmvbdu_false2'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_unary_false parameters handler error + bmvbdu_false0'' + in + let error, handler, bmvbdu_false3'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true3'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true4'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true5'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_or parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false4'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false5'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true6'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false6'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_and parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false7'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true7'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false8'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true8'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_xor parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true9'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true10'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false9'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true11'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nand parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true12'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false10'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false11'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true13'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nsnd parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true14'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true15'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false12'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false13'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nfst parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false14'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true16'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true17'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false15'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_snd parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false16'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false17'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true18'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true19'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_fst parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true20'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false18'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false19'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false20'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nor parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false21'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false22'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false23'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false24'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_false parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true21'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true22'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true23'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true24'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_bi_true parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true25'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true26'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true27'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false25'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_imply parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true28'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false26'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true29'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true30'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_rev_imply parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false27'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false28'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false29'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_true31'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nimply parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_false30'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error + bmvbdu_false0'' bmvbdu_false0'' + in + let error, handler, bmvbdu_true32'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error + bmvbdu_false0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false31'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error + bmvbdu_true0'' bmvbdu_true0'' + in + let error, handler, bmvbdu_false32'' = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_nrev_imply parameters handler error + bmvbdu_true0'' bmvbdu_false0'' + in + let list = [ 4, 1; 2, 2; 1, 3 ] in + let list' = [ 2, 2; 4, 1; 1, 3 ] in + let error, handler, list___a = + Mvbdu_wrapper.Optimized_Mvbdu.build_association_list parameters handler + error list + in + let error, handler, _list___b = + Mvbdu_wrapper.Optimized_Mvbdu.build_sorted_association_list parameters + handler error list + in + let error, handler, list___c = + Mvbdu_wrapper.Optimized_Mvbdu.build_reverse_sorted_association_list + parameters handler error list + in + let error, handler, list___a' = + Mvbdu_wrapper.Optimized_Mvbdu.build_association_list parameters handler + error list' + in + let error, handler, _list___b' = + Mvbdu_wrapper.Optimized_Mvbdu.build_sorted_association_list parameters + handler error list' + in + let error, handler, _list___c' = + Mvbdu_wrapper.Optimized_Mvbdu.build_reverse_sorted_association_list + parameters handler error list' + in + let error, _handler, _mvbdu = + Mvbdu_wrapper.Optimized_Mvbdu.mvbdu_redefine parameters handler error + bmvbdu_true0'' list___a + in - (* WRAPPED MVBDU INTERNALIZED *) + (* WRAPPED MVBDU INTERNALIZED *) let b0'' = Mvbdu_wrapper.IntMvbdu.is_init () in let () = Mvbdu_wrapper.IntMvbdu.init parameters in let b1'' = Mvbdu_wrapper.IntMvbdu.is_init () in let () = Mvbdu_wrapper.IntMvbdu.init parameters in let bmvbdu_true0''' = Mvbdu_wrapper.IntMvbdu.mvbdu_true () in let bmvbdu_false0''' = Mvbdu_wrapper.IntMvbdu.mvbdu_false () in - let bmvbdu_true1''' = Mvbdu_wrapper.IntMvbdu.mvbdu_unary_true bmvbdu_true0''' in - let bmvbdu_true2''' = Mvbdu_wrapper.IntMvbdu.mvbdu_unary_true bmvbdu_false0''' in - let bmvbdu_false1''' = Mvbdu_wrapper.IntMvbdu.mvbdu_unary_false bmvbdu_true0''' in - let bmvbdu_false2''' = Mvbdu_wrapper.IntMvbdu.mvbdu_unary_false bmvbdu_false0''' in - let bmvbdu_false3''' = Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true3''' = Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_true4''' = Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true5''' = Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_false4''' = Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_false5''' = Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_true6''' = Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_false6''' = Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_false7''' = Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true7''' = Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false8''' = Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true8''' = Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_true9''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true10''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false9''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true11''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_true12''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_false10''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false11''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true13''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_true14''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true15''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false12''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_false13''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_false14''' = Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true16''' = Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_true17''' = Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_false15''' = Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_false16''' = Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_false17''' = Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_true18''' = Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true19''' = Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_true20''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_false18''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false19''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_false20''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_false21''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_false22''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false23''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_false24''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_true21''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true22''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_true23''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true24''' = Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_true25''' = Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true26''' = Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_true27''' = Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_false25''' = Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_true28''' = Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_false26''' = Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_true29''' = Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true30''' = Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_false27''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_false28''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false29''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_true31''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_true0''' bmvbdu_false0''' in - let bmvbdu_false30''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_false0''' bmvbdu_false0''' in - let bmvbdu_true32''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_false0''' bmvbdu_true0''' in - let bmvbdu_false31''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_true0''' bmvbdu_true0''' in - let bmvbdu_false32''' = Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_true0''' bmvbdu_false0''' in - let list = [4,1; 2,2; 1,3] in - let list' = [2,2; 4,1; 1,3] in + let bmvbdu_true1''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_unary_true bmvbdu_true0''' + in + let bmvbdu_true2''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_unary_true bmvbdu_false0''' + in + let bmvbdu_false1''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_unary_false bmvbdu_true0''' + in + let bmvbdu_false2''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_unary_false bmvbdu_false0''' + in + let bmvbdu_false3''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true3''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_true4''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true5''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_or bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_false4''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_false5''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_true6''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_false6''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_and bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_false7''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true7''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false8''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true8''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_xor bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_true9''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true10''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false9''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true11''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nand bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_true12''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_false10''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false11''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true13''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nsnd bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_true14''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true15''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false12''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_false13''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nfst bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_false14''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true16''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_true17''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_false15''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_snd bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_false16''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_false17''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_true18''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true19''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_fst bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_true20''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_false18''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false19''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_false20''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nor bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_false21''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_false22''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false23''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_false24''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_false bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_true21''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true22''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_true23''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true24''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_bi_true bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_true25''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true26''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_true27''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_false25''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_imply bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_true28''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_false26''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_true29''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true30''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_rev_imply bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_false27''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_false28''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false29''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_true31''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nimply bmvbdu_true0''' bmvbdu_false0''' + in + let bmvbdu_false30''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_false0''' bmvbdu_false0''' + in + let bmvbdu_true32''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_false0''' bmvbdu_true0''' + in + let bmvbdu_false31''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_true0''' bmvbdu_true0''' + in + let bmvbdu_false32''' = + Mvbdu_wrapper.IntMvbdu.mvbdu_nrev_imply bmvbdu_true0''' bmvbdu_false0''' + in + let list = [ 4, 1; 2, 2; 1, 3 ] in + let list' = [ 2, 2; 4, 1; 1, 3 ] in let list____a = Mvbdu_wrapper.IntMvbdu.build_association_list list in - let list____c = Mvbdu_wrapper.IntMvbdu.build_reverse_sorted_association_list list in - let list____a' =Mvbdu_wrapper.IntMvbdu.build_association_list list' in + let list____c = + Mvbdu_wrapper.IntMvbdu.build_reverse_sorted_association_list list + in + let list____a' = Mvbdu_wrapper.IntMvbdu.build_association_list list' in let _ = Mvbdu_wrapper.IntMvbdu.mvbdu_redefine bmvbdu_true0''' list____a in - (* WRAPPED MVBDU INTERNALISED & OPTIMIZED *) + (* WRAPPED MVBDU INTERNALISED & OPTIMIZED *) let b0''' = Mvbdu_wrapper.Optimized_IntMvbdu.is_init () in let () = Mvbdu_wrapper.Optimized_IntMvbdu.init parameters in let b1''' = Mvbdu_wrapper.Optimized_IntMvbdu.is_init () in let () = Mvbdu_wrapper.Optimized_IntMvbdu.init parameters in let bmvbdu_true0'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_true () in let bmvbdu_false0'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_false () in - let bmvbdu_true1'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_true bmvbdu_true0'''' in - let bmvbdu_true2'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_true bmvbdu_false0'''' in - let bmvbdu_false1'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_false bmvbdu_true0'''' in - let bmvbdu_false2'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_false bmvbdu_false0'''' in - let bmvbdu_false3'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true3'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_true4'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true5'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_false4'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_false5'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_true6'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_false6'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_false7'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true7'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false8'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true8'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_true9'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true10'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false9'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true11'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_true12'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_false10'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false11'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true13'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_true14'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true15'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false12'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_false13'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_false14'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true16'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_true17'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_false15'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_false16'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_false17'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_true18'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true19'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_true20'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_false18'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false19'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_false20'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_false21'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_false22'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false23'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_false24'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_true21'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true22'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_true23'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true24'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_true25'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true26'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_true27'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_false25'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_true28'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_false26'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_true29'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true30'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_false27'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_false28'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false29'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_true31'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_true0'''' bmvbdu_false0'''' in - let bmvbdu_false30'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_false0'''' bmvbdu_false0'''' in - let bmvbdu_true32'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_false0'''' bmvbdu_true0'''' in - let bmvbdu_false31'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_true0'''' bmvbdu_true0'''' in - let bmvbdu_false32'''' = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_true0'''' bmvbdu_false0'''' in - let list = [4,1; 2,2; 1,3] in - let list' = [2,2; 4,1; 1,3] in - let list_____a = Mvbdu_wrapper.Optimized_IntMvbdu.build_association_list list in - let list_____c = Mvbdu_wrapper.Optimized_IntMvbdu.build_reverse_sorted_association_list list in - let list_____a' =Mvbdu_wrapper.Optimized_IntMvbdu.build_association_list list' in - let _ = Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_redefine bmvbdu_true0'''' list_____a in - - - { - remanent with - Sanity_test_sig.error = error ; - Sanity_test_sig.mvbdu_handler = handler_0 - }, - ("Mvbdu.001",fun remanent -> - let b = Mvbdu_core.mvbdu_equal f'' c'' in - remanent, b, None) :: (List.map (fun (a, b, c) -> a, - fun remanent -> Mvbdu_sanity.test remanent c b) - [ - "Mvbdu.002",a',(true,true,true); - "Mvbdu.003",b',(true,true,true); - "Mvbdu.004",c',(true,true,true); - "Mvbdu.005",d',(true,true,true); - "Mvbdu.006",e',(true,true,false); - "Mvbdu.007",f',(true,true,false); - "Mvbdu.008",g',(false,true,true); - "Mvbdu.009",h',(false,true,true); - "Mvbdu.010",i',(true,true,true); - "Mvbdu.011",j',(false,true,true); - "Mvbdu.012",k',(false,true,true); - "Mvbdu.013",l',(true,false,true); - - "Mvbdu.014",a'',(true,true,true); - "Mvbdu.015",b'',(true,true,true); - "Mvbdu.016",c'',(true,true,true); - "Mvbdu.017",d'',(true,true,true); - "Mvbdu.018",e'',(true,true,true); - "Mvbdu.019",f'',(true,true,true); - "Mvbdu.020",g'',(false,true,true); - "Mvbdu.021",h'',(false,true,true); - "Mvbdu.022",i'',(true,true,true); - "Mvbdu.023",j'',(false,true,true); - "Mvbdu.024",k'',(false,true,true); - "Mvbdu.025",l'',(true,false,true); - - "Mvbdu.026",copy a',(true,false,true); - "Mvbdu.027",copy b',(true,false,true); - "Mvbdu.028",copy c',(true,false,true); - "Mvbdu.029",copy d',(true,false,true); - "Mvbdu.030",copy e',(true,false,false); - "Mvbdu.031",copy f',(true,false,false); - "Mvbdu.032",copy g',(false,false,true); - "Mvbdu.033",copy h',(false,false,true); - "Mvbdu.034",copy i',(true,false,true); - "Mvbdu.035",copy j',(false,false,true); - "Mvbdu.036",copy k',(false,false,true); - "Mvbdu.037",copy l',(true,false,true); - - "Mvbdu.038",copy a'',(true,false,true); - "Mvbdu.039",copy b'',(true,false,true); - "Mvbdu.040",copy c'',(true,false,true); - "Mvbdu.041",copy d'',(true,false,true); - "Mvbdu.042",copy e'',(true,false,true); - "Mvbdu.043",copy f'',(true,false,true); - "Mvbdu.044",copy g'',(false,false,true); - "Mvbdu.045",copy h'',(false,false,true); - "Mvbdu.046",copy i'',(true,false,true); - "Mvbdu.047",copy j'',(false,false,true); - "Mvbdu.048",copy k'',(false,false,true); - "Mvbdu.049",copy l'',(true,false,true); - - "Mvbdu.050",copy_c,(true,false,true); - "Mvbdu.051",bmvbdu_true0,(true,true,true); - "Mvbdu.052",bmvbdu_true1,(true,true,true); - "Mvbdu.053",bmvbdu_true2,(true,true,true); - "Mvbdu.054",bmvbdu_true3,(true,true,true); - "Mvbdu.055",bmvbdu_true4,(true,true,true); - "Mvbdu.056",bmvbdu_true5,(true,true,true); - "Mvbdu.057",bmvbdu_true6,(true,true,true); - "Mvbdu.058",bmvbdu_true7,(true,true,true); - "Mvbdu.059",bmvbdu_true8,(true,true,true); - "Mvbdu.060",bmvbdu_true9,(true,true,true); - "Mvbdu.061",bmvbdu_true10,(true,true,true); - "Mvbdu.062",bmvbdu_true11,(true,true,true); - "Mvbdu.063",bmvbdu_true12,(true,true,true); - "Mvbdu.064",bmvbdu_true13,(true,true,true); - "Mvbdu.065",bmvbdu_true14,(true,true,true); - "Mvbdu.066",bmvbdu_true15,(true,true,true); - "Mvbdu.067",bmvbdu_true16,(true,true,true); - "Mvbdu.068",bmvbdu_true17,(true,true,true); - "Mvbdu.069",bmvbdu_true18,(true,true,true); - "Mvbdu.070",bmvbdu_true19,(true,true,true); - "Mvbdu.071",bmvbdu_true20,(true,true,true); - "Mvbdu.072",bmvbdu_true21,(true,true,true); - "Mvbdu.073",bmvbdu_true22,(true,true,true); - "Mvbdu.074",bmvbdu_true23,(true,true,true); - "Mvbdu.075",bmvbdu_true24,(true,true,true); - "Mvbdu.076",bmvbdu_true25,(true,true,true); - "Mvbdu.077",bmvbdu_true26,(true,true,true); - "Mvbdu.078",bmvbdu_true27,(true,true,true); - "Mvbdu.079",bmvbdu_true28,(true,true,true); - "Mvbdu.080",bmvbdu_true29,(true,true,true); - "Mvbdu.081",bmvbdu_true30,(true,true,true); - "Mvbdu.082",bmvbdu_true31,(true,true,true); - "Mvbdu.083",bmvbdu_true32,(true,true,true); - "Mvbdu.084",bmvbdu_false0,(true,true,true); - "Mvbdu.085",bmvbdu_false1,(true,true,true); - "Mvbdu.086",bmvbdu_false2,(true,true,true); - "Mvbdu.087",bmvbdu_false3,(true,true,true); - "Mvbdu.088",bmvbdu_false4,(true,true,true); - "Mvbdu.089",bmvbdu_false5,(true,true,true); - "Mvbdu.090",bmvbdu_false6,(true,true,true); - "Mvbdu.091",bmvbdu_false7,(true,true,true); - "Mvbdu.092",bmvbdu_false8,(true,true,true); - "Mvbdu.093",bmvbdu_false9,(true,true,true); - "Mvbdu.094",bmvbdu_false10,(true,true,true); - "Mvbdu.095",bmvbdu_false11,(true,true,true); - "Mvbdu.096",bmvbdu_false12,(true,true,true); - "Mvbdu.097",bmvbdu_false13,(true,true,true); - "Mvbdu.098",bmvbdu_false14,(true,true,true); - "Mvbdu.099",bmvbdu_false15,(true,true,true); - "Mvbdu.100",bmvbdu_false16,(true,true,true); - "Mvbdu.101",bmvbdu_false17,(true,true,true); - "Mvbdu.102",bmvbdu_false18,(true,true,true); - "Mvbdu.103",bmvbdu_false19,(true,true,true); - "Mvbdu.104",bmvbdu_false20,(true,true,true); - "Mvbdu.105",bmvbdu_false21,(true,true,true); - "Mvbdu.106",bmvbdu_false22,(true,true,true); - "Mvbdu.107",bmvbdu_false23,(true,true,true); - "Mvbdu.108",bmvbdu_false24,(true,true,true); - "Mvbdu.109",bmvbdu_false25,(true,true,true); - "Mvbdu.110",bmvbdu_false26,(true,true,true); - "Mvbdu.111",bmvbdu_false27,(true,true,true); - "Mvbdu.112",bmvbdu_false28,(true,true,true); - "Mvbdu.113",bmvbdu_false29,(true,true,true); - "Mvbdu.114",bmvbdu_false30,(true,true,true); - "Mvbdu.115",bmvbdu_false31,(true,true,true); - "Mvbdu.116",bmvbdu_false32,(true,true,true); - "Mvbdu.117",bmvbdu_true33,(true,true,true); - "Mvbdu.118",l''',(true,true,true); + let bmvbdu_true1'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_true bmvbdu_true0'''' + in + let bmvbdu_true2'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_true bmvbdu_false0'''' + in + let bmvbdu_false1'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_false bmvbdu_true0'''' + in + let bmvbdu_false2'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_unary_false bmvbdu_false0'''' + in + let bmvbdu_false3'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true3'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_false0'''' bmvbdu_true0'''' + in + let bmvbdu_true4'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_true0'''' bmvbdu_true0'''' + in + let bmvbdu_true5'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_or bmvbdu_true0'''' bmvbdu_false0'''' + in + let bmvbdu_false4'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_false5'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_true6'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_true0'''' bmvbdu_true0'''' + in + let bmvbdu_false6'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_and bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_false7'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true7'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false8'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_true0'''' bmvbdu_true0'''' + in + let bmvbdu_true8'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_xor bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_true9'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true10'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false9'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_true11'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nand bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_true12'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_false10'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false11'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_true13'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nsnd bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_true14'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true15'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false12'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_false13'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nfst bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_false14'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true16'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_true17'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_true0'''' bmvbdu_true0'''' + in + let bmvbdu_false15'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_snd bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_false16'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_false17'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_true18'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_true0'''' bmvbdu_true0'''' + in + let bmvbdu_true19'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_fst bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_true20'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_false18'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false19'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_true0'''' bmvbdu_true0'''' + in + let bmvbdu_false20'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nor bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_false21'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_false22'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false23'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_false24'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_false bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_true21'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true22'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_true23'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_true24'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_bi_true bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_true25'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true26'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_true27'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_false25'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_imply bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_true28'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_false26'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_true29'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_true30'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_rev_imply bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_false27'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_false28'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false29'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_true31'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nimply bmvbdu_true0'''' + bmvbdu_false0'''' + in + let bmvbdu_false30'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_false0'''' + bmvbdu_false0'''' + in + let bmvbdu_true32'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_false0'''' + bmvbdu_true0'''' + in + let bmvbdu_false31'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_true0'''' + bmvbdu_true0'''' + in + let bmvbdu_false32'''' = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_nrev_imply bmvbdu_true0'''' + bmvbdu_false0'''' + in + let list = [ 4, 1; 2, 2; 1, 3 ] in + let list' = [ 2, 2; 4, 1; 1, 3 ] in + let list_____a = + Mvbdu_wrapper.Optimized_IntMvbdu.build_association_list list + in + let list_____c = + Mvbdu_wrapper.Optimized_IntMvbdu.build_reverse_sorted_association_list list + in + let list_____a' = + Mvbdu_wrapper.Optimized_IntMvbdu.build_association_list list' + in + let _ = + Mvbdu_wrapper.Optimized_IntMvbdu.mvbdu_redefine bmvbdu_true0'''' list_____a + in - ])@ - (List.map (fun (a,b) -> a,(fun remanent -> remanent, b == bmvbdu_true0, None)) - ["true00",bmvbdu_true0; - "true01",bmvbdu_true1; - "true02",bmvbdu_true2; - "true03",bmvbdu_true3; - "true04",bmvbdu_true4; - "true05",bmvbdu_true5; - "true06",bmvbdu_true6; - "true07",bmvbdu_true7; - "true08",bmvbdu_true8; - "true09",bmvbdu_true9; - "true10",bmvbdu_true10; - "true11",bmvbdu_true11; - "true12",bmvbdu_true12; - "true13",bmvbdu_true13; - "true14",bmvbdu_true14; - "true15",bmvbdu_true15; - "true16",bmvbdu_true16; - "true17",bmvbdu_true17; - "true18",bmvbdu_true18; - "true19",bmvbdu_true19; - "true20",bmvbdu_true20; - "true21",bmvbdu_true21; - "true22",bmvbdu_true22; - "true23",bmvbdu_true23; - "true24",bmvbdu_true24; - "true25",bmvbdu_true25; - "true26",bmvbdu_true26; - "true27",bmvbdu_true27; - "true28",bmvbdu_true28; - "true29",bmvbdu_true29; - "true30",bmvbdu_true30; - "true31",bmvbdu_true31; - "true32",bmvbdu_true32; - "true33",bmvbdu_true33])@ - (List.map (fun (a,b) -> a,(fun remanent -> remanent, b == bmvbdu_true0', None)) - [ "true00'",bmvbdu_true0'; - "true01'",bmvbdu_true1'; - "true02'",bmvbdu_true2'; - "true03'",bmvbdu_true3'; - "true04'",bmvbdu_true4'; - "true05'",bmvbdu_true5'; - "true06'",bmvbdu_true6'; - "true07'",bmvbdu_true7'; - "true08'",bmvbdu_true8'; - "true09'",bmvbdu_true9'; - "true10'",bmvbdu_true10'; - "true11'",bmvbdu_true11'; - "true12'",bmvbdu_true12'; - "true13'",bmvbdu_true13'; - "true14'",bmvbdu_true14'; - "true15'",bmvbdu_true15'; - "true16'",bmvbdu_true16'; - "true17'",bmvbdu_true17'; - "true18'",bmvbdu_true18'; - "true19'",bmvbdu_true19'; - "true20'",bmvbdu_true20'; - "true21'",bmvbdu_true21'; - "true22'",bmvbdu_true22'; - "true23'",bmvbdu_true23'; - "true24'",bmvbdu_true24'; - "true25'",bmvbdu_true25'; - "true26'",bmvbdu_true26'; - "true27'",bmvbdu_true27'; - "true28'",bmvbdu_true28'; - "true29'",bmvbdu_true29'; - "true30'",bmvbdu_true30'; - "true31'",bmvbdu_true31'; - "true32'",bmvbdu_true32'; - ])@ - (List.map (fun (a,b) -> a,(fun remanent -> remanent, b == bmvbdu_true0'', None)) - [ "true00''",bmvbdu_true0''; - "true01''",bmvbdu_true1''; - "true02''",bmvbdu_true2''; - "true03''",bmvbdu_true3''; - "true04''",bmvbdu_true4''; - "true05''",bmvbdu_true5''; - "true06''",bmvbdu_true6''; - "true07''",bmvbdu_true7''; - "true08''",bmvbdu_true8''; - "true09''",bmvbdu_true9''; - "true10''",bmvbdu_true10''; - "true11''",bmvbdu_true11''; - "true12''",bmvbdu_true12''; - "true13''",bmvbdu_true13''; - "true14''",bmvbdu_true14''; - "true15''",bmvbdu_true15''; - "true16''",bmvbdu_true16''; - "true17''",bmvbdu_true17''; - "true18''",bmvbdu_true18''; - "true19''",bmvbdu_true19''; - "true20''",bmvbdu_true20''; - "true21''",bmvbdu_true21''; - "true22''",bmvbdu_true22''; - "true23''",bmvbdu_true23''; - "true24''",bmvbdu_true24''; - "true25''",bmvbdu_true25''; - "true26''",bmvbdu_true26''; - "true27''",bmvbdu_true27''; - "true28''",bmvbdu_true28''; - "true29''",bmvbdu_true29''; - "true30''",bmvbdu_true30''; - "true31''",bmvbdu_true31''; - "true32''",bmvbdu_true32''; - ])@ - (List.map (fun (a,b) -> a,(fun remanent -> remanent, b == bmvbdu_true0''', None)) - [ "true00'''",bmvbdu_true0'''; - "true01'''",bmvbdu_true1'''; - "true02'''",bmvbdu_true2'''; - "true03'''",bmvbdu_true3'''; - "true04'''",bmvbdu_true4'''; - "true05'''",bmvbdu_true5'''; - "true06'''",bmvbdu_true6'''; - "true07'''",bmvbdu_true7'''; - "true08'''",bmvbdu_true8'''; - "true09'''",bmvbdu_true9'''; - "true10'''",bmvbdu_true10'''; - "true11'''",bmvbdu_true11'''; - "true12'''",bmvbdu_true12'''; - "true13'''",bmvbdu_true13'''; - "true14'''",bmvbdu_true14'''; - "true15'''",bmvbdu_true15'''; - "true16'''",bmvbdu_true16'''; - "true17'''",bmvbdu_true17'''; - "true18'''",bmvbdu_true18'''; - "true19'''",bmvbdu_true19'''; - "true20'''",bmvbdu_true20'''; - "true21'''",bmvbdu_true21'''; - "true22'''",bmvbdu_true22'''; - "true23'''",bmvbdu_true23'''; - "true24'''",bmvbdu_true24'''; - "true25'''",bmvbdu_true25'''; - "true26'''",bmvbdu_true26'''; - "true27'''",bmvbdu_true27'''; - "true28'''",bmvbdu_true28'''; - "true29'''",bmvbdu_true29'''; - "true30'''",bmvbdu_true30'''; - "true31'''",bmvbdu_true31'''; - "true32'''",bmvbdu_true32'''; - ])@ - (List.map (fun (a,b) -> a,(fun remanent -> remanent, b == bmvbdu_true0'''', None)) - [ "true00''''",bmvbdu_true0''''; - "true01''''",bmvbdu_true1''''; - "true02''''",bmvbdu_true2''''; - "true03''''",bmvbdu_true3''''; - "true04''''",bmvbdu_true4''''; - "true05''''",bmvbdu_true5''''; - "true06''''",bmvbdu_true6''''; - "true07''''",bmvbdu_true7''''; - "true08''''",bmvbdu_true8''''; - "true09''''",bmvbdu_true9''''; - "true10''''",bmvbdu_true10''''; - "true11''''",bmvbdu_true11''''; - "true12''''",bmvbdu_true12''''; - "true13''''",bmvbdu_true13''''; - "true14''''",bmvbdu_true14''''; - "true15''''",bmvbdu_true15''''; - "true16''''",bmvbdu_true16''''; - "true17''''",bmvbdu_true17''''; - "true18''''",bmvbdu_true18''''; - "true19''''",bmvbdu_true19''''; - "true20''''",bmvbdu_true20''''; - "true21''''",bmvbdu_true21''''; - "true22''''",bmvbdu_true22''''; - "true23''''",bmvbdu_true23''''; - "true24''''",bmvbdu_true24''''; - "true25''''",bmvbdu_true25''''; - "true26''''",bmvbdu_true26''''; - "true27''''",bmvbdu_true27''''; - "true28''''",bmvbdu_true28''''; - "true29''''",bmvbdu_true29''''; - "true30''''",bmvbdu_true30''''; - "true31''''",bmvbdu_true31''''; - "true32''''",bmvbdu_true32''''; - ])@ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == bmvbdu_false0, None)) - ["false00",bmvbdu_false0; - "false01",bmvbdu_false1; - "false02",bmvbdu_false2; - "false03",bmvbdu_false3; - "false04",bmvbdu_false4; - "false05",bmvbdu_false5; - "false06",bmvbdu_false6; - "false07",bmvbdu_false7; - "false08",bmvbdu_false8; - "false09",bmvbdu_false9; - "false10",bmvbdu_false10; - "false11",bmvbdu_false11; - "false12",bmvbdu_false12; - "false13",bmvbdu_false13; - "false14",bmvbdu_false14; - "false15",bmvbdu_false15; - "false16",bmvbdu_false16; - "false17",bmvbdu_false17; - "false18",bmvbdu_false18; - "false19",bmvbdu_false19; - "false20",bmvbdu_false20; - "false21",bmvbdu_false21; - "false22",bmvbdu_false22; - "false23",bmvbdu_false23; - "false24",bmvbdu_false24; - "false25",bmvbdu_false25; - "false26",bmvbdu_false26; - "false27",bmvbdu_false27; - "false28",bmvbdu_false28; - "false29",bmvbdu_false29; - "false30",bmvbdu_false30; - "false31",bmvbdu_false31; - "false32",bmvbdu_false32;])@ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == bmvbdu_false0', None)) - [ - "false00'",bmvbdu_false0'; - "false01'",bmvbdu_false1'; - "false02'",bmvbdu_false2'; - "false03'",bmvbdu_false3'; - "false04'",bmvbdu_false4'; - "false05'",bmvbdu_false5'; - "false06'",bmvbdu_false6'; - "false07'",bmvbdu_false7'; - "false08'",bmvbdu_false8'; - "false09'",bmvbdu_false9'; - "false10'",bmvbdu_false10'; - "false11'",bmvbdu_false11'; - "false12'",bmvbdu_false12'; - "false13'",bmvbdu_false13'; - "false14'",bmvbdu_false14'; - "false15'",bmvbdu_false15'; - "false16'",bmvbdu_false16'; - "false17'",bmvbdu_false17'; - "false18'",bmvbdu_false18'; - "false19'",bmvbdu_false19'; - "false20'",bmvbdu_false20'; - "false21'",bmvbdu_false21'; - "false22'",bmvbdu_false22'; - "false23'",bmvbdu_false23'; - "false24'",bmvbdu_false24'; - "false25'",bmvbdu_false25'; - "false26'",bmvbdu_false26'; - "false27'",bmvbdu_false27'; - "false28'",bmvbdu_false28'; - "false29'",bmvbdu_false29'; - "false30'",bmvbdu_false30'; - "false31'",bmvbdu_false31'; - "false32'",bmvbdu_false32' - ])@ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == bmvbdu_false0'', None)) - [ - "false00''",bmvbdu_false0''; - "false01''",bmvbdu_false1''; - "false02''",bmvbdu_false2''; - "false03''",bmvbdu_false3''; - "false04''",bmvbdu_false4''; - "false05''",bmvbdu_false5''; - "false06''",bmvbdu_false6''; - "false07''",bmvbdu_false7''; - "false08''",bmvbdu_false8''; - "false09''",bmvbdu_false9''; - "false10''",bmvbdu_false10''; - "false11''",bmvbdu_false11''; - "false12''",bmvbdu_false12''; - "false13''",bmvbdu_false13''; - "false14''",bmvbdu_false14''; - "false15''",bmvbdu_false15''; - "false16''",bmvbdu_false16''; - "false17''",bmvbdu_false17''; - "false18''",bmvbdu_false18''; - "false19''",bmvbdu_false19''; - "false20''",bmvbdu_false20''; - "false21''",bmvbdu_false21''; - "false22''",bmvbdu_false22''; - "false23''",bmvbdu_false23''; - "false24''",bmvbdu_false24''; - "false25''",bmvbdu_false25''; - "false26''",bmvbdu_false26''; - "false27''",bmvbdu_false27''; - "false28''",bmvbdu_false28''; - "false29''",bmvbdu_false29''; - "false30''",bmvbdu_false30''; - "false31''",bmvbdu_false31''; - "false32''",bmvbdu_false32'' - ])@ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == bmvbdu_false0''', None)) - [ - "false00'''",bmvbdu_false0'''; - "false01'''",bmvbdu_false1'''; - "false02'''",bmvbdu_false2'''; - "false03'''",bmvbdu_false3'''; - "false04'''",bmvbdu_false4'''; - "false05'''",bmvbdu_false5'''; - "false06'''",bmvbdu_false6'''; - "false07'''",bmvbdu_false7'''; - "false08'''",bmvbdu_false8'''; - "false09'''",bmvbdu_false9'''; - "false10'''",bmvbdu_false10'''; - "false11'''",bmvbdu_false11'''; - "false12'''",bmvbdu_false12'''; - "false13'''",bmvbdu_false13'''; - "false14'''",bmvbdu_false14'''; - "false15'''",bmvbdu_false15'''; - "false16'''",bmvbdu_false16'''; - "false17'''",bmvbdu_false17'''; - "false18'''",bmvbdu_false18'''; - "false19'''",bmvbdu_false19'''; - "false20'''",bmvbdu_false20'''; - "false21'''",bmvbdu_false21'''; - "false22'''",bmvbdu_false22'''; - "false23'''",bmvbdu_false23'''; - "false24'''",bmvbdu_false24'''; - "false25'''",bmvbdu_false25'''; - "false26'''",bmvbdu_false26'''; - "false27'''",bmvbdu_false27'''; - "false28'''",bmvbdu_false28'''; - "false29'''",bmvbdu_false29'''; - "false30'''",bmvbdu_false30'''; - "false31'''",bmvbdu_false31'''; - "false32'''",bmvbdu_false32''' - ])@ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == bmvbdu_false0'''', None)) - [ - "false00''''",bmvbdu_false0''''; - "false01''''",bmvbdu_false1''''; - "false02''''",bmvbdu_false2''''; - "false03''''",bmvbdu_false3''''; - "false04''''",bmvbdu_false4''''; - "false05''''",bmvbdu_false5''''; - "false06''''",bmvbdu_false6''''; - "false07''''",bmvbdu_false7''''; - "false08''''",bmvbdu_false8''''; - "false09''''",bmvbdu_false9''''; - "false10''''",bmvbdu_false10''''; - "false11''''",bmvbdu_false11''''; - "false12''''",bmvbdu_false12''''; - "false13''''",bmvbdu_false13''''; - "false14''''",bmvbdu_false14''''; - "false15''''",bmvbdu_false15''''; - "false16''''",bmvbdu_false16''''; - "false17''''",bmvbdu_false17''''; - "false18''''",bmvbdu_false18''''; - "false19''''",bmvbdu_false19''''; - "false20''''",bmvbdu_false20''''; - "false21''''",bmvbdu_false21''''; - "false22''''",bmvbdu_false22''''; - "false23''''",bmvbdu_false23''''; - "false24''''",bmvbdu_false24''''; - "false25''''",bmvbdu_false25''''; - "false26''''",bmvbdu_false26''''; - "false27''''",bmvbdu_false27''''; - "false28''''",bmvbdu_false28''''; - "false29''''",bmvbdu_false29''''; - "false30''''",bmvbdu_false30''''; - "false31''''",bmvbdu_false31''''; - "false32''''",bmvbdu_false32'''' - ])@ - (List.map (fun (a,s) -> a,(fun remanent -> remanent,s,None)) - ["Non initialisation detection (MVBDU)",not b0; - "Initialisation (MVBDU)",b1; - "Initialisation detection (MVBDU)",b2; - "Refuse to reinitialise (MVBDU)",not b3; - "Non initialisation detection (MVBDU)",not b0'; - "Initialisation (MVBDU)",b1'; - "Initialisation detection (MVBDU)",b2'; - "Refuse to reinitialise (MVBDU)",not b3'; - "Non initialisation detection (MVBDU)",not b0''; - "Initialisation detection (MVBDU)",b1''; - "Non initialisation detection (MVBDU)",not b0'''; - "Initialisation detection (MVBDU)",b1'''; - ])@ - (List.map (fun (a,b,c) -> a, fun remanent -> List_sanity.test remanent c b) - [ - "List.001",list_a,(true,true); - "List.002",list_b,(false,true); - "List.003",list_c,(true,true); - "List.004",list_a',(true,true); - "List.005",list_b',(false,true); - "List.006",list_c',(false,true); - ])@ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == list_a, None)) - ["List.007",list_a; - "List.008",list_c; - "List.009",list_a'; - ])@ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == list__a, None)) - ["List.010",list__a; - "List.011",list__c; - "List.012",list__a'; - ]) - @ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == list___a, None)) - ["List.013",list___a; - "List.014",list___c; - "List.015",list___a'; - ]) - @ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == list____a, None)) - ["List.016",list____a; - "List.017",list____c; - "List.018",list____a'; - ]) - @ - (List.map (fun (a,b) -> a, (fun remanent -> remanent, b == list_____a, None)) - ["List.019",list_____a; - "List.020",list_____c; - "List.021",list_____a'; - ]) + ( { + remanent with + Sanity_test_sig.error; + Sanity_test_sig.mvbdu_handler = handler_0; + }, + ( "Mvbdu.001", + fun remanent -> + let b = Mvbdu_core.mvbdu_equal f'' c'' in + remanent, b, None ) + :: List.map + (fun (a, b, c) -> a, fun remanent -> Mvbdu_sanity.test remanent c b) + [ + "Mvbdu.002", a', (true, true, true); + "Mvbdu.003", b', (true, true, true); + "Mvbdu.004", c', (true, true, true); + "Mvbdu.005", d', (true, true, true); + "Mvbdu.006", e', (true, true, false); + "Mvbdu.007", f', (true, true, false); + "Mvbdu.008", g', (false, true, true); + "Mvbdu.009", h', (false, true, true); + "Mvbdu.010", i', (true, true, true); + "Mvbdu.011", j', (false, true, true); + "Mvbdu.012", k', (false, true, true); + "Mvbdu.013", l', (true, false, true); + "Mvbdu.014", a'', (true, true, true); + "Mvbdu.015", b'', (true, true, true); + "Mvbdu.016", c'', (true, true, true); + "Mvbdu.017", d'', (true, true, true); + "Mvbdu.018", e'', (true, true, true); + "Mvbdu.019", f'', (true, true, true); + "Mvbdu.020", g'', (false, true, true); + "Mvbdu.021", h'', (false, true, true); + "Mvbdu.022", i'', (true, true, true); + "Mvbdu.023", j'', (false, true, true); + "Mvbdu.024", k'', (false, true, true); + "Mvbdu.025", l'', (true, false, true); + "Mvbdu.026", copy a', (true, false, true); + "Mvbdu.027", copy b', (true, false, true); + "Mvbdu.028", copy c', (true, false, true); + "Mvbdu.029", copy d', (true, false, true); + "Mvbdu.030", copy e', (true, false, false); + "Mvbdu.031", copy f', (true, false, false); + "Mvbdu.032", copy g', (false, false, true); + "Mvbdu.033", copy h', (false, false, true); + "Mvbdu.034", copy i', (true, false, true); + "Mvbdu.035", copy j', (false, false, true); + "Mvbdu.036", copy k', (false, false, true); + "Mvbdu.037", copy l', (true, false, true); + "Mvbdu.038", copy a'', (true, false, true); + "Mvbdu.039", copy b'', (true, false, true); + "Mvbdu.040", copy c'', (true, false, true); + "Mvbdu.041", copy d'', (true, false, true); + "Mvbdu.042", copy e'', (true, false, true); + "Mvbdu.043", copy f'', (true, false, true); + "Mvbdu.044", copy g'', (false, false, true); + "Mvbdu.045", copy h'', (false, false, true); + "Mvbdu.046", copy i'', (true, false, true); + "Mvbdu.047", copy j'', (false, false, true); + "Mvbdu.048", copy k'', (false, false, true); + "Mvbdu.049", copy l'', (true, false, true); + "Mvbdu.050", copy_c, (true, false, true); + "Mvbdu.051", bmvbdu_true0, (true, true, true); + "Mvbdu.052", bmvbdu_true1, (true, true, true); + "Mvbdu.053", bmvbdu_true2, (true, true, true); + "Mvbdu.054", bmvbdu_true3, (true, true, true); + "Mvbdu.055", bmvbdu_true4, (true, true, true); + "Mvbdu.056", bmvbdu_true5, (true, true, true); + "Mvbdu.057", bmvbdu_true6, (true, true, true); + "Mvbdu.058", bmvbdu_true7, (true, true, true); + "Mvbdu.059", bmvbdu_true8, (true, true, true); + "Mvbdu.060", bmvbdu_true9, (true, true, true); + "Mvbdu.061", bmvbdu_true10, (true, true, true); + "Mvbdu.062", bmvbdu_true11, (true, true, true); + "Mvbdu.063", bmvbdu_true12, (true, true, true); + "Mvbdu.064", bmvbdu_true13, (true, true, true); + "Mvbdu.065", bmvbdu_true14, (true, true, true); + "Mvbdu.066", bmvbdu_true15, (true, true, true); + "Mvbdu.067", bmvbdu_true16, (true, true, true); + "Mvbdu.068", bmvbdu_true17, (true, true, true); + "Mvbdu.069", bmvbdu_true18, (true, true, true); + "Mvbdu.070", bmvbdu_true19, (true, true, true); + "Mvbdu.071", bmvbdu_true20, (true, true, true); + "Mvbdu.072", bmvbdu_true21, (true, true, true); + "Mvbdu.073", bmvbdu_true22, (true, true, true); + "Mvbdu.074", bmvbdu_true23, (true, true, true); + "Mvbdu.075", bmvbdu_true24, (true, true, true); + "Mvbdu.076", bmvbdu_true25, (true, true, true); + "Mvbdu.077", bmvbdu_true26, (true, true, true); + "Mvbdu.078", bmvbdu_true27, (true, true, true); + "Mvbdu.079", bmvbdu_true28, (true, true, true); + "Mvbdu.080", bmvbdu_true29, (true, true, true); + "Mvbdu.081", bmvbdu_true30, (true, true, true); + "Mvbdu.082", bmvbdu_true31, (true, true, true); + "Mvbdu.083", bmvbdu_true32, (true, true, true); + "Mvbdu.084", bmvbdu_false0, (true, true, true); + "Mvbdu.085", bmvbdu_false1, (true, true, true); + "Mvbdu.086", bmvbdu_false2, (true, true, true); + "Mvbdu.087", bmvbdu_false3, (true, true, true); + "Mvbdu.088", bmvbdu_false4, (true, true, true); + "Mvbdu.089", bmvbdu_false5, (true, true, true); + "Mvbdu.090", bmvbdu_false6, (true, true, true); + "Mvbdu.091", bmvbdu_false7, (true, true, true); + "Mvbdu.092", bmvbdu_false8, (true, true, true); + "Mvbdu.093", bmvbdu_false9, (true, true, true); + "Mvbdu.094", bmvbdu_false10, (true, true, true); + "Mvbdu.095", bmvbdu_false11, (true, true, true); + "Mvbdu.096", bmvbdu_false12, (true, true, true); + "Mvbdu.097", bmvbdu_false13, (true, true, true); + "Mvbdu.098", bmvbdu_false14, (true, true, true); + "Mvbdu.099", bmvbdu_false15, (true, true, true); + "Mvbdu.100", bmvbdu_false16, (true, true, true); + "Mvbdu.101", bmvbdu_false17, (true, true, true); + "Mvbdu.102", bmvbdu_false18, (true, true, true); + "Mvbdu.103", bmvbdu_false19, (true, true, true); + "Mvbdu.104", bmvbdu_false20, (true, true, true); + "Mvbdu.105", bmvbdu_false21, (true, true, true); + "Mvbdu.106", bmvbdu_false22, (true, true, true); + "Mvbdu.107", bmvbdu_false23, (true, true, true); + "Mvbdu.108", bmvbdu_false24, (true, true, true); + "Mvbdu.109", bmvbdu_false25, (true, true, true); + "Mvbdu.110", bmvbdu_false26, (true, true, true); + "Mvbdu.111", bmvbdu_false27, (true, true, true); + "Mvbdu.112", bmvbdu_false28, (true, true, true); + "Mvbdu.113", bmvbdu_false29, (true, true, true); + "Mvbdu.114", bmvbdu_false30, (true, true, true); + "Mvbdu.115", bmvbdu_false31, (true, true, true); + "Mvbdu.116", bmvbdu_false32, (true, true, true); + "Mvbdu.117", bmvbdu_true33, (true, true, true); + "Mvbdu.118", l''', (true, true, true); + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_true0, None) + [ + "true00", bmvbdu_true0; + "true01", bmvbdu_true1; + "true02", bmvbdu_true2; + "true03", bmvbdu_true3; + "true04", bmvbdu_true4; + "true05", bmvbdu_true5; + "true06", bmvbdu_true6; + "true07", bmvbdu_true7; + "true08", bmvbdu_true8; + "true09", bmvbdu_true9; + "true10", bmvbdu_true10; + "true11", bmvbdu_true11; + "true12", bmvbdu_true12; + "true13", bmvbdu_true13; + "true14", bmvbdu_true14; + "true15", bmvbdu_true15; + "true16", bmvbdu_true16; + "true17", bmvbdu_true17; + "true18", bmvbdu_true18; + "true19", bmvbdu_true19; + "true20", bmvbdu_true20; + "true21", bmvbdu_true21; + "true22", bmvbdu_true22; + "true23", bmvbdu_true23; + "true24", bmvbdu_true24; + "true25", bmvbdu_true25; + "true26", bmvbdu_true26; + "true27", bmvbdu_true27; + "true28", bmvbdu_true28; + "true29", bmvbdu_true29; + "true30", bmvbdu_true30; + "true31", bmvbdu_true31; + "true32", bmvbdu_true32; + "true33", bmvbdu_true33; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_true0', None) + [ + "true00'", bmvbdu_true0'; + "true01'", bmvbdu_true1'; + "true02'", bmvbdu_true2'; + "true03'", bmvbdu_true3'; + "true04'", bmvbdu_true4'; + "true05'", bmvbdu_true5'; + "true06'", bmvbdu_true6'; + "true07'", bmvbdu_true7'; + "true08'", bmvbdu_true8'; + "true09'", bmvbdu_true9'; + "true10'", bmvbdu_true10'; + "true11'", bmvbdu_true11'; + "true12'", bmvbdu_true12'; + "true13'", bmvbdu_true13'; + "true14'", bmvbdu_true14'; + "true15'", bmvbdu_true15'; + "true16'", bmvbdu_true16'; + "true17'", bmvbdu_true17'; + "true18'", bmvbdu_true18'; + "true19'", bmvbdu_true19'; + "true20'", bmvbdu_true20'; + "true21'", bmvbdu_true21'; + "true22'", bmvbdu_true22'; + "true23'", bmvbdu_true23'; + "true24'", bmvbdu_true24'; + "true25'", bmvbdu_true25'; + "true26'", bmvbdu_true26'; + "true27'", bmvbdu_true27'; + "true28'", bmvbdu_true28'; + "true29'", bmvbdu_true29'; + "true30'", bmvbdu_true30'; + "true31'", bmvbdu_true31'; + "true32'", bmvbdu_true32'; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_true0'', None) + [ + "true00''", bmvbdu_true0''; + "true01''", bmvbdu_true1''; + "true02''", bmvbdu_true2''; + "true03''", bmvbdu_true3''; + "true04''", bmvbdu_true4''; + "true05''", bmvbdu_true5''; + "true06''", bmvbdu_true6''; + "true07''", bmvbdu_true7''; + "true08''", bmvbdu_true8''; + "true09''", bmvbdu_true9''; + "true10''", bmvbdu_true10''; + "true11''", bmvbdu_true11''; + "true12''", bmvbdu_true12''; + "true13''", bmvbdu_true13''; + "true14''", bmvbdu_true14''; + "true15''", bmvbdu_true15''; + "true16''", bmvbdu_true16''; + "true17''", bmvbdu_true17''; + "true18''", bmvbdu_true18''; + "true19''", bmvbdu_true19''; + "true20''", bmvbdu_true20''; + "true21''", bmvbdu_true21''; + "true22''", bmvbdu_true22''; + "true23''", bmvbdu_true23''; + "true24''", bmvbdu_true24''; + "true25''", bmvbdu_true25''; + "true26''", bmvbdu_true26''; + "true27''", bmvbdu_true27''; + "true28''", bmvbdu_true28''; + "true29''", bmvbdu_true29''; + "true30''", bmvbdu_true30''; + "true31''", bmvbdu_true31''; + "true32''", bmvbdu_true32''; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_true0''', None) + [ + "true00'''", bmvbdu_true0'''; + "true01'''", bmvbdu_true1'''; + "true02'''", bmvbdu_true2'''; + "true03'''", bmvbdu_true3'''; + "true04'''", bmvbdu_true4'''; + "true05'''", bmvbdu_true5'''; + "true06'''", bmvbdu_true6'''; + "true07'''", bmvbdu_true7'''; + "true08'''", bmvbdu_true8'''; + "true09'''", bmvbdu_true9'''; + "true10'''", bmvbdu_true10'''; + "true11'''", bmvbdu_true11'''; + "true12'''", bmvbdu_true12'''; + "true13'''", bmvbdu_true13'''; + "true14'''", bmvbdu_true14'''; + "true15'''", bmvbdu_true15'''; + "true16'''", bmvbdu_true16'''; + "true17'''", bmvbdu_true17'''; + "true18'''", bmvbdu_true18'''; + "true19'''", bmvbdu_true19'''; + "true20'''", bmvbdu_true20'''; + "true21'''", bmvbdu_true21'''; + "true22'''", bmvbdu_true22'''; + "true23'''", bmvbdu_true23'''; + "true24'''", bmvbdu_true24'''; + "true25'''", bmvbdu_true25'''; + "true26'''", bmvbdu_true26'''; + "true27'''", bmvbdu_true27'''; + "true28'''", bmvbdu_true28'''; + "true29'''", bmvbdu_true29'''; + "true30'''", bmvbdu_true30'''; + "true31'''", bmvbdu_true31'''; + "true32'''", bmvbdu_true32'''; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_true0'''', None) + [ + "true00''''", bmvbdu_true0''''; + "true01''''", bmvbdu_true1''''; + "true02''''", bmvbdu_true2''''; + "true03''''", bmvbdu_true3''''; + "true04''''", bmvbdu_true4''''; + "true05''''", bmvbdu_true5''''; + "true06''''", bmvbdu_true6''''; + "true07''''", bmvbdu_true7''''; + "true08''''", bmvbdu_true8''''; + "true09''''", bmvbdu_true9''''; + "true10''''", bmvbdu_true10''''; + "true11''''", bmvbdu_true11''''; + "true12''''", bmvbdu_true12''''; + "true13''''", bmvbdu_true13''''; + "true14''''", bmvbdu_true14''''; + "true15''''", bmvbdu_true15''''; + "true16''''", bmvbdu_true16''''; + "true17''''", bmvbdu_true17''''; + "true18''''", bmvbdu_true18''''; + "true19''''", bmvbdu_true19''''; + "true20''''", bmvbdu_true20''''; + "true21''''", bmvbdu_true21''''; + "true22''''", bmvbdu_true22''''; + "true23''''", bmvbdu_true23''''; + "true24''''", bmvbdu_true24''''; + "true25''''", bmvbdu_true25''''; + "true26''''", bmvbdu_true26''''; + "true27''''", bmvbdu_true27''''; + "true28''''", bmvbdu_true28''''; + "true29''''", bmvbdu_true29''''; + "true30''''", bmvbdu_true30''''; + "true31''''", bmvbdu_true31''''; + "true32''''", bmvbdu_true32''''; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_false0, None) + [ + "false00", bmvbdu_false0; + "false01", bmvbdu_false1; + "false02", bmvbdu_false2; + "false03", bmvbdu_false3; + "false04", bmvbdu_false4; + "false05", bmvbdu_false5; + "false06", bmvbdu_false6; + "false07", bmvbdu_false7; + "false08", bmvbdu_false8; + "false09", bmvbdu_false9; + "false10", bmvbdu_false10; + "false11", bmvbdu_false11; + "false12", bmvbdu_false12; + "false13", bmvbdu_false13; + "false14", bmvbdu_false14; + "false15", bmvbdu_false15; + "false16", bmvbdu_false16; + "false17", bmvbdu_false17; + "false18", bmvbdu_false18; + "false19", bmvbdu_false19; + "false20", bmvbdu_false20; + "false21", bmvbdu_false21; + "false22", bmvbdu_false22; + "false23", bmvbdu_false23; + "false24", bmvbdu_false24; + "false25", bmvbdu_false25; + "false26", bmvbdu_false26; + "false27", bmvbdu_false27; + "false28", bmvbdu_false28; + "false29", bmvbdu_false29; + "false30", bmvbdu_false30; + "false31", bmvbdu_false31; + "false32", bmvbdu_false32; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_false0', None) + [ + "false00'", bmvbdu_false0'; + "false01'", bmvbdu_false1'; + "false02'", bmvbdu_false2'; + "false03'", bmvbdu_false3'; + "false04'", bmvbdu_false4'; + "false05'", bmvbdu_false5'; + "false06'", bmvbdu_false6'; + "false07'", bmvbdu_false7'; + "false08'", bmvbdu_false8'; + "false09'", bmvbdu_false9'; + "false10'", bmvbdu_false10'; + "false11'", bmvbdu_false11'; + "false12'", bmvbdu_false12'; + "false13'", bmvbdu_false13'; + "false14'", bmvbdu_false14'; + "false15'", bmvbdu_false15'; + "false16'", bmvbdu_false16'; + "false17'", bmvbdu_false17'; + "false18'", bmvbdu_false18'; + "false19'", bmvbdu_false19'; + "false20'", bmvbdu_false20'; + "false21'", bmvbdu_false21'; + "false22'", bmvbdu_false22'; + "false23'", bmvbdu_false23'; + "false24'", bmvbdu_false24'; + "false25'", bmvbdu_false25'; + "false26'", bmvbdu_false26'; + "false27'", bmvbdu_false27'; + "false28'", bmvbdu_false28'; + "false29'", bmvbdu_false29'; + "false30'", bmvbdu_false30'; + "false31'", bmvbdu_false31'; + "false32'", bmvbdu_false32'; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_false0'', None) + [ + "false00''", bmvbdu_false0''; + "false01''", bmvbdu_false1''; + "false02''", bmvbdu_false2''; + "false03''", bmvbdu_false3''; + "false04''", bmvbdu_false4''; + "false05''", bmvbdu_false5''; + "false06''", bmvbdu_false6''; + "false07''", bmvbdu_false7''; + "false08''", bmvbdu_false8''; + "false09''", bmvbdu_false9''; + "false10''", bmvbdu_false10''; + "false11''", bmvbdu_false11''; + "false12''", bmvbdu_false12''; + "false13''", bmvbdu_false13''; + "false14''", bmvbdu_false14''; + "false15''", bmvbdu_false15''; + "false16''", bmvbdu_false16''; + "false17''", bmvbdu_false17''; + "false18''", bmvbdu_false18''; + "false19''", bmvbdu_false19''; + "false20''", bmvbdu_false20''; + "false21''", bmvbdu_false21''; + "false22''", bmvbdu_false22''; + "false23''", bmvbdu_false23''; + "false24''", bmvbdu_false24''; + "false25''", bmvbdu_false25''; + "false26''", bmvbdu_false26''; + "false27''", bmvbdu_false27''; + "false28''", bmvbdu_false28''; + "false29''", bmvbdu_false29''; + "false30''", bmvbdu_false30''; + "false31''", bmvbdu_false31''; + "false32''", bmvbdu_false32''; + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == bmvbdu_false0''', None) + [ + "false00'''", bmvbdu_false0'''; + "false01'''", bmvbdu_false1'''; + "false02'''", bmvbdu_false2'''; + "false03'''", bmvbdu_false3'''; + "false04'''", bmvbdu_false4'''; + "false05'''", bmvbdu_false5'''; + "false06'''", bmvbdu_false6'''; + "false07'''", bmvbdu_false7'''; + "false08'''", bmvbdu_false8'''; + "false09'''", bmvbdu_false9'''; + "false10'''", bmvbdu_false10'''; + "false11'''", bmvbdu_false11'''; + "false12'''", bmvbdu_false12'''; + "false13'''", bmvbdu_false13'''; + "false14'''", bmvbdu_false14'''; + "false15'''", bmvbdu_false15'''; + "false16'''", bmvbdu_false16'''; + "false17'''", bmvbdu_false17'''; + "false18'''", bmvbdu_false18'''; + "false19'''", bmvbdu_false19'''; + "false20'''", bmvbdu_false20'''; + "false21'''", bmvbdu_false21'''; + "false22'''", bmvbdu_false22'''; + "false23'''", bmvbdu_false23'''; + "false24'''", bmvbdu_false24'''; + "false25'''", bmvbdu_false25'''; + "false26'''", bmvbdu_false26'''; + "false27'''", bmvbdu_false27'''; + "false28'''", bmvbdu_false28'''; + "false29'''", bmvbdu_false29'''; + "false30'''", bmvbdu_false30'''; + "false31'''", bmvbdu_false31'''; + "false32'''", bmvbdu_false32'''; + ] + @ List.map + (fun (a, b) -> + a, fun remanent -> remanent, b == bmvbdu_false0'''', None) + [ + "false00''''", bmvbdu_false0''''; + "false01''''", bmvbdu_false1''''; + "false02''''", bmvbdu_false2''''; + "false03''''", bmvbdu_false3''''; + "false04''''", bmvbdu_false4''''; + "false05''''", bmvbdu_false5''''; + "false06''''", bmvbdu_false6''''; + "false07''''", bmvbdu_false7''''; + "false08''''", bmvbdu_false8''''; + "false09''''", bmvbdu_false9''''; + "false10''''", bmvbdu_false10''''; + "false11''''", bmvbdu_false11''''; + "false12''''", bmvbdu_false12''''; + "false13''''", bmvbdu_false13''''; + "false14''''", bmvbdu_false14''''; + "false15''''", bmvbdu_false15''''; + "false16''''", bmvbdu_false16''''; + "false17''''", bmvbdu_false17''''; + "false18''''", bmvbdu_false18''''; + "false19''''", bmvbdu_false19''''; + "false20''''", bmvbdu_false20''''; + "false21''''", bmvbdu_false21''''; + "false22''''", bmvbdu_false22''''; + "false23''''", bmvbdu_false23''''; + "false24''''", bmvbdu_false24''''; + "false25''''", bmvbdu_false25''''; + "false26''''", bmvbdu_false26''''; + "false27''''", bmvbdu_false27''''; + "false28''''", bmvbdu_false28''''; + "false29''''", bmvbdu_false29''''; + "false30''''", bmvbdu_false30''''; + "false31''''", bmvbdu_false31''''; + "false32''''", bmvbdu_false32''''; + ] + @ List.map + (fun (a, s) -> a, fun remanent -> remanent, s, None) + [ + "Non initialisation detection (MVBDU)", not b0; + "Initialisation (MVBDU)", b1; + "Initialisation detection (MVBDU)", b2; + "Refuse to reinitialise (MVBDU)", not b3; + "Non initialisation detection (MVBDU)", not b0'; + "Initialisation (MVBDU)", b1'; + "Initialisation detection (MVBDU)", b2'; + "Refuse to reinitialise (MVBDU)", not b3'; + "Non initialisation detection (MVBDU)", not b0''; + "Initialisation detection (MVBDU)", b1''; + "Non initialisation detection (MVBDU)", not b0'''; + "Initialisation detection (MVBDU)", b1'''; + ] + @ List.map + (fun (a, b, c) -> a, fun remanent -> List_sanity.test remanent c b) + [ + "List.001", list_a, (true, true); + "List.002", list_b, (false, true); + "List.003", list_c, (true, true); + "List.004", list_a', (true, true); + "List.005", list_b', (false, true); + "List.006", list_c', (false, true); + ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == list_a, None) + [ "List.007", list_a; "List.008", list_c; "List.009", list_a' ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == list__a, None) + [ "List.010", list__a; "List.011", list__c; "List.012", list__a' ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == list___a, None) + [ "List.013", list___a; "List.014", list___c; "List.015", list___a' ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == list____a, None) + [ "List.016", list____a; "List.017", list____c; "List.018", list____a' ] + @ List.map + (fun (a, b) -> a, fun remanent -> remanent, b == list_____a, None) + [ + "List.019", list_____a; + "List.020", list_____c; + "List.021", list_____a'; + ] ) diff --git a/core/KaSa_rep/sanity_test/sanity_test.expected b/core/KaSa_rep/sanity_test/sanity_test.expected index 343effc431..22ee181ff9 100644 --- a/core/KaSa_rep/sanity_test/sanity_test.expected +++ b/core/KaSa_rep/sanity_test/sanity_test.expected @@ -301,9 +301,9 @@ Print Hash_7: Print Hash_8: Print Hash_9: Some exceptions have been raised -error: file_name: core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml; message: line 778; exception:Exit +error: file_name: core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml; message: line 889; exception:Exit Some exceptions have been raised -error: file_name: core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml; message: line 778; exception:Exit +error: file_name: core/KaSa_rep/abstract_domains/mvbdu/mvbdu_wrapper.ml; message: line 889; exception:Exit Mvbdu.001: ok Mvbdu.002: ok Mvbdu.003: ok diff --git a/core/KaSa_rep/sanity_test/sanity_test.ml b/core/KaSa_rep/sanity_test/sanity_test.ml index d7006e287c..d69aae0e58 100644 --- a/core/KaSa_rep/sanity_test/sanity_test.ml +++ b/core/KaSa_rep/sanity_test/sanity_test.ml @@ -12,85 +12,78 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -let test remanent p s1 = - let remanent,bool,report = p remanent in - let _ = - match report with - | Some s2 -> Printf.fprintf remanent.Sanity_test_sig.output "%s: %s\n" s1 s2 - | None -> - Printf.fprintf remanent.Sanity_test_sig.output "%s: %s\n" - s1 - (if bool then "ok" else "FAIL!") - in remanent +let test remanent p s1 = + let remanent, bool, report = p remanent in + let _ = + match report with + | Some s2 -> Printf.fprintf remanent.Sanity_test_sig.output "%s: %s\n" s1 s2 + | None -> + Printf.fprintf remanent.Sanity_test_sig.output "%s: %s\n" s1 + (if bool then + "ok" + else + "FAIL!") + in + remanent + +let gen_aux parameters allocate get update error b c d e old_handler = + let old_dictionary = get old_handler in + let error, output = allocate parameters error b c d e old_dictionary in + match output with + | None -> error, None + | Some (i, a, b, new_dic) -> error, Some (i, a, b, update old_handler new_dic) -let gen_aux parameters allocate get update = - (fun error b c d e old_handler -> - let old_dictionary = get old_handler in - let error,output = - allocate - parameters - error - b - c - d - e - old_dictionary - in - match output with - | None -> error, None - | Some (i, a, b, new_dic) -> error, - Some (i, a, b, update old_handler new_dic)) - -let gen parameters allocate_uniquely allocate get update x error b c d e old_handler = - match x with - | true -> gen_aux parameters allocate_uniquely get update error b c d e old_handler - | false -> gen_aux parameters allocate get update error b c d e old_handler +let gen parameters allocate_uniquely allocate get update x error b c d e + old_handler = + match x with + | true -> + gen_aux parameters allocate_uniquely get update error b c d e old_handler + | false -> gen_aux parameters allocate get update error b c d e old_handler -let remanent parameters = - Sanity_test_sig.initial_remanent - (Boolean_mvbdu.init_remanent parameters) - (gen - parameters - Boolean_mvbdu.D_mvbdu_skeleton.allocate_uniquely +let remanent parameters = + Sanity_test_sig.initial_remanent + (Boolean_mvbdu.init_remanent parameters) + (gen parameters Boolean_mvbdu.D_mvbdu_skeleton.allocate_uniquely Boolean_mvbdu.D_mvbdu_skeleton.allocate (fun x -> x.Memo_sig.mvbdu_dictionary) Mvbdu_core.update_dictionary) - (gen - parameters - Boolean_mvbdu.D_Association_list_skeleton.allocate_uniquely + (gen parameters Boolean_mvbdu.D_Association_list_skeleton.allocate_uniquely Boolean_mvbdu.D_Association_list_skeleton.allocate (fun x -> x.Memo_sig.association_list_dictionary) List_core.update_association_dictionary) - (gen - parameters - Boolean_mvbdu.D_Variables_list_skeleton.allocate_uniquely + (gen parameters Boolean_mvbdu.D_Variables_list_skeleton.allocate_uniquely Boolean_mvbdu.D_Variables_list_skeleton.allocate (fun x -> x.Memo_sig.variables_list_dictionary) List_core.update_variables_dictionary) - module I = Mods.IntSetMap -module LI = (Map_wrapper.Make(I):Map_wrapper.S_with_logs with type 'a Map.t = 'a I.Map.t and type elt = int and type Set.t = I.Set.t) -module LLI = Map_wrapper.Make(I) - +module LI : + Map_wrapper.S_with_logs + with type 'a Map.t = 'a I.Map.t + and type elt = int + and type Set.t = I.Set.t = + Map_wrapper.Make (I) + +module LLI = Map_wrapper.Make (I) + let () = let error = Exception.empty_error_handler in - let parameters = Remanent_parameters.get_parameters - ~called_from:Remanent_parameters_sig.KaSa () in - let _ = Exception.print parameters error in + let parameters = + Remanent_parameters.get_parameters ~called_from:Remanent_parameters_sig.KaSa + () + in + let _ = Exception.print parameters error in let counting_test_list = Counting_test.test_counting_procedure parameters in - let remanent_bdd,bdu_test_list = Mvbdu_test.bdu_test (remanent parameters) parameters in - let map_test_list = Map_test.map_test (remanent parameters) parameters in - let _ = + let remanent_bdd, bdu_test_list = + Mvbdu_test.bdu_test (remanent parameters) parameters + in + let map_test_list = Map_test.map_test (remanent parameters) parameters in + let _ = List.fold_left - ( - List.fold_left - (fun remanent (s,p) -> test remanent p s)) + (List.fold_left (fun remanent (s, p) -> test remanent p s)) remanent_bdd - [bdu_test_list; - map_test_list; - counting_test_list] + [ bdu_test_list; map_test_list; counting_test_list ] in - let _ = Printf.fprintf stdout "END SANITY\n" in + let _ = Printf.fprintf stdout "END SANITY\n" in () diff --git a/core/KaSa_rep/sanity_test/sanity_test_sig.ml b/core/KaSa_rep/sanity_test/sanity_test_sig.ml index d2d81028d3..73b0bf63d1 100644 --- a/core/KaSa_rep/sanity_test/sanity_test_sig.ml +++ b/core/KaSa_rep/sanity_test/sanity_test_sig.ml @@ -12,67 +12,100 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) f = - Exception.method_handler -> - (bool Mvbdu_sig.cell -> bool Mvbdu_sig.cell -> int) -> - bool Mvbdu_sig.skeleton -> - bool Mvbdu_sig.cell -> - (int -> bool Mvbdu_sig.mvbdu) -> - ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist,bool,int) Memo_sig.handler -> - Exception.method_handler * - ((int * bool Mvbdu_sig.cell * bool Mvbdu_sig.mvbdu * - ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist,bool,int) Memo_sig.handler) option) +type ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) f = + Exception.method_handler -> + (bool Mvbdu_sig.cell -> bool Mvbdu_sig.cell -> int) -> + bool Mvbdu_sig.skeleton -> + bool Mvbdu_sig.cell -> + (int -> bool Mvbdu_sig.mvbdu) -> + ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist, bool, int) Memo_sig.handler -> + Exception.method_handler + * (int + * bool Mvbdu_sig.cell + * bool Mvbdu_sig.mvbdu + * ( 'data, + 'dicmvbdu, + 'diclist, + 'dicrlist, + 'dicvlist, + bool, + int ) + Memo_sig.handler) + option -type ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) g = - Exception.method_handler -> - (int List_sig.cell -> int List_sig.cell -> int) -> - int List_sig.skeleton -> - int List_sig.cell -> - (int -> int List_sig.list) -> - ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist,bool,int) Memo_sig.handler -> - Exception.method_handler * - ((int * int List_sig.cell * int List_sig.list * - ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist,bool,int) Memo_sig.handler) option) +type ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) g = + Exception.method_handler -> + (int List_sig.cell -> int List_sig.cell -> int) -> + int List_sig.skeleton -> + int List_sig.cell -> + (int -> int List_sig.list) -> + ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist, bool, int) Memo_sig.handler -> + Exception.method_handler + * (int + * int List_sig.cell + * int List_sig.list + * ( 'data, + 'dicmvbdu, + 'diclist, + 'dicrlist, + 'dicvlist, + bool, + int ) + Memo_sig.handler) + option -type ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) h = - Exception.method_handler -> - (unit List_sig.cell -> unit List_sig.cell -> int) -> - unit List_sig.skeleton -> - unit List_sig.cell -> - (int -> unit List_sig.list) -> - ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist,bool,int) Memo_sig.handler -> - Exception.method_handler * - ((int * unit List_sig.cell * unit List_sig.list * - ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist,bool,int) Memo_sig.handler) option) +type ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) h = + Exception.method_handler -> + (unit List_sig.cell -> unit List_sig.cell -> int) -> + unit List_sig.skeleton -> + unit List_sig.cell -> + (int -> unit List_sig.list) -> + ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist, bool, int) Memo_sig.handler -> + Exception.method_handler + * (int + * unit List_sig.cell + * unit List_sig.list + * ( 'data, + 'dicmvbdu, + 'diclist, + 'dicrlist, + 'dicvlist, + bool, + int ) + Memo_sig.handler) + option -type ('mvbdu_handler,'dicmvbdu,'diclist,'dicrlist,'dicvlist,'data) remanent = - { - mvbdu_handler: 'mvbdu_handler; - error: Exception.method_handler; - output:out_channel; - allocate_mvbdu: ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) f; - allocate_uniquely_mvbdu: ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) f; - allocate_association_list: ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) g; - allocate_uniquely_association_list: ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) g; - allocate_variables_list: ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) h; - allocate_uniquely_variables_list: ('data,'dicmvbdu,'diclist,'dicrlist,'dicvlist) h; - parameters: Remanent_parameters_sig.parameters; - } +type ('mvbdu_handler, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist, 'data) remanent = { + mvbdu_handler: 'mvbdu_handler; + error: Exception.method_handler; + output: out_channel; + allocate_mvbdu: ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) f; + allocate_uniquely_mvbdu: ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) f; + allocate_association_list: + ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) g; + allocate_uniquely_association_list: + ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) g; + allocate_variables_list: ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) h; + allocate_uniquely_variables_list: + ('data, 'dicmvbdu, 'diclist, 'dicrlist, 'dicvlist) h; + parameters: Remanent_parameters_sig.parameters; +} -let initial_remanent make_mvbdu_handler make_allocate_mvbdu make_allocate_association_list make_allocate_variables_list = +let initial_remanent make_mvbdu_handler make_allocate_mvbdu + make_allocate_association_list make_allocate_variables_list = let error = Exception.empty_error_handler in - let error,handler = make_mvbdu_handler error in + let error, handler = make_mvbdu_handler error in { - output=stdout; - mvbdu_handler=handler; - error=error; - parameters = Remanent_parameters.get_parameters - ~called_from:Remanent_parameters_sig.KaSa (); + output = stdout; + mvbdu_handler = handler; + error; + parameters = + Remanent_parameters.get_parameters + ~called_from:Remanent_parameters_sig.KaSa (); allocate_mvbdu = make_allocate_mvbdu false; allocate_uniquely_mvbdu = make_allocate_mvbdu true; - allocate_association_list = make_allocate_association_list false ; - allocate_uniquely_association_list = make_allocate_association_list true ; - allocate_variables_list = make_allocate_variables_list false ; - allocate_uniquely_variables_list = make_allocate_variables_list true ; - + allocate_association_list = make_allocate_association_list false; + allocate_uniquely_association_list = make_allocate_association_list true; + allocate_variables_list = make_allocate_variables_list false; + allocate_uniquely_variables_list = make_allocate_variables_list true; } diff --git a/core/KaSa_rep/site_graphs/dune b/core/KaSa_rep/site_graphs/dune index a0232dea66..1d52e44898 100644 --- a/core/KaSa_rep/site_graphs/dune +++ b/core/KaSa_rep/site_graphs/dune @@ -1,12 +1,21 @@ (library - (name kappa_kasa_site_graphs) - (libraries yojson kappa_kasa_frontend) - (flags (:standard -w @a - -open Kappa_kasa_frontend - -open Kappa_kasa_kastor_toolset - -open Kappa_parameters - -open Kappa_errors - -open Kappa_logging - -open Kappa_generic_toolset - -open Kappa_kasa_type_interface - ))) + (name kappa_kasa_site_graphs) + (libraries yojson kappa_kasa_frontend) + (flags + (:standard + -w + @a + -open + Kappa_kasa_frontend + -open + Kappa_kasa_kastor_toolset + -open + Kappa_parameters + -open + Kappa_errors + -open + Kappa_logging + -open + Kappa_generic_toolset + -open + Kappa_kasa_type_interface))) diff --git a/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.ml b/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.ml index a471632317..92d81c4f2e 100644 --- a/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.ml +++ b/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.ml @@ -1,43 +1,46 @@ -module type Site_graph = -sig +module type Site_graph = sig type t - type agent_id type bond_index type binding_state = - | Free | Wildcard | Bound_to_unknown + | Free + | Wildcard + | Bound_to_unknown | Binding_type of string * string | Bound_to of bond_index val binding_state_to_json : binding_state -> Yojson.Basic.t val binding_state_of_json : Yojson.Basic.t -> binding_state - - val int_of_bond_index : bond_index -> int val bond_index_of_int : int -> bond_index + val empty : t - val empty: t - - val get_string_version : t -> - (string * - (string option * binding_state option * (int option * int option) option) - Wrapped_modules.LoggedStringMap.t) - Ckappa_sig.Agent_id_map_and_set.Map.t - - val set_string_version : (*FIXME*) - (string * - (string option * binding_state option * (int option * int option) option) Wrapped_modules.LoggedStringMap.t) - Ckappa_sig.Agent_id_map_and_set.Map.t -> t -> t + val get_string_version : + t -> + (string + * (string option * binding_state option * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t) + Ckappa_sig.Agent_id_map_and_set.Map.t + + val set_string_version : + (*FIXME*) + (string + * (string option * binding_state option * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t) + Ckappa_sig.Agent_id_map_and_set.Map.t -> + t -> + t - val add_agent: + val add_agent : Remanent_parameters_sig.parameters -> - Exception.method_handler -> + Exception.method_handler -> Cckappa_sig.kappa_handler -> - Ckappa_sig.c_agent_name -> t -> + Ckappa_sig.c_agent_name -> + t -> Exception.method_handler * agent_id * t - val add_site: + val add_site : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -46,24 +49,26 @@ sig t -> Exception.method_handler * t - val add_state: + val add_state : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> agent_id -> Ckappa_sig.c_site_name -> - Ckappa_sig.c_state -> t -> + Ckappa_sig.c_state -> + t -> Exception.method_handler * t - val add_bound_to_unknown: + val add_bound_to_unknown : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> agent_id -> - Ckappa_sig.c_site_name -> t -> + Ckappa_sig.c_site_name -> + t -> Exception.method_handler * t - val add_bond: + val add_bond : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -74,7 +79,7 @@ sig t -> Exception.method_handler * t - val add_bond_type: + val add_bond_type : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -85,7 +90,7 @@ sig t -> Exception.method_handler * t - val add_counter_range: + val add_counter_range : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -96,34 +101,38 @@ sig t -> Exception.method_handler * t - val to_string: + val to_string : Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> Exception.method_handler * string - val print: + val print : Loggers.t -> Remanent_parameters_sig.parameters -> Exception.method_handler -> - t -> Exception.method_handler + t -> + Exception.method_handler - val print_agent: + val print_agent : Loggers.t -> Remanent_parameters_sig.parameters -> Exception.method_handler -> string -> (string option * binding_state option * (int option * int option) option) - Wrapped_modules.LoggedStringMap.t -> bool -> Exception.method_handler + Wrapped_modules.LoggedStringMap.t -> + bool -> + Exception.method_handler - val print_list: + val print_list : Loggers.t -> Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> - t list -> Exception.method_handler + t list -> + Exception.method_handler - val has_a_counter: + val has_a_counter : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -131,13 +140,11 @@ sig Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool - val has_a_binding_state: + val has_a_binding_state : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool - - end diff --git a/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.mli b/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.mli index c2afafddc7..92d81c4f2e 100644 --- a/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.mli +++ b/core/KaSa_rep/site_graphs/kasa_site_graphs_sig.mli @@ -1,43 +1,46 @@ -module type Site_graph = -sig +module type Site_graph = sig type t - type agent_id type bond_index type binding_state = - | Free | Wildcard | Bound_to_unknown + | Free + | Wildcard + | Bound_to_unknown | Binding_type of string * string | Bound_to of bond_index val binding_state_to_json : binding_state -> Yojson.Basic.t val binding_state_of_json : Yojson.Basic.t -> binding_state - - val int_of_bond_index : bond_index -> int val bond_index_of_int : int -> bond_index + val empty : t - val empty: t - - val get_string_version : t -> - (string * - (string option * binding_state option * (int option * int option) option) - Wrapped_modules.LoggedStringMap.t) - Ckappa_sig.Agent_id_map_and_set.Map.t - - val set_string_version : (*FIXME*) - (string * - (string option * binding_state option * (int option * int option) option) Wrapped_modules.LoggedStringMap.t) - Ckappa_sig.Agent_id_map_and_set.Map.t -> t -> t + val get_string_version : + t -> + (string + * (string option * binding_state option * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t) + Ckappa_sig.Agent_id_map_and_set.Map.t + + val set_string_version : + (*FIXME*) + (string + * (string option * binding_state option * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t) + Ckappa_sig.Agent_id_map_and_set.Map.t -> + t -> + t - val add_agent: + val add_agent : Remanent_parameters_sig.parameters -> - Exception.method_handler -> + Exception.method_handler -> Cckappa_sig.kappa_handler -> - Ckappa_sig.c_agent_name -> t -> + Ckappa_sig.c_agent_name -> + t -> Exception.method_handler * agent_id * t - val add_site: + val add_site : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -46,24 +49,26 @@ sig t -> Exception.method_handler * t - val add_state: + val add_state : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> agent_id -> Ckappa_sig.c_site_name -> - Ckappa_sig.c_state -> t -> + Ckappa_sig.c_state -> + t -> Exception.method_handler * t - val add_bound_to_unknown: + val add_bound_to_unknown : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> agent_id -> - Ckappa_sig.c_site_name -> t -> + Ckappa_sig.c_site_name -> + t -> Exception.method_handler * t - val add_bond: + val add_bond : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -74,7 +79,7 @@ sig t -> Exception.method_handler * t - val add_bond_type: + val add_bond_type : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -85,7 +90,7 @@ sig t -> Exception.method_handler * t - val add_counter_range: + val add_counter_range : Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> @@ -96,35 +101,38 @@ sig t -> Exception.method_handler * t - val to_string: + val to_string : Remanent_parameters_sig.parameters -> Exception.method_handler -> t -> Exception.method_handler * string - val print: + val print : Loggers.t -> Remanent_parameters_sig.parameters -> Exception.method_handler -> - t -> Exception.method_handler + t -> + Exception.method_handler - val print_agent: + val print_agent : Loggers.t -> Remanent_parameters_sig.parameters -> Exception.method_handler -> string -> (string option * binding_state option * (int option * int option) option) - Wrapped_modules.LoggedStringMap.t -> bool -> Exception.method_handler + Wrapped_modules.LoggedStringMap.t -> + bool -> + Exception.method_handler - val print_list: + val print_list : Loggers.t -> Remanent_parameters_sig.parameters -> Exception.method_handler -> Cckappa_sig.kappa_handler -> - t list -> Exception.method_handler - + t list -> + Exception.method_handler - val has_a_counter: + val has_a_counter : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> @@ -132,13 +140,11 @@ sig Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool - val has_a_binding_state: + val has_a_binding_state : Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> Cckappa_sig.kappa_handler -> Ckappa_sig.c_agent_name -> Ckappa_sig.c_site_name -> Exception_without_parameter.method_handler * bool - - end diff --git a/core/KaSa_rep/site_graphs/site_graphs.ml b/core/KaSa_rep/site_graphs/site_graphs.ml index 0466575d56..a1eaa09ef2 100644 --- a/core/KaSa_rep/site_graphs/site_graphs.ml +++ b/core/KaSa_rep/site_graphs/site_graphs.ml @@ -1,11 +1,11 @@ -module KaSa_site_graph = -struct - +module KaSa_site_graph = struct type agent_id = Ckappa_sig.c_agent_id type bond_index = int type binding_state = - | Free | Wildcard | Bound_to_unknown + | Free + | Wildcard + | Bound_to_unknown | Binding_type of Ckappa_sig.agent_name * Ckappa_sig.site_name | Bound_to of bond_index @@ -17,491 +17,389 @@ struct let bond_id = "bond id" let bound_to = "bound to" let binding_type = "binding type" - let int_of_bond_index (a:bond_index) : int = a - let bond_index_of_int (a:int) : bond_index = a - - let binding_state_to_json = - function - | Free -> `Assoc [free, `Null] - | Wildcard -> `Assoc [wildcard, `Null] - | Bound_to_unknown -> `Assoc [bound_to, `Null] - | (Bound_to i) -> - `Assoc [bond_id, JsonUtil.of_int (int_of_bond_index i)] - | (Binding_type (agent_name, site_name)) -> - `Assoc [binding_type, - JsonUtil.of_pair ~lab1:agent ~lab2:site - JsonUtil.of_string - JsonUtil.of_string - (agent_name, site_name)] - - let binding_state_of_json = - function - | `Assoc [s, `Null] when s = free -> Free - | `Assoc [s, `Null] when s = wildcard -> Wildcard - | `Assoc [s, `Null] when s = bound_to -> Bound_to_unknown - | `Assoc [s, j] when s = bond_id -> - let i = - JsonUtil.to_int ~error_msg:"wrong binding id" j - in + let int_of_bond_index (a : bond_index) : int = a + let bond_index_of_int (a : int) : bond_index = a + + let binding_state_to_json = function + | Free -> `Assoc [ free, `Null ] + | Wildcard -> `Assoc [ wildcard, `Null ] + | Bound_to_unknown -> `Assoc [ bound_to, `Null ] + | Bound_to i -> `Assoc [ bond_id, JsonUtil.of_int (int_of_bond_index i) ] + | Binding_type (agent_name, site_name) -> + `Assoc + [ + ( binding_type, + JsonUtil.of_pair ~lab1:agent ~lab2:site JsonUtil.of_string + JsonUtil.of_string (agent_name, site_name) ); + ] + + let binding_state_of_json = function + | `Assoc [ (s, `Null) ] when s = free -> Free + | `Assoc [ (s, `Null) ] when s = wildcard -> Wildcard + | `Assoc [ (s, `Null) ] when s = bound_to -> Bound_to_unknown + | `Assoc [ (s, j) ] when s = bond_id -> + let i = JsonUtil.to_int ~error_msg:"wrong binding id" j in let bond_index = bond_index_of_int i in Bound_to bond_index - | `Assoc [s, j] when s = binding_type -> - let (agent_name, site_name) = - JsonUtil.to_pair - ~lab1:agent ~lab2:site ~error_msg:"binding type" - (JsonUtil.to_string ~error_msg:"agent name") (JsonUtil.to_string ~error_msg:"site name") + | `Assoc [ (s, j) ] when s = binding_type -> + let agent_name, site_name = + JsonUtil.to_pair ~lab1:agent ~lab2:site ~error_msg:"binding type" + (JsonUtil.to_string ~error_msg:"agent name") + (JsonUtil.to_string ~error_msg:"site name") j in Binding_type (agent_name, site_name) - | x -> raise - (Yojson.Basic.Util.Type_error ("wrong binding state",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("wrong binding state", x)) type agent = - (string * - (string option * binding_state option * (int option * int option) option) - Wrapped_modules.LoggedStringMap.t) - - type t = - { - views: - (Ckappa_sig.c_agent_name * - ((Ckappa_sig.c_state option * Ckappa_sig.c_state option)) - Ckappa_sig.Site_map_and_set.Map.t) Ckappa_sig.Agent_id_map_and_set.Map.t ; - fresh_agent_id: agent_id ; - fresh_bond_id: bond_index ; - bonds: - bond_index - Ckappa_sig.Site_map_and_set.Map.t - Ckappa_sig.Agent_id_map_and_set.Map.t; - string_version: - agent - Ckappa_sig.Agent_id_map_and_set.Map.t - } + string + * (string option * binding_state option * (int option * int option) option) + Wrapped_modules.LoggedStringMap.t + + type t = { + views: + (Ckappa_sig.c_agent_name + * (Ckappa_sig.c_state option * Ckappa_sig.c_state option) + Ckappa_sig.Site_map_and_set.Map.t) + Ckappa_sig.Agent_id_map_and_set.Map.t; + fresh_agent_id: agent_id; + fresh_bond_id: bond_index; + bonds: + bond_index Ckappa_sig.Site_map_and_set.Map.t + Ckappa_sig.Agent_id_map_and_set.Map.t; + string_version: agent Ckappa_sig.Agent_id_map_and_set.Map.t; + } let get_string_version t = t.string_version - let set_string_version s_v t = - {t with string_version = s_v} + let set_string_version s_v t = { t with string_version = s_v } let empty = { - views = Ckappa_sig.Agent_id_map_and_set.Map.empty ; - fresh_agent_id = Ckappa_sig.dummy_agent_id ; - fresh_bond_id = 1 ; - bonds = Ckappa_sig.Agent_id_map_and_set.Map.empty ; - string_version = Ckappa_sig.Agent_id_map_and_set.Map.empty ; + views = Ckappa_sig.Agent_id_map_and_set.Map.empty; + fresh_agent_id = Ckappa_sig.dummy_agent_id; + fresh_bond_id = 1; + bonds = Ckappa_sig.Agent_id_map_and_set.Map.empty; + string_version = Ckappa_sig.Agent_id_map_and_set.Map.empty; } let add_agent parameter error kappa_handler agent_type t = let error, agent_string = - Handler.translate_agent - ~message:"unknown agent type" ~ml_pos:(Some __POS__) parameter error kappa_handler agent_type + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameter error kappa_handler agent_type in let agent_id = t.fresh_agent_id in let error', views = - Ckappa_sig.Agent_id_map_and_set.Map.add - parameter error - agent_id + Ckappa_sig.Agent_id_map_and_set.Map.add parameter error agent_id (agent_type, Ckappa_sig.Site_map_and_set.Map.empty) t.views in let error = - Exception.check_point - Exception.warn parameter error error' __POS__ - ~message:"this agent id is already used" - Exit + Exception.check_point Exception.warn parameter error error' __POS__ + ~message:"this agent id is already used" Exit in let error', string_version = - Ckappa_sig.Agent_id_map_and_set.Map.add - parameter error - agent_id + Ckappa_sig.Agent_id_map_and_set.Map.add parameter error agent_id (agent_string, Wrapped_modules.LoggedStringMap.empty) t.string_version in let error = - Exception.check_point - Exception.warn parameter error error' __POS__ - ~message:"this agent id is already used" - Exit - in - error, t.fresh_agent_id, - {t - with - fresh_agent_id = Ckappa_sig.next_agent_id t.fresh_agent_id ; - views = views ; - string_version = string_version } + Exception.check_point Exception.warn parameter error error' __POS__ + ~message:"this agent id is already used" Exit + in + ( error, + t.fresh_agent_id, + { + t with + fresh_agent_id = Ckappa_sig.next_agent_id t.fresh_agent_id; + views; + string_version; + } ) let has_a_counter parameter error kappa_handler agent_type site = - let error,site = + let error, site = Handler.translate_site parameter error kappa_handler agent_type site in match site with - | Ckappa_sig.Internal s - | Ckappa_sig.Binding s -> + | Ckappa_sig.Internal s | Ckappa_sig.Binding s -> let new_site = Ckappa_sig.Counter s in let error, dic_opt = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameter error agent_type kappa_handler.Cckappa_sig.sites + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameter + error agent_type kappa_handler.Cckappa_sig.sites in - begin - match dic_opt with - | None -> - Exception.warn parameter error __POS__ Exit false - | Some dic -> - Ckappa_sig.Dictionary_of_sites.member - parameter error new_site dic - end - | Ckappa_sig.Counter _ -> - Exception.warn parameter error __POS__ Exit false + (match dic_opt with + | None -> Exception.warn parameter error __POS__ Exit false + | Some dic -> + Ckappa_sig.Dictionary_of_sites.member parameter error new_site dic) + | Ckappa_sig.Counter _ -> Exception.warn parameter error __POS__ Exit false let has_a_binding_state parameter error kappa_handler agent_type site = - let error,site = + let error, site = Handler.translate_site parameter error kappa_handler agent_type site in match site with - | Ckappa_sig.Internal s - | Ckappa_sig.Counter s -> + | Ckappa_sig.Internal s | Ckappa_sig.Counter s -> let new_site = Ckappa_sig.Binding s in let error, dic_opt = - Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get - parameter error agent_type kappa_handler.Cckappa_sig.sites + Ckappa_sig.Agent_type_nearly_Inf_Int_storage_Imperatif.get parameter + error agent_type kappa_handler.Cckappa_sig.sites in - begin - match dic_opt with - | None -> - Exception.warn parameter error __POS__ Exit false - | Some dic -> - Ckappa_sig.Dictionary_of_sites.member - parameter error new_site dic - end - | Ckappa_sig.Binding _ -> - Exception.warn parameter error __POS__ Exit false - + (match dic_opt with + | None -> Exception.warn parameter error __POS__ Exit false + | Some dic -> + Ckappa_sig.Dictionary_of_sites.member parameter error new_site dic) + | Ckappa_sig.Binding _ -> Exception.warn parameter error __POS__ Exit false let add_site parameter error kappa_handler agent_id site t = let error, agent_op = - Ckappa_sig.Agent_id_map_and_set.Map.find_option - parameter error - agent_id + Ckappa_sig.Agent_id_map_and_set.Map.find_option parameter error agent_id t.views in match agent_op with | None -> - Exception.warn - parameter error __POS__ - ~message:"unknown agent type" - Exit t + Exception.warn parameter error __POS__ ~message:"unknown agent type" Exit + t | Some (agent_type, _map) -> - begin - let error', (agent_string, sitemap) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error - ("",Wrapped_modules.LoggedStringMap.empty) - agent_id - t.string_version - in - let error = - Exception.check_point - Exception.warn - parameter error error' __POS__ Exit - in - let error', site_string = - Handler.string_of_site_contact_map - ~ml_pos:(Some __POS__) - ~message:"undefined site" - parameter error kappa_handler agent_type site - in - let error = - Exception.check_point - Exception.warn - parameter error error' __POS__ Exit - in - let error, state_opt = - Wrapped_modules.LoggedStringMap.find_option_without_logs - parameter error - site_string - sitemap - in - let state = - match - state_opt - with - | None -> None, None, None - | Some state -> state - in - let error, sitemap = - Wrapped_modules.LoggedStringMap.add_or_overwrite - parameter error - site_string - state - sitemap + let error', (agent_string, sitemap) = + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error + ("", Wrapped_modules.LoggedStringMap.empty) + agent_id t.string_version + in + let error = + Exception.check_point Exception.warn parameter error error' __POS__ Exit + in + let error', site_string = + Handler.string_of_site_contact_map ~ml_pos:(Some __POS__) + ~message:"undefined site" parameter error kappa_handler agent_type + site + in + let error = + Exception.check_point Exception.warn parameter error error' __POS__ Exit + in + let error, state_opt = + Wrapped_modules.LoggedStringMap.find_option_without_logs parameter error + site_string sitemap + in + let state = + match state_opt with + | None -> None, None, None + | Some state -> state + in + let error, sitemap = + Wrapped_modules.LoggedStringMap.add_or_overwrite parameter error + site_string state sitemap in let error', string_version = - Ckappa_sig.Agent_id_map_and_set.Map.overwrite - parameter error - agent_id - (agent_string, sitemap) - t.string_version + Ckappa_sig.Agent_id_map_and_set.Map.overwrite parameter error agent_id + (agent_string, sitemap) t.string_version in let error = - Exception.check_point - Exception.warn - parameter error error' __POS__ Exit + Exception.check_point Exception.warn parameter error error' __POS__ Exit in - error, - { t with string_version } - end + error, { t with string_version } - let add_state_interv parameter error kappa_handler agent_id site - state_min state_max t = + let add_state_interv parameter error kappa_handler agent_id site state_min + state_max t = let error, agent_op = - Ckappa_sig.Agent_id_map_and_set.Map.find_option - parameter error - agent_id + Ckappa_sig.Agent_id_map_and_set.Map.find_option parameter error agent_id t.views in match agent_op with | None -> - Exception.warn - parameter error __POS__ - ~message:"unknown agent type" - Exit t + Exception.warn parameter error __POS__ ~message:"unknown agent type" Exit + t | Some (agent_type, map) -> - begin - let error, site_string = - Handler.string_of_site_contact_map - ~ml_pos:(Some __POS__) - ~message:"undefined site" - parameter error kappa_handler agent_type site - in - let error, b_counter = - Handler.is_counter parameter error kappa_handler agent_type site - in - let error = - if b_counter then error - else - match state_min with - | Some state_min -> - let error, _ = - Handler.translate_state - ~ml_pos:(Some __POS__) - ~message:"undefined site state" - parameter error kappa_handler - agent_type site state_min - in error - | None -> error + let error, site_string = + Handler.string_of_site_contact_map ~ml_pos:(Some __POS__) + ~message:"undefined site" parameter error kappa_handler agent_type + site + in + let error, b_counter = + Handler.is_counter parameter error kappa_handler agent_type site + in + let error = + if b_counter then + error + else ( + match state_min with + | Some state_min -> + let error, _ = + Handler.translate_state ~ml_pos:(Some __POS__) + ~message:"undefined site state" parameter error kappa_handler + agent_type site state_min + in + error + | None -> error + ) + in + let error = + if b_counter then + error + else ( + match state_max with + | Some state_max -> + let error, _ = + Handler.translate_state ~ml_pos:(Some __POS__) + ~message:"undefined site state" parameter error kappa_handler + agent_type site state_max + in + error + | None -> error + ) + in + let error, old_asso = + Ckappa_sig.Site_map_and_set.Map.find_option_without_logs parameter error + site map + in + let error, (new_map, range_opt) = + match old_asso with + | None -> + let error, map = + Ckappa_sig.Site_map_and_set.Map.add parameter error site + (state_min, state_max) map + in + error, (map, Some (state_min, state_max)) + | Some (old_min, old_max) -> + if + Ckappa_sig.compare_state_index_option_min old_min state_min <= 0 + || Ckappa_sig.compare_state_index_option_max state_max old_max <= 0 + then ( + let new_min = + Cckappa_sig.max_state_index_option_min state_min old_min + in + let new_max = + Cckappa_sig.min_state_index_option_max state_max old_max + in + let error', map = + Ckappa_sig.Site_map_and_set.Map.overwrite parameter error site + (new_min, new_max) map + in + let error = + Exception.check_point Exception.warn parameter error error' + __POS__ Exit + in + error, (map, Some (new_min, new_max)) + ) else + Exception.warn parameter error __POS__ + ~message:"incompatible states" Exit (map, None) + in + let error, views = + Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite parameter error + agent_id (agent_type, new_map) t.views + in + (match range_opt with + | None -> error, t + | Some (state_min, state_max) -> + let error, is_binding_site = + Handler.is_binding_site parameter error kappa_handler agent_type site in - let error = - if b_counter then error - else - match state_max with - | Some state_max -> - let error, _ = - Handler.translate_state - ~ml_pos:(Some __POS__) - ~message:"undefined site state" - parameter error kappa_handler - agent_type site state_max + let ( error, + (internal_state_string_opt, binding_state_opt, counter_state_opt) + ) = + match + state_min = state_max, is_binding_site, b_counter, state_min + with + | true, true, false, Some state_min -> + if state_min = Ckappa_sig.dummy_state_index then + error, (None, Some Free, None) + else ( + let error, triple_opt = + Handler.dual parameter error kappa_handler agent_type site + state_min in - error - | None -> error - in - let error, old_asso = - Ckappa_sig.Site_map_and_set.Map.find_option_without_logs - parameter error - site map - in - let error, (new_map, range_opt) = - match old_asso with - | None -> - let error , map = - Ckappa_sig.Site_map_and_set.Map.add - parameter error - site (state_min,state_max) - map - in - error, (map, Some (state_min, state_max)) - | Some (old_min, old_max) -> - if - Ckappa_sig.compare_state_index_option_min old_min state_min <= - 0 - || Ckappa_sig.compare_state_index_option_max state_max old_max <= - 0 - then - let new_min = - Cckappa_sig.max_state_index_option_min state_min - old_min + let error, (agent_type', site') = + match triple_opt with + | None -> + Exception.warn parameter error __POS__ Exit + (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_site_name) + | Some (agent_type', site', _) -> error, (agent_type', site') in - let new_max = Cckappa_sig.min_state_index_option_max state_max old_max in - let error', map = - Ckappa_sig.Site_map_and_set.Map.overwrite - parameter error - site (new_min,new_max) - map + let error, agent_string' = + Handler.translate_agent ~message:"unknown agent type" + ~ml_pos:(Some __POS__) parameter error kappa_handler + agent_type' in - let error = - Exception.check_point - Exception.warn - parameter error error' __POS__ Exit + let error, site_string' = + Handler.string_of_site_contact_map parameter error kappa_handler + agent_type' site' in - error, (map, Some (new_min, new_max)) + ( error, + (None, Some (Binding_type (agent_string', site_string')), None) + ) + ) + | true, false, false, Some state_min -> + let error, state_string = + Handler.string_of_state parameter error kappa_handler agent_type + site state_min + in + error, (Some state_string, None, None) + | false, true, false, _ | _, true, false, None -> + if state_min = Some Ckappa_sig.dummy_state_index then + error, (None, Some Wildcard, None) else - Exception.warn - parameter error __POS__ - ~message:"incompatible states" - Exit (map, None) + error, (None, Some Bound_to_unknown, None) + | _, false, true, _ -> error, (None, None, Some (state_min, state_max)) + | false, false, false, _ | _, false, false, None | _, true, true, _ -> + Exception.warn parameter error __POS__ Exit (None, None, None) in - let error, views = - Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite - parameter error - agent_id (agent_type, new_map) - t.views + let error, (agent_string, sitemap) = + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error + ("", Wrapped_modules.LoggedStringMap.empty) + agent_id t.string_version in - match range_opt with - | None -> error, t - | Some (state_min,state_max) -> - let error, is_binding_site = - Handler.is_binding_site parameter error kappa_handler - agent_type site - in - let error, - (internal_state_string_opt, binding_state_opt, counter_state_opt) = - match state_min = state_max, is_binding_site, b_counter, state_min with - | true, true, false, Some state_min -> - if state_min = Ckappa_sig.dummy_state_index - then - error, (None, Some Free, None) - else - let error, triple_opt = - Handler.dual - parameter error kappa_handler - agent_type site state_min - in - let error, (agent_type', site') = - match triple_opt with - | None -> - Exception.warn - parameter error __POS__ - Exit - (Ckappa_sig.dummy_agent_name, Ckappa_sig.dummy_site_name) - | Some (agent_type', site', _) -> - error, (agent_type', site') - in - let error, agent_string' = - Handler.translate_agent - ~message:"unknown agent type" - ~ml_pos:(Some __POS__) - parameter error kappa_handler - agent_type' - in - let error, site_string' = - Handler.string_of_site_contact_map - parameter error kappa_handler - agent_type' site' - in - error, - (None, Some (Binding_type (agent_string',site_string')), None) - | true, false, false, Some state_min -> - let error, state_string = - Handler.string_of_state - parameter error kappa_handler - agent_type site state_min - in - error, (Some state_string, None, None) - | false, true, false, _ | _, true, false, None-> - if state_min = Some Ckappa_sig.dummy_state_index - then error, (None, Some Wildcard, None) - else error, (None, Some Bound_to_unknown, None) - | _, false, true, _ -> - error, (None, None, Some (state_min, state_max)) - | false,false,false, _ | _, false,false, None - | _, true, true, _ -> - begin - Exception.warn - parameter error __POS__ - Exit (None, None, None) - end - in - let error, (agent_string, sitemap) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error - ("",Wrapped_modules.LoggedStringMap.empty) - agent_id - t.string_version - in - let error, (old_state,old_binding,old_counter) = - Wrapped_modules.LoggedStringMap.find_default_without_logs - parameter error - (None,None,None) - site_string - sitemap - in - let new_internal_state = - match internal_state_string_opt with - | None -> old_state - | Some x -> Some x - in - let new_counter_state = - match counter_state_opt with - | None -> old_counter - | Some (inf, sup) -> - let inf = - match inf with - | None -> None - | Some a -> Some (Ckappa_sig.int_of_state_index a) - in - let sup = - match sup with - | None -> None - | Some a -> Some (Ckappa_sig.int_of_state_index a) - in - begin - match old_counter with - | None -> Some (inf,sup) - | Some (inf', sup') -> - Some (max inf inf',min sup sup') - end - in - let error, new_binding_state = - match - binding_state_opt - with - | None -> - error, old_binding - | Some _ -> error, binding_state_opt - in - let error, sitemap = - Wrapped_modules.LoggedStringMap.add_or_overwrite - parameter error - site_string - (new_internal_state,new_binding_state,new_counter_state) - sitemap - in - let error', string_version = - Ckappa_sig.Agent_id_map_and_set.Map.overwrite - parameter error - agent_id - (agent_string, sitemap) - t.string_version - in - let error = - Exception.check_point - Exception.warn - parameter error error' __POS__ Exit - in - error, - { - t - with views = views ; - string_version = string_version - } - end + let error, (old_state, old_binding, old_counter) = + Wrapped_modules.LoggedStringMap.find_default_without_logs parameter + error (None, None, None) site_string sitemap + in + let new_internal_state = + match internal_state_string_opt with + | None -> old_state + | Some x -> Some x + in + let new_counter_state = + match counter_state_opt with + | None -> old_counter + | Some (inf, sup) -> + let inf = + match inf with + | None -> None + | Some a -> Some (Ckappa_sig.int_of_state_index a) + in + let sup = + match sup with + | None -> None + | Some a -> Some (Ckappa_sig.int_of_state_index a) + in + (match old_counter with + | None -> Some (inf, sup) + | Some (inf', sup') -> Some (max inf inf', min sup sup')) + in + let error, new_binding_state = + match binding_state_opt with + | None -> error, old_binding + | Some _ -> error, binding_state_opt + in + let error, sitemap = + Wrapped_modules.LoggedStringMap.add_or_overwrite parameter error + site_string + (new_internal_state, new_binding_state, new_counter_state) + sitemap + in + let error', string_version = + Ckappa_sig.Agent_id_map_and_set.Map.overwrite parameter error agent_id + (agent_string, sitemap) t.string_version + in + let error = + Exception.check_point Exception.warn parameter error error' __POS__ + Exit + in + error, { t with views; string_version }) - let add_state parameter error kappa_handler agent_id site - state t = - add_state_interv parameter error kappa_handler agent_id site - (Some state) (Some state) t + let add_state parameter error kappa_handler agent_id site state t = + add_state_interv parameter error kappa_handler agent_id site (Some state) + (Some state) t - let add_counter_range parameter error kappa_handler agent_id site ?inf ?sup t = + let add_counter_range parameter error kappa_handler agent_id site ?inf ?sup t + = let inf = match inf with | None -> None @@ -512,172 +410,121 @@ struct | None -> None | Some i -> Some (Ckappa_sig.state_index_of_int i) in - add_state_interv parameter error kappa_handler agent_id site - inf sup t - + add_state_interv parameter error kappa_handler agent_id site inf sup t - - let add_bound_to_unknown - parameter error kappa_handler - agent_id site t = + let add_bound_to_unknown parameter error kappa_handler agent_id site t = let error, (agent_type, _) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error (Ckappa_sig.dummy_agent_name, Ckappa_sig.Site_map_and_set.Map.empty) - agent_id - t.views + agent_id t.views in let error, state_max = - Handler.last_state_of_site - parameter error kappa_handler - agent_type site + Handler.last_state_of_site parameter error kappa_handler agent_type site in add_state_interv parameter error kappa_handler agent_id site (Some Ckappa_sig.dummy_state_index_1) (Some state_max) t let add_bond_to parameter error kappa_handler agent_id site bond_id t = let error, (agent_type, _) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error (Ckappa_sig.dummy_agent_name, Ckappa_sig.Site_map_and_set.Map.empty) - agent_id - t.views + agent_id t.views in let error, old_site_map = - Ckappa_sig.Agent_id_map_and_set.Map.find_default_without_logs - parameter error - Ckappa_sig.Site_map_and_set.Map.empty - agent_id - t.bonds + Ckappa_sig.Agent_id_map_and_set.Map.find_default_without_logs parameter + error Ckappa_sig.Site_map_and_set.Map.empty agent_id t.bonds in let error, new_site_map = - Ckappa_sig.Site_map_and_set.Map.add - parameter error - site - bond_id + Ckappa_sig.Site_map_and_set.Map.add parameter error site bond_id old_site_map in let error', new_bonds = - Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite - parameter error - agent_id - new_site_map - t.bonds + Ckappa_sig.Agent_id_map_and_set.Map.add_or_overwrite parameter error + agent_id new_site_map t.bonds in let error = - Exception.check_point - Exception.warn - parameter error error' __POS__ Exit + Exception.check_point Exception.warn parameter error error' __POS__ Exit in let error, (agent_string, old_site_map) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error - ("",Wrapped_modules.LoggedStringMap.empty) - agent_id - t.string_version + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error + ("", Wrapped_modules.LoggedStringMap.empty) + agent_id t.string_version in let error, site_string = - Handler.string_of_site_contact_map parameter error kappa_handler agent_type site + Handler.string_of_site_contact_map parameter error kappa_handler + agent_type site in - let error, (old_internal, _old_binding,old_counter) = - Wrapped_modules.LoggedStringMap.find_default_without_logs - parameter error - (None,None,None) - site_string - old_site_map + let error, (old_internal, _old_binding, old_counter) = + Wrapped_modules.LoggedStringMap.find_default_without_logs parameter error + (None, None, None) site_string old_site_map in let error, new_site_map = - Wrapped_modules.LoggedStringMap.add_or_overwrite - parameter error + Wrapped_modules.LoggedStringMap.add_or_overwrite parameter error site_string (old_internal, Some (Bound_to bond_id), old_counter) old_site_map in let error', string_version = - Ckappa_sig.Agent_id_map_and_set.Map.overwrite - parameter error - agent_id + Ckappa_sig.Agent_id_map_and_set.Map.overwrite parameter error agent_id (agent_string, new_site_map) t.string_version in let error = - Exception.check_point - Exception.warn - parameter error error' __POS__ Exit + Exception.check_point Exception.warn parameter error error' __POS__ Exit in - error, - {t with bonds = new_bonds ; string_version = string_version} + error, { t with bonds = new_bonds; string_version } - let add_bond_type - parameter error kappa_handler - agent_id site agent_name' site' t = + let add_bond_type parameter error kappa_handler agent_id site agent_name' + site' t = let error, (agent_type, _) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error (Ckappa_sig.dummy_agent_name, Ckappa_sig.Site_map_and_set.Map.empty) - agent_id - t.views + agent_id t.views in let error, state_id = - Handler.id_of_binding_type - parameter error kappa_handler - agent_type site agent_name' site' + Handler.id_of_binding_type parameter error kappa_handler agent_type site + agent_name' site' in - add_state parameter error kappa_handler - agent_id site state_id t + add_state parameter error kappa_handler agent_id site state_id t - let add_bond - parameter error kappa_handler - agent_id site agent_id' site' t = + let add_bond parameter error kappa_handler agent_id site agent_id' site' t = let bond_id = t.fresh_bond_id in let error_ref = error in let error, (agent_type, _) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error (Ckappa_sig.dummy_agent_name, Ckappa_sig.Site_map_and_set.Map.empty) - agent_id - t.views + agent_id t.views in let error, (agent_type', _) = - Ckappa_sig.Agent_id_map_and_set.Map.find_default - parameter error + Ckappa_sig.Agent_id_map_and_set.Map.find_default parameter error (Ckappa_sig.dummy_agent_name, Ckappa_sig.Site_map_and_set.Map.empty) - agent_id' - t.views + agent_id' t.views in let error, state_id = - Handler.id_of_binding_type - parameter error kappa_handler - agent_type site agent_type' site' + Handler.id_of_binding_type parameter error kappa_handler agent_type site + agent_type' site' in let error, state_id' = - Handler.id_of_binding_type - parameter error kappa_handler - agent_type' site' agent_type site + Handler.id_of_binding_type parameter error kappa_handler agent_type' site' + agent_type site in let error, t = - add_state - parameter error kappa_handler agent_id site state_id t + add_state parameter error kappa_handler agent_id site state_id t in let error, t = - add_state - parameter error kappa_handler agent_id' site' state_id' t + add_state parameter error kappa_handler agent_id' site' state_id' t in - if error == error_ref - then + if error == error_ref then ( let error, t = add_bond_to parameter error kappa_handler agent_id site bond_id t in let error, t = add_bond_to parameter error kappa_handler agent_id' site' bond_id t in - error, - {t with fresh_bond_id = t.fresh_bond_id +1 } - else - Exception.warn - parameter error __POS__ - ~message:"incompatible binding states" - Exit t + error, { t with fresh_bond_id = t.fresh_bond_id + 1 } + ) else + Exception.warn parameter error __POS__ + ~message:"incompatible binding states" Exit t let print_agent logger parameter error agent_string site_map bool = let () = @@ -685,165 +532,150 @@ struct Loggers.fprintf logger "%s" (Remanent_parameters.get_site_sep_comma_symbol parameter) in - let () = Loggers.fprintf logger "%s%s" agent_string + let () = + Loggers.fprintf logger "%s%s" agent_string (Remanent_parameters.get_agent_open_symbol parameter) in let _ = Wrapped_modules.LoggedStringMap.fold - (fun site_string (internal,binding,counter) bool -> - let () = - if bool then - Loggers.fprintf logger - "%s" - (Remanent_parameters.get_site_sep_comma_symbol parameter) - in - let () = Loggers.fprintf logger "%s" site_string in - let () = - match internal with - | None -> () - | Some s -> - Loggers.fprintf - logger "%s%s%s%s" - (Remanent_parameters.get_open_internal_state parameter) - (Remanent_parameters.get_internal_state_symbol parameter) - s - (Remanent_parameters.get_close_internal_state parameter) - in - let () = - match binding with - | None -> - Loggers.fprintf logger - "%s" - (Remanent_parameters.get_missing_binding_state parameter) - - | Some Free -> - Loggers.fprintf logger - "%s%s%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_free_symbol parameter) - (Remanent_parameters.get_close_binding_state parameter) - | Some Wildcard -> - Loggers.fprintf logger "%s%s%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_link_to_any parameter) - (Remanent_parameters.get_close_binding_state parameter) - | Some Bound_to_unknown -> - Loggers.fprintf logger "%s%s%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_link_to_some parameter) - (Remanent_parameters.get_close_binding_state parameter) - | Some (Bound_to int) -> - Loggers.fprintf logger "%s%s%i%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_bound_symbol parameter) - int - (Remanent_parameters.get_close_binding_state parameter) - | Some (Binding_type (agent_name,site_name)) -> - let binding_type_symbol = - Remanent_parameters.get_btype_sep_symbol parameter - in - let binding = - Public_data.string_of_binding_type - ~binding_type_symbol ~agent_name ~site_name () - in - Loggers.fprintf logger - "%s%s%s%s" - (Remanent_parameters.get_open_binding_state parameter) - (Remanent_parameters.get_bound_symbol parameter) - binding - (Remanent_parameters.get_close_binding_state parameter) - in - let () = - match counter with - | None | Some (None, None) - -> () - | Some (None, Some i) -> - Loggers.fprintf logger - ":%s%s%s%i%s" - (Remanent_parameters.get_open_int_interval_infinity_symbol parameter) - (Remanent_parameters.get_minus_infinity_symbol parameter) - (Remanent_parameters.get_int_interval_separator_symbol parameter) - i - (Remanent_parameters.get_close_int_interval_inclusive_symbol parameter) - | Some (Some i, None) -> - Loggers.fprintf logger - ":%s%i%s%s%s" - (Remanent_parameters.get_open_int_interval_inclusive_symbol parameter) - i - (Remanent_parameters.get_int_interval_separator_symbol parameter) - (Remanent_parameters.get_plus_infinity_symbol parameter) - (Remanent_parameters.get_close_int_interval_infinity_symbol parameter) - | Some (Some i, Some j) -> - Loggers.fprintf logger - ":%s%i%s%i%s" - (Remanent_parameters.get_open_int_interval_inclusive_symbol parameter) - i - (Remanent_parameters.get_int_interval_separator_symbol parameter) - j - (Remanent_parameters.get_close_int_interval_inclusive_symbol parameter) - in - true - ) site_map false + (fun site_string (internal, binding, counter) bool -> + let () = + if bool then + Loggers.fprintf logger "%s" + (Remanent_parameters.get_site_sep_comma_symbol parameter) + in + let () = Loggers.fprintf logger "%s" site_string in + let () = + match internal with + | None -> () + | Some s -> + Loggers.fprintf logger "%s%s%s%s" + (Remanent_parameters.get_open_internal_state parameter) + (Remanent_parameters.get_internal_state_symbol parameter) + s + (Remanent_parameters.get_close_internal_state parameter) + in + let () = + match binding with + | None -> + Loggers.fprintf logger "%s" + (Remanent_parameters.get_missing_binding_state parameter) + | Some Free -> + Loggers.fprintf logger "%s%s%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_free_symbol parameter) + (Remanent_parameters.get_close_binding_state parameter) + | Some Wildcard -> + Loggers.fprintf logger "%s%s%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_link_to_any parameter) + (Remanent_parameters.get_close_binding_state parameter) + | Some Bound_to_unknown -> + Loggers.fprintf logger "%s%s%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_link_to_some parameter) + (Remanent_parameters.get_close_binding_state parameter) + | Some (Bound_to int) -> + Loggers.fprintf logger "%s%s%i%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_bound_symbol parameter) + int + (Remanent_parameters.get_close_binding_state parameter) + | Some (Binding_type (agent_name, site_name)) -> + let binding_type_symbol = + Remanent_parameters.get_btype_sep_symbol parameter + in + let binding = + Public_data.string_of_binding_type ~binding_type_symbol + ~agent_name ~site_name () + in + Loggers.fprintf logger "%s%s%s%s" + (Remanent_parameters.get_open_binding_state parameter) + (Remanent_parameters.get_bound_symbol parameter) + binding + (Remanent_parameters.get_close_binding_state parameter) + in + let () = + match counter with + | None | Some (None, None) -> () + | Some (None, Some i) -> + Loggers.fprintf logger ":%s%s%s%i%s" + (Remanent_parameters.get_open_int_interval_infinity_symbol + parameter) + (Remanent_parameters.get_minus_infinity_symbol parameter) + (Remanent_parameters.get_int_interval_separator_symbol parameter) + i + (Remanent_parameters.get_close_int_interval_inclusive_symbol + parameter) + | Some (Some i, None) -> + Loggers.fprintf logger ":%s%i%s%s%s" + (Remanent_parameters.get_open_int_interval_inclusive_symbol + parameter) + i + (Remanent_parameters.get_int_interval_separator_symbol parameter) + (Remanent_parameters.get_plus_infinity_symbol parameter) + (Remanent_parameters.get_close_int_interval_infinity_symbol + parameter) + | Some (Some i, Some j) -> + Loggers.fprintf logger ":%s%i%s%i%s" + (Remanent_parameters.get_open_int_interval_inclusive_symbol + parameter) + i + (Remanent_parameters.get_int_interval_separator_symbol parameter) + j + (Remanent_parameters.get_close_int_interval_inclusive_symbol + parameter) + in + true) + site_map false in let () = - Loggers.fprintf logger - "%s" + Loggers.fprintf logger "%s" (Remanent_parameters.get_agent_close_symbol parameter) in error - let print logger parameter error t = - let error,_ = + let print logger parameter error t = + let error, _ = Ckappa_sig.Agent_id_map_and_set.Map.fold - (fun _ (agent_string, site_map) (error,bool) -> - let error = - print_agent logger parameter error - agent_string site_map bool - in - error, true - ) - t.string_version - (error, false) - in error - - - + (fun _ (agent_string, site_map) (error, bool) -> + let error = + print_agent logger parameter error agent_string site_map bool + in + error, true) + t.string_version (error, false) + in + error (***************************************************************************) let print_list logger parameter error _kappa_handler list = match list with | [] -> error - | [a] -> print logger parameter error a - | _::_ -> - begin - let () = Loggers.fprintf logger "%s " - (Remanent_parameters.get_open_binding_state parameter) - in - let error,_ = - List.fold_left - (fun (error, bool) pattern -> - let () = - if bool then - Loggers.fprintf logger " v " - in - print logger parameter error pattern,true) - (error, false) - list in - let () = Loggers.fprintf logger " %s" - (Remanent_parameters.get_close_binding_state parameter) - in - error - end + | [ a ] -> print logger parameter error a + | _ :: _ -> + let () = + Loggers.fprintf logger "%s " + (Remanent_parameters.get_open_binding_state parameter) + in + let error, _ = + List.fold_left + (fun (error, bool) pattern -> + let () = if bool then Loggers.fprintf logger " v " in + print logger parameter error pattern, true) + (error, false) list + in + let () = + Loggers.fprintf logger " %s" + (Remanent_parameters.get_close_binding_state parameter) + in + error - let to_string parameters error t = + let to_string parameters error t = let buffer = Buffer.create 1 in let string_fmt = Format.formatter_of_buffer buffer in let logger = Loggers.open_logger_from_formatter string_fmt in - let error = - print logger parameters error t - in + let error = print logger parameters error t in let () = Format.pp_print_flush string_fmt () in error, Buffer.contents buffer - end diff --git a/core/KaSa_rep/site_graphs/site_graphs.mli b/core/KaSa_rep/site_graphs/site_graphs.mli index 33d64a4911..dcf081f14d 100644 --- a/core/KaSa_rep/site_graphs/site_graphs.mli +++ b/core/KaSa_rep/site_graphs/site_graphs.mli @@ -1 +1 @@ -module KaSa_site_graph: Kasa_site_graphs_sig.Site_graph +module KaSa_site_graph : Kasa_site_graphs_sig.Site_graph diff --git a/core/KaSa_rep/type_interface/dune b/core/KaSa_rep/type_interface/dune index 1328e63114..b1135bf18a 100644 --- a/core/KaSa_rep/type_interface/dune +++ b/core/KaSa_rep/type_interface/dune @@ -1,6 +1,5 @@ (library - (name kappa_kasa_type_interface) - (libraries yojson kappa-library.mixtures) - (flags (:standard -w @a - -open Kappa_generic_toolset - -open Kappa_mixtures))) + (name kappa_kasa_type_interface) + (libraries yojson kappa-library.mixtures) + (flags + (:standard -w @a -open Kappa_generic_toolset -open Kappa_mixtures))) diff --git a/core/KaSa_rep/type_interface/public_data.ml b/core/KaSa_rep/type_interface/public_data.ml index ed7049a90b..77c377fa29 100644 --- a/core/KaSa_rep/type_interface/public_data.ml +++ b/core/KaSa_rep/type_interface/public_data.ml @@ -10,15 +10,15 @@ (* JSon labels*) (**************) -let agent="agent name" -let contactmap="contact map" +let agent = "agent name" +let contactmap = "contact map" let accuracy_string = "accuracy" let dead_rules = "dead rules" let dead_agents = "dead agents" let map = "map" -let interface="interface" -let site="site name" -let stateslist="states list" +let interface = "interface" +let site = "site name" +let stateslist = "states list" let sitename = "site_name" let sitetype = "site_type" let sitelinks = "port_links" @@ -30,7 +30,7 @@ let hyp = "site graph" let refinement = "site graph list" let domain_name = "domain name" let refinements_list = "refinements list" -let refinement_lemmas="refinement lemmas" +let refinement_lemmas = "refinement lemmas" let rule_id = "id" let agent_id = "id" let label = "label" @@ -47,8 +47,8 @@ let target = "target" let location_pair_list = "location pair list" let rhs = "RHS" let lhs = "LHS" -let influencemap="influence map" -let nodesofinfluencemap="nodes of influence map" +let influencemap = "influence map" +let nodesofinfluencemap = "nodes of influence map" let wakeup = "wake-up map" let inhibition = "inhibition map" let nodes = "nodes" @@ -61,7 +61,7 @@ let rule_hidden = "hidden" let scc = "scc" let accuracy_cm = "accuracy_cm" let accuracy_scc = "accuracy_scc" -let contactmapscc="contact map scc" +let contactmapscc = "contact map scc" let counter = "counter" let inf = "min" let sup = "max" @@ -73,10 +73,12 @@ let locality = "locality" (*******************) type accuracy_level = Low | Medium | High | Full + let accuracy_levels = [ Low; Medium; High; Full ] let contact_map_accuracy_levels = [ Low; High ] -let influence_map_accuracy_levels = [ Low; Medium; High] -let reduction_accuracy_levels = [Low; High] +let influence_map_accuracy_levels = [ Low; Medium; High ] +let reduction_accuracy_levels = [ Low; High ] + let accuracy_to_string = function | Low -> "low" | Medium -> "medium" @@ -97,33 +99,32 @@ let accuracy_of_json json = | Some x -> x | None -> raise - (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "accuracy level",json)) + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "accuracy level", json)) (******************************************************************) -module AccuracySetMap = - SetMap.Make - (struct - type t = accuracy_level - let compare a b = - match a,b with - | Low,Low -> 0 - | Low,_ -> -1 - | _,Low -> 1 - | Medium,Medium -> 0 - | Medium,_ -> -1 - | _,Medium -> 1 - | High, High -> 0 - | High,_ -> -1 - | _,High -> 1 - | Full,Full -> 0 - - let print f = function - | Full -> Format.fprintf f "Full" - | High -> Format.fprintf f "High" - | Medium -> Format.fprintf f "Medium" - | Low -> Format.fprintf f "Low" - end) +module AccuracySetMap = SetMap.Make (struct + type t = accuracy_level + + let compare a b = + match a, b with + | Low, Low -> 0 + | Low, _ -> -1 + | _, Low -> 1 + | Medium, Medium -> 0 + | Medium, _ -> -1 + | _, Medium -> 1 + | High, High -> 0 + | High, _ -> -1 + | _, High -> 1 + | Full, Full -> 0 + + let print f = function + | Full -> Format.fprintf f "Full" + | High -> Format.fprintf f "High" + | Medium -> Format.fprintf f "Medium" + | Low -> Format.fprintf f "Low" +end) module AccuracyMap = AccuracySetMap.Map @@ -138,236 +139,197 @@ type contact_map = User_graph.connected_component let site_type_to_json = function | User_graph.Counter i -> `List [ `String "counter"; `Int i ] | User_graph.Port p -> - `List [ - `String "port"; - `Assoc [ - sitelinks, - (match p.User_graph.port_links with - | User_graph.LINKS l -> - JsonUtil.of_list (fun ((xl,xr),y) -> `List [`List [`Int xl; `Int xr]; `Int y]) l - | User_graph.WHATEVER -> `Null - | User_graph.SOME -> `Bool true - | User_graph.TYPE (si,ty) -> - `Assoc [ "site_name",`String si;"port_name",`String ty]); - sitestates, - JsonUtil.of_option (JsonUtil.of_list JsonUtil.of_string) - p.User_graph.port_states + `List + [ + `String "port"; + `Assoc + [ + ( sitelinks, + match p.User_graph.port_links with + | User_graph.LINKS l -> + JsonUtil.of_list + (fun ((xl, xr), y) -> + `List [ `List [ `Int xl; `Int xr ]; `Int y ]) + l + | User_graph.WHATEVER -> `Null + | User_graph.SOME -> `Bool true + | User_graph.TYPE (si, ty) -> + `Assoc [ "site_name", `String si; "port_name", `String ty ] ); + ( sitestates, + JsonUtil.of_option + (JsonUtil.of_list JsonUtil.of_string) + p.User_graph.port_states ); + ]; ] - ] let site_to_json site = `Assoc [ sitename, JsonUtil.of_string site.User_graph.site_name; - sitetype, site_type_to_json site.User_graph.site_type + sitetype, site_type_to_json site.User_graph.site_type; ] let site_type_of_json = function | `List [ `String "counter"; `Int i ] -> User_graph.Counter i | `List [ `String "port"; `Assoc l ] as x -> - begin - try - let port_links = - let json = List.assoc sitelinks l in - User_graph.links_of_yojson json in - let port_states = - let json = List.assoc sitestates l in - JsonUtil.to_option - (JsonUtil.to_list ~error_msg:"state list" - (JsonUtil.to_string ~error_msg:"state")) - json - in - User_graph.Port { User_graph.port_links; User_graph.port_states } - with - | _ -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node type",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node type",x)) - -let site_of_json = - function - | `Assoc l as x -> - begin - try - let site_name = - let json = List.assoc sitename l in - JsonUtil.to_string json - in - let site_type = - let json = List.assoc sitetype l in - site_type_of_json json - in - { - User_graph.site_name; - User_graph.site_type; - } - with - | _ -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node",x)) - - -let site_node_sites_to_json list = - JsonUtil.of_array site_to_json list + (try + let port_links = + let json = List.assoc sitelinks l in + User_graph.links_of_yojson json + in + let port_states = + let json = List.assoc sitestates l in + JsonUtil.to_option + (JsonUtil.to_list ~error_msg:"state list" + (JsonUtil.to_string ~error_msg:"state")) + json + in + User_graph.Port { User_graph.port_links; User_graph.port_states } + with _ -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node type", x))) + | x -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node type", x)) + +let site_of_json = function + | `Assoc l as x -> + (try + let site_name = + let json = List.assoc sitename l in + JsonUtil.to_string json + in + let site_type = + let json = List.assoc sitetype l in + site_type_of_json json + in + { User_graph.site_name; User_graph.site_type } + with _ -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node", x))) + | x -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node", x)) + +let site_node_sites_to_json list = JsonUtil.of_array site_to_json list let site_node_sites_of_json = - JsonUtil.to_array - ~error_msg:"site node sites" - site_of_json + JsonUtil.to_array ~error_msg:"site node sites" site_of_json let site_node_to_json = function | None -> `Null | Some node -> `Assoc - [ sitenodename, - JsonUtil.of_string node.User_graph.node_type; - - sitenodesites, - site_node_sites_to_json node.User_graph.node_sites] - -let site_node_of_json = -function -| `Assoc l as x -> - begin - try - let node_id = - let json = List.assoc_opt sitenodeid l in - Option_util.map (JsonUtil.to_int ?error_msg:None) json - in - let node_type = - let json = List.assoc sitenodename l in - JsonUtil.to_string json - in - let node_sites = - let json = List.assoc sitenodesites l in - site_node_sites_of_json json - in - Some { - User_graph.node_type; - User_graph.node_id; - User_graph.node_sites - } - with - | _ -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node",x)) - end -| x -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node",x)) + [ + sitenodename, JsonUtil.of_string node.User_graph.node_type; + sitenodesites, site_node_sites_to_json node.User_graph.node_sites; + ] + +let site_node_of_json = function + | `Assoc l as x -> + (try + let node_id = + let json = List.assoc_opt sitenodeid l in + Option_util.map (JsonUtil.to_int ?error_msg:None) json + in + let node_type = + let json = List.assoc sitenodename l in + JsonUtil.to_string json + in + let node_sites = + let json = List.assoc sitenodesites l in + site_node_sites_of_json json + in + Some { User_graph.node_type; User_graph.node_id; User_graph.node_sites } + with _ -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node", x))) + | x -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "site node", x)) let contact_map_to_json contact_map = `Assoc - [contactmap, - JsonUtil.of_pair - ~lab1:accuracy_string ~lab2:map - accuracy_to_json - (JsonUtil.of_array (JsonUtil.of_array site_node_to_json)) - contact_map + [ + ( contactmap, + JsonUtil.of_pair ~lab1:accuracy_string ~lab2:map accuracy_to_json + (JsonUtil.of_array (JsonUtil.of_array site_node_to_json)) + contact_map ); ] -let contact_map_of_json = - function +let contact_map_of_json = function | `Assoc l as x -> - begin - try - let json = List.assoc contactmap l in - JsonUtil.to_pair - ~lab1:accuracy_string ~lab2:map - ~error_msg:(JsonUtil.build_msg "contact map") - accuracy_of_json - (JsonUtil.to_array - ~error_msg:(JsonUtil.build_msg "site nodes list") - (JsonUtil.to_array - ~error_msg:(JsonUtil.build_msg "site nodes list") - site_node_of_json) - ) - json - with - | _ -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "contact map",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "contact map",x)) + (try + let json = List.assoc contactmap l in + JsonUtil.to_pair ~lab1:accuracy_string ~lab2:map + ~error_msg:(JsonUtil.build_msg "contact map") + accuracy_of_json + (JsonUtil.to_array + ~error_msg:(JsonUtil.build_msg "site nodes list") + (JsonUtil.to_array + ~error_msg:(JsonUtil.build_msg "site nodes list") + site_node_of_json)) + json + with _ -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "contact map", x))) + | x -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "contact map", x)) (**********************************************************) (*strongly connected component*) type scc = ((string * string) * (string * string)) list list -let string_pair_to_json (a,b) = - JsonUtil.of_pair - ~lab1:agent ~lab2:sitename - JsonUtil.of_string - JsonUtil.of_string - (a,b) +let string_pair_to_json (a, b) = + JsonUtil.of_pair ~lab1:agent ~lab2:sitename JsonUtil.of_string + JsonUtil.of_string (a, b) -let string_pair_of_json (json:Yojson.Basic.t) : string * string = +let string_pair_of_json (json : Yojson.Basic.t) : string * string = JsonUtil.to_pair ~lab1:agent ~lab2:sitename ~error_msg:"site" - (JsonUtil.to_string ~error_msg:"agent name") - (JsonUtil.to_string ~error_msg:"site_name") - json + (JsonUtil.to_string ~error_msg:"agent name") + (JsonUtil.to_string ~error_msg:"site_name") + json -let string_pair_pair_to_json (a,b) = - JsonUtil.of_pair - string_pair_to_json - string_pair_to_json - (a,b) +let string_pair_pair_to_json (a, b) = + JsonUtil.of_pair string_pair_to_json string_pair_to_json (a, b) let string_pair_pair_of_json json : (string * string) * (string * string) = - JsonUtil.to_pair ~error_msg:"bond" - string_pair_of_json - string_pair_of_json + JsonUtil.to_pair ~error_msg:"bond" string_pair_of_json string_pair_of_json json let string_pair_pair_list_to_json l = - JsonUtil.of_list - string_pair_pair_to_json - l + JsonUtil.of_list string_pair_pair_to_json l let string_pair_pair_list_of_json json = - JsonUtil.to_list ~error_msg:"list_of_bonds" - string_pair_pair_of_json json + JsonUtil.to_list ~error_msg:"list_of_bonds" string_pair_pair_of_json json let string_pair_pair_list_list_to_json l = - JsonUtil.of_list - string_pair_pair_list_to_json - l + JsonUtil.of_list string_pair_pair_list_to_json l let string_pair_pair_list_list_of_json json = JsonUtil.to_list ~error_msg:"list_of_lists_of_bonds" string_pair_pair_list_of_json json -let scc_to_json (cm_acc,scc_acc,scc) = - `Assoc [ - contactmapscc, - JsonUtil.of_triple - ~lab1:accuracy_cm ~lab2:accuracy_scc ~lab3:map - accuracy_to_json - accuracy_to_json - string_pair_pair_list_list_to_json - (cm_acc, scc_acc, scc) - ] - +let scc_to_json (cm_acc, scc_acc, scc) = + `Assoc + [ + ( contactmapscc, + JsonUtil.of_triple ~lab1:accuracy_cm ~lab2:accuracy_scc ~lab3:map + accuracy_to_json accuracy_to_json string_pair_pair_list_list_to_json + (cm_acc, scc_acc, scc) ); + ] -let scc_of_json = - function +let scc_of_json = function | `Assoc l as x -> - begin - try - let json = List.assoc contactmapscc l in - JsonUtil.to_triple - ~lab1:accuracy_cm ~lab2:accuracy_scc ~lab3:map - ~error_msg:"scc decomposition" - accuracy_of_json - accuracy_of_json - string_pair_pair_list_list_of_json - json - with - | _ -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "scc decomposition",x)) - - end + (try + let json = List.assoc contactmapscc l in + JsonUtil.to_triple ~lab1:accuracy_cm ~lab2:accuracy_scc ~lab3:map + ~error_msg:"scc decomposition" accuracy_of_json accuracy_of_json + string_pair_pair_list_list_of_json json + with _ -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "scc decomposition", x))) | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "scc decomposition",x)) - - + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "scc decomposition", x)) (******************************************************************************) @@ -382,16 +344,14 @@ type rule_direction = | Dummy_rule_direction | Variable - -type rule = - { - rule_id: int; - rule_label: string ; - rule_ast: string; - rule_position: Locality.t; - rule_direction: rule_direction; - rule_hidden: bool; - } +type rule = { + rule_id: int; + rule_label: string; + rule_ast: string; + rule_position: Loc.t; + rule_direction: rule_direction; + rule_hidden: bool; +} let direction_to_json d = match d with @@ -401,7 +361,6 @@ let direction_to_json d = | Dummy_rule_direction -> `String "dummy" | Variable -> `String "variable" - let json_to_direction s = match s with | `String "direct" -> Direct_rule @@ -409,105 +368,85 @@ let json_to_direction s = | `String "both" -> Both_directions | `String "dummy" -> Dummy_rule_direction | `String "variable" -> Variable - | x -> - raise (Yojson.Basic.Util.Type_error ("rule direction",x)) - + | x -> raise (Yojson.Basic.Util.Type_error ("rule direction", x)) let rule_to_json rule = `Assoc [ - rule_id,JsonUtil.of_int rule.rule_id; + rule_id, JsonUtil.of_int rule.rule_id; label, JsonUtil.of_string rule.rule_label; ast, JsonUtil.of_string rule.rule_ast; - position,Locality.annot_to_yojson - JsonUtil.of_unit ((),rule.rule_position); + position, Loc.yojson_of_annoted JsonUtil.of_unit ((), rule.rule_position); direction, direction_to_json rule.rule_direction; - rule_hidden, JsonUtil.of_bool rule.rule_hidden + rule_hidden, JsonUtil.of_bool rule.rule_hidden; ] -let json_to_rule = - function +let json_to_rule = function | `Assoc l as x when List.length l = 6 -> - begin - try - { - rule_id = JsonUtil.to_int (List.assoc rule_id l) ; - rule_label = JsonUtil.to_string (List.assoc label l) ; - rule_ast = JsonUtil.to_string (List.assoc ast l) ; - rule_position = - snd (Locality.annot_of_yojson - (JsonUtil.to_unit ~error_msg:(JsonUtil.build_msg "locality")) - (List.assoc position l)); - rule_direction = - json_to_direction (List.assoc direction l); - rule_hidden = JsonUtil.to_bool (List.assoc rule_hidden l) - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg " rule",x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error ("rule",x)) - -type var = - { - var_id: int; - var_label: string ; - var_ast: string; - var_position: Locality.t - } + (try + { + rule_id = JsonUtil.to_int (List.assoc rule_id l); + rule_label = JsonUtil.to_string (List.assoc label l); + rule_ast = JsonUtil.to_string (List.assoc ast l); + rule_position = + snd + (Loc.annoted_of_yojson + (JsonUtil.to_unit ~error_msg:(JsonUtil.build_msg "locality")) + (List.assoc position l)); + rule_direction = json_to_direction (List.assoc direction l); + rule_hidden = JsonUtil.to_bool (List.assoc rule_hidden l); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg " rule", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("rule", x)) + +type var = { + var_id: int; + var_label: string; + var_ast: string; + var_position: Loc.t; +} let var_to_json var = `Assoc [ - rule_id,JsonUtil.of_int var.var_id; + rule_id, JsonUtil.of_int var.var_id; label, JsonUtil.of_string var.var_label; ast, JsonUtil.of_string var.var_ast; - position,Locality.annot_to_yojson - JsonUtil.of_unit ((),var.var_position) + position, Loc.yojson_of_annoted JsonUtil.of_unit ((), var.var_position); ] -let json_to_var = - function +let json_to_var = function | `Assoc l as x when List.length l = 4 -> - begin - try - { - var_id = JsonUtil.to_int (List.assoc rule_id l) ; - var_label = JsonUtil.to_string (List.assoc label l) ; - var_ast = JsonUtil.to_string (List.assoc ast l) ; - var_position = - snd (Locality.annot_of_yojson - (JsonUtil.to_unit ~error_msg:(JsonUtil.build_msg "locality")) - (List.assoc position l))} - with Not_found -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg " var",x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error ("var",x)) - -type ('rule,'var) influence_node = - | Rule of 'rule - | Var of 'var - -type pos_of_rules_and_vars = ((int,int) influence_node * Locality.t) list + (try + { + var_id = JsonUtil.to_int (List.assoc rule_id l); + var_label = JsonUtil.to_string (List.assoc label l); + var_ast = JsonUtil.to_string (List.assoc ast l); + var_position = + snd + (Loc.annoted_of_yojson + (JsonUtil.to_unit ~error_msg:(JsonUtil.build_msg "locality")) + (List.assoc position l)); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg " var", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("var", x)) + +type ('rule, 'var) influence_node = Rule of 'rule | Var of 'var +type pos_of_rules_and_vars = ((int, int) influence_node * Loc.t) list let influence_node_to_json rule_to_json var_to_json a = match a with - | Var i -> - `Assoc [variable,var_to_json i] - | Rule i -> - `Assoc [rule,rule_to_json i] - -let influence_node_of_json json_to_rule json_to_var - = - function - | `Assoc [s,json] when s = variable -> - Var (json_to_var json) - | `Assoc [s,json] when s = rule -> - Rule (json_to_rule json) + | Var i -> `Assoc [ variable, var_to_json i ] + | Rule i -> `Assoc [ rule, rule_to_json i ] + +let influence_node_of_json json_to_rule json_to_var = function + | `Assoc [ (s, json) ] when s = variable -> Var (json_to_var json) + | `Assoc [ (s, json) ] when s = rule -> Rule (json_to_rule json) | x -> let error_msg = "Not a correct influence node" in - raise (Yojson.Basic.Util.Type_error (error_msg,x)) + raise (Yojson.Basic.Util.Type_error (error_msg, x)) let short_influence_node_to_json = influence_node_to_json JsonUtil.of_int JsonUtil.of_int @@ -517,24 +456,17 @@ let short_influence_node_of_json = (JsonUtil.to_int ~error_msg:(JsonUtil.build_msg "rule id")) (JsonUtil.to_int ~error_msg:(JsonUtil.build_msg "var id")) - let pos_of_rules_and_vars_to_json = JsonUtil.of_list - (JsonUtil.of_pair - ~lab1:key ~lab2:locality - short_influence_node_to_json - (fun loc -> - Locality.annot_to_yojson - JsonUtil.of_unit ((),loc)) - ) + (JsonUtil.of_pair ~lab1:key ~lab2:locality short_influence_node_to_json + (fun loc -> Loc.yojson_of_annoted JsonUtil.of_unit ((), loc))) let pos_of_rules_and_vars_of_json = JsonUtil.to_list - (JsonUtil.to_pair - ~lab1:key ~lab2:locality - short_influence_node_of_json + (JsonUtil.to_pair ~lab1:key ~lab2:locality short_influence_node_of_json (fun x -> - snd (Locality.annot_of_yojson + snd + (Loc.annoted_of_yojson (JsonUtil.to_unit ~error_msg:(JsonUtil.build_msg "locality")) x))) @@ -552,293 +484,245 @@ let position_of_refined_influence_node = function | Rule r -> r.rule_position | Var v -> v.var_position -module InfluenceNodeSetMap = - SetMap.Make - (struct - type t = (int, int) influence_node - let compare = compare - let print f = function - | Rule r -> Format.fprintf f "Rule %i" r - | Var r -> Format.fprintf f "Var %i" r - end) +module InfluenceNodeSetMap = SetMap.Make (struct + type t = (int, int) influence_node + + let compare = compare + + let print f = function + | Rule r -> Format.fprintf f "Rule %i" r + | Var r -> Format.fprintf f "Var %i" r +end) module InfluenceNodeMap = InfluenceNodeSetMap.Map (* Relations *) type 'a pair = 'a * 'a - -type location = - | Direct of int - | Side_effect of int +type location = Direct of int | Side_effect of int let dump_location fmt = function | Direct int -> Format.fprintf fmt "%i" int | Side_effect int -> Format.fprintf fmt "%i*" int -let dump_location_pair fmt (a,b) = +let dump_location_pair fmt (a, b) = Format.fprintf fmt "(%a,%a)" dump_location a dump_location b let dump_location_pair_list fmt l = Format.fprintf fmt "[%a]" - (Pp.list - (fun fmt -> Format.pp_print_string fmt ";") - dump_location_pair) l + (Pp.list (fun fmt -> Format.pp_print_string fmt ";") dump_location_pair) + l -let string_of_label_list l = - Format.asprintf "%a" dump_location_pair_list l +let string_of_label_list l = Format.asprintf "%a" dump_location_pair_list l type half_influence_map = location pair list InfluenceNodeMap.t InfluenceNodeMap.t -type influence_map = - { - nodes: (rule, var) influence_node list ; - positive: half_influence_map ; - negative: half_influence_map ; - - } +type influence_map = { + nodes: (rule, var) influence_node list; + positive: half_influence_map; + negative: half_influence_map; +} (* Location labels *) let location_to_json a = match a with - | Direct i -> `Assoc [direct,JsonUtil.of_int i] - | Side_effect i -> `Assoc [side_effect,JsonUtil.of_int i] - -let location_of_json - ?error_msg:(error_msg="Not a correct location") - = - function - | `Assoc [s,json] when s=direct -> Direct (JsonUtil.to_int json) - | `Assoc [s,json] when s=side_effect -> Side_effect (JsonUtil.to_int json) - | x -> - raise (Yojson.Basic.Util.Type_error (error_msg,x)) + | Direct i -> `Assoc [ direct, JsonUtil.of_int i ] + | Side_effect i -> `Assoc [ side_effect, JsonUtil.of_int i ] + +let location_of_json ?(error_msg = "Not a correct location") = function + | `Assoc [ (s, json) ] when s = direct -> Direct (JsonUtil.to_int json) + | `Assoc [ (s, json) ] when s = side_effect -> + Side_effect (JsonUtil.to_int json) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) let half_influence_map_to_json = - InfluenceNodeMap.to_json - ~lab_key:source ~lab_value:target_map + InfluenceNodeMap.to_json ~lab_key:source ~lab_value:target_map short_influence_node_to_json - (InfluenceNodeMap.to_json - ~lab_key:target ~lab_value:location_pair_list + (InfluenceNodeMap.to_json ~lab_key:target ~lab_value:location_pair_list short_influence_node_to_json (JsonUtil.of_list - (JsonUtil.of_pair - ~lab1:rhs ~lab2:lhs - location_to_json - location_to_json - ) - ) - ) + (JsonUtil.of_pair ~lab1:rhs ~lab2:lhs location_to_json + location_to_json))) let half_influence_map_of_json = InfluenceNodeMap.of_json ~error_msg:(JsonUtil.build_msg "activation or inhibition map") - ~lab_key:source ~lab_value:target_map - short_influence_node_of_json - (InfluenceNodeMap.of_json - ~lab_key:target ~lab_value:location_pair_list + ~lab_key:source ~lab_value:target_map short_influence_node_of_json + (InfluenceNodeMap.of_json ~lab_key:target ~lab_value:location_pair_list ~error_msg:"map of lists of pairs of locations" short_influence_node_of_json (JsonUtil.to_list ~error_msg:"list of pair of locations" - (JsonUtil.to_pair - ~error_msg:"" - ~lab1:rhs ~lab2:lhs + (JsonUtil.to_pair ~error_msg:"" ~lab1:rhs ~lab2:lhs (location_of_json ~error_msg:(JsonUtil.build_msg "location")) (location_of_json ~error_msg:(JsonUtil.build_msg "location"))))) (* Influence map *) -let nodes_list_to_json = - JsonUtil.of_list - refined_influence_node_to_json - -let nodes_list_of_json = - JsonUtil.to_list - refined_influence_node_of_json +let nodes_list_to_json = JsonUtil.of_list refined_influence_node_to_json +let nodes_list_of_json = JsonUtil.to_list refined_influence_node_of_json let influence_map_to_json influence_map = `Assoc - [influencemap, - JsonUtil.of_pair - ~lab1:accuracy_string ~lab2:map - accuracy_to_json - (fun influence_map -> - `Assoc - [ nodes, nodes_list_to_json influence_map.nodes; - wakeup,half_influence_map_to_json influence_map.positive; - inhibition,half_influence_map_to_json - influence_map.negative;]) influence_map] + [ + ( influencemap, + JsonUtil.of_pair ~lab1:accuracy_string ~lab2:map accuracy_to_json + (fun influence_map -> + `Assoc + [ + nodes, nodes_list_to_json influence_map.nodes; + wakeup, half_influence_map_to_json influence_map.positive; + inhibition, half_influence_map_to_json influence_map.negative; + ]) + influence_map ); + ] let nodes_of_influence_map_to_json nodes_list = `Assoc - [nodesofinfluencemap, - JsonUtil.of_pair - ~lab1:accuracy_string ~lab2:map - accuracy_to_json - (fun nodes_list -> - `Assoc - [ nodes, - nodes_list_to_json nodes_list;]) - nodes_list] - -let nodes_of_influence_map_of_json = - function + [ + ( nodesofinfluencemap, + JsonUtil.of_pair ~lab1:accuracy_string ~lab2:map accuracy_to_json + (fun nodes_list -> `Assoc [ nodes, nodes_list_to_json nodes_list ]) + nodes_list ); + ] + +let nodes_of_influence_map_of_json = function | `Assoc l as x -> - begin - try - let json = List.assoc nodesofinfluencemap l in - JsonUtil.to_pair - ~lab1:accuracy_string ~lab2:map - ~error_msg:(JsonUtil.build_msg "nodes of influence map1") - accuracy_of_json - (function - | `Assoc l as x when List.length l = 1 -> - begin - try - nodes_list_of_json - (List.assoc nodes l) - with Not_found -> - raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "nodes of influence map",x)) - end - | x -> - raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "nodes of influence map",x))) - json - with - | _ -> - raise - (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "nodes of influence map",x)) - end + (try + let json = List.assoc nodesofinfluencemap l in + JsonUtil.to_pair ~lab1:accuracy_string ~lab2:map + ~error_msg:(JsonUtil.build_msg "nodes of influence map1") + accuracy_of_json + (function + | `Assoc l as x when List.length l = 1 -> + (try nodes_list_of_json (List.assoc nodes l) + with Not_found -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "nodes of influence map", x))) + | x -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "nodes of influence map", x))) + json + with _ -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "nodes of influence map", x))) | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "nodes of influence map",x)) + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "nodes of influence map", x)) let local_influence_map_to_json influence_map = let accuracy, total, bwd, fwd, origin_opt, influence_map = influence_map in `Assoc - [influencemap, - `Assoc [accuracy_string,accuracy_to_json accuracy; - total_string,JsonUtil.of_int total; - fwd_string,JsonUtil.of_option JsonUtil.of_int fwd; - bwd_string,JsonUtil.of_option JsonUtil.of_int bwd; - origin,JsonUtil.of_option refined_influence_node_to_json origin_opt; - map, - (fun influence_map -> + [ + ( influencemap, + `Assoc + [ + accuracy_string, accuracy_to_json accuracy; + total_string, JsonUtil.of_int total; + fwd_string, JsonUtil.of_option JsonUtil.of_int fwd; + bwd_string, JsonUtil.of_option JsonUtil.of_int bwd; + origin, JsonUtil.of_option refined_influence_node_to_json origin_opt; + ( map, + (fun influence_map -> `Assoc [ nodes, nodes_list_to_json influence_map.nodes; - wakeup,half_influence_map_to_json influence_map.positive; - inhibition,half_influence_map_to_json - influence_map.negative;]) influence_map - ] + wakeup, half_influence_map_to_json influence_map.positive; + ( inhibition, + half_influence_map_to_json influence_map.negative ); + ]) + influence_map ); + ] ); ] -let influence_map_of_json = - function - | `Assoc l as x -> - begin - try - let json = List.assoc influencemap l in - JsonUtil.to_pair - ~lab1:accuracy_string ~lab2:map - ~error_msg:(JsonUtil.build_msg "influence map1") - accuracy_of_json - (function - | `Assoc l as x when List.length l = 3 -> - begin - try - {nodes = - nodes_list_of_json (List.assoc nodes l); - positive = - half_influence_map_of_json (List.assoc wakeup l); - negative = - half_influence_map_of_json (List.assoc inhibition l)} - with Not_found -> - raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "influence map",x)) - end - | x -> - raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "influence map",x))) - json - with - | _ -> - raise - (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map",x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map",x)) - -let local_influence_map_of_json = - function +let influence_map_of_json = function | `Assoc l as x -> - begin - try - let json = List.assoc influencemap l in - match json with - | `Assoc l' -> - let accuracy = - accuracy_of_json (List.assoc accuracy_string l') - in - let total = - JsonUtil.to_int (List.assoc total_string l') - in - let error_msg = JsonUtil.build_msg "fwd radius" in - let fwd = - JsonUtil.to_option - (JsonUtil.to_int ~error_msg) (List.assoc fwd_string l') - in - let error_msg = JsonUtil.build_msg "bwd radius" in - let bwd = - JsonUtil.to_option - (JsonUtil.to_int ~error_msg) (List.assoc bwd_string l') - in - let origin = - JsonUtil.to_option - refined_influence_node_of_json - (List.assoc origin l') - in - let influence_map = - (function - | `Assoc l as x when List.length l = 3 -> - begin - try - { - nodes = - nodes_list_of_json (List.assoc nodes l); - positive = - half_influence_map_of_json (List.assoc wakeup l); - negative = - half_influence_map_of_json (List.assoc inhibition l) - } - with Not_found -> - raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "local influence map",x)) - end - | x -> + (try + let json = List.assoc influencemap l in + JsonUtil.to_pair ~lab1:accuracy_string ~lab2:map + ~error_msg:(JsonUtil.build_msg "influence map1") + accuracy_of_json + (function + | `Assoc l as x when List.length l = 3 -> + (try + { + nodes = nodes_list_of_json (List.assoc nodes l); + positive = half_influence_map_of_json (List.assoc wakeup l); + negative = + half_influence_map_of_json (List.assoc inhibition l); + } + with Not_found -> raise (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "local influence map",x))) - (List.assoc map l') - in - (accuracy, total, fwd, bwd, origin, influence_map) - | _ -> - raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "influence map",x)) - with _ -> - raise - (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "influence map",x)) - end + (JsonUtil.build_msg "influence map", x))) + | x -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "influence map", x))) + json + with _ -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map", x))) | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map",x)) + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map", x)) +let local_influence_map_of_json = function + | `Assoc l as x -> + (try + let json = List.assoc influencemap l in + match json with + | `Assoc l' -> + let accuracy = accuracy_of_json (List.assoc accuracy_string l') in + let total = JsonUtil.to_int (List.assoc total_string l') in + let error_msg = JsonUtil.build_msg "fwd radius" in + let fwd = + JsonUtil.to_option + (JsonUtil.to_int ~error_msg) + (List.assoc fwd_string l') + in + let error_msg = JsonUtil.build_msg "bwd radius" in + let bwd = + JsonUtil.to_option + (JsonUtil.to_int ~error_msg) + (List.assoc bwd_string l') + in + let origin = + JsonUtil.to_option refined_influence_node_of_json + (List.assoc origin l') + in + let influence_map = + (function + | `Assoc l as x when List.length l = 3 -> + (try + { + nodes = nodes_list_of_json (List.assoc nodes l); + positive = half_influence_map_of_json (List.assoc wakeup l); + negative = + half_influence_map_of_json (List.assoc inhibition l); + } + with Not_found -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "local influence map", x))) + | x -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "local influence map", x))) + (List.assoc map l') + in + accuracy, total, fwd, bwd, origin, influence_map + | _ -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map", x)) + with _ -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map", x))) + | x -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "influence map", x)) (***************) (* dead rules *) @@ -847,93 +731,69 @@ let local_influence_map_of_json = type dead_rules = rule list let dead_rules_to_json json = - `Assoc - [dead_rules, JsonUtil.of_list rule_to_json json] - -let dead_rules_of_json = - function - | `Assoc [s,json] as x when s=dead_rules -> - begin - try - JsonUtil.to_list json_to_rule json - with Not_found -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_rules,x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_rules,x)) + `Assoc [ dead_rules, JsonUtil.of_list rule_to_json json ] + +let dead_rules_of_json = function + | `Assoc [ (s, json) ] as x when s = dead_rules -> + (try JsonUtil.to_list json_to_rule json + with Not_found -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_rules, x))) + | x -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_rules, x)) (***************) (* dead agents *) (***************) -type agent_kind = - { - agent_id: int; - agent_ast: string ; - agent_position: Locality.t list; - } +type agent_kind = { + agent_id: int; + agent_ast: string; + agent_position: Loc.t list; +} -let json_to_agent_kind = - function +let json_to_agent_kind = function | `Assoc l as x when List.length l = 3 -> - begin - try - { - agent_id = JsonUtil.to_int (List.assoc agent_id l) ; - agent_ast = JsonUtil.to_string (List.assoc ast l) ; - agent_position = - JsonUtil.to_list - ~error_msg:(JsonUtil.build_msg "locality list") - (fun json -> - snd - (Locality.annot_of_yojson - (JsonUtil.to_unit - ~error_msg:(JsonUtil.build_msg "locality") - ) - json - )) - (List.assoc position_list l); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "agent kind",x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error ("agent kind",x)) - + (try + { + agent_id = JsonUtil.to_int (List.assoc agent_id l); + agent_ast = JsonUtil.to_string (List.assoc ast l); + agent_position = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "locality list") + (fun json -> + snd + (Loc.annoted_of_yojson + (JsonUtil.to_unit + ~error_msg:(JsonUtil.build_msg "locality")) + json)) + (List.assoc position_list l); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "agent kind", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("agent kind", x)) let agent_kind_to_json agent_kind = `Assoc [ - agent_id,JsonUtil.of_int agent_kind.agent_id; + agent_id, JsonUtil.of_int agent_kind.agent_id; ast, JsonUtil.of_string agent_kind.agent_ast; - position_list, - JsonUtil.of_list - (fun a -> - Locality.annot_to_yojson - JsonUtil.of_unit ((),a)) - agent_kind.agent_position; - ] - + ( position_list, + JsonUtil.of_list + (fun a -> Loc.yojson_of_annoted JsonUtil.of_unit ((), a)) + agent_kind.agent_position ); + ] type dead_agents = agent_kind list let json_of_dead_agents json = - `Assoc - [dead_agents, JsonUtil.of_list agent_kind_to_json json] - -let json_to_dead_agents = - function - | `Assoc [s,json] as x when s=dead_agents -> - begin - try - JsonUtil.to_list - json_to_agent_kind json - with Not_found -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_agents,x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_agents,x)) + `Assoc [ dead_agents, JsonUtil.of_list agent_kind_to_json json ] +let json_to_dead_agents = function + | `Assoc [ (s, json) ] as x when s = dead_agents -> + (try JsonUtil.to_list json_to_agent_kind json + with Not_found -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_agents, x))) + | x -> + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg dead_agents, x)) (*************************************) (* non weakly reversible transitions *) @@ -943,97 +803,74 @@ type separating_transitions = (rule * (string * string) list) list let separating_transitions_to_json = JsonUtil.of_list - (JsonUtil.of_pair - ~lab1:"rule" ~lab2:"potential-contexts" - rule_to_json + (JsonUtil.of_pair ~lab1:"rule" ~lab2:"potential-contexts" rule_to_json (JsonUtil.of_list - ( - JsonUtil.of_pair - ~lab1:"s1" ~lab2:"s2" - JsonUtil.of_string - JsonUtil.of_string) - )) + (JsonUtil.of_pair ~lab1:"s1" ~lab2:"s2" JsonUtil.of_string + JsonUtil.of_string))) let separating_transitions_of_json = - JsonUtil.to_list - ~error_msg:"separating transitions list" - (JsonUtil.to_pair ~error_msg:"separating transition" - ~lab1:"rule" ~lab2:"potential-contexts" - json_to_rule - (JsonUtil.to_list - ~error_msg:"separating transitions" - ( - JsonUtil.to_pair - ~error_msg:"transition" - ~lab1:"s1" ~lab2:"s2" - (JsonUtil.to_string ?error_msg:None) - (JsonUtil.to_string ?error_msg:None)) - )) + JsonUtil.to_list ~error_msg:"separating transitions list" + (JsonUtil.to_pair ~error_msg:"separating transition" ~lab1:"rule" + ~lab2:"potential-contexts" json_to_rule + (JsonUtil.to_list ~error_msg:"separating transitions" + (JsonUtil.to_pair ~error_msg:"transition" ~lab1:"s1" ~lab2:"s2" + (JsonUtil.to_string ?error_msg:None) + (JsonUtil.to_string ?error_msg:None)))) (***************) (* Constraints *) (***************) type binding_state = - | Free - | Wildcard - | Bound_to_unknown - | Bound_to of int - | Binding_type of string * string - -type agent = string * (string * string option * binding_state option * (int option * int option) option) list - - -type 'site_graph lemma = - { - hyp : 'site_graph ; - refinement : 'site_graph list - } - + | Free + | Wildcard + | Bound_to_unknown + | Bound_to of int + | Binding_type of string * string + +type agent = + string + * (string + * string option + * binding_state option + * (int option * int option) option) + list + +type 'site_graph lemma = { hyp: 'site_graph; refinement: 'site_graph list } type 'site_graph poly_constraints_list = (string * 'site_graph lemma list) list let lemma_to_json site_graph_to_json json = - JsonUtil.of_pair - ~lab1:hyp ~lab2:refinement - site_graph_to_json + JsonUtil.of_pair ~lab1:hyp ~lab2:refinement site_graph_to_json (JsonUtil.of_list site_graph_to_json) - (json.hyp,json.refinement) + (json.hyp, json.refinement) let lemma_of_json site_graph_of_json json = - let a,b = - JsonUtil.to_pair - ~lab1:hyp ~lab2:refinement ~error_msg:"lemma" + let a, b = + JsonUtil.to_pair ~lab1:hyp ~lab2:refinement ~error_msg:"lemma" site_graph_of_json - (JsonUtil.to_list ~error_msg:"refinements list" site_graph_of_json) + (JsonUtil.to_list ~error_msg:"refinements list" site_graph_of_json) json in - { - hyp = a; - refinement = b - } + { hyp = a; refinement = b } let get_hyp h = h.hyp - let get_refinement r = r.refinement - - let free = "" let wildcard = "?" let bound = "!_" let bond_id = "bond id" let bound_to = "bound to" let binding_type = "binding type" -let prop="property state" -let bind="binding state" - -let binding_type_backend_symbol="." +let prop = "property state" +let bind = "binding state" +let binding_type_backend_symbol = "." let free_backend_symbol = "." let missing_binding_site_backend_symbol = "" let wildcard_backend_symbol = "#" let bound_to_unknown_backend_symbol = "_" let internal_state_introduction_backend_symbol = "~" -let internal_state_delimiter_backend_symbol="," -let binding_state_delimiter_backend_symbol="," +let internal_state_delimiter_backend_symbol = "," +let binding_state_delimiter_backend_symbol = "," let binding_state_opening_backend_symbol = "[" let binding_state_closing_backend_symbol = "]" let internal_state_opening_backend_symbol = "{" @@ -1048,154 +885,128 @@ let close_interval_exclusive_symbol = "[" let plus_infinity_symbol = "+oo" let minus_infinity_symbol = "-oo" -let string_of_binding_type - ?binding_type_symbol:(binding_type_symbol=".") - ~agent_name - ~site_name - () - = +let string_of_binding_type ?(binding_type_symbol = ".") ~agent_name ~site_name + () = Format.sprintf "%s%s%s" site_name binding_type_symbol agent_name - -let binding_state_light_of_json = - function - | `Assoc [s, `Null] when s = free -> Free - | `Assoc [s, `Null] when s = wildcard -> Wildcard - | `Assoc [s, `Null] when s = bound_to -> Bound_to_unknown - | `Assoc [s, j] when s = bond_id -> - let i = - JsonUtil.to_int ~error_msg:"wrong binding id" j - in +let binding_state_light_of_json = function + | `Assoc [ (s, `Null) ] when s = free -> Free + | `Assoc [ (s, `Null) ] when s = wildcard -> Wildcard + | `Assoc [ (s, `Null) ] when s = bound_to -> Bound_to_unknown + | `Assoc [ (s, j) ] when s = bond_id -> + let i = JsonUtil.to_int ~error_msg:"wrong binding id" j in let bond_index = i in Bound_to bond_index - | `Assoc [s, j] when s = binding_type -> - let (agent_name, site_name) = - JsonUtil.to_pair - ~lab1:"agent" ~lab2:"site" ~error_msg:"binding type" - (JsonUtil.to_string ~error_msg:"agent name") (JsonUtil.to_string - ~error_msg:"site name") + | `Assoc [ (s, j) ] when s = binding_type -> + let agent_name, site_name = + JsonUtil.to_pair ~lab1:"agent" ~lab2:"site" ~error_msg:"binding type" + (JsonUtil.to_string ~error_msg:"agent name") + (JsonUtil.to_string ~error_msg:"site name") j in Binding_type (agent_name, site_name) - | x -> raise - (Yojson.Basic.Util.Type_error ("wrong binding state",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("wrong binding state", x)) let binding_state_light_to_json = function - | Free -> `Assoc [free, `Null] - | Wildcard -> `Assoc [wildcard, `Null] - | Bound_to_unknown -> `Assoc [bound_to, `Null] - | Bound_to bond_index -> `Assoc [bond_id, JsonUtil.of_int bond_index] + | Free -> `Assoc [ free, `Null ] + | Wildcard -> `Assoc [ wildcard, `Null ] + | Bound_to_unknown -> `Assoc [ bound_to, `Null ] + | Bound_to bond_index -> `Assoc [ bond_id, JsonUtil.of_int bond_index ] | Binding_type (agent_name, site_name) -> let j = - JsonUtil.of_pair - ~lab1:"agent" ~lab2:"site" JsonUtil.of_string JsonUtil.of_string - (agent_name, site_name) in - `Assoc [binding_type, j] + JsonUtil.of_pair ~lab1:"agent" ~lab2:"site" JsonUtil.of_string + JsonUtil.of_string (agent_name, site_name) + in + `Assoc [ binding_type, j ] let counter_state_light_of_json = - JsonUtil.to_pair - ~lab1:inf - ~lab2:sup - ~error_msg:"wrong counter state" + JsonUtil.to_pair ~lab1:inf ~lab2:sup ~error_msg:"wrong counter state" (JsonUtil.to_option (JsonUtil.to_int ~error_msg:counter)) (JsonUtil.to_option (JsonUtil.to_int ~error_msg:counter)) let counter_state_light_to_json = - JsonUtil.of_pair - ~lab1:inf ~lab2:sup - (JsonUtil.of_option JsonUtil.of_int) (JsonUtil.of_option JsonUtil.of_int) + JsonUtil.of_pair ~lab1:inf ~lab2:sup + (JsonUtil.of_option JsonUtil.of_int) + (JsonUtil.of_option JsonUtil.of_int) let interface_light_to_json intf = - JsonUtil.of_map - ~lab_key:site ~lab_value:stateslist + JsonUtil.of_map ~lab_key:site ~lab_value:stateslist ~fold:(fun f a x -> - List.fold_left (fun list (k,a,b,c) -> f k (a,b,c) list) x a) + List.fold_left (fun list (k, a, b, c) -> f k (a, b, c) list) x a) (*json -> elt*) - (fun site -> JsonUtil.of_string site) + (fun site -> JsonUtil.of_string site) (*json -> 'value*) - (JsonUtil.of_triple - ~lab1:prop ~lab2:bind ~lab3:counter + (JsonUtil.of_triple ~lab1:prop ~lab2:bind ~lab3:counter (JsonUtil.of_option JsonUtil.of_string) (JsonUtil.of_option binding_state_light_to_json) (JsonUtil.of_option counter_state_light_to_json)) intf let interface_light_of_json json = - JsonUtil.to_map - ~lab_key:site ~lab_value:stateslist ~error_msg:interface + JsonUtil.to_map ~lab_key:site ~lab_value:stateslist ~error_msg:interface ~empty:[] - ~add:(fun k (a,b,c) list -> (k,a,b,c)::list) + ~add:(fun k (a, b, c) list -> (k, a, b, c) :: list) (*json -> elt*) - (fun json -> JsonUtil.to_string ~error_msg:site json) + (fun json -> JsonUtil.to_string ~error_msg:site json) (*json -> 'value*) - (JsonUtil.to_triple - ~lab1:prop ~lab2:bind ~lab3:counter + (JsonUtil.to_triple ~lab1:prop ~lab2:bind ~lab3:counter ~error_msg:"wrong binding state" - (JsonUtil.to_option - (JsonUtil.to_string ~error_msg:prop) - - ) - (JsonUtil.to_option - binding_state_light_of_json) - (JsonUtil.to_option - counter_state_light_of_json) - ) + (JsonUtil.to_option (JsonUtil.to_string ~error_msg:prop)) + (JsonUtil.to_option binding_state_light_of_json) + (JsonUtil.to_option counter_state_light_of_json)) json let agent_gen_of_json interface_of_json = - JsonUtil.to_pair - ~lab1:agent ~lab2:interface ~error_msg:"agent" + JsonUtil.to_pair ~lab1:agent ~lab2:interface ~error_msg:"agent" (JsonUtil.to_string ~error_msg:"agent name") interface_of_json let poly_constraints_list_of_json site_graph_of_json = JsonUtil.to_list - (JsonUtil.to_pair ~error_msg:"constraints list" - ~lab1:domain_name ~lab2:refinements_list + (JsonUtil.to_pair ~error_msg:"constraints list" ~lab1:domain_name + ~lab2:refinements_list (JsonUtil.to_string ~error_msg:"abstract domain") (JsonUtil.to_list (lemma_of_json site_graph_of_json))) let lemmas_list_of_json_gen interface_of_json = function | `Assoc l as x -> - begin - try - let json = List.assoc refinement_lemmas l in - poly_constraints_list_of_json - (JsonUtil.to_list ~error_msg:"site graph" - (agent_gen_of_json interface_of_json)) - json - with _ -> - raise - (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "refinement lemmas list",x)) - end + (try + let json = List.assoc refinement_lemmas l in + poly_constraints_list_of_json + (JsonUtil.to_list ~error_msg:"site graph" + (agent_gen_of_json interface_of_json)) + json + with _ -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "refinement lemmas list", x))) | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "refinement lemmas list",x)) + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "refinement lemmas list", x)) let lemmas_list_of_json json = lemmas_list_of_json_gen interface_light_of_json json let agent_gen_to_json interface_to_json = - JsonUtil.of_pair - ~lab1:agent ~lab2:interface - JsonUtil.of_string + JsonUtil.of_pair ~lab1:agent ~lab2:interface JsonUtil.of_string interface_to_json let poly_constraints_list_to_json site_graph_to_json constraints = JsonUtil.of_list - (JsonUtil.of_pair - ~lab1:domain_name ~lab2:refinements_list + (JsonUtil.of_pair ~lab1:domain_name ~lab2:refinements_list JsonUtil.of_string - (JsonUtil.of_list (lemma_to_json site_graph_to_json)) - ) + (JsonUtil.of_list (lemma_to_json site_graph_to_json))) constraints let lemmas_list_to_json_gen interface_to_json constraints = `Assoc [ - refinement_lemmas, - poly_constraints_list_to_json - (JsonUtil.of_list (agent_gen_to_json interface_to_json)) constraints + ( refinement_lemmas, + poly_constraints_list_to_json + (JsonUtil.of_list (agent_gen_to_json interface_to_json)) + constraints ); ] let lemmas_list_to_json constraints = - lemmas_list_to_json_gen interface_light_to_json constraints + lemmas_list_to_json_gen interface_light_to_json constraints diff --git a/core/KaSa_rep/type_interface/public_data.mli b/core/KaSa_rep/type_interface/public_data.mli index 65550bd707..1f7826895f 100644 --- a/core/KaSa_rep/type_interface/public_data.mli +++ b/core/KaSa_rep/type_interface/public_data.mli @@ -7,180 +7,157 @@ (******************************************************************************) (* JSon labels *) -val prop:string -val bind:string -val counter:string -val domain_name:string -val refinements_list:string -val refinement_lemmas:string -val free:string -val bound:string -val wildcard:string -val influencemap: string -val scc:string -val inf:string -val sup:string +val prop : string +val bind : string +val counter : string +val domain_name : string +val refinements_list : string +val refinement_lemmas : string +val free : string +val bound : string +val wildcard : string +val influencemap : string +val scc : string +val inf : string +val sup : string (* Backend *) -val binding_type_backend_symbol: string -val free_backend_symbol: string -val wildcard_backend_symbol: string -val missing_binding_site_backend_symbol: string -val bound_to_unknown_backend_symbol: string -val internal_state_introduction_backend_symbol: string -val internal_state_delimiter_backend_symbol: string -val binding_state_delimiter_backend_symbol: string -val binding_state_opening_backend_symbol: string -val binding_state_closing_backend_symbol: string -val internal_state_opening_backend_symbol: string -val internal_state_closing_backend_symbol: string -val counter_state_opening_backend_symbol: string -val counter_state_closing_backend_symbol: string -val counter_state_range_backend_symbol: string -val open_interval_inclusive_symbol: string -val close_interval_inclusive_symbol: string -val open_interval_exclusive_symbol: string -val close_interval_exclusive_symbol: string -val plus_infinity_symbol: string -val minus_infinity_symbol: string - +val binding_type_backend_symbol : string +val free_backend_symbol : string +val wildcard_backend_symbol : string +val missing_binding_site_backend_symbol : string +val bound_to_unknown_backend_symbol : string +val internal_state_introduction_backend_symbol : string +val internal_state_delimiter_backend_symbol : string +val binding_state_delimiter_backend_symbol : string +val binding_state_opening_backend_symbol : string +val binding_state_closing_backend_symbol : string +val internal_state_opening_backend_symbol : string +val internal_state_closing_backend_symbol : string +val counter_state_opening_backend_symbol : string +val counter_state_closing_backend_symbol : string +val counter_state_range_backend_symbol : string +val open_interval_inclusive_symbol : string +val close_interval_inclusive_symbol : string +val open_interval_exclusive_symbol : string +val close_interval_exclusive_symbol : string +val plus_infinity_symbol : string +val minus_infinity_symbol : string type accuracy_level = Low | Medium | High | Full + val accuracy_levels : accuracy_level list val contact_map_accuracy_levels : accuracy_level list val influence_map_accuracy_levels : accuracy_level list -val reduction_accuracy_levels: accuracy_level list - +val reduction_accuracy_levels : accuracy_level list val accuracy_to_string : accuracy_level -> string val accuracy_of_string : string -> accuracy_level option - val accuracy_to_json : accuracy_level -> Yojson.Basic.t val accuracy_of_json : Yojson.Basic.t -> accuracy_level -module AccuracyMap: SetMap.Map with type elt = accuracy_level +module AccuracyMap : SetMap.Map with type elt = accuracy_level type contact_map = User_graph.connected_component -val contact_map_to_json: - accuracy_level * contact_map -> Yojson.Basic.t - -val contact_map_of_json: - Yojson.Basic.t -> accuracy_level * contact_map +val contact_map_to_json : accuracy_level * contact_map -> Yojson.Basic.t +val contact_map_of_json : Yojson.Basic.t -> accuracy_level * contact_map type scc = ((string * string) * (string * string)) list list -val scc_to_json: - accuracy_level * accuracy_level * scc -> Yojson.Basic.t - -val scc_of_json: - Yojson.Basic.t -> accuracy_level * accuracy_level * scc +val scc_to_json : accuracy_level * accuracy_level * scc -> Yojson.Basic.t +val scc_of_json : Yojson.Basic.t -> accuracy_level * accuracy_level * scc type rule_direction = - | Direct_rule - | Reverse_rule - | Both_directions - | Dummy_rule_direction - | Variable - -type rule = - { - rule_id: int; - rule_label: string ; - rule_ast: string; - rule_position: Locality.t; - rule_direction: rule_direction ; - rule_hidden : bool ; - } - -type var = - { - var_id: int; - var_label: string ; - var_ast: string; - var_position: Locality.t - } - -type ('rule, 'var) influence_node = - | Rule of 'rule - | Var of 'var - -type pos_of_rules_and_vars = - ((int,int) influence_node * Locality.t) list - -val pos_of_rules_and_vars_of_json: - Yojson.Basic.t -> pos_of_rules_and_vars - -val pos_of_rules_and_vars_to_json: - pos_of_rules_and_vars -> Yojson.Basic.t - -val short_node_of_refined_node: + | Direct_rule + | Reverse_rule + | Both_directions + | Dummy_rule_direction + | Variable + +type rule = { + rule_id: int; + rule_label: string; + rule_ast: string; + rule_position: Loc.t; + rule_direction: rule_direction; + rule_hidden: bool; +} + +type var = { + var_id: int; + var_label: string; + var_ast: string; + var_position: Loc.t; +} + +type ('rule, 'var) influence_node = Rule of 'rule | Var of 'var +type pos_of_rules_and_vars = ((int, int) influence_node * Loc.t) list + +val pos_of_rules_and_vars_of_json : Yojson.Basic.t -> pos_of_rules_and_vars +val pos_of_rules_and_vars_to_json : pos_of_rules_and_vars -> Yojson.Basic.t + +val short_node_of_refined_node : (rule, var) influence_node -> (int, int) influence_node -val short_influence_node_of_json: - Yojson.Basic.t -> (int, int) influence_node - -val short_influence_node_to_json: - (int, int) influence_node -> Yojson.Basic.t +val short_influence_node_of_json : Yojson.Basic.t -> (int, int) influence_node +val short_influence_node_to_json : (int, int) influence_node -> Yojson.Basic.t -val refined_influence_node_of_json: - Yojson.Basic.t -> (rule, var) influence_node +val refined_influence_node_of_json : + Yojson.Basic.t -> (rule, var) influence_node -val refined_influence_node_to_json: +val refined_influence_node_to_json : (rule, var) influence_node -> Yojson.Basic.t -val position_of_refined_influence_node : - (rule, var) influence_node -> Locality.t +val position_of_refined_influence_node : (rule, var) influence_node -> Loc.t -module InfluenceNodeMap: SetMap.Map - with type elt = - (int,int) influence_node - - -type location = - | Direct of int - | Side_effect of int +module InfluenceNodeMap : SetMap.Map with type elt = (int, int) influence_node +type location = Direct of int | Side_effect of int type 'a pair = 'a * 'a -type influence_map = - { - nodes: (rule, var) influence_node list ; - positive: location pair list InfluenceNodeMap.t InfluenceNodeMap.t ; - negative: location pair list InfluenceNodeMap.t InfluenceNodeMap.t ; - } - +type influence_map = { + nodes: (rule, var) influence_node list; + positive: location pair list InfluenceNodeMap.t InfluenceNodeMap.t; + negative: location pair list InfluenceNodeMap.t InfluenceNodeMap.t; +} -val influence_map_to_json: - accuracy_level * influence_map -> Yojson.Basic.t +val influence_map_to_json : accuracy_level * influence_map -> Yojson.Basic.t +val influence_map_of_json : Yojson.Basic.t -> accuracy_level * influence_map -val influence_map_of_json: - Yojson.Basic.t -> accuracy_level * influence_map - -val nodes_of_influence_map_to_json: +val nodes_of_influence_map_to_json : accuracy_level * (rule, var) influence_node list -> Yojson.Basic.t -val nodes_of_influence_map_of_json: +val nodes_of_influence_map_of_json : Yojson.Basic.t -> accuracy_level * (rule, var) influence_node list -val local_influence_map_to_json: - accuracy_level * int * int option * int option * (rule, var) influence_node option * influence_map -> Yojson.Basic.t +val local_influence_map_to_json : + accuracy_level + * int + * int option + * int option + * (rule, var) influence_node option + * influence_map -> + Yojson.Basic.t -val local_influence_map_of_json: +val local_influence_map_of_json : Yojson.Basic.t -> - accuracy_level * int * int option * int option * - (rule, var) influence_node option * influence_map + accuracy_level + * int + * int option + * int option + * (rule, var) influence_node option + * influence_map type dead_rules = rule list val dead_rules_of_json : Yojson.Basic.t -> dead_rules val dead_rules_to_json : dead_rules -> Yojson.Basic.t -type agent_kind = - { - agent_id: int; - agent_ast: string ; - agent_position: Locality.t list; - } +type agent_kind = { + agent_id: int; + agent_ast: string; + agent_position: Loc.t list; +} type dead_agents = agent_kind list @@ -189,14 +166,10 @@ val json_of_dead_agents : dead_agents -> Yojson.Basic.t type separating_transitions = (rule * (string * string) list) list -val separating_transitions_of_json: Yojson.Basic.t -> separating_transitions -val separating_transitions_to_json: separating_transitions -> Yojson.Basic.t +val separating_transitions_of_json : Yojson.Basic.t -> separating_transitions +val separating_transitions_to_json : separating_transitions -> Yojson.Basic.t -type 'site_graph lemma = - { - hyp : 'site_graph ; - refinement : 'site_graph list - } +type 'site_graph lemma = { hyp: 'site_graph; refinement: 'site_graph list } type binding_state = | Free @@ -206,39 +179,45 @@ type binding_state = | Binding_type of string * string type agent = - string * - (string * string option * binding_state option * - (int option * int option) option) list + string + * (string + * string option + * binding_state option + * (int option * int option) option) + list type 'site_graph poly_constraints_list = (string * 'site_graph lemma list) list -val lemma_to_json: +val lemma_to_json : ('site_graph -> Yojson.Basic.t) -> 'site_graph lemma -> Yojson.Basic.t -val lemma_of_json: +val lemma_of_json : (Yojson.Basic.t -> 'site_graph) -> Yojson.Basic.t -> 'site_graph lemma -val lemmas_list_to_json_gen: +val lemmas_list_to_json_gen : ('a -> Yojson.Basic.t) -> - (string * (string * 'a) list lemma list) list -> Yojson.Basic.t + (string * (string * 'a) list lemma list) list -> + Yojson.Basic.t -val lemmas_list_of_json_gen: +val lemmas_list_of_json_gen : (Yojson.Basic.t -> 'a) -> - Yojson.Basic.t -> (string * (string * 'a) list lemma list) list + Yojson.Basic.t -> + (string * (string * 'a) list lemma list) list -val lemmas_list_to_json: - (string * agent list lemma list ) list -> Yojson.Basic.t +val lemmas_list_to_json : + (string * agent list lemma list) list -> Yojson.Basic.t -val lemmas_list_of_json: +val lemmas_list_of_json : Yojson.Basic.t -> (string * agent list lemma list) list -val get_hyp: 'site_graph lemma -> 'site_graph - -val get_refinement: 'site_graph lemma -> 'site_graph list +val get_hyp : 'site_graph lemma -> 'site_graph +val get_refinement : 'site_graph lemma -> 'site_graph list -val string_of_binding_type: - ?binding_type_symbol:string -> agent_name:string -> - site_name:string -> unit -> string +val string_of_binding_type : + ?binding_type_symbol:string -> + agent_name:string -> + site_name:string -> + unit -> + string -val string_of_label_list: - location pair list -> string +val string_of_label_list : location pair list -> string diff --git a/core/agents/KaMoHa.ml b/core/agents/KaMoHa.ml index e8618e600e..daefa748f2 100644 --- a/core/agents/KaMoHa.ml +++ b/core/agents/KaMoHa.ml @@ -9,23 +9,26 @@ open Lwt.Infix let process_command (message_delimiter : char) : string -> unit Lwt.t = - Kamoha_mpi.on_message - Lwt.pause - (fun message -> - Lwt_io.atomic (fun f -> - Lwt_io.write f message >>= fun () -> - Lwt_io.write_char f message_delimiter) - Lwt_io.stdout) + Kamoha_mpi.on_message Lwt.pause (fun message -> + Lwt_io.atomic + (fun f -> + Lwt_io.write f message >>= fun () -> + Lwt_io.write_char f message_delimiter) + Lwt_io.stdout) (* start server *) let () = let common_args = Common_args.default in let stdsim_args = Agent_args.default in let options = - Common_args.options common_args @ Agent_args.options stdsim_args in + Common_args.options common_args @ Agent_args.options stdsim_args + in let usage_msg = "Kappa Model Handler" in - let () = Arg.parse options - (fun x -> raise (Arg.Bad ("Don't know what to do of "^x))) usage_msg in + let () = + Arg.parse options + (fun x -> raise (Arg.Bad ("Don't know what to do of " ^ x))) + usage_msg + in let () = Printexc.record_backtrace common_args.Common_args.backtrace in Lwt_main.run (Agent_common.serve Lwt_io.stdin stdsim_args.Agent_args.delimiter diff --git a/core/agents/KaSaAgent.ml b/core/agents/KaSaAgent.ml index d12e51b977..c29f49aac2 100644 --- a/core/agents/KaSaAgent.ml +++ b/core/agents/KaSaAgent.ml @@ -9,19 +9,20 @@ open Lwt.Infix let process_command (message_delimiter : char) : string -> unit Lwt.t = - Kasa_mpi.on_message - (fun message -> - Lwt_io.atomic (fun f -> - Lwt_io.write f message >>= fun () -> - Lwt_io.write_char f message_delimiter) - Lwt_io.stdout) + Kasa_mpi.on_message (fun message -> + Lwt_io.atomic + (fun f -> + Lwt_io.write f message >>= fun () -> + Lwt_io.write_char f message_delimiter) + Lwt_io.stdout) (* start server *) let () = let common_args = Common_args.default in let stdsim_args = Agent_args.default in let options = - Common_args.options common_args @ Agent_args.options stdsim_args in + Common_args.options common_args @ Agent_args.options stdsim_args + in let usage_msg = "Kappa Static Analyser agent" in let () = Arg.parse options (fun _ -> ()) usage_msg in let () = Printexc.record_backtrace common_args.Common_args.backtrace in diff --git a/core/agents/KaSimAgent.ml b/core/agents/KaSimAgent.ml index fcd4ed66d5..ab79513e27 100644 --- a/core/agents/KaSimAgent.ml +++ b/core/agents/KaSimAgent.ml @@ -12,26 +12,27 @@ open Lwt.Infix class system_process () : Kappa_facade.system_process = object method log ?exn (msg : string) = - Logs_lwt.info - (fun m -> m "%s%a" msg - (Pp.option (fun f e -> Fmt.pf f ": %s" (Printexc.to_string e))) exn) + Logs_lwt.info (fun m -> + m "%s%a" msg + (Pp.option (fun f e -> Fmt.pf f ": %s" (Printexc.to_string e))) + exn) + method yield () : unit Lwt.t = Lwt.pause () method min_run_duration () = 0.1 end (* set up handlers for v2 *) -let process_comand_v2 - (message_delimiter : char) : - string -> unit Lwt.t = +let process_comand_v2 (message_delimiter : char) : string -> unit Lwt.t = let sytem_process : Kappa_facade.system_process = new system_process () in - let manager : Api.manager_simulation = new Api_runtime.manager sytem_process in - Mpi_api.on_message - manager - (fun message -> - Lwt_io.atomic (fun f -> - Lwt_io.write f message >>= fun () -> - Lwt_io.write_char f message_delimiter) - Lwt_io.stdout) + let manager : Api.manager_simulation = + new Api_runtime.manager sytem_process + in + Mpi_api.on_message manager (fun message -> + Lwt_io.atomic + (fun f -> + Lwt_io.write f message >>= fun () -> + Lwt_io.write_char f message_delimiter) + Lwt_io.stdout) (* start server *) let () = @@ -39,24 +40,25 @@ let () = let common_args = Common_args.default in let stdsim_args = Agent_args.default in let options = - App_args.options app_args @ - Common_args.options common_args @ - Agent_args.options stdsim_args in - let usage_msg = - "kappa stdio simulator" in - let () = - Arg.parse options - (fun _ -> ()) usage_msg in + App_args.options app_args + @ Common_args.options common_args + @ Agent_args.options stdsim_args + in + let usage_msg = "kappa stdio simulator" in + let () = Arg.parse options (fun _ -> ()) usage_msg in (* set protocol version *) - let () = Logs.set_reporter - (Agent_common.lwt_reporter app_args.App_args.log_channel) in + let () = + Logs.set_reporter (Agent_common.lwt_reporter app_args.App_args.log_channel) + in let process_comand : string -> unit Lwt.t = (match app_args.App_args.api with - | App_args.V2 -> process_comand_v2 - ) stdsim_args.Agent_args.delimiter in + | App_args.V2 -> process_comand_v2) + stdsim_args.Agent_args.delimiter + in Lwt_main.run - (Agent_common.serve - Lwt_io.stdin stdsim_args.Agent_args.delimiter process_comand >>= fun ()-> - match app_args.App_args.log_channel with - | None -> Lwt.return_unit - | Some ch -> Lwt_io.close ch) + ( Agent_common.serve Lwt_io.stdin stdsim_args.Agent_args.delimiter + process_comand + >>= fun () -> + match app_args.App_args.log_channel with + | None -> Lwt.return_unit + | Some ch -> Lwt_io.close ch ) diff --git a/core/agents/KaStor.ml b/core/agents/KaStor.ml index de60c599a4..144b4e9b4d 100644 --- a/core/agents/KaStor.ml +++ b/core/agents/KaStor.ml @@ -12,80 +12,102 @@ let none_compression = ref false let weak_compression = ref false let strong_compression = ref false -let options = [ - ("-o", Arg.String Kappa_files.set_cflow, - "file name skeleton for outputs") ; - ("-d", - Arg.String Kappa_files.set_dir, - "Specifies directory name where output file(s) should be stored"); - ("--none", Arg.Set none_compression, "Outputs uncompressed stories"); - ("--weak", Arg.Set weak_compression, "Outputs weakly compressed stories"); - ("--strong", - Arg.Set strong_compression, - "Outputs strongly compressed stories"); - ("-format", Arg.String - (function - "true" | "yes" | "dot" -> dotCflows := Causal.Dot - |"false" | "no" | "html"-> dotCflows := Causal.Html - |"json" -> dotCflows := Causal.Json - | _ as error -> - raise - (ExceptionDefn.Malformed_Decl - (Locality.dummy_annot - ("Value "^error^ - " should be either \"html, dot\" or \"json\"")))), - "Print stories in html format"); - ("--time-independent", - Arg.Set Parameter.time_independent, - "Disable the use of time is story heuritics (for test suite)") -] +let options = + [ + "-o", Arg.String Kappa_files.set_cflow, "file name skeleton for outputs"; + ( "-d", + Arg.String Kappa_files.set_dir, + "Specifies directory name where output file(s) should be stored" ); + "--none", Arg.Set none_compression, "Outputs uncompressed stories"; + "--weak", Arg.Set weak_compression, "Outputs weakly compressed stories"; + ( "--strong", + Arg.Set strong_compression, + "Outputs strongly compressed stories" ); + ( "-format", + Arg.String + (function + | "true" | "yes" | "dot" -> dotCflows := Causal.Dot + | "false" | "no" | "html" -> dotCflows := Causal.Html + | "json" -> dotCflows := Causal.Json + | _ as error -> + raise + (ExceptionDefn.Malformed_Decl + (Loc.annot_with_dummy + ("Value " ^ error + ^ " should be either \"html, dot\" or \"json\"")))), + "Print stories in html format" ); + ( "--time-independent", + Arg.Set Parameter.time_independent, + "Disable the use of time is story heuritics (for test suite)" ); + ] let process_command delimiter = - let f = Kastor_mpi.on_message - ~none:!none_compression ~weak:!weak_compression ~strong:!strong_compression - ~send_message:(fun x -> Format.printf "%s%c@?" x delimiter) in - fun text -> let () = f text in Lwt.return_unit + let f = + Kastor_mpi.on_message ~none:!none_compression ~weak:!weak_compression + ~strong:!strong_compression ~send_message:(fun x -> + Format.printf "%s%c@?" x delimiter) + in + fun text -> + let () = f text in + Lwt.return_unit let get_simulation fname = - let env, steps = Trace.fold_trace_file - (fun _env steps step -> step::steps) (fun _ -> []) fname in + let env, steps = + Trace.fold_trace_file + (fun _env steps step -> step :: steps) + (fun _ -> []) + fname + in env, List.rev steps let main () = let common_args = Common_args.default in let stdsim_args = Agent_args.default in let options = - Common_args.options common_args @ Agent_args.options stdsim_args @ options in + Common_args.options common_args @ Agent_args.options stdsim_args @ options + in let () = - Arg.parse - options - (fun f -> if !file = "" then file := f else - let () = Format.eprintf "Deals only with 1 file" in exit 2) - (Sys.argv.(0) ^ - " trace\n computes stories from 'trace' file generated by KaSim") in + Arg.parse options + (fun f -> + if !file = "" then + file := f + else ( + let () = Format.eprintf "Deals only with 1 file" in + exit 2 + )) + (Sys.argv.(0) + ^ " trace\n computes stories from 'trace' file generated by KaSim") + in let () = Printexc.record_backtrace common_args.Common_args.backtrace in - if!file = "" then - Lwt_main.run - (Agent_common.serve Lwt_io.stdin stdsim_args.Agent_args.delimiter - (process_command stdsim_args.Agent_args.delimiter)) - else - let (none,weak,strong) = - (!none_compression, !weak_compression, !strong_compression) in + if !file = "" then + Lwt_main.run + (Agent_common.serve Lwt_io.stdin stdsim_args.Agent_args.delimiter + (process_command stdsim_args.Agent_args.delimiter)) + else ( + let none, weak, strong = + !none_compression, !weak_compression, !strong_compression + in let parameter = Compression_main.build_parameter - ~called_from:Remanent_parameters_sig.KaSim ?send_message:None - ~none ~weak ~strong () in + ~called_from:Remanent_parameters_sig.KaSim ?send_message:None ~none + ~weak ~strong () + in let () = - Loggers.fprintf (Compression_main.get_logger parameter) - "+ Loading trace@." in + Loggers.fprintf + (Compression_main.get_logger parameter) + "+ Loading trace@." + in let dotFormat = !dotCflows in try - let env,steps = get_simulation !file in - Compression_main.compress_and_print - parameter ~dotFormat env (Compression_main.init_secret_log_info ()) steps - with Yojson.Basic.Util.Type_error(s,x) -> - Loggers.fprintf (Compression_main.get_logger parameter) + let env, steps = get_simulation !file in + Compression_main.compress_and_print parameter ~dotFormat env + (Compression_main.init_secret_log_info ()) + steps + with Yojson.Basic.Util.Type_error (s, x) -> + Loggers.fprintf + (Compression_main.get_logger parameter) "Json error: \"%s\" in %s@." s (Yojson.Basic.to_string x) + ) let () = Sys.catch_break true let () = main () diff --git a/core/agents/KappaSwitchman.ml b/core/agents/KappaSwitchman.ml index ac9898b15a..ce1b72ff5f 100644 --- a/core/agents/KappaSwitchman.ml +++ b/core/agents/KappaSwitchman.ml @@ -17,23 +17,32 @@ type _ handle = | Info : (string * int) handle | Ast : Ast.parsing_compil handle | JSON : Yojson.Basic.t handle - | Influence_map : - (Public_data.accuracy_level * int * int option * int option * - (Public_data.rule, Public_data.var) Public_data.influence_node option * - Public_data.influence_map) handle - | Short_influence_node : (int,int) Public_data.influence_node option handle - | Influence_node : - (Public_data.rule, Public_data.var) Public_data.influence_node option handle - | Influence_nodes : - (Public_data.accuracy_level * - (Public_data.rule, Public_data.var) Public_data.influence_node list) handle + | Influence_map + : (Public_data.accuracy_level + * int + * int option + * int option + * (Public_data.rule, Public_data.var) Public_data.influence_node option + * Public_data.influence_map) + handle + | Short_influence_node : (int, int) Public_data.influence_node option handle + | Influence_node + : (Public_data.rule, Public_data.var) Public_data.influence_node option + handle + | Influence_nodes + : (Public_data.accuracy_level + * (Public_data.rule, Public_data.var) Public_data.influence_node list) + handle | Rules_kasa : Public_data.rule list handle | Agents_kasa : Public_data.dead_agents handle - | Transitions_kasa : (Public_data.rule * (string*string) list) list handle - | Constraints_kasa : - (string * Public_data.agent list Public_data.lemma list) list handle - | Polymers_kasa : - (Public_data.accuracy_level * Public_data.accuracy_level * Public_data.scc) handle + | Transitions_kasa : (Public_data.rule * (string * string) list) list handle + | Constraints_kasa + : (string * Public_data.agent list Public_data.lemma list) list handle + | Polymers_kasa + : (Public_data.accuracy_level + * Public_data.accuracy_level + * Public_data.scc) + handle | DIN : Data.din handle | Plot : Data.plot handle | Snapshot : Data.snapshot handle @@ -43,393 +52,478 @@ type _ handle = | Simulation_artifact : Api_types_t.simulation_artifact handle type box = - B : 'a handle * int * ('a, Result_util.message list) Result_util.t -> box + | B : 'a handle * int * ('a, Result_util.message list) Result_util.t -> box let reply post write_v id v = let message = JsonUtil.string_of_write (fun b () -> - JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_int b id); - (fun b -> Result_util.write_t - write_v (JsonUtil.write_list Result_util.write_message) b v); - ]) () in + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_int b id); + (fun b -> + Result_util.write_t write_v + (JsonUtil.write_list Result_util.write_message) + b v); + ]) + () + in post message let on_message exec_command message_delimiter = let post message = - Lwt_io.atomic (fun f -> + Lwt_io.atomic + (fun f -> Lwt_io.write f message >>= fun () -> Lwt_io.write_char f message_delimiter) - Lwt_io.stdout in + Lwt_io.stdout + in let manager = new Agents_client.t exec_command message_delimiter in let () = at_exit (fun () -> manager#terminate) in let current_id = ref None in fun text -> - try - Lwt.bind - (JsonUtil.read_of_string - (JsonUtil.read_variant Yojson.Basic.read_int - (fun st b msg_id -> - let () = current_id := Some msg_id in - JsonUtil.read_next_item - (JsonUtil.read_variant Yojson.Basic.read_string - (fun st b -> function - (* KaMoHa *) - | "FileCatalog" -> - manager#file_catalog >>= fun out -> - Lwt.return (B (Catalog, msg_id, out)) - | "FileCreate" -> - let position = - JsonUtil.read_next_item Yojson.Basic.read_int st b in - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let content = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#file_create position id content >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - | "FileGet" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#file_get id >>= fun out -> - Lwt.return (B (Info, msg_id, out)) - | "FileMove" -> - let position = - JsonUtil.read_next_item Yojson.Basic.read_int st b in - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#file_move position id >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - | "FileUpdate" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let content = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#file_update id content >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - | "FileDelete" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#file_delete id >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - | "ProjectOverwrite" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let content = - JsonUtil.read_next_item Ast.read_parsing_compil st b in - manager#project_overwrite id content >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - (* KaSa *) - | "INIT" -> - let compil = - JsonUtil.read_next_item Ast.read_parsing_compil st b in - manager#init_static_analyser compil >>= fun out -> - Lwt.return (B (Nothing, msg_id, Api_common.result_kasa out)) - | "CONTACT_MAP" -> - let acc = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let accuracy = - JsonUtil.to_option Public_data.accuracy_of_json acc in - manager#get_contact_map accuracy >>= fun out -> - Lwt.return (B (JSON, msg_id, Api_common.result_kasa out)) - | "LOCAL_INFLUENCE_MAP" -> - let acc = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let fwd = - JsonUtil.read_next_item - (JsonUtil.read_option Yojson.Basic.read_int) st b in - let bwd = - JsonUtil.read_next_item - (JsonUtil.read_option Yojson.Basic.read_int) st b in - let total = - JsonUtil.read_next_item Yojson.Basic.read_int st b in - let origin = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let accuracy = - JsonUtil.to_option Public_data.accuracy_of_json acc in - let origin = - JsonUtil.to_option - Public_data.short_influence_node_of_json origin in - manager#get_local_influence_map - accuracy ?fwd ?bwd ?origin ~total >>= fun out -> - Lwt.return (B (Influence_map, msg_id, Api_common.result_kasa out)) - | "INFLUENCE_MAP" -> - let acc = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let accuracy = - JsonUtil.to_option Public_data.accuracy_of_json acc in - manager#get_influence_map_raw accuracy >>= fun out -> - Lwt.return (B (String, msg_id, Api_common.result_kasa out)) - | "INFLUENCE_MAP_ORIGINAL_NODE" -> - manager#get_initial_node >>= fun out -> - Lwt.return (B (Influence_node, msg_id, Api_common.result_kasa out)) - | "INFLUENCE_MAP_NEXT_NODE" -> - let origin = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let origin = - JsonUtil.to_option - Public_data.short_influence_node_of_json origin in - manager#get_next_node origin >>= fun out -> - Lwt.return (B (Influence_node, msg_id, Api_common.result_kasa out)) - | "INFLUENCE_MAP_PREVIOUS_NODE" -> - let origin = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let origin = - JsonUtil.to_option - Public_data.short_influence_node_of_json origin in - manager#get_next_node origin >>= fun out -> - Lwt.return (B (Influence_node, msg_id, Api_common.result_kasa out)) - | "INFLUENCE_MAP_NODE_AT" -> - let filename = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let pos = - JsonUtil.read_next_item Locality.read_position st b in - manager#get_influence_map_node_at ~filename pos >>= fun out -> - Lwt.return (B (Short_influence_node, msg_id, out)) - | "INFLUENCE_MAP_ALL_NODES" -> - let accuracy_level = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let accuracy = - JsonUtil.to_option Public_data.accuracy_of_json accuracy_level in - manager#get_nodes_of_influence_map accuracy >>= fun out -> - Lwt.return (B (Influence_nodes, msg_id, Api_common.result_kasa out)) - | "DEAD_RULES" -> - manager#get_dead_rules >>= fun out -> - Lwt.return (B (Rules_kasa, msg_id, Api_common.result_kasa out)) - | "DEAD_AGENTS" -> - manager#get_dead_agents >>= fun out -> - Lwt.return (B (Agents_kasa, msg_id, Api_common.result_kasa out)) - | "NON_WEAKLY_REVERSIBLE_TRANSITIONS" -> - manager#get_non_weakly_reversible_transitions >>= fun out -> - Lwt.return (B (Transitions_kasa, msg_id, Api_common.result_kasa out)) - | "CONSTRAINTS" -> - manager#get_constraints_list >>= fun out -> - Lwt.return (B (Constraints_kasa, msg_id, Api_common.result_kasa out)) - | "POLYMERS" -> - let acc_cm = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let acc_scc = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let accuracy_cm = - JsonUtil.to_option Public_data.accuracy_of_json acc_cm in - let accuracy_scc = - JsonUtil.to_option Public_data.accuracy_of_json acc_scc in - manager#get_potential_polymers accuracy_cm accuracy_scc >>= fun out -> - Lwt.return (B (Polymers_kasa, msg_id, Api_common.result_kasa out)) - (* KaSim *) - | "ProjectParse" -> - let patternSharing = - JsonUtil.read_next_item - Kappa_terms.Pattern.read_sharing_level st b in - let overwrites = - JsonUtil.read_next_item - (Yojson.Basic.read_list - (JsonUtil.read_compact_pair - Yojson.Basic.read_string Nbr.read_t)) - st b in - manager#project_parse ~patternSharing overwrites >>= - fun out -> Lwt.return (B (Nothing, msg_id, out)) - | "SimulationContinue" -> - let simulation_parameter = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#simulation_continue simulation_parameter >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - | "SimulationDelete" -> - manager#simulation_delete >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - | "SimulationDetailFileLine" -> - let file_line_id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#simulation_detail_file_line file_line_id >>= fun out -> - Lwt.return (B (Strings, msg_id, out)) - | "SimulationDetailDIN" -> - let din_id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#simulation_detail_din din_id >>= fun out -> - Lwt.return (B (DIN, msg_id, out)) - | "SimulationDetailLogMessage" -> - manager#simulation_detail_log_message >>= fun out -> - Lwt.return (B (String, msg_id, out)) - | "SimulationDetailPlot" -> - let plot_parameter = - JsonUtil.read_next_item Api_types_j.read_plot_parameter st b in - manager#simulation_detail_plot plot_parameter >>= fun out -> - Lwt.return (B (Plot, msg_id, out)) - | "SimulationDetailSnapshot" -> - let snapshot_id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#simulation_detail_snapshot snapshot_id >>= fun out -> - Lwt.return (B (Snapshot, msg_id, out)) - | "SimulationInfo" -> - manager#simulation_info >>= fun out -> - Lwt.return (B (Simulation_info, msg_id, out)) - | "SimulationEfficiency" -> - manager#simulation_efficiency >>= fun out -> - Lwt.return (B (Simulation_efficiency, msg_id, out)) - | "SimulationCatalogFileLine" -> - manager#simulation_catalog_file_line >>= fun out -> - Lwt.return (B (Strings, msg_id, out)) - | "SimulationCatalogDIN" -> - manager#simulation_catalog_din >>= fun out -> - Lwt.return (B (Strings, msg_id, out)) - | "SimulationCatalogSnapshot" -> - manager#simulation_catalog_snapshot >>= fun out -> - Lwt.return (B (Strings, msg_id, out)) - | "SimulationParameter" -> - manager#simulation_parameter >>= fun out -> - Lwt.return (B (Simulation_parameter, msg_id, out)) - | "SimulationTrace" -> - manager#simulation_raw_trace >>= fun out -> - Lwt.return (B (String, msg_id, out)) - | "SimulationOutputsZip" -> - manager#simulation_outputs_zip >>= fun out -> - Lwt.return (B (BigString, msg_id, out)) - (*(handler (fun result -> `SimulationOutputsZip (Base64.encode result)))*) - | "SimulationPause" -> - manager#simulation_pause >>= fun out -> - Lwt.return (B (Nothing, msg_id, out)) - | "SimulationIntervention" -> - let intervention = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - manager#simulation_intervention intervention >>= fun out -> - Lwt.return (B (String, msg_id, out)) - | "SimulationStart" -> - let simulation_parameter = - JsonUtil.read_next_item Api_types_j.read_simulation_parameter st b in - manager#simulation_start simulation_parameter >>= fun out -> - Lwt.return (B (Simulation_artifact, msg_id, out)) - (* Errors *) - | x -> - Lwt.return - (B (Nothing, msg_id, - Result_util.error [{ - Result_util.severity = Logs.Error; - range = None; - text = ("Invalid directive: "^x); - }])))) - st b)) - text) - (fun answer -> - let () = current_id := None in - match answer with - | B (Catalog, msg_id, x) -> - reply post (JsonUtil.write_list Kfiles.write_catalog_item) msg_id x - | B (Nothing, msg_id, x) -> reply post Yojson.Basic.write_null msg_id x - | B (BigString, msg_id, x) -> - let x = Result_util.map (Base64.encode ?pad:None ?alphabet:None) x in - reply post Yojson.Basic.write_string msg_id x - | B (String, msg_id, x) -> reply post Yojson.Basic.write_string msg_id x - | B (Strings, msg_id, x) -> - reply post (JsonUtil.write_list Yojson.Basic.write_string) msg_id x - | B (Ast, msg_id, x) -> reply post Ast.write_parsing_compil msg_id x - | B (JSON, msg_id, x) -> reply post Yojson.Basic.write_json msg_id x - | B (Info, msg_id, x) -> - reply post - (JsonUtil.write_compact_pair - Yojson.Basic.write_string Yojson.Basic.write_int) - msg_id x - | B (Influence_map, msg_id, x) -> - reply - post - (fun b n -> - Yojson.Basic.write_json - b (Public_data.local_influence_map_to_json n)) - msg_id x - | B (Short_influence_node, msg_id, x) -> - reply - post - (JsonUtil.write_option - (fun b n -> - Yojson.Basic.write_json - b (Public_data.short_influence_node_to_json n))) - msg_id x - | B (Influence_node, msg_id, x) -> - reply - post - (JsonUtil.write_option - (fun b n -> - Yojson.Basic.write_json - b (Public_data.refined_influence_node_to_json n))) - msg_id x - | B (Influence_nodes, msg_id, x) -> - reply - post - (fun b n -> - Yojson.Basic.write_json - b (Public_data.nodes_of_influence_map_to_json n)) - msg_id x - | B (Rules_kasa, msg_id, x) -> - reply - post - (fun b n -> + try + Lwt.bind + (JsonUtil.read_of_string + (JsonUtil.read_variant Yojson.Basic.read_int (fun st b msg_id -> + let () = current_id := Some msg_id in + JsonUtil.read_next_item + (JsonUtil.read_variant Yojson.Basic.read_string (fun st b -> + function + (* KaMoHa *) + | "FileCatalog" -> + manager#file_catalog >>= fun out -> + Lwt.return (B (Catalog, msg_id, out)) + | "FileCreate" -> + let position = + JsonUtil.read_next_item Yojson.Basic.read_int st b + in + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let content = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#file_create position id content >>= fun out -> + Lwt.return (B (Nothing, msg_id, out)) + | "FileGet" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#file_get id >>= fun out -> + Lwt.return (B (Info, msg_id, out)) + | "FileMove" -> + let position = + JsonUtil.read_next_item Yojson.Basic.read_int st b + in + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#file_move position id >>= fun out -> + Lwt.return (B (Nothing, msg_id, out)) + | "FileUpdate" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let content = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#file_update id content >>= fun out -> + Lwt.return (B (Nothing, msg_id, out)) + | "FileDelete" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#file_delete id >>= fun out -> + Lwt.return (B (Nothing, msg_id, out)) + | "ProjectOverwrite" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let content = + JsonUtil.read_next_item Ast.read_parsing_compil st b + in + manager#project_overwrite id content >>= fun out -> + Lwt.return (B (Nothing, msg_id, out)) + (* KaSa *) + | "INIT" -> + let compil = + JsonUtil.read_next_item Ast.read_parsing_compil st b + in + manager#init_static_analyser compil >>= fun out -> + Lwt.return + (B (Nothing, msg_id, Api_common.result_kasa out)) + | "CONTACT_MAP" -> + let acc = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let accuracy = + JsonUtil.to_option Public_data.accuracy_of_json acc + in + manager#get_contact_map accuracy >>= fun out -> + Lwt.return (B (JSON, msg_id, Api_common.result_kasa out)) + | "LOCAL_INFLUENCE_MAP" -> + let acc = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let fwd = + JsonUtil.read_next_item + (JsonUtil.read_option Yojson.Basic.read_int) + st b + in + let bwd = + JsonUtil.read_next_item + (JsonUtil.read_option Yojson.Basic.read_int) + st b + in + let total = + JsonUtil.read_next_item Yojson.Basic.read_int st b + in + let origin = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let accuracy = + JsonUtil.to_option Public_data.accuracy_of_json acc + in + let origin = + JsonUtil.to_option + Public_data.short_influence_node_of_json origin + in + manager#get_local_influence_map accuracy ?fwd ?bwd + ?origin ~total + >>= fun out -> + Lwt.return + (B (Influence_map, msg_id, Api_common.result_kasa out)) + | "INFLUENCE_MAP" -> + let acc = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let accuracy = + JsonUtil.to_option Public_data.accuracy_of_json acc + in + manager#get_influence_map_raw accuracy >>= fun out -> + Lwt.return + (B (String, msg_id, Api_common.result_kasa out)) + | "INFLUENCE_MAP_ORIGINAL_NODE" -> + manager#get_initial_node >>= fun out -> + Lwt.return + (B (Influence_node, msg_id, Api_common.result_kasa out)) + | "INFLUENCE_MAP_NEXT_NODE" -> + let origin = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let origin = + JsonUtil.to_option + Public_data.short_influence_node_of_json origin + in + manager#get_next_node origin >>= fun out -> + Lwt.return + (B (Influence_node, msg_id, Api_common.result_kasa out)) + | "INFLUENCE_MAP_PREVIOUS_NODE" -> + let origin = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let origin = + JsonUtil.to_option + Public_data.short_influence_node_of_json origin + in + manager#get_next_node origin >>= fun out -> + Lwt.return + (B (Influence_node, msg_id, Api_common.result_kasa out)) + | "INFLUENCE_MAP_NODE_AT" -> + let filename = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let pos = + JsonUtil.read_next_item Loc.read_position st b + in + manager#get_influence_map_node_at ~filename pos + >>= fun out -> + Lwt.return (B (Short_influence_node, msg_id, out)) + | "INFLUENCE_MAP_ALL_NODES" -> + let accuracy_level = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let accuracy = + JsonUtil.to_option Public_data.accuracy_of_json + accuracy_level + in + manager#get_nodes_of_influence_map accuracy + >>= fun out -> + Lwt.return + (B (Influence_nodes, msg_id, Api_common.result_kasa out)) + | "DEAD_RULES" -> + manager#get_dead_rules >>= fun out -> + Lwt.return + (B (Rules_kasa, msg_id, Api_common.result_kasa out)) + | "DEAD_AGENTS" -> + manager#get_dead_agents >>= fun out -> + Lwt.return + (B (Agents_kasa, msg_id, Api_common.result_kasa out)) + | "NON_WEAKLY_REVERSIBLE_TRANSITIONS" -> + manager#get_non_weakly_reversible_transitions + >>= fun out -> + Lwt.return + (B + ( Transitions_kasa, + msg_id, + Api_common.result_kasa out )) + | "CONSTRAINTS" -> + manager#get_constraints_list >>= fun out -> + Lwt.return + (B + ( Constraints_kasa, + msg_id, + Api_common.result_kasa out )) + | "POLYMERS" -> + let acc_cm = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let acc_scc = + JsonUtil.read_next_item Yojson.Basic.read_json st b + in + let accuracy_cm = + JsonUtil.to_option Public_data.accuracy_of_json acc_cm + in + let accuracy_scc = + JsonUtil.to_option Public_data.accuracy_of_json acc_scc + in + manager#get_potential_polymers accuracy_cm accuracy_scc + >>= fun out -> + Lwt.return + (B (Polymers_kasa, msg_id, Api_common.result_kasa out)) + (* KaSim *) + | "ProjectParse" -> + let patternSharing = + JsonUtil.read_next_item + Kappa_terms.Pattern.read_sharing_level st b + in + let overwrites = + JsonUtil.read_next_item + (Yojson.Basic.read_list + (JsonUtil.read_compact_pair + Yojson.Basic.read_string Nbr.read_t)) + st b + in + manager#project_parse ~patternSharing overwrites + >>= fun out -> Lwt.return (B (Nothing, msg_id, out)) + | "SimulationContinue" -> + let simulation_parameter = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#simulation_continue simulation_parameter + >>= fun out -> Lwt.return (B (Nothing, msg_id, out)) + | "SimulationDelete" -> + manager#simulation_delete >>= fun out -> + Lwt.return (B (Nothing, msg_id, out)) + | "SimulationDetailFileLine" -> + let file_line_id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#simulation_detail_file_line file_line_id + >>= fun out -> Lwt.return (B (Strings, msg_id, out)) + | "SimulationDetailDIN" -> + let din_id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#simulation_detail_din din_id >>= fun out -> + Lwt.return (B (DIN, msg_id, out)) + | "SimulationDetailLogMessage" -> + manager#simulation_detail_log_message >>= fun out -> + Lwt.return (B (String, msg_id, out)) + | "SimulationDetailPlot" -> + let plot_parameter = + JsonUtil.read_next_item Api_types_j.read_plot_parameter + st b + in + manager#simulation_detail_plot plot_parameter + >>= fun out -> Lwt.return (B (Plot, msg_id, out)) + | "SimulationDetailSnapshot" -> + let snapshot_id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#simulation_detail_snapshot snapshot_id + >>= fun out -> Lwt.return (B (Snapshot, msg_id, out)) + | "SimulationInfo" -> + manager#simulation_info >>= fun out -> + Lwt.return (B (Simulation_info, msg_id, out)) + | "SimulationEfficiency" -> + manager#simulation_efficiency >>= fun out -> + Lwt.return (B (Simulation_efficiency, msg_id, out)) + | "SimulationCatalogFileLine" -> + manager#simulation_catalog_file_line >>= fun out -> + Lwt.return (B (Strings, msg_id, out)) + | "SimulationCatalogDIN" -> + manager#simulation_catalog_din >>= fun out -> + Lwt.return (B (Strings, msg_id, out)) + | "SimulationCatalogSnapshot" -> + manager#simulation_catalog_snapshot >>= fun out -> + Lwt.return (B (Strings, msg_id, out)) + | "SimulationParameter" -> + manager#simulation_parameter >>= fun out -> + Lwt.return (B (Simulation_parameter, msg_id, out)) + | "SimulationTrace" -> + manager#simulation_raw_trace >>= fun out -> + Lwt.return (B (String, msg_id, out)) + | "SimulationOutputsZip" -> + manager#simulation_outputs_zip >>= fun out -> + Lwt.return (B (BigString, msg_id, out)) + (*(handler (fun result -> `SimulationOutputsZip (Base64.encode result)))*) + | "SimulationPause" -> + manager#simulation_pause >>= fun out -> + Lwt.return (B (Nothing, msg_id, out)) + | "SimulationIntervention" -> + let intervention = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + manager#simulation_intervention intervention + >>= fun out -> Lwt.return (B (String, msg_id, out)) + | "SimulationStart" -> + let simulation_parameter = + JsonUtil.read_next_item + Api_types_j.read_simulation_parameter st b + in + manager#simulation_start simulation_parameter + >>= fun out -> + Lwt.return (B (Simulation_artifact, msg_id, out)) + (* Errors *) + | x -> + Lwt.return + (B + ( Nothing, + msg_id, + Result_util.error + [ + { + Result_util.severity = Logs.Error; + range = None; + text = "Invalid directive: " ^ x; + }; + ] )))) + st b)) + text) + (fun answer -> + let () = current_id := None in + match answer with + | B (Catalog, msg_id, x) -> + reply post (JsonUtil.write_list Kfiles.write_catalog_item) msg_id x + | B (Nothing, msg_id, x) -> + reply post Yojson.Basic.write_null msg_id x + | B (BigString, msg_id, x) -> + let x = + Result_util.map (Base64.encode ?pad:None ?alphabet:None) x + in + reply post Yojson.Basic.write_string msg_id x + | B (String, msg_id, x) -> + reply post Yojson.Basic.write_string msg_id x + | B (Strings, msg_id, x) -> + reply post (JsonUtil.write_list Yojson.Basic.write_string) msg_id x + | B (Ast, msg_id, x) -> reply post Ast.write_parsing_compil msg_id x + | B (JSON, msg_id, x) -> reply post Yojson.Basic.write_json msg_id x + | B (Info, msg_id, x) -> + reply post + (JsonUtil.write_compact_pair Yojson.Basic.write_string + Yojson.Basic.write_int) + msg_id x + | B (Influence_map, msg_id, x) -> + reply post + (fun b n -> + Yojson.Basic.write_json b + (Public_data.local_influence_map_to_json n)) + msg_id x + | B (Short_influence_node, msg_id, x) -> + reply post + (JsonUtil.write_option (fun b n -> + Yojson.Basic.write_json b + (Public_data.short_influence_node_to_json n))) + msg_id x + | B (Influence_node, msg_id, x) -> + reply post + (JsonUtil.write_option (fun b n -> + Yojson.Basic.write_json b + (Public_data.refined_influence_node_to_json n))) + msg_id x + | B (Influence_nodes, msg_id, x) -> + reply post + (fun b n -> + Yojson.Basic.write_json b + (Public_data.nodes_of_influence_map_to_json n)) + msg_id x + | B (Rules_kasa, msg_id, x) -> + reply post + (fun b n -> Yojson.Basic.write_json b (Public_data.dead_rules_to_json n)) - msg_id x - | B (Agents_kasa, msg_id, x) -> - reply - post - (fun b n -> + msg_id x + | B (Agents_kasa, msg_id, x) -> + reply post + (fun b n -> Yojson.Basic.write_json b (Public_data.json_of_dead_agents n)) - msg_id x - | B (Transitions_kasa, msg_id, x) -> - reply - post - (fun b n -> - Yojson.Basic.write_json b (Public_data.separating_transitions_to_json n)) - msg_id x - | B (Constraints_kasa, msg_id, x) -> - reply - post - (fun b n -> + msg_id x + | B (Transitions_kasa, msg_id, x) -> + reply post + (fun b n -> + Yojson.Basic.write_json b + (Public_data.separating_transitions_to_json n)) + msg_id x + | B (Constraints_kasa, msg_id, x) -> + reply post + (fun b n -> Yojson.Basic.write_json b (Public_data.lemmas_list_to_json n)) - msg_id x - | B (Polymers_kasa, msg_id, x) -> - reply - post - (fun b n -> - Yojson.Basic.write_json b (Public_data.scc_to_json n)) - msg_id x - | B (DIN, msg_id, x) -> reply post Data.write_din msg_id x - | B (Plot, msg_id, x) -> reply post Data.write_plot msg_id x - | B (Snapshot, msg_id, x) -> reply post Data.write_snapshot msg_id x - | B (Simulation_efficiency, msg_id, x) -> - reply post Counter.Efficiency.write_t msg_id x - | B (Simulation_info, msg_id, x) -> - reply post Api_types_j.write_simulation_info msg_id x - | B (Simulation_parameter, msg_id, x) -> - reply post Api_types_j.write_simulation_parameter msg_id x - | B (Simulation_artifact, msg_id, x) -> - reply post Api_types_j.write_simulation_artifact msg_id x - ) - with e -> - match !current_id with - | Some msg_id -> - reply post Yojson.Basic.write_null msg_id - (Result_util.error [{Result_util.severity = Logs.Error; - range = None; - text = ("Exception raised: "^ - Printexc.to_string e);}]) - | None -> - match e with - | Yojson.Json_error x -> - post - (Yojson.to_string - (`String (x^"\nMessage format must be [ id, [\"Request\", ... ] ]"))) - | e -> - post - (Yojson.to_string - (`String ("unexpected exception: "^ - Printexc.to_string e^ - "\nMessage format must be [ id, [\"Request\", ... ] ]"))) + msg_id x + | B (Polymers_kasa, msg_id, x) -> + reply post + (fun b n -> Yojson.Basic.write_json b (Public_data.scc_to_json n)) + msg_id x + | B (DIN, msg_id, x) -> reply post Data.write_din msg_id x + | B (Plot, msg_id, x) -> reply post Data.write_plot msg_id x + | B (Snapshot, msg_id, x) -> reply post Data.write_snapshot msg_id x + | B (Simulation_efficiency, msg_id, x) -> + reply post Counter.Efficiency.write_t msg_id x + | B (Simulation_info, msg_id, x) -> + reply post Api_types_j.write_simulation_info msg_id x + | B (Simulation_parameter, msg_id, x) -> + reply post Api_types_j.write_simulation_parameter msg_id x + | B (Simulation_artifact, msg_id, x) -> + reply post Api_types_j.write_simulation_artifact msg_id x) + with e -> + (match !current_id with + | Some msg_id -> + reply post Yojson.Basic.write_null msg_id + (Result_util.error + [ + { + Result_util.severity = Logs.Error; + range = None; + text = "Exception raised: " ^ Printexc.to_string e; + }; + ]) + | None -> + (match e with + | Yojson.Json_error x -> + post + (Yojson.to_string + (`String + (x ^ "\nMessage format must be [ id, [\"Request\", ... ] ]"))) + | e -> + post + (Yojson.to_string + (`String + ("unexpected exception: " ^ Printexc.to_string e + ^ "\nMessage format must be [ id, [\"Request\", ... ] ]"))))) (* start server *) let () = let common_args = Common_args.default in let stdsim_args = Agent_args.default in let options = - Common_args.options common_args @ Agent_args.options stdsim_args in + Common_args.options common_args @ Agent_args.options stdsim_args + in let usage_msg = "Kappa Model Handler" in - let () = Arg.parse options - (fun x -> raise (Arg.Bad ("Don't know what to do of "^x))) usage_msg in + let () = + Arg.parse options + (fun x -> raise (Arg.Bad ("Don't know what to do of " ^ x))) + usage_msg + in let () = Printexc.record_backtrace common_args.Common_args.backtrace in Lwt_main.run (Agent_common.serve Lwt_io.stdin stdsim_args.Agent_args.delimiter diff --git a/core/agents/agent_common.ml b/core/agents/agent_common.ml index 573c8a9f35..034a402283 100644 --- a/core/agents/agent_common.ml +++ b/core/agents/agent_common.ml @@ -11,28 +11,33 @@ open Lwt.Infix let lwt_reporter chan = let buf_fmt ~like = let b = Buffer.create 512 in - Fmt.with_buffer ~like b, - fun () -> let m = Buffer.contents b in Buffer.reset b; m + ( Fmt.with_buffer ~like b, + fun () -> + let m = Buffer.contents b in + Buffer.reset b; + m ) in let app, app_flush = buf_fmt ~like:Fmt.stdout in let dst, dst_flush = buf_fmt ~like:Fmt.stderr in let reporter = Logs_fmt.reporter ~app ~dst () in let report src level ~over k msgf = let k () = - let write () = match level with - | Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ()) - | Logs.Debug | Logs.Info | Logs.Warning | Logs.Error -> - Lwt_io.write - (Option_util.unsome Lwt_io.stderr chan) - (dst_flush ()) + let write () = + match level with + | Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ()) + | Logs.Debug | Logs.Info | Logs.Warning | Logs.Error -> + Lwt_io.write (Option_util.unsome Lwt_io.stderr chan) (dst_flush ()) + in + let unblock () = + over (); + Lwt.return_unit in - let unblock () = over (); Lwt.return_unit in Lwt.finalize write unblock |> Lwt.ignore_result; k () in - reporter.Logs.report src level ~over:(fun () -> ()) k msgf; + reporter.Logs.report src level ~over:(fun () -> ()) k msgf in - { Logs.report = report } + { Logs.report } (* http://ocsigen.org/lwt/2.5.2/api/Lwt_io *) let serve chan delimiter process_command : unit Lwt.t = @@ -41,12 +46,15 @@ let serve chan delimiter process_command : unit Lwt.t = let rec aux_serve () = Lwt_io.read_char_opt chan >>= function | Some char -> - if char = delimiter then + if char = delimiter then ( let m = Buffer.contents buffer in process_command m >>= fun () -> - let () = Buffer.reset buffer in aux_serve () - else + let () = Buffer.reset buffer in + aux_serve () + ) else ( let () = Buffer.add_char buffer char in aux_serve () - | None -> Lwt.return_unit in + ) + | None -> Lwt.return_unit + in aux_serve () diff --git a/core/agents/agent_common.mli b/core/agents/agent_common.mli index 5f6a4b1993..e9f29b7007 100644 --- a/core/agents/agent_common.mli +++ b/core/agents/agent_common.mli @@ -7,5 +7,4 @@ (******************************************************************************) val lwt_reporter : Lwt_io.output_channel option -> Logs.reporter - val serve : Lwt_io.input_channel -> char -> (string -> unit Lwt.t) -> unit Lwt.t diff --git a/core/agents/agents_client.ml b/core/agents/agents_client.ml index ec870dd1c5..4898b3ebc3 100644 --- a/core/agents/agents_client.ml +++ b/core/agents/agents_client.ml @@ -6,61 +6,67 @@ let serve chan delimiter process_command : unit Lwt.t = let rec aux_serve () = Lwt_io.read_char_opt chan >>= function | Some char -> - if char = delimiter then + if char = delimiter then ( let m = Buffer.contents buffer in process_command m; - let () = Buffer.reset buffer in aux_serve () - else + let () = Buffer.reset buffer in + aux_serve () + ) else ( let () = Buffer.add_char buffer char in aux_serve () - | None -> Lwt.return_unit in + ) + | None -> Lwt.return_unit + in aux_serve () let post chan message_delimiter message_text = Lwt.ignore_result (Lwt_io.atomic (fun chan -> - Lwt_io.write chan message_text >>= fun () -> - Lwt_io.write_char chan message_delimiter) + Lwt_io.write chan message_text >>= fun () -> + Lwt_io.write_char chan message_delimiter) chan) class t exec_command message_delimiter = let switch_re = Re.compile (Re.str "KappaSwitchman") in let kamoha = - let command = Re.replace_string switch_re ~by:"KaMoHa" exec_command in + let command = Re.replace_string switch_re ~by:"KaMoHa" exec_command in Lwt_process.open_process_full - (command,[|command;"--delimiter";Char.escaped message_delimiter|]) in + (command, [| command; "--delimiter"; Char.escaped message_delimiter |]) + in let kasim = - let command = Re.replace_string switch_re ~by:"KaSimAgent" exec_command in + let command = Re.replace_string switch_re ~by:"KaSimAgent" exec_command in Lwt_process.open_process_full - (command,[|command;"--delimiter";Char.escaped message_delimiter|]) in + (command, [| command; "--delimiter"; Char.escaped message_delimiter |]) + in (*let kastor = let command = Re.replace_string switch_re ~by:"KaSimAgent" exec_command in Lwt_process.open_process_full (command,[|comman;"--delimiter";Char.escaped message_delimiter|]) in*) let kasa = - let command = Re.replace_string switch_re ~by:"KaSaAgent" exec_command in + let command = Re.replace_string switch_re ~by:"KaSaAgent" exec_command in Lwt_process.open_process_full - (command,[|command;"--delimiter";Char.escaped message_delimiter|]) in + (command, [| command; "--delimiter"; Char.escaped message_delimiter |]) + in let moha_mailbox = Kamoha_client.new_mailbox () in let sa_mailbox = Kasa_client.new_mailbox () in (*let stor_state,update_stor_state = Kastor_client.init_state () in*) - object(self) + object (self) initializer let () = - serve - kamoha#stdout message_delimiter (Kamoha_client.receive moha_mailbox) - |> Lwt.ignore_result in + serve kamoha#stdout message_delimiter + (Kamoha_client.receive moha_mailbox) + |> Lwt.ignore_result + in (*let () = serve kastor#stdout message_delimiter (Kastor_client.receive update_stor_state) |> Lwt.ignore_result in*) let () = - serve - kasa#stdout message_delimiter (Kasa_client.receive sa_mailbox) - |> Lwt.ignore_result in - serve kasim#stdout message_delimiter self#receive - |> Lwt.ignore_result + serve kasa#stdout message_delimiter (Kasa_client.receive sa_mailbox) + |> Lwt.ignore_result + in + serve kasim#stdout message_delimiter self#receive |> Lwt.ignore_result method terminate = kamoha#terminate; @@ -69,16 +75,18 @@ class t exec_command message_delimiter = kasa#terminate method is_running = - kamoha#state = Lwt_process.Running && - kasim#state = Lwt_process.Running && - (*kastor#state = Lwt_process.Running &&*) + kamoha#state = Lwt_process.Running + && kasim#state = Lwt_process.Running + && (*kastor#state = Lwt_process.Running &&*) kasa#state = Lwt_process.Running method is_computing = - self#sim_is_computing || Kasa_client.is_computing sa_mailbox || - (*self#story_is_computing ||*) Kamoha_client.is_computing moha_mailbox + self#sim_is_computing + || Kasa_client.is_computing sa_mailbox + || (*self#story_is_computing ||*) Kamoha_client.is_computing moha_mailbox - inherit Kasa_client.new_client + inherit + Kasa_client.new_client ~is_running:(fun () -> kasa#state = Lwt_process.Running) ~post:(post kasa#stdin message_delimiter) sa_mailbox @@ -87,38 +95,44 @@ class t exec_command message_delimiter = ~post:(post kastor#stdin message_delimiter) stor_state*) - inherit Kamoha_client.new_client + inherit + Kamoha_client.new_client ~post:(post kamoha#stdin message_delimiter) moha_mailbox method private sleep timeout = Lwt_unix.sleep timeout method private post_message txt = post kasim#stdin message_delimiter txt inherit Mpi_api.manager () - val mutable kasa_locator = [] method project_parse ~patternSharing overwrites = - self#secret_project_parse >>= - Api_common.result_bind_lwt - ~ok:(fun out -> - let load = self#secret_simulation_load patternSharing out overwrites in - let init = self#init_static_analyser out in - let locators = - init >>= function - | Result.Error _ as e -> - let () = kasa_locator <- [] in - Lwt.return (Api_common.result_kasa e) - | Result.Ok () -> - self#get_pos_of_rules_and_vars >>= function - | Result.Ok infos -> - let () = kasa_locator <- infos in - Lwt.return (Result_util.ok ()) - |Result.Error _ as e -> + self#secret_project_parse + >>= Api_common.result_bind_lwt ~ok:(fun out -> + let load = + self#secret_simulation_load patternSharing out overwrites + in + let init = self#init_static_analyser out in + let locators = + init >>= function + | Result.Error _ as e -> let () = kasa_locator <- [] in - Lwt.return (Api_common.result_kasa e) in - load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) + Lwt.return (Api_common.result_kasa e) + | Result.Ok () -> + self#get_pos_of_rules_and_vars >>= ( function + | Result.Ok infos -> + let () = kasa_locator <- infos in + Lwt.return (Result_util.ok ()) + | Result.Error _ as e -> + let () = kasa_locator <- [] in + Lwt.return (Api_common.result_kasa e) ) + in + load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) method get_influence_map_node_at ~filename pos : _ Api.result Lwt.t = - List.find_opt (fun (_,x) -> Locality.is_included_in filename pos x) kasa_locator |> - Option_util.map fst |> Result_util.ok ?status:None |> Lwt.return + List.find_opt + (fun (_, x) -> Loc.is_included_in filename pos x) + kasa_locator + |> Option_util.map fst + |> Result_util.ok ?status:None + |> Lwt.return end diff --git a/core/agents/app_args.ml b/core/agents/app_args.ml index d7a9111cc3..998a618b86 100644 --- a/core/agents/app_args.ml +++ b/core/agents/app_args.ml @@ -9,46 +9,50 @@ type api_version = V2 type t = { - mutable api : api_version; - mutable log_channel : Lwt_io.output_channel option; + mutable api: api_version; + mutable log_channel: Lwt_io.output_channel option; } -let default : t = { api = V2; log_channel = None; } +let default : t = { api = V2; log_channel = None } -let options (t :t) : (string * Arg.spec * string) list = [ - ("--development", - Arg.Unit - (fun () -> t.api <- V2), - "enable experimental api - not intended for public use or comment"); - ("--log", - Arg.String - (fun file_name -> - let () = Lwt.ignore_result (match t.log_channel with - | None -> Lwt.return_unit - | Some c -> Lwt_io.close c) in - if file_name = "-" then t.log_channel <- None - else - let fd = Unix.openfile - file_name - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND; Unix.O_NONBLOCK] - 0o640 in - let () = Unix.set_close_on_exec fd in - t.log_channel <- - Some (Lwt_io.of_unix_fd ~mode:Lwt_io.output fd) - ), - "path to log file path '-' logs to stdout"); - ("--level", - Arg.String - (fun level -> - Logs.set_level - (Some (match level with - | "debug" -> Logs.Debug - | "info" -> Logs.Info - | "warning" -> Logs.Warning - | "error" -> Logs.Error - | "app" -> Logs.App - | level -> raise (Arg.Bad ("\""^level^"\" is not a valid level")) - ))), - "levels : debug,info,warning,error,app" - ) +let options (t : t) : (string * Arg.spec * string) list = + [ + ( "--development", + Arg.Unit (fun () -> t.api <- V2), + "enable experimental api - not intended for public use or comment" ); + ( "--log", + Arg.String + (fun file_name -> + let () = + Lwt.ignore_result + (match t.log_channel with + | None -> Lwt.return_unit + | Some c -> Lwt_io.close c) + in + if file_name = "-" then + t.log_channel <- None + else ( + let fd = + Unix.openfile file_name + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND; Unix.O_NONBLOCK ] + 0o640 + in + let () = Unix.set_close_on_exec fd in + t.log_channel <- Some (Lwt_io.of_unix_fd ~mode:Lwt_io.output fd) + )), + "path to log file path '-' logs to stdout" ); + ( "--level", + Arg.String + (fun level -> + Logs.set_level + (Some + (match level with + | "debug" -> Logs.Debug + | "info" -> Logs.Info + | "warning" -> Logs.Warning + | "error" -> Logs.Error + | "app" -> Logs.App + | level -> + raise (Arg.Bad ("\"" ^ level ^ "\" is not a valid level"))))), + "levels : debug,info,warning,error,app" ); ] diff --git a/core/agents/app_args.mli b/core/agents/app_args.mli index 6e0befe3d6..f5e225816c 100644 --- a/core/agents/app_args.mli +++ b/core/agents/app_args.mli @@ -1,11 +1,9 @@ type api_version = V2 -type t = -{ - mutable api : api_version; - mutable log_channel : Lwt_io.output_channel option; +type t = { + mutable api: api_version; + mutable log_channel: Lwt_io.output_channel option; } val default : t - -val options: t -> (string * Arg.spec * string) list +val options : t -> (string * Arg.spec * string) list diff --git a/core/agents/dune b/core/agents/dune index fc5936cbd3..08a7903d59 100644 --- a/core/agents/dune +++ b/core/agents/dune @@ -1,37 +1,55 @@ (library - (name kappa_agents) - (modules agent_common app_args) - (libraries logs.fmt lwt.unix kappa-library.generic) - (flags (:standard -w @a - -open Kappa_generic_toolset))) + (name kappa_agents) + (modules agent_common app_args) + (libraries logs.fmt lwt.unix kappa-library.generic) + (flags + (:standard -w @a -open Kappa_generic_toolset))) (executable - (name KaStor) - (modules KaStor) - (libraries yojson lwt.unix kappa_cflow kappa_agents) - (public_name KaStor) - (package kappa-binaries) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_runtime - -open Kappa_cli - -open Kappa_logging - -open Kappa_cflow - -open Kappa_agents - -open Kappa_parameters))) + (name KaStor) + (modules KaStor) + (libraries yojson lwt.unix kappa_cflow kappa_agents) + (public_name KaStor) + (package kappa-binaries) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_runtime + -open + Kappa_cli + -open + Kappa_logging + -open + Kappa_cflow + -open + Kappa_agents + -open + Kappa_parameters))) (executable - (name KaSimAgent) - (modules KaSimAgent) - (libraries logs.lwt logs.fmt lwt.unix - kappa_json_api kappa-library.runtime kappa_agents) - (public_name KaSimAgent) - (package kappa-agents) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_cli - -open Kappa_agents - -open Kappa_json_api))) + (name KaSimAgent) + (modules KaSimAgent) + (libraries + logs.lwt + logs.fmt + lwt.unix + kappa_json_api + kappa-library.runtime + kappa_agents) + (public_name KaSimAgent) + (package kappa-agents) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_cli + -open + Kappa_agents + -open + Kappa_json_api))) (executable (name KaMoHa) @@ -39,44 +57,80 @@ (libraries logs.lwt lwt.unix kappa_grammar kappa_cli kappa_agents) (public_name KaMoHa) (package kappa-agents) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_grammar - -open Kappa_cli - -open Kappa_agents))) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_grammar + -open + Kappa_cli + -open + Kappa_agents))) (executable (name KappaSwitchman) (modules agents_client KappaSwitchman) - (libraries logs.lwt lwt.unix kappa_json_api kappa_cli kappa_agents - kappa_staticanalyses kappa-library.runtime) + (libraries + logs.lwt + lwt.unix + kappa_json_api + kappa_cli + kappa_agents + kappa_staticanalyses + kappa-library.runtime) (public_name KappaSwitchman) (package kappa-agents) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_grammar - -open Kappa_cli - -open Kappa_kasa_type_interface - -open Kappa_runtime - -open Kappa_json_api - -open Kappa_agents))) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_grammar + -open + Kappa_cli + -open + Kappa_kasa_type_interface + -open + Kappa_runtime + -open + Kappa_json_api + -open + Kappa_agents))) (executable - (name KaSaAgent) - (modules KaSaAgent) - (libraries num str lwt.unix kappa_staticanalyses - kappa_json_api kappa_agents) - (public_name KaSaAgent) - (package kappa-agents) - (flags (:standard - -open Kappa_logging - -open Kappa_errors - -open Kappa_parameters - -open Kappa_reachability - -open Kappa_staticanalyses - -open Kappa_kasa_frontend - -open Kappa_kasa_export - -open Kappa_kasa_type_interface - -open Kappa_agents - -open Kappa_cli - -open Kappa_json_api))) + (name KaSaAgent) + (modules KaSaAgent) + (libraries + num + str + lwt.unix + kappa_staticanalyses + kappa_json_api + kappa_agents) + (public_name KaSaAgent) + (package kappa-agents) + (flags + (:standard + -open + Kappa_logging + -open + Kappa_errors + -open + Kappa_parameters + -open + Kappa_reachability + -open + Kappa_staticanalyses + -open + Kappa_kasa_frontend + -open + Kappa_kasa_export + -open + Kappa_kasa_type_interface + -open + Kappa_agents + -open + Kappa_cli + -open + Kappa_json_api))) diff --git a/core/api/api.ml b/core/api/api.ml index 0ece23da07..42f453f7d6 100644 --- a/core/api/api.ml +++ b/core/api/api.ml @@ -11,51 +11,42 @@ are run using the kappa code. *) -type compression_modes = { causal : bool; weak : bool; strong : bool; } - +type compression_modes = { causal: bool; weak: bool; strong: bool } type 'ok result = ('ok, Result_util.message list) Result_util.t - type project_id = string class type manager_environment = object - method environment_info: - unit -> Api_types_t.environment_info result Lwt.t + method environment_info : unit -> Api_types_t.environment_info result Lwt.t end class type virtual manager_model = object method virtual is_running : bool method secret_project_parse : Ast.parsing_compil result Lwt.t - method project_overwrite : string -> Ast.parsing_compil -> unit result Lwt.t - method file_catalog : Kfiles.catalog_item list result Lwt.t - method file_create : int -> string -> string -> unit result Lwt.t - method file_get : string -> (string * int) result Lwt.t - method file_update : string -> string -> unit result Lwt.t - method file_move : int -> string -> unit result Lwt.t - method file_delete : string -> unit result Lwt.t end class type manager_file_line = object method simulation_catalog_file_line : Api_types_t.file_line_catalog result Lwt.t + method simulation_detail_file_line : string -> string list result Lwt.t end class type manager_din = object method simulation_catalog_din : Api_types_t.din_catalog result Lwt.t + method simulation_detail_din : Api_types_t.din_id -> Api_types_t.din result Lwt.t end class type manager_log_message = object - method simulation_detail_log_message : - Api_types_t.log_message result Lwt.t + method simulation_detail_log_message : Api_types_t.log_message result Lwt.t end class type manager_plot = object @@ -65,13 +56,16 @@ end class type manager_snapshot = object method simulation_catalog_snapshot : Api_types_t.snapshot_catalog result Lwt.t + method simulation_detail_snapshot : Api_types_t.snapshot_id -> Api_types_t.snapshot result Lwt.t end class type manager_simulation = object method secret_simulation_load : - Pattern.sharing_level -> Ast.parsing_compil -> (string * Nbr.t) list -> + Pattern.sharing_level -> + Ast.parsing_compil -> + (string * Nbr.t) list -> unit result Lwt.t method simulation_delete : unit result Lwt.t @@ -86,17 +80,11 @@ class type manager_simulation = object Api_types_t.simulation_intervention -> string result Lwt.t method simulation_continue : string -> unit result Lwt.t - method simulation_info : Api_types_t.simulation_info result Lwt.t - method simulation_efficiency : Counter.Efficiency.t result Lwt.t - method simulation_parameter : Api_types_t.simulation_parameter result Lwt.t - method simulation_raw_trace : string result Lwt.t - method simulation_outputs_zip : Bigbuffer.bigstring result Lwt.t - inherit manager_file_line inherit manager_din inherit manager_log_message @@ -109,110 +97,153 @@ type 'a kasa_reply = class type manager_static_analysis = object method init_static_analyser : Ast.parsing_compil -> unit kasa_reply + method init_static_analyser_raw : string -> unit kasa_reply (** The string has to be the json corresponding to an [Ast.parsing_compil] *) method get_contact_map : Public_data.accuracy_level option -> Yojson.Basic.t kasa_reply + method get_pos_of_rules_and_vars : - Public_data.pos_of_rules_and_vars kasa_reply + Public_data.pos_of_rules_and_vars kasa_reply + method get_influence_map_raw : Public_data.accuracy_level option -> string kasa_reply + method get_local_influence_map : - ?fwd:int -> ?bwd:int -> ?origin:(int,int) Public_data.influence_node -> - total:int -> Public_data.accuracy_level option -> - (Public_data.accuracy_level * int * int option * int option * - (Public_data.rule, Public_data.var) Public_data.influence_node - option * - Public_data.influence_map) kasa_reply + ?fwd:int -> + ?bwd:int -> + ?origin:(int, int) Public_data.influence_node -> + total:int -> + Public_data.accuracy_level option -> + (Public_data.accuracy_level + * int + * int option + * int option + * (Public_data.rule, Public_data.var) Public_data.influence_node option + * Public_data.influence_map) + kasa_reply + method get_initial_node : - (Public_data.rule, Public_data.var) Public_data.influence_node - option kasa_reply + (Public_data.rule, Public_data.var) Public_data.influence_node option + kasa_reply + method get_next_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option kasa_reply + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option + kasa_reply + method get_previous_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option kasa_reply + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option + kasa_reply + method get_nodes_of_influence_map : Public_data.accuracy_level option -> - (Public_data.accuracy_level * - (Public_data.rule, Public_data.var) Public_data.influence_node - list) kasa_reply + (Public_data.accuracy_level + * (Public_data.rule, Public_data.var) Public_data.influence_node list) + kasa_reply + method get_dead_rules : Public_data.dead_rules kasa_reply - method get_dead_agents: Public_data.dead_agents kasa_reply + method get_dead_agents : Public_data.dead_agents kasa_reply + method get_non_weakly_reversible_transitions : Public_data.separating_transitions kasa_reply + method get_constraints_list : (string * Public_data.agent list Public_data.lemma list) list kasa_reply + method get_potential_polymers : Public_data.accuracy_level option -> Public_data.accuracy_level option -> (Public_data.accuracy_level * Public_data.accuracy_level * Public_data.scc) - kasa_reply + kasa_reply end class type uniform_manager_static_analysis = object method init_static_analyser : Ast.parsing_compil -> unit result Lwt.t + method init_static_analyser_raw : string -> unit result Lwt.t (** The string has to be the json corresponding to an [Ast.parsing_compil] *) method get_contact_map : Public_data.accuracy_level option -> Yojson.Basic.t result Lwt.t + method secret_get_pos_of_rules_and_vars : - Public_data.pos_of_rules_and_vars result Lwt.t + Public_data.pos_of_rules_and_vars result Lwt.t + method get_influence_map_raw : Public_data.accuracy_level option -> string result Lwt.t + method get_local_influence_map : - ?fwd:int -> ?bwd:int -> ?origin:(int,int) Public_data.influence_node -> - total:int -> Public_data.accuracy_level option -> - (Public_data.accuracy_level * int * int option * int option * - (Public_data.rule, Public_data.var) Public_data.influence_node - option * - Public_data.influence_map) result Lwt.t + ?fwd:int -> + ?bwd:int -> + ?origin:(int, int) Public_data.influence_node -> + total:int -> + Public_data.accuracy_level option -> + (Public_data.accuracy_level + * int + * int option + * int option + * (Public_data.rule, Public_data.var) Public_data.influence_node option + * Public_data.influence_map) + result + Lwt.t + method get_initial_node : - (Public_data.rule, Public_data.var) Public_data.influence_node - option result Lwt.t + (Public_data.rule, Public_data.var) Public_data.influence_node option result + Lwt.t + method get_next_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option result Lwt.t + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option result + Lwt.t + method get_previous_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option result Lwt.t + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option result + Lwt.t + method get_nodes_of_influence_map : Public_data.accuracy_level option -> - (Public_data.accuracy_level * - (Public_data.rule, Public_data.var) Public_data.influence_node - list) result Lwt.t + (Public_data.accuracy_level + * (Public_data.rule, Public_data.var) Public_data.influence_node list) + result + Lwt.t + method get_dead_rules : Public_data.dead_rules result Lwt.t - method get_dead_agents: Public_data.dead_agents result Lwt.t + method get_dead_agents : Public_data.dead_agents result Lwt.t + method get_non_weakly_reversible_transitions : Public_data.separating_transitions result Lwt.t + method get_constraints_list : (string * Public_data.agent list Public_data.lemma list) list result Lwt.t + method get_potential_polymers : Public_data.accuracy_level option -> Public_data.accuracy_level option -> (Public_data.accuracy_level * Public_data.accuracy_level * Public_data.scc) - result Lwt.t + result + Lwt.t end class type virtual manager_stories = object method virtual is_running : bool + method config_story_computation : - compression_modes -> (unit,string) Lwt_result.t - method raw_launch_story_computation : string -> (unit,string) Lwt_result.t + compression_modes -> (unit, string) Lwt_result.t + + method raw_launch_story_computation : string -> (unit, string) Lwt_result.t method story_log : string list method story_is_computing : bool method story_progress : Story_json.progress_bar option + method story_list : - (compression_modes * - unit Trace.Simulation_info.t list list * - Graph_loggers_sig.graph) Mods.IntMap.t + (compression_modes + * unit Trace.Simulation_info.t list list + * Graph_loggers_sig.graph) + Mods.IntMap.t end class type concrete_manager = object @@ -220,12 +251,17 @@ class type concrete_manager = object inherit manager_simulation inherit uniform_manager_static_analysis inherit manager_stories + method project_parse : - patternSharing:Pattern.sharing_level -> (string * Nbr.t) list -> + patternSharing:Pattern.sharing_level -> + (string * Nbr.t) list -> unit result Lwt.t + method get_influence_map_node_at : - filename:string -> Locality.position -> (int,int) Public_data.influence_node - option result Lwt.t + filename:string -> + Loc.position -> + (int, int) Public_data.influence_node option result Lwt.t + method is_running : bool method terminate : unit method is_computing : bool @@ -235,7 +271,6 @@ class type rest_manager = object inherit manager_environment inherit concrete_manager method project_catalog : string list result Lwt.t - method project_create : - Api_types_t.project_parameter -> unit result Lwt.t + method project_create : Api_types_t.project_parameter -> unit result Lwt.t method project_delete : project_id -> unit result Lwt.t end diff --git a/core/api/api.mli b/core/api/api.mli index 0ffb4e5493..42f453f7d6 100644 --- a/core/api/api.mli +++ b/core/api/api.mli @@ -11,51 +11,42 @@ are run using the kappa code. *) -type compression_modes = { causal : bool; weak : bool; strong : bool; } - +type compression_modes = { causal: bool; weak: bool; strong: bool } type 'ok result = ('ok, Result_util.message list) Result_util.t - type project_id = string class type manager_environment = object - method environment_info: - unit -> Api_types_t.environment_info result Lwt.t + method environment_info : unit -> Api_types_t.environment_info result Lwt.t end class type virtual manager_model = object method virtual is_running : bool method secret_project_parse : Ast.parsing_compil result Lwt.t - method project_overwrite : string -> Ast.parsing_compil -> unit result Lwt.t - method file_catalog : Kfiles.catalog_item list result Lwt.t - method file_create : int -> string -> string -> unit result Lwt.t - method file_get : string -> (string * int) result Lwt.t - method file_update : string -> string -> unit result Lwt.t - method file_move : int -> string -> unit result Lwt.t - method file_delete : string -> unit result Lwt.t end class type manager_file_line = object method simulation_catalog_file_line : Api_types_t.file_line_catalog result Lwt.t + method simulation_detail_file_line : string -> string list result Lwt.t end class type manager_din = object method simulation_catalog_din : Api_types_t.din_catalog result Lwt.t + method simulation_detail_din : Api_types_t.din_id -> Api_types_t.din result Lwt.t end class type manager_log_message = object - method simulation_detail_log_message : - Api_types_t.log_message result Lwt.t + method simulation_detail_log_message : Api_types_t.log_message result Lwt.t end class type manager_plot = object @@ -65,13 +56,16 @@ end class type manager_snapshot = object method simulation_catalog_snapshot : Api_types_t.snapshot_catalog result Lwt.t + method simulation_detail_snapshot : Api_types_t.snapshot_id -> Api_types_t.snapshot result Lwt.t end class type manager_simulation = object method secret_simulation_load : - Pattern.sharing_level -> Ast.parsing_compil -> (string * Nbr.t) list -> + Pattern.sharing_level -> + Ast.parsing_compil -> + (string * Nbr.t) list -> unit result Lwt.t method simulation_delete : unit result Lwt.t @@ -86,17 +80,11 @@ class type manager_simulation = object Api_types_t.simulation_intervention -> string result Lwt.t method simulation_continue : string -> unit result Lwt.t - method simulation_info : Api_types_t.simulation_info result Lwt.t - method simulation_efficiency : Counter.Efficiency.t result Lwt.t - method simulation_parameter : Api_types_t.simulation_parameter result Lwt.t - method simulation_raw_trace : string result Lwt.t - method simulation_outputs_zip : Bigbuffer.bigstring result Lwt.t - inherit manager_file_line inherit manager_din inherit manager_log_message @@ -109,110 +97,153 @@ type 'a kasa_reply = class type manager_static_analysis = object method init_static_analyser : Ast.parsing_compil -> unit kasa_reply + method init_static_analyser_raw : string -> unit kasa_reply (** The string has to be the json corresponding to an [Ast.parsing_compil] *) method get_contact_map : Public_data.accuracy_level option -> Yojson.Basic.t kasa_reply + method get_pos_of_rules_and_vars : Public_data.pos_of_rules_and_vars kasa_reply + method get_influence_map_raw : Public_data.accuracy_level option -> string kasa_reply + method get_local_influence_map : - ?fwd:int -> ?bwd:int -> ?origin:(int,int) Public_data.influence_node -> - total:int -> Public_data.accuracy_level option -> - (Public_data.accuracy_level * int * int option * int option * - (Public_data.rule, Public_data.var) Public_data.influence_node - option * - Public_data.influence_map) kasa_reply + ?fwd:int -> + ?bwd:int -> + ?origin:(int, int) Public_data.influence_node -> + total:int -> + Public_data.accuracy_level option -> + (Public_data.accuracy_level + * int + * int option + * int option + * (Public_data.rule, Public_data.var) Public_data.influence_node option + * Public_data.influence_map) + kasa_reply + method get_initial_node : - (Public_data.rule, Public_data.var) Public_data.influence_node - option kasa_reply + (Public_data.rule, Public_data.var) Public_data.influence_node option + kasa_reply + method get_next_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option kasa_reply + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option + kasa_reply + method get_previous_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option kasa_reply + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option + kasa_reply + method get_nodes_of_influence_map : Public_data.accuracy_level option -> - (Public_data.accuracy_level * - (Public_data.rule, Public_data.var) Public_data.influence_node - list) kasa_reply + (Public_data.accuracy_level + * (Public_data.rule, Public_data.var) Public_data.influence_node list) + kasa_reply + method get_dead_rules : Public_data.dead_rules kasa_reply - method get_dead_agents: Public_data.dead_agents kasa_reply + method get_dead_agents : Public_data.dead_agents kasa_reply + method get_non_weakly_reversible_transitions : Public_data.separating_transitions kasa_reply + method get_constraints_list : (string * Public_data.agent list Public_data.lemma list) list kasa_reply + method get_potential_polymers : Public_data.accuracy_level option -> Public_data.accuracy_level option -> (Public_data.accuracy_level * Public_data.accuracy_level * Public_data.scc) - kasa_reply + kasa_reply end class type uniform_manager_static_analysis = object method init_static_analyser : Ast.parsing_compil -> unit result Lwt.t + method init_static_analyser_raw : string -> unit result Lwt.t (** The string has to be the json corresponding to an [Ast.parsing_compil] *) method get_contact_map : Public_data.accuracy_level option -> Yojson.Basic.t result Lwt.t + method secret_get_pos_of_rules_and_vars : - Public_data.pos_of_rules_and_vars result Lwt.t + Public_data.pos_of_rules_and_vars result Lwt.t + method get_influence_map_raw : Public_data.accuracy_level option -> string result Lwt.t + method get_local_influence_map : - ?fwd:int -> ?bwd:int -> ?origin:(int,int) Public_data.influence_node -> - total:int -> Public_data.accuracy_level option -> - (Public_data.accuracy_level * int * int option * int option * - (Public_data.rule, Public_data.var) Public_data.influence_node - option * - Public_data.influence_map) result Lwt.t + ?fwd:int -> + ?bwd:int -> + ?origin:(int, int) Public_data.influence_node -> + total:int -> + Public_data.accuracy_level option -> + (Public_data.accuracy_level + * int + * int option + * int option + * (Public_data.rule, Public_data.var) Public_data.influence_node option + * Public_data.influence_map) + result + Lwt.t + method get_initial_node : - (Public_data.rule, Public_data.var) Public_data.influence_node - option result Lwt.t + (Public_data.rule, Public_data.var) Public_data.influence_node option result + Lwt.t + method get_next_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option result Lwt.t + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option result + Lwt.t + method get_previous_node : - (int,int) Public_data.influence_node option -> - (Public_data.rule, Public_data.var) Public_data.influence_node - option result Lwt.t + (int, int) Public_data.influence_node option -> + (Public_data.rule, Public_data.var) Public_data.influence_node option result + Lwt.t + method get_nodes_of_influence_map : Public_data.accuracy_level option -> - (Public_data.accuracy_level * - (Public_data.rule, Public_data.var) Public_data.influence_node - list) result Lwt.t + (Public_data.accuracy_level + * (Public_data.rule, Public_data.var) Public_data.influence_node list) + result + Lwt.t + method get_dead_rules : Public_data.dead_rules result Lwt.t - method get_dead_agents: Public_data.dead_agents result Lwt.t + method get_dead_agents : Public_data.dead_agents result Lwt.t + method get_non_weakly_reversible_transitions : Public_data.separating_transitions result Lwt.t + method get_constraints_list : (string * Public_data.agent list Public_data.lemma list) list result Lwt.t + method get_potential_polymers : Public_data.accuracy_level option -> Public_data.accuracy_level option -> (Public_data.accuracy_level * Public_data.accuracy_level * Public_data.scc) - result Lwt.t + result + Lwt.t end class type virtual manager_stories = object method virtual is_running : bool + method config_story_computation : - compression_modes -> (unit,string) Lwt_result.t - method raw_launch_story_computation : string -> (unit,string) Lwt_result.t + compression_modes -> (unit, string) Lwt_result.t + + method raw_launch_story_computation : string -> (unit, string) Lwt_result.t method story_log : string list method story_is_computing : bool method story_progress : Story_json.progress_bar option + method story_list : - (compression_modes * - unit Trace.Simulation_info.t list list * - Graph_loggers_sig.graph) Mods.IntMap.t + (compression_modes + * unit Trace.Simulation_info.t list list + * Graph_loggers_sig.graph) + Mods.IntMap.t end class type concrete_manager = object @@ -220,12 +251,17 @@ class type concrete_manager = object inherit manager_simulation inherit uniform_manager_static_analysis inherit manager_stories + method project_parse : - patternSharing:Pattern.sharing_level -> (string * Nbr.t) list -> + patternSharing:Pattern.sharing_level -> + (string * Nbr.t) list -> unit result Lwt.t + method get_influence_map_node_at : - filename:string -> Locality.position -> (int,int) Public_data.influence_node - option result Lwt.t + filename:string -> + Loc.position -> + (int, int) Public_data.influence_node option result Lwt.t + method is_running : bool method terminate : unit method is_computing : bool @@ -235,7 +271,6 @@ class type rest_manager = object inherit manager_environment inherit concrete_manager method project_catalog : string list result Lwt.t - method project_create : - Api_types_t.project_parameter -> unit result Lwt.t + method project_create : Api_types_t.project_parameter -> unit result Lwt.t method project_delete : project_id -> unit result Lwt.t end diff --git a/core/api/api_common.ml b/core/api/api_common.ml index 9084ecb870..ec6439a4b8 100644 --- a/core/api/api_common.ml +++ b/core/api/api_common.ml @@ -12,85 +12,82 @@ open Lwt.Infix let error_msg ?(severity = Logs.Error) ?range text : Result_util.message = { Result_util.severity; Result_util.text; Result_util.range } -let result_error_msg - ?severity ?range ?result_code (message:string) : 'ok Api.result = - Result_util.error ?status:result_code [error_msg ?severity ?range message] +let result_error_msg ?severity ?range ?result_code (message : string) : + 'ok Api.result = + Result_util.error ?status:result_code [ error_msg ?severity ?range message ] -let result_messages - ?result_code messages : 'ok Api.result = +let result_messages ?result_code messages : 'ok Api.result = Result_util.error ?status:result_code messages -let result_error_exception - ?severity ?result_code (e : exn) : 'ok Api.result = - let message = (try (Printexc.to_string e) - with _ -> "unspecified exception thrown") in +let result_error_exception ?severity ?result_code (e : exn) : 'ok Api.result = + let message = + try Printexc.to_string e with _ -> "unspecified exception thrown" + in result_error_msg ?severity ?result_code message let method_handler_errors ?severity mh = - let uncaught = Exception_without_parameter.get_uncaught_exception_list mh in - let caught = Exception_without_parameter.get_caught_exception_list mh in + let uncaught = + Exception_without_parameter.get_uncaught_exception_list_to_ui mh + in + let caught = Exception_without_parameter.get_caught_exception_list_to_ui mh in List.fold_right (fun x l -> - error_msg ?severity - (Format.asprintf - "%a" Exception_without_parameter.pp_caught x)::l) + error_msg ?severity + (Format.asprintf "%a" Exception_without_parameter.pp_caught x) + :: l) caught (List.map (fun x -> - error_msg ?severity - (Format.asprintf "%a" Exception_without_parameter.pp_uncaught x)) + error_msg ?severity + (Format.asprintf "%a" Exception_without_parameter.pp_uncaught x)) uncaught) let method_handler_messages ?severity ?result_code mh = - result_messages ?result_code (method_handler_errors ?severity mh) + result_messages ?result_code (method_handler_errors ?severity mh) let result_kasa = function | Result.Ok x -> Result_util.ok x | Result.Error mh -> method_handler_messages ~severity:Logs.Error mh let result_bind_lwt : - ok:('ok -> ('a_ok, 'a_code) Api_types_t.result Lwt.t) -> - ('ok, 'a_code) Api_types_t.result -> - ('a_ok, 'a_code) Api_types_t.result Lwt.t = - fun - ~(ok:'ok -> ('a_ok,'a_code) Api_types_t.result Lwt.t) - { Result_util.value; status; messages } -> - match value with - | Result.Ok data -> ok data - | Result.Error e -> - Lwt.return { Result_util.value = Result.Error e; status; messages } + ok:('ok -> ('a_ok, 'a_code) Api_types_t.result Lwt.t) -> + ('ok, 'a_code) Api_types_t.result -> + ('a_ok, 'a_code) Api_types_t.result Lwt.t = + fun ~(ok : 'ok -> ('a_ok, 'a_code) Api_types_t.result Lwt.t) + { Result_util.value; status; messages } -> + match value with + | Result.Ok data -> ok data + | Result.Error e -> + Lwt.return { Result_util.value = Result.Error e; status; messages } let rec result_fold_lwt : - f:(('ok, 'a_code) Api_types_t.result -> - 'value -> - ('ok, 'a_code) Api_types_t.result Lwt.t) -> - id:('ok, 'a_code) Api_types_t.result -> - ('value list) -> - ('a_ok, 'a_code) Api_types_t.result Lwt.t = - fun - ~(f : (('ok, 'a_code) Api_types_t.result -> - 'value -> - ('ok, 'a_code) Api_types_t.result Lwt.t)) - ~(id : ('ok, 'a_code) Api_types_t.result) - (l : ('value list)) -> - match l with - | [] -> Lwt.return id - | h::t -> - (f id h)>>= - (fun result -> result_fold_lwt ~f:f ~id:result t) + f: + (('ok, 'a_code) Api_types_t.result -> + 'value -> + ('ok, 'a_code) Api_types_t.result Lwt.t) -> + id:('ok, 'a_code) Api_types_t.result -> + 'value list -> + ('a_ok, 'a_code) Api_types_t.result Lwt.t = + fun ~(f : + ('ok, 'a_code) Api_types_t.result -> + 'value -> + ('ok, 'a_code) Api_types_t.result Lwt.t) + ~(id : ('ok, 'a_code) Api_types_t.result) (l : 'value list) -> + match l with + | [] -> Lwt.return id + | h :: t -> f id h >>= fun result -> result_fold_lwt ~f ~id:result t -let rec result_combine : unit Api.result list -> unit Api.result = - function +let rec result_combine : unit Api.result list -> unit Api.result = function | [] -> Result_util.ok () - | l::t -> + | l :: t -> Result_util.fold ~ok:(fun () -> result_combine t) ~error:(fun data_1 -> - Result_util.fold - ~ok:(fun () -> l) - ~error:(fun data_r -> - Result_util.error ~status:l.Result_util.status (data_1@data_r)) - (result_combine t)) + Result_util.fold + ~ok:(fun () -> l) + ~error:(fun data_r -> + Result_util.error ~status:l.Result_util.status (data_1 @ data_r)) + (result_combine t)) l let md5sum text = Digest.to_hex (Digest.string text) diff --git a/core/api/api_common.mli b/core/api/api_common.mli index 6d836d5372..828b19ebd6 100644 --- a/core/api/api_common.mli +++ b/core/api/api_common.mli @@ -7,32 +7,47 @@ (******************************************************************************) val error_msg : - ?severity:Logs.level -> ?range: Locality.range -> string -> Result_util.message + ?severity:Logs.level -> ?range:Loc.t -> string -> Result_util.message + val result_error_msg : - ?severity:Logs.level -> ?range: Locality.range -> - ?result_code:Result_util.status -> string -> 'ok Api.result + ?severity:Logs.level -> + ?range:Loc.t -> + ?result_code:Result_util.status -> + string -> + 'ok Api.result + val result_messages : ?result_code:Result_util.status -> Result_util.message list -> 'ok Api.result + val result_error_exception : ?severity:Logs.level -> - ?result_code:Result_util.status -> exn -> 'ok Api.result + ?result_code:Result_util.status -> + exn -> + 'ok Api.result val method_handler_errors : ?severity:Logs.level -> - Exception_without_parameter.method_handler -> Result_util.message list + Exception_without_parameter.method_handler -> + Result_util.message list + val method_handler_messages : - ?severity:Logs.level -> ?result_code:Result_util.status -> - Exception_without_parameter.method_handler -> 'a Api.result + ?severity:Logs.level -> + ?result_code:Result_util.status -> + Exception_without_parameter.method_handler -> + 'a Api.result + val result_kasa : ('a, Exception_without_parameter.method_handler) Result.result -> 'a Api.result val result_bind_lwt : ok:('ok -> 'a_ok Api.result Lwt.t) -> 'ok Api.result -> 'a_ok Api.result Lwt.t + val result_fold_lwt : f:('ok Api.result -> 'value -> 'ok Api.result Lwt.t) -> id:'ok Api.result -> - 'value list -> 'ok Api.result Lwt.t -val result_combine : unit Api.result list -> unit Api.result + 'value list -> + 'ok Api.result Lwt.t +val result_combine : unit Api.result list -> unit Api.result val md5sum : string -> string diff --git a/core/api/api_data.ml b/core/api/api_data.ml index ee9112dc9c..52173b5fd7 100644 --- a/core/api/api_data.ml +++ b/core/api/api_data.ml @@ -7,13 +7,13 @@ (******************************************************************************) type simulation_detail_output = - (Api_types_t.plot option, - (string * Api_types_t.din) list, - string list Mods.StringMap.t, - Api_types_t.snapshot Mods.StringMap.t, - string, - string) - Api_types_t.simulation_output + ( Api_types_t.plot option, + (string * Api_types_t.din) list, + string list Mods.StringMap.t, + Api_types_t.snapshot Mods.StringMap.t, + string, + string ) + Api_types_t.simulation_output let api_snapshot_dot (snapshot : Api_types_t.snapshot) = Format.asprintf "%a@." (Data.print_dot_snapshot ?uuid:None) snapshot @@ -21,28 +21,29 @@ let api_snapshot_dot (snapshot : Api_types_t.snapshot) = let api_snapshot_kappa (snapshot : Data.snapshot) : string = Format.asprintf "%a@." (Data.print_snapshot ?uuid:None) snapshot -let api_simulation_status - (progress : Api_types_t.simulation_progress) - (detail : simulation_detail_output) : - Api_types_t.simulation_info = +let api_simulation_status (progress : Api_types_t.simulation_progress) + (detail : simulation_detail_output) : Api_types_t.simulation_info = let output : Api_types_t.simulation_info_output = - { Api_types_t.simulation_output_plot = + { + Api_types_t.simulation_output_plot = (match detail.Api_types_t.simulation_output_plot with | None -> 0 | Some plot -> List.length plot.Data.plot_series); Api_types_t.simulation_output_dins = - List.length detail.Api_types_t.simulation_output_dins ; + List.length detail.Api_types_t.simulation_output_dins; Api_types_t.simulation_output_file_lines = - Mods.StringMap.size detail.Api_types_t.simulation_output_file_lines ; + Mods.StringMap.size detail.Api_types_t.simulation_output_file_lines; Api_types_t.simulation_output_snapshots = - Mods.StringMap.size detail.Api_types_t.simulation_output_snapshots ; + Mods.StringMap.size detail.Api_types_t.simulation_output_snapshots; Api_types_t.simulation_output_inputs = (); Api_types_t.simulation_output_log_messages = - String.length detail.Api_types_t.simulation_output_log_messages ; + String.length detail.Api_types_t.simulation_output_log_messages; } in - { Api_types_t.simulation_info_progress = progress ; - Api_types_t.simulation_info_output = output ; } + { + Api_types_t.simulation_info_progress = progress; + Api_types_t.simulation_info_output = output; + } (* return the agent count *) let agent_count (species : Api_types_t.site_graph) : int = Array.length species diff --git a/core/api/api_data.mli b/core/api/api_data.mli index 4ba20e9f4c..5e2d4f71f6 100644 --- a/core/api/api_data.mli +++ b/core/api/api_data.mli @@ -7,17 +7,20 @@ (******************************************************************************) type simulation_detail_output = - (Api_types_t.plot option, - (string * Api_types_t.din) list, - string list Mods.StringMap.t, - Api_types_t.snapshot Mods.StringMap.t, - string, - string) - Api_types_t.simulation_output + ( Api_types_t.plot option, + (string * Api_types_t.din) list, + string list Mods.StringMap.t, + Api_types_t.snapshot Mods.StringMap.t, + string, + string ) + Api_types_t.simulation_output val api_snapshot_dot : Api_types_t.snapshot -> string val api_snapshot_kappa : Api_types_t.snapshot -> string + val api_simulation_status : - Api_types_t.simulation_progress -> simulation_detail_output -> + Api_types_t.simulation_progress -> + simulation_detail_output -> Api_types_t.simulation_info + val agent_count : Api_types_t.site_graph -> int diff --git a/core/api/api_environment.ml b/core/api/api_environment.ml index 7c6236e5c8..61718b2f07 100644 --- a/core/api/api_environment.ml +++ b/core/api/api_environment.ml @@ -8,7 +8,7 @@ (* data structures *) (* Manager state *) -type parse_state = (Kappa_facade.t,Result_util.message list) Result_util.t +type parse_state = (Kappa_facade.t, Result_util.message list) Result_util.t class type simulation = object method get_runtime_state : unit -> Kappa_facade.t @@ -19,10 +19,11 @@ end class type project = object method unset_simulation : unit -> unit + method set_simulation : Api_types_j.simulation_parameter -> Kappa_facade.t -> unit - method get_simulation : unit -> simulation option + method get_simulation : unit -> simulation option method get_state : unit -> parse_state option Lwt.t method set_state : parse_state Lwt.t -> unit end diff --git a/core/api/api_environment.mli b/core/api/api_environment.mli index 7c6236e5c8..61718b2f07 100644 --- a/core/api/api_environment.mli +++ b/core/api/api_environment.mli @@ -8,7 +8,7 @@ (* data structures *) (* Manager state *) -type parse_state = (Kappa_facade.t,Result_util.message list) Result_util.t +type parse_state = (Kappa_facade.t, Result_util.message list) Result_util.t class type simulation = object method get_runtime_state : unit -> Kappa_facade.t @@ -19,10 +19,11 @@ end class type project = object method unset_simulation : unit -> unit + method set_simulation : Api_types_j.simulation_parameter -> Kappa_facade.t -> unit - method get_simulation : unit -> simulation option + method get_simulation : unit -> simulation option method get_state : unit -> parse_state option Lwt.t method set_state : parse_state Lwt.t -> unit end diff --git a/core/api/api_runtime.ml b/core/api/api_runtime.ml index 03de6a20b8..18cacf0b62 100644 --- a/core/api/api_runtime.ml +++ b/core/api/api_runtime.ml @@ -8,10 +8,9 @@ (* good old cake pattern *) -class manager - (system_process : Kappa_facade.system_process) : Api.manager_simulation = - let project = new Environment_memory.project - in +class manager (system_process : Kappa_facade.system_process) : + Api.manager_simulation = + let project = new Environment_memory.project in object inherit Manager_simulation.manager_simulation project system_process - end;; + end diff --git a/core/api/api_runtime.mli b/core/api/api_runtime.mli index 795eba758a..f8f5edef2b 100644 --- a/core/api/api_runtime.mli +++ b/core/api/api_runtime.mli @@ -1 +1 @@ -class manager: Kappa_facade.system_process -> Api.manager_simulation +class manager : Kappa_facade.system_process -> Api.manager_simulation diff --git a/core/api/dune b/core/api/dune index a9c8db223b..79d46706bc 100644 --- a/core/api/dune +++ b/core/api/dune @@ -1,34 +1,54 @@ (library (name kappa_json_api) - (libraries atdgen-runtime lwt - kappa_grammar kappa_kasa_type_interface kappa_cflow) - (flags (:standard -w +a - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms - -open Kappa_grammar - -open Kappa_runtime - -open Kappa_parameters - -open Kappa_kasa_type_interface - -open Kappa_classical_graphs - -open Kappa_cflow))) + (libraries + atdgen-runtime + lwt + kappa_grammar + kappa_kasa_type_interface + kappa_cflow) + (flags + (:standard + -w + +a-40-42 + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms + -open + Kappa_grammar + -open + Kappa_runtime + -open + Kappa_parameters + -open + Kappa_kasa_type_interface + -open + Kappa_classical_graphs + -open + Kappa_cflow))) (rule - (targets api_types_j.ml api_types_j.mli) - (deps api_types.atd) - (action (run atdgen -j -j-std %{deps}))) + (targets api_types_j.ml api_types_j.mli) + (deps api_types.atd) + (action + (run atdgen -j -j-std %{deps}))) (rule - (targets api_types_t.ml api_types_t.mli) - (deps api_types.atd) - (action (run atdgen -t %{deps}))) + (targets api_types_t.ml api_types_t.mli) + (deps api_types.atd) + (action + (run atdgen -t %{deps}))) (rule - (targets mpi_message_j.ml mpi_message_j.mli) - (deps mpi_message.atd) - (action (run atdgen -j -j-std %{deps}))) + (targets mpi_message_j.ml mpi_message_j.mli) + (deps mpi_message.atd) + (action + (run atdgen -j -j-std %{deps}))) (rule - (targets mpi_message_t.ml mpi_message_t.mli) - (deps mpi_message.atd) - (action (run atdgen -t %{deps}))) + (targets mpi_message_t.ml mpi_message_t.mli) + (deps mpi_message.atd) + (action + (run atdgen -t %{deps}))) diff --git a/core/api/environment_memory.ml b/core/api/environment_memory.ml index da694d2f79..e78503e1ce 100644 --- a/core/api/environment_memory.ml +++ b/core/api/environment_memory.ml @@ -8,41 +8,45 @@ open Lwt.Infix -class simulation - (runtime_state : Kappa_facade.t) - (simulation_parameter : Api_types_j.simulation_parameter) : +class simulation (runtime_state : Kappa_facade.t) + (simulation_parameter : Api_types_j.simulation_parameter) : Api_environment.simulation = object val mutable _runtime_state = runtime_state val mutable _simulation_parameter = simulation_parameter method get_runtime_state () = _runtime_state + method set_runtime_state (runtime_state : Kappa_facade.t) = _runtime_state <- runtime_state + method get_simulation_parameter () = _simulation_parameter - method set_simulation_parameter (simulation_parameter : Api_types_j.simulation_parameter) : unit = + + method set_simulation_parameter + (simulation_parameter : Api_types_j.simulation_parameter) : unit = _simulation_parameter <- simulation_parameter end class project : Api_environment.project = object val mutable _simulation = None + val mutable _state : Api_environment.parse_state option Lwt.t = Lwt.return_none method get_simulation () = _simulation method unset_simulation () = _simulation <- None + method set_simulation (simulation_parameter : Api_types_j.simulation_parameter) (runtime_state : Kappa_facade.t) = _simulation <- Some - (new simulation - runtime_state simulation_parameter :> Api_environment.simulation) + (new simulation runtime_state simulation_parameter + :> Api_environment.simulation) method set_state (state : Api_environment.parse_state Lwt.t) = let () = Lwt.cancel _state in _state <- (state >>= fun x -> Lwt.return (Some x)) - method get_state () : Api_environment.parse_state option Lwt.t = - _state + method get_state () : Api_environment.parse_state option Lwt.t = _state end diff --git a/core/api/environment_memory.mli b/core/api/environment_memory.mli index 309689a958..3dbdf72425 100644 --- a/core/api/environment_memory.mli +++ b/core/api/environment_memory.mli @@ -1 +1 @@ -class project: Api_environment.project +class project : Api_environment.project diff --git a/core/api/fakezip.ml b/core/api/fakezip.ml index 22e365e852..eed232cf48 100644 --- a/core/api/fakezip.ml +++ b/core/api/fakezip.ml @@ -16,36 +16,42 @@ exception Error of string * string * string let write1 oc n = Bigbuffer.add_char oc (Char.unsafe_chr n) + let write2 oc n = - write1 oc n; write1 oc (n lsr 8) + write1 oc n; + write1 oc (n lsr 8) + let write4 oc n = write2 oc (Int32.to_int n); write2 oc (Int32.to_int (Int32.shift_right_logical n 16)) + let write4_int oc n = write2 oc n; write2 oc (n lsr 16) -let writestring oc s = - Bigbuffer.add_string oc s + +let writestring oc s = Bigbuffer.add_string oc s type compression_method = Stored -type entry = - { filename: string; - extra: string; - comment: string; - methd: compression_method; - mtime: float; - crc: int32; - uncompressed_size: int; - compressed_size: int; - (*is_directory: bool;*) - file_offset: int32 } +type entry = { + filename: string; + extra: string; + comment: string; + methd: compression_method; + mtime: float; + crc: int32; + uncompressed_size: int; + compressed_size: int; + (*is_directory: bool;*) + file_offset: int32; +} -type out_file = - { of_filename: string; - of_channel: Bigbuffer.t; - mutable of_entries: entry list; - of_comment: string } +type out_file = { + of_filename: string; + of_channel: Bigbuffer.t; + mutable of_entries: entry list; + of_comment: string; +} (*let filename_is_directory name = String.length name > 0 && name.[String.length name - 1] = '/'*) @@ -54,48 +60,72 @@ type out_file = let dostime_of_unixtime t = let tm = Unix.localtime t in - (tm.Unix.tm_sec lsr 1 - + (tm.Unix.tm_min lsl 5) - + (tm.Unix.tm_hour lsl 11), - tm.Unix.tm_mday - + (tm.Unix.tm_mon + 1) lsl 5 - + (tm.Unix.tm_year - 80) lsl 9) + ( (tm.Unix.tm_sec lsr 1) + (tm.Unix.tm_min lsl 5) + (tm.Unix.tm_hour lsl 11), + tm.Unix.tm_mday + + ((tm.Unix.tm_mon + 1) lsl 5) + + ((tm.Unix.tm_year - 80) lsl 9) ) (* Open a ZIP file for writing *) let open_out ?(comment = "") filename = if String.length comment >= 0x10000 then - raise(Error(filename, "", "comment too long")); - { of_filename = filename; + raise (Error (filename, "", "comment too long")); + { + of_filename = filename; of_channel = Bigbuffer.create 8192; of_entries = []; - of_comment = comment } + of_comment = comment; + } (* Close a ZIP file for writing. Add central directory. *) let write_directory_entry oc e = - write4 oc (Int32.of_int 0x02014b50); (* signature *) - let version = match e.methd with Stored -> 10 in - write2 oc version; (* version made by *) - write2 oc version; (* version needed to extract *) - write2 oc 8; (* flags *) - write2 oc (match e.methd with Stored -> 0); (* method *) - let (time, date) = dostime_of_unixtime e.mtime in - write2 oc time; (* last mod time *) - write2 oc date; (* last mod date *) - write4 oc e.crc; (* CRC32 *) - write4_int oc e.compressed_size; (* compressed size *) - write4_int oc e.uncompressed_size; (* uncompressed size *) - write2 oc (String.length e.filename); (* filename length *) - write2 oc (String.length e.extra); (* extra length *) - write2 oc (String.length e.comment); (* comment length *) - write2 oc 0; (* disk number start *) - write2 oc 0; (* internal attributes *) - write4_int oc 0; (* external attributes *) - write4 oc e.file_offset; (* offset of local header *) - writestring oc e.filename; (* filename *) - writestring oc e.extra; (* extra info *) - writestring oc e.comment (* file comment *) + write4 oc (Int32.of_int 0x02014b50); + (* signature *) + let version = + match e.methd with + | Stored -> 10 + in + write2 oc version; + (* version made by *) + write2 oc version; + (* version needed to extract *) + write2 oc 8; + (* flags *) + write2 oc + (match e.methd with + | Stored -> 0); + (* method *) + let time, date = dostime_of_unixtime e.mtime in + write2 oc time; + (* last mod time *) + write2 oc date; + (* last mod date *) + write4 oc e.crc; + (* CRC32 *) + write4_int oc e.compressed_size; + (* compressed size *) + write4_int oc e.uncompressed_size; + (* uncompressed size *) + write2 oc (String.length e.filename); + (* filename length *) + write2 oc (String.length e.extra); + (* extra length *) + write2 oc (String.length e.comment); + (* comment length *) + write2 oc 0; + (* disk number start *) + write2 oc 0; + (* internal attributes *) + write4_int oc 0; + (* external attributes *) + write4 oc e.file_offset; + (* offset of local header *) + writestring oc e.filename; + (* filename *) + writestring oc e.extra; + (* extra info *) + writestring oc e.comment (* file comment *) let close_out ofile = let oc = ofile.of_channel in @@ -104,83 +134,124 @@ let close_out ofile = let cd_size = Bigbuffer.length oc - start_cd in let num_entries = List.length ofile.of_entries in if num_entries >= 0x10000 then - raise(Error(ofile.of_filename, "", "too many entries")); - write4 oc (Int32.of_int 0x06054b50); (* signature *) - write2 oc 0; (* disk number *) - write2 oc 0; (* number of disk with central dir *) - write2 oc num_entries; (* # entries in this disk *) - write2 oc num_entries; (* # entries in central dir *) - write4_int oc cd_size; (* size of central dir *) - write4_int oc start_cd; (* offset of central dir *) - write2 oc (String.length ofile.of_comment); (* length of comment *) - writestring oc ofile.of_comment; (* comment *) + raise (Error (ofile.of_filename, "", "too many entries")); + write4 oc (Int32.of_int 0x06054b50); + (* signature *) + write2 oc 0; + (* disk number *) + write2 oc 0; + (* number of disk with central dir *) + write2 oc num_entries; + (* # entries in this disk *) + write2 oc num_entries; + (* # entries in central dir *) + write4_int oc cd_size; + (* size of central dir *) + write4_int oc start_cd; + (* offset of central dir *) + write2 oc (String.length ofile.of_comment); + (* length of comment *) + writestring oc ofile.of_comment; + (* comment *) Bigbuffer.contents oc (* Write a local file header and return the corresponding entry *) let add_entry_header ofile extra comment level mtime filename = if level <> 0 then - raise(Error(ofile.of_filename, filename, "fake_zip cannot compress")); + raise (Error (ofile.of_filename, filename, "fake_zip cannot compress")); if String.length filename >= 0x10000 then - raise(Error(ofile.of_filename, filename, "filename too long")); + raise (Error (ofile.of_filename, filename, "filename too long")); if String.length extra >= 0x10000 then - raise(Error(ofile.of_filename, filename, "extra data too long")); + raise (Error (ofile.of_filename, filename, "extra data too long")); if String.length comment >= 0x10000 then - raise(Error(ofile.of_filename, filename, "comment too long")); + raise (Error (ofile.of_filename, filename, "comment too long")); let oc = ofile.of_channel in let pos = Bigbuffer.length oc in - write4 oc (Int32.of_int 0x04034b50); (* signature *) - let version = if level = 0 then 10 else 20 in - write2 oc version; (* version needed to extract *) - write2 oc 8; (* flags *) - write2 oc (if level = 0 then 0 else 8); (* method *) - let (time, date) = dostime_of_unixtime mtime in - write2 oc time; (* last mod time *) - write2 oc date; (* last mod date *) - write4 oc Int32.zero; (* CRC32 - to be filled later *) - write4_int oc 0; (* compressed size - later *) - write4_int oc 0; (* uncompressed size - later *) - write2 oc (String.length filename); (* filename length *) - write2 oc (String.length extra); (* extra length *) - writestring oc filename; (* filename *) - writestring oc extra; (* extra info *) - { filename = filename; - extra = extra; - comment = comment; + write4 oc (Int32.of_int 0x04034b50); + (* signature *) + let version = + if level = 0 then + 10 + else + 20 + in + write2 oc version; + (* version needed to extract *) + write2 oc 8; + (* flags *) + write2 oc + (if level = 0 then + 0 + else + 8); + (* method *) + let time, date = dostime_of_unixtime mtime in + write2 oc time; + (* last mod time *) + write2 oc date; + (* last mod date *) + write4 oc Int32.zero; + (* CRC32 - to be filled later *) + write4_int oc 0; + (* compressed size - later *) + write4_int oc 0; + (* uncompressed size - later *) + write2 oc (String.length filename); + (* filename length *) + write2 oc (String.length extra); + (* extra length *) + writestring oc filename; + (* filename *) + writestring oc extra; + (* extra info *) + { + filename; + extra; + comment; methd = Stored; - mtime = mtime; + mtime; crc = Int32.zero; uncompressed_size = 0; compressed_size = 0; (*is_directory = filename_is_directory filename;*) - file_offset = Int32.of_int pos } + file_offset = Int32.of_int pos; + } (* Write a data descriptor and update the entry *) let add_data_descriptor ofile crc compr_size uncompr_size entry = let oc = ofile.of_channel in - write4 oc (Int32.of_int 0x08074b50); (* signature *) - write4 oc crc; (* CRC *) - write4_int oc compr_size; (* compressed size *) - write4_int oc uncompr_size; (* uncompressed size *) - { entry with crc = crc; - uncompressed_size = uncompr_size; - compressed_size = compr_size } + write4 oc (Int32.of_int 0x08074b50); + (* signature *) + write4 oc crc; + (* CRC *) + write4_int oc compr_size; + (* compressed size *) + write4_int oc uncompr_size; + (* uncompressed size *) + { + entry with + crc; + uncompressed_size = uncompr_size; + compressed_size = compr_size; + } let update_crc crc buf start len = Crc32.string ~crc buf start len (* Add an entry with the contents of a string *) -let add_entry data ofile ?(extra = "") ?(comment = "") - ?(level = 0) ?(mtime = Unix.time()) name = +let add_entry data ofile ?(extra = "") ?(comment = "") ?(level = 0) + ?(mtime = Unix.time ()) name = let e = add_entry_header ofile extra comment level mtime name in let crc = update_crc Int32.zero data 0 (String.length data) in let compr_size = match level with - 0 -> - Bigbuffer.add_substring ofile.of_channel data 0 (String.length data); - String.length data - | _ -> raise (Error(ofile.of_filename, name, "compression error")) in + | 0 -> + Bigbuffer.add_substring ofile.of_channel data 0 (String.length data); + String.length data + | _ -> raise (Error (ofile.of_filename, name, "compression error")) + in let e' = add_data_descriptor ofile crc compr_size (String.length data) e in ofile.of_entries <- e' :: ofile.of_entries @@ -228,8 +299,8 @@ let copy_file_to_entry infilename ofile ?(extra = "") ?(comment = "") (* Add an entry whose content will be produced by the caller *) -let add_entry_generator ofile ?(extra = "") ?(comment = "") - ?(level = 0) ?(mtime = Unix.time()) name = +let add_entry_generator ofile ?(extra = "") ?(comment = "") ?(level = 0) + ?(mtime = Unix.time ()) name = let e = add_entry_header ofile extra comment level mtime name in let crc = ref Int32.zero in let compr_size = ref 0 in @@ -237,7 +308,7 @@ let add_entry_generator ofile ?(extra = "") ?(comment = "") let finished = ref false in let check () = if !finished then - raise (Error(ofile.of_filename, name, "entry already finished")) + raise (Error (ofile.of_filename, name, "entry already finished")) in let finish () = finished := true; @@ -246,14 +317,12 @@ let add_entry_generator ofile ?(extra = "") ?(comment = "") in match level with | 0 -> - (fun buf pos len -> + ( (fun buf pos len -> check (); Bigbuffer.add_subbytes ofile.of_channel buf pos len; compr_size := !compr_size + len; - uncompr_size := !uncompr_size + len - ), - (fun () -> + uncompr_size := !uncompr_size + len), + fun () -> check (); - finish () - ) - | _ -> raise (Error(ofile.of_filename, name, "compression error")) + finish () ) + | _ -> raise (Error (ofile.of_filename, name, "compression error")) diff --git a/core/api/fakezip.mli b/core/api/fakezip.mli index 91b0811293..5e4ead1a0c 100644 --- a/core/api/fakezip.mli +++ b/core/api/fakezip.mli @@ -22,28 +22,32 @@ (** {6 Information on ZIP entries} *) -type compression_method = - Stored (** data is stored without compression *) - (** Indicate whether the data in the entry is compressed or not. *) +(** Indicate whether the data in the entry is compressed or not. *) +type compression_method = Stored (** data is stored without compression *) (** {6 Writing to ZIP files} *) type out_file - (** Abstract type representing a handle opened for writing to +(** Abstract type representing a handle opened for writing to a ZIP file. *) -val open_out: ?comment: string -> string -> out_file +val open_out : ?comment:string -> string -> out_file (** Create the structure representing a ZIP file. The argument (morally the filename) is useless. The optional argument [comment] is a comment string that is attached to the ZIP file as a whole (as opposed to the comments that can be attached to individual ZIP entries). *) -val add_entry: - string -> out_file -> - ?extra: string -> ?comment: string -> ?level: int -> - ?mtime: float -> string -> unit - (** [Zip.add_entry data zf name] adds a new entry to the +val add_entry : + string -> + out_file -> + ?extra:string -> + ?comment:string -> + ?level:int -> + ?mtime:float -> + string -> + unit +(** [Zip.add_entry data zf name] adds a new entry to the ZIP file [zf]. The data (file contents) associated with the entry is taken from the string [data]. It is compressed and written to the ZIP file [zf]. [name] is the file name @@ -60,7 +64,7 @@ val add_entry: @param mtime last modification time (in seconds since the epoch). Default: the current time. *) - (* +(* val copy_channel_to_entry: in_channel -> out_file -> ?extra: string -> ?comment: string -> ?level: int -> @@ -79,11 +83,15 @@ val copy_file_to_entry: file. *) *) -val add_entry_generator: +val add_entry_generator : out_file -> - ?extra: string -> ?comment: string -> ?level: int -> - ?mtime: float -> string -> (bytes -> int -> int -> unit) * (unit -> unit) - (** [Zip.add_entry_generator zf name] returns a pair of functions + ?extra:string -> + ?comment:string -> + ?level:int -> + ?mtime:float -> + string -> + (bytes -> int -> int -> unit) * (unit -> unit) +(** [Zip.add_entry_generator zf name] returns a pair of functions [(add, finish)]. It adds a new entry to the ZIP file [zf]. The file name stored along with this entry is [name]. Initially, no data is stored in this entry. @@ -97,14 +105,14 @@ val add_entry_generator: The optional arguments to [Zip.add_entry_generator] are as described in {!Zip.add_entry}. *) -val close_out: out_file -> Bigbuffer.bigstring - (** Finish writing the ZIP archive by adding the table of +val close_out : out_file -> Bigbuffer.bigstring +(** Finish writing the ZIP archive by adding the table of contents, and return its content. *) (** {6 Error reporting} *) exception Error of string * string * string - (** Exception raised when an ill-formed ZIP archive is encountered, +(** Exception raised when an ill-formed ZIP archive is encountered, or illegal parameters are given to the functions in this module. The exception is of the form [Error(ZIP_name, entry_name, message)] where [ZIP_name] diff --git a/core/api/kamoha_client.ml b/core/api/kamoha_client.ml index ad78db4610..36986c4566 100644 --- a/core/api/kamoha_client.ml +++ b/core/api/kamoha_client.ml @@ -13,126 +13,137 @@ type _ handle = | Ast : Ast.parsing_compil handle type box = - B : 'a handle * ('a,Result_util.message list) Result_util.t Lwt.u -> box + | B : 'a handle * ('a, Result_util.message list) Result_util.t Lwt.u -> box -type mailbox = - (int, box) Hashtbl.t +type mailbox = (int, box) Hashtbl.t let new_mailbox () = Hashtbl.create 2 let read_result f p lb = JsonUtil.read_next_item - (Result_util.read_t - f (Yojson.Basic.read_list Result_util.read_message)) p lb + (Result_util.read_t f (Yojson.Basic.read_list Result_util.read_message)) + p lb let receive mailbox x = JsonUtil.read_of_string - (JsonUtil.read_variant Yojson.Basic.read_int - (fun p lb id -> - let () = - match Hashtbl.find mailbox id with - | B (Nothing, thread) -> - Lwt.wakeup thread (read_result Yojson.Basic.read_null p lb) - | B (Catalog, thread) -> - Lwt.wakeup thread - (read_result - (Yojson.Basic.read_list Kfiles.read_catalog_item) p lb) - | B (Info, thread) -> - Lwt.wakeup thread - (read_result - (JsonUtil.read_compact_pair - Yojson.Basic.read_string Yojson.Basic.read_int) p lb) - | B (Ast, thread) -> - Lwt.wakeup thread - (read_result Ast.read_parsing_compil p lb) in - Hashtbl.remove mailbox id)) + (JsonUtil.read_variant Yojson.Basic.read_int (fun p lb id -> + let () = + match Hashtbl.find mailbox id with + | B (Nothing, thread) -> + Lwt.wakeup thread (read_result Yojson.Basic.read_null p lb) + | B (Catalog, thread) -> + Lwt.wakeup thread + (read_result + (Yojson.Basic.read_list Kfiles.read_catalog_item) + p lb) + | B (Info, thread) -> + Lwt.wakeup thread + (read_result + (JsonUtil.read_compact_pair Yojson.Basic.read_string + Yojson.Basic.read_int) + p lb) + | B (Ast, thread) -> + Lwt.wakeup thread (read_result Ast.read_parsing_compil p lb) + in + Hashtbl.remove mailbox id)) x let is_computing mailbox = Hashtbl.length mailbox <> 0 -class virtual new_client ~post mailbox : - Api.manager_model = object(self) - val mutable id = 0 - method virtual is_running : bool - - method private message : - type a. a handle -> (Buffer.t -> unit) -> - (a, Result_util.message list) Result_util.t Lwt.t = - fun handle request -> - if self#is_running then - let result,feeder = Lwt.task () in - let message = - JsonUtil.string_of_write - (fun b () -> - JsonUtil.write_sequence b - [(fun b -> Yojson.Basic.write_int b id); request]) () in - let () = post message in - let () = Hashtbl.replace mailbox id (B (handle,feeder)) in - let () = id <- succ id in - result - else - Lwt.return (Result_util.error - [{ Result_util.severity = Logs.Error; - Result_util.range = None; - Result_util.text = "kamoha agent has died"; - }]) - - method file_delete file_id = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileDelete"); - (fun b -> Yojson.Basic.write_string b file_id); - ]) - - method file_update file_id file_content = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileUpdate"); - (fun b -> Yojson.Basic.write_string b file_id); - (fun b -> Yojson.Basic.write_string b file_content); - ]) - - method file_move file_position file_id = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileMove"); - (fun b -> Yojson.Basic.write_int b file_position); - (fun b -> Yojson.Basic.write_string b file_id); - ]) - - method file_get file_id = - self#message Info - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileGet"); - (fun b -> Yojson.Basic.write_string b file_id); - ]) - - method file_create file_position file_id file_content = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileCreate"); - (fun b -> Yojson.Basic.write_int b file_position); - (fun b -> Yojson.Basic.write_string b file_id); - (fun b -> Yojson.Basic.write_string b file_content); - ]) - - method file_catalog = - self#message Catalog - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileCatalog"); - ]) - - method secret_project_parse = - self#message Ast - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "ProjectParse"); - ]) - - method project_overwrite file_id ast = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "ProjectOverwrite"); - (fun b -> Yojson.Basic.write_string b file_id); - (fun b -> Ast.write_parsing_compil b ast); - ]) -end +class virtual new_client ~post mailbox : Api.manager_model = + object (self) + val mutable id = 0 + method virtual is_running : bool + + method private message : type a. + a handle -> + (Buffer.t -> unit) -> + (a, Result_util.message list) Result_util.t Lwt.t = + fun handle request -> + if self#is_running then ( + let result, feeder = Lwt.task () in + let message = + JsonUtil.string_of_write + (fun b () -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_int b id); request ]) + () + in + let () = post message in + let () = Hashtbl.replace mailbox id (B (handle, feeder)) in + let () = id <- succ id in + result + ) else + Lwt.return + (Result_util.error + [ + { + Result_util.severity = Logs.Error; + Result_util.range = None; + Result_util.text = "kamoha agent has died"; + }; + ]) + + method file_delete file_id = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileDelete"); + (fun b -> Yojson.Basic.write_string b file_id); + ]) + + method file_update file_id file_content = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileUpdate"); + (fun b -> Yojson.Basic.write_string b file_id); + (fun b -> Yojson.Basic.write_string b file_content); + ]) + + method file_move file_position file_id = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileMove"); + (fun b -> Yojson.Basic.write_int b file_position); + (fun b -> Yojson.Basic.write_string b file_id); + ]) + + method file_get file_id = + self#message Info (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileGet"); + (fun b -> Yojson.Basic.write_string b file_id); + ]) + + method file_create file_position file_id file_content = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileCreate"); + (fun b -> Yojson.Basic.write_int b file_position); + (fun b -> Yojson.Basic.write_string b file_id); + (fun b -> Yojson.Basic.write_string b file_content); + ]) + + method file_catalog = + self#message Catalog (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "FileCatalog") ]) + + method secret_project_parse = + self#message Ast (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "ProjectParse") ]) + + method project_overwrite file_id ast = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "ProjectOverwrite"); + (fun b -> Yojson.Basic.write_string b file_id); + (fun b -> Ast.write_parsing_compil b ast); + ]) + end diff --git a/core/api/kamoha_client.mli b/core/api/kamoha_client.mli index 448e2c1cb5..962e67fc12 100644 --- a/core/api/kamoha_client.mli +++ b/core/api/kamoha_client.mli @@ -1,7 +1,7 @@ type mailbox -val new_mailbox: unit -> mailbox -val receive: mailbox -> string -> unit -val is_computing: mailbox -> bool +val new_mailbox : unit -> mailbox +val receive : mailbox -> string -> unit +val is_computing : mailbox -> bool -class virtual new_client: post:(string -> unit) -> mailbox -> Api.manager_model +class virtual new_client : post:(string -> unit) -> mailbox -> Api.manager_model diff --git a/core/api/kappa_facade.ml b/core/api/kappa_facade.ml index 9c3ede3a73..ca503613e5 100644 --- a/core/api/kappa_facade.ml +++ b/core/api/kappa_facade.ml @@ -8,312 +8,325 @@ open Lwt.Infix -(** Interface to kappa runtime *) (* Error messages *) -let msg_process_not_paused = - "process not paused" + +(** Interface to kappa runtime *) +let msg_process_not_paused = "process not paused" (** System process These are system process implementation details that vary. *) -class type system_process = - object - method log : ?exn:exn -> string -> unit Lwt.t - method yield : unit -> unit Lwt.t - method min_run_duration : unit -> float - end +class type system_process = object + method log : ?exn:exn -> string -> unit Lwt.t + method yield : unit -> unit Lwt.t + method min_run_duration : unit -> float +end (** Trivial implementation primarily for unit testing. *) class null_process : system_process = object method log ?exn (_ : string) = - let () = ignore(exn) in + let () = ignore exn in Lwt.return_unit + method yield () = Lwt.return_unit - method min_run_duration() = 0.0 + method min_run_duration () = 0.0 end +type t = { + mutable is_running: bool; + mutable run_finalize: bool; + mutable pause_condition: (Pattern.id array list, int) Alg_expr.bool; + dumpIfDeadlocked: bool; + maxConsecutiveClash: int; + patternSharing: Pattern.sharing_level; + counter: Counter.t; + log_buffer: Buffer.t; + log_form: Format.formatter; + mutable plot: Data.plot; + mutable snapshots: Data.snapshot Mods.StringMap.t; + mutable dins: (string * Data.din) list; + mutable species: + (float * User_graph.connected_component) list Mods.StringMap.t; + mutable files: string list Mods.StringMap.t; + mutable error_messages: Result_util.message list; + (*mutable*) trace: Buffer.t; + inputs_buffer: Buffer.t; + inputs_form: Format.formatter; + ast: Ast.parsing_compil; + contact_map: Contact_map.t; + mutable env: Model.t; + mutable graph: Rule_interpreter.t; + mutable state: State_interpreter.t; + init_l: (Primitives.alg_expr * Primitives.elementary_rule) list; + mutable lastyield: float; +} (** State of the running simulation. *) -type t = - { mutable is_running : bool ; - mutable run_finalize : bool ; - mutable pause_condition : (Pattern.id array list,int) Alg_expr.bool ; - dumpIfDeadlocked : bool; - maxConsecutiveClash : int; - patternSharing : Pattern.sharing_level; - counter : Counter.t ; - log_buffer : Buffer.t ; - log_form : Format.formatter ; - mutable plot : Data.plot ; - mutable snapshots : Data.snapshot Mods.StringMap.t ; - mutable dins : (string * Data.din) list ; - mutable species : (float*User_graph.connected_component) list Mods.StringMap.t; - mutable files : string list Mods.StringMap.t ; - mutable error_messages : Result_util.message list ; - (*mutable*) trace : Buffer.t ; - inputs_buffer : Buffer.t; - inputs_form : Format.formatter; - ast : Ast.parsing_compil; - contact_map : Contact_map.t ; - mutable env : Model.t ; - mutable graph : Rule_interpreter.t ; - mutable state : State_interpreter.t ; - init_l : - (Primitives.alg_expr * Primitives.elementary_rule) list ; - mutable lastyield : float ; - } let create_t ~log_form ~log_buffer ~contact_map ~inputs_buffer ~inputs_form ~dumpIfDeadlocked ~maxConsecutiveClash ~patternSharing ~env ~counter ~graph - ~state ~init_l ~lastyield ~ast : t = { - is_running = false; run_finalize = false; counter; log_buffer; log_form; - pause_condition = Alg_expr.FALSE; dumpIfDeadlocked; maxConsecutiveClash; - patternSharing; plot = Data.init_plot env; - snapshots = Mods.StringMap.empty; - dins = []; - species = Mods.StringMap.empty; - files = Mods.StringMap.empty; - error_messages = []; - trace = Buffer.create 1024; - inputs_buffer; inputs_form; ast; contact_map; env; graph; state; init_l; - lastyield; -} + ~state ~init_l ~lastyield ~ast : t = + { + is_running = false; + run_finalize = false; + counter; + log_buffer; + log_form; + pause_condition = Alg_expr.FALSE; + dumpIfDeadlocked; + maxConsecutiveClash; + patternSharing; + plot = Data.init_plot env; + snapshots = Mods.StringMap.empty; + dins = []; + species = Mods.StringMap.empty; + files = Mods.StringMap.empty; + error_messages = []; + trace = Buffer.create 1024; + inputs_buffer; + inputs_form; + ast; + contact_map; + env; + graph; + state; + init_l; + lastyield; + } let reinitialize ~outputs random_state t = let () = Counter.reinitialize t.counter in -(* let () = Format.pp_print_flush t.log_form () in - let () = Buffer.reset t.log_buffer in*) + (* let () = Format.pp_print_flush t.log_form () in + let () = Buffer.reset t.log_buffer in*) t.is_running <- false; t.run_finalize <- false; t.pause_condition <- Alg_expr.FALSE; - t.plot <- Data.init_plot t.env ; + t.plot <- Data.init_plot t.env; t.snapshots <- Mods.StringMap.empty; t.dins <- []; t.files <- Mods.StringMap.empty; t.error_messages <- []; - t.graph <- Rule_interpreter.empty - ~outputs ~with_trace:false - random_state t.env t.counter; - t.state <- State_interpreter.empty - ~with_delta_activities:false t.counter t.env + t.graph <- + Rule_interpreter.empty ~outputs ~with_trace:false random_state t.env + t.counter; + t.state <- + State_interpreter.empty ~with_delta_activities:false t.counter t.env let catch_error handler = function - | ExceptionDefn.Syntax_Error - ((message,range) : string Locality.annot) -> + | ExceptionDefn.Syntax_Error ((message, range) : string Loc.annoted) -> handler (Api_common.error_msg ~range message) - | ExceptionDefn.Malformed_Decl - ((message,range) : string Locality.annot) -> + | ExceptionDefn.Malformed_Decl ((message, range) : string Loc.annoted) -> handler (Api_common.error_msg ~range message) - | ExceptionDefn.Internal_Error - ((message,range) : string Locality.annot) -> + | ExceptionDefn.Internal_Error ((message, range) : string Loc.annoted) -> handler (Api_common.error_msg ~range message) | Invalid_argument error -> - handler (Api_common.error_msg ("Runtime error "^ error)) + handler (Api_common.error_msg ("Runtime error " ^ error)) | exn -> - let message = (try (Printexc.to_string exn) - with _ -> "unspecified exception thrown") in + let message = + try Printexc.to_string exn with _ -> "unspecified exception thrown" + in handler (Api_common.error_msg message) -let parse ~patternSharing (ast : Ast.parsing_compil) overwrite system_process = +let parse ~patternSharing (ast : Ast.parsing_compil) var_overwrite + system_process = let yield = system_process#yield in let log_buffer = Buffer.create 512 in let log_form = Format.formatter_of_buffer log_buffer in let inputs_buffer = Buffer.create 512 in let inputs_form = Format.formatter_of_buffer inputs_buffer in - let (conf,_,_,_) = - Configuration.parse ast.Ast.configurations in + let conf, _, _, _ = Configuration.parse ast.Ast.configurations in let warning ~pos msg = Data.print_warning ~pos log_form msg in Lwt.catch (fun () -> - (Lwt.wrap2 - (LKappa_compiler.compil_of_ast - ~warning ~debugMode:false ~syntax_version:Ast.V4) overwrite ast) >>= - (fun - (sig_nd, - contact_map, - tk_nd,_algs_nd, - _updated_vars, - (result : - (Ast.agent, LKappa.rule_agent list, Raw_mixture.t, - int, LKappa.rule) Ast.compil)) -> - (yield ()) >>= - (fun () -> - (* The last yield is updated after the last yield. - It is gotten here for the initial last yeild value. *) - let lastyield = Sys.time () in - try (* exception raised by compile must have used Lwt.fail. - Something is wrong for now *) - let outputs = function - | Data.Log s -> - Format.fprintf log_form "%s@." s - | Data.Warning (pos,msg) -> - Data.print_warning ?pos log_form msg - | Data.Snapshot _ - | Data.DIN _ - | Data.Species _ - | Data.DeltaActivities _ - | Data.Plot _ - | Data.TraceStep _ - | Data.Print _ -> assert false in - Eval.compile - ~debugMode:false ~pause:(fun f -> Lwt.bind (yield ()) f) - ~return:Lwt.return ?rescale_init:None ?overwrite_t0:None ~compileModeOn:false - ~outputs ~sharing:patternSharing sig_nd tk_nd contact_map - result >>= - (fun (env,with_trace,init_l) -> - let counter = - Counter.create - ~init_t:(0. : float) ~init_e:(0 : int) - ?max_time:None ?max_event:None - ~plot_period:(Configuration.DT 1.) - ~nb_rules:(Model.nb_rules env) () in - let theSeed = - match conf.Configuration.seed with - | None -> - let () = Random.self_init () in - let out = Random.bits () in - let () = - Format.fprintf log_form "Random seed used: %i@." out in - out - | Some theSeed -> theSeed in - let random_state = Random.State.make [|theSeed|] in - let () = - Data.print_initial_inputs - ?uuid:None {conf with Configuration.seed = Some theSeed} - env inputs_form init_l in - let simulation = - create_t - ~contact_map ~log_form ~log_buffer ~inputs_buffer ~inputs_form - ~ast ~env ~counter - ~dumpIfDeadlocked:conf.Configuration.dumpIfDeadlocked - ~maxConsecutiveClash:conf.Configuration.maxConsecutiveClash - ~patternSharing - ~graph:(Rule_interpreter.empty - ~outputs ~with_trace - random_state env counter) - ~state:(State_interpreter.empty - ~with_delta_activities:false counter env) - ~init_l ~lastyield - in - Lwt.return (Result_util.ok simulation)) - with e -> - (catch_error (fun x -> Lwt.return (Result_util.error [x]))) e - ))) - (catch_error (fun e -> Lwt.return (Result_util.error [e]))) + Lwt.wrap2 + (fun var_overwrite -> + LKappa_compiler.compil_of_ast ~warning ~debug_mode:false + ~syntax_version:Ast.V4 ~var_overwrite) + var_overwrite ast + >>= fun (ast_compiled_data : LKappa_compiler.ast_compiled_data) -> + yield () >>= fun () -> + (* The last yield is updated after the last yield. + It is gotten here for the initial last yeild value. *) + let lastyield = Sys.time () in + try + (* exception raised by compile must have used Lwt.fail. + Something is wrong for now *) + let outputs = function + | Data.Log s -> Format.fprintf log_form "%s@." s + | Data.Warning (pos, msg) -> Data.print_warning ?pos log_form msg + | Data.Snapshot _ | Data.DIN _ | Data.Species _ + | Data.DeltaActivities _ | Data.Plot _ | Data.TraceStep _ + | Data.Print _ -> + assert false + in + Eval.compile ~debug_mode:false + ~pause:(fun f -> Lwt.bind (yield ()) f) + ~return:Lwt.return ?rescale_init:None ?overwrite_t0:None + ~compile_mode_on:false ~outputs ~sharing:patternSharing + ast_compiled_data.agents_sig ast_compiled_data.token_names + ast_compiled_data.contact_map ast_compiled_data.result + >>= fun (env, with_trace, init_l) -> + let counter = + Counter.create + ~init_t:(0. : float) + ~init_e:(0 : int) + ?max_time:None ?max_event:None ~plot_period:(Configuration.DT 1.) + ~nb_rules:(Model.nb_rules env) () + in + let theSeed = + match conf.Configuration.seed with + | None -> + let () = Random.self_init () in + let out = Random.bits () in + let () = Format.fprintf log_form "Random seed used: %i@." out in + out + | Some theSeed -> theSeed + in + let random_state = Random.State.make [| theSeed |] in + let () = + Data.print_initial_inputs ?uuid:None + { conf with Configuration.seed = Some theSeed } + env inputs_form init_l + in + let simulation = + create_t ~contact_map:ast_compiled_data.contact_map ~log_form + ~log_buffer ~inputs_buffer ~inputs_form ~ast ~env ~counter + ~dumpIfDeadlocked:conf.Configuration.dumpIfDeadlocked + ~maxConsecutiveClash:conf.Configuration.maxConsecutiveClash + ~patternSharing + ~graph: + (Rule_interpreter.empty ~outputs ~with_trace random_state env + counter) + ~state: + (State_interpreter.empty ~with_delta_activities:false counter env) + ~init_l ~lastyield + in + Lwt.return (Result_util.ok simulation) + with e -> + (catch_error (fun x -> Lwt.return (Result_util.error [ x ]))) e) + (catch_error (fun e -> Lwt.return (Result_util.error [ e ]))) -let outputs (simulation : t) = - function - | Data.DIN (flux_name,flux_map) -> - simulation.dins <- (flux_name,flux_map)::simulation.dins +let outputs (simulation : t) = function + | Data.DIN (flux_name, flux_map) -> + simulation.dins <- (flux_name, flux_map) :: simulation.dins | Data.DeltaActivities _ -> assert false | Data.Plot new_observables -> simulation.plot <- Data.add_plot_line new_observables simulation.plot - | Data.Species(file,time,mix) -> + | Data.Species (file, time, mix) -> let p = Mods.StringMap.find_default [] file simulation.species in simulation.species <- - Mods.StringMap.add file ((time,mix)::p) simulation.species + Mods.StringMap.add file ((time, mix) :: p) simulation.species | Data.Print file_line -> - begin - match file_line.Data.file_line_name with - | None -> - Format.fprintf simulation.log_form "%s@." file_line.Data.file_line_text - | Some na -> - let lines = Mods.StringMap.find_default [] na simulation.files in - simulation.files <- - Mods.StringMap.add - na (file_line.Data.file_line_text::lines) simulation.files - end - | Data.Snapshot (filename,snapshot) -> - let already_there x = - Mods.StringMap.mem x simulation.snapshots in + (match file_line.Data.file_line_name with + | None -> + Format.fprintf simulation.log_form "%s@." file_line.Data.file_line_text + | Some na -> + let lines = Mods.StringMap.find_default [] na simulation.files in + simulation.files <- + Mods.StringMap.add na + (file_line.Data.file_line_text :: lines) + simulation.files) + | Data.Snapshot (filename, snapshot) -> + let already_there x = Mods.StringMap.mem x simulation.snapshots in let snapshot_file = - Tools.find_available_name - ~already_there filename - ~facultative:(string_of_int snapshot.Data.snapshot_event) ~ext:None in + Tools.find_available_name ~already_there filename + ~facultative:(string_of_int snapshot.Data.snapshot_event) + ~ext:None + in simulation.snapshots <- Mods.StringMap.add snapshot_file snapshot simulation.snapshots | Data.Log s -> Format.fprintf simulation.log_form "%s@." s - | Data.Warning (pos,msg) -> Data.print_warning ?pos simulation.log_form msg + | Data.Warning (pos, msg) -> Data.print_warning ?pos simulation.log_form msg | Data.TraceStep st -> - let () = Buffer.add_char simulation.trace - (if Buffer.length simulation.trace = 0 then '[' else ',') in + let () = + Buffer.add_char simulation.trace + (if Buffer.length simulation.trace = 0 then + '[' + else + ',') + in Trace.write_step simulation.trace st let interactive_outputs formatter t = function | Data.Log s -> Format.fprintf formatter "%s@." s - | Data.Warning (pos,msg) -> Data.print_warning ?pos formatter msg + | Data.Warning (pos, msg) -> Data.print_warning ?pos formatter msg | Data.Print file_line when file_line.Data.file_line_name = None -> Format.fprintf formatter "%s@." file_line.Data.file_line_text - | Data.DIN _ | Data.DeltaActivities _ | Data.Plot _ | Data.Species _ | - Data.Print _ | Data.Snapshot _ | Data.TraceStep _ as v -> outputs t v + | ( Data.DIN _ | Data.DeltaActivities _ | Data.Plot _ | Data.Species _ + | Data.Print _ | Data.Snapshot _ | Data.TraceStep _ ) as v -> + outputs t v -let time_yield - ~(system_process : system_process) - ~(t : t) : unit Lwt.t = +let time_yield ~(system_process : system_process) ~(t : t) : unit Lwt.t = let time = Sys.time () in - if time -. t.lastyield > system_process#min_run_duration () then + if time -. t.lastyield > system_process#min_run_duration () then ( let () = t.lastyield <- time in system_process#yield () - else Lwt.return_unit + ) else + Lwt.return_unit let finalize_simulation ~(t : t) : unit = - State_interpreter.end_of_simulation - ~outputs:(outputs t) t.env t.counter t.graph t.state + State_interpreter.end_of_simulation ~outputs:(outputs t) t.env t.counter + t.graph t.state -let run_simulation - ~(system_process : system_process) ~(t : t) stopped : unit Lwt.t = +let run_simulation ~(system_process : system_process) ~(t : t) stopped : + unit Lwt.t = Lwt.catch (fun () -> - let rstop = ref stopped in - let () = t.is_running <- true in - let rec iter () = - (try - let () = - while (not !rstop) && - Sys.time () -. t.lastyield < - system_process#min_run_duration () - do - let (stop,graph',state') = - State_interpreter.a_loop - ~debugMode:false ~outputs:(outputs t) - ~dumpIfDeadlocked:t.dumpIfDeadlocked - ~maxConsecutiveClash:t.maxConsecutiveClash - t.env t.counter t.graph t.state in - rstop := stop || Rule_interpreter.value_bool - t.counter graph' t.pause_condition; - t.graph <- graph'; - t.state <- state' - done in - Lwt.return_unit - with e -> Lwt.fail e) >>= fun () -> - if !rstop then - let () = t.is_running <- false in + let rstop = ref stopped in + let () = t.is_running <- true in + let rec iter () = + (try + let () = + while + (not !rstop) + && Sys.time () -. t.lastyield + < system_process#min_run_duration () + do + let stop, graph', state' = + State_interpreter.a_loop ~debug_mode:false ~outputs:(outputs t) + ~dumpIfDeadlocked:t.dumpIfDeadlocked + ~maxConsecutiveClash:t.maxConsecutiveClash t.env t.counter + t.graph t.state + in + rstop := + stop + || Rule_interpreter.value_bool t.counter graph' + t.pause_condition; + t.graph <- graph'; + t.state <- state' + done + in Lwt.return_unit - else if t.is_running then - (system_process#yield ()) >>= (fun () -> - let () = t.lastyield <- Sys.time () in iter ()) - else - Lwt.return_unit in - (iter ()) >>= - (fun () -> - let () = if t.run_finalize then finalize_simulation ~t in - Lwt.return_unit)) - (catch_error - (fun e -> + with e -> Lwt.fail e) + >>= fun () -> + if !rstop then ( let () = t.is_running <- false in - let () = t.error_messages <- [e] in - Lwt.return_unit)) + Lwt.return_unit + ) else if t.is_running then + system_process#yield () >>= fun () -> + let () = t.lastyield <- Sys.time () in + iter () + else + Lwt.return_unit + in + iter () >>= fun () -> + let () = if t.run_finalize then finalize_simulation ~t in + Lwt.return_unit) + (catch_error (fun e -> + let () = t.is_running <- false in + let () = t.error_messages <- [ e ] in + Lwt.return_unit)) -let start - ~(system_process : system_process) - ~(parameter : Api_types_t.simulation_parameter) - ~(t : t) - : (unit,Result_util.message list) Result_util.t Lwt.t = +let start ~(system_process : system_process) + ~(parameter : Api_types_t.simulation_parameter) ~(t : t) : + (unit, Result_util.message list) Result_util.t Lwt.t = let lexbuf = - Lexing.from_string parameter.Api_types_t.simulation_pause_condition in - Lwt.catch (fun () -> + Lexing.from_string parameter.Api_types_t.simulation_pause_condition + in + Lwt.catch + (fun () -> (*let () = Counter.set_max_time t.counter @@ -327,231 +340,220 @@ let start let random_state = match parameter.Api_types_t.simulation_seed with | None -> Random.State.make_self_init () - | Some seed -> Random.State.make [|seed|] in + | Some seed -> Random.State.make [| seed |] + in let () = reinitialize random_state ~outputs:(outputs t) t in try let pause = Kparser4.standalone_bool_expr Klexer4.token lexbuf in - Lwt.wrap4 (Evaluator.get_pause_criteria - ~debugMode:false ~outputs:(outputs t) - ~sharing:t.patternSharing ~syntax_version:Ast.V4) - t.contact_map t.env t.graph pause >>= - fun (env',graph',b'') -> + Lwt.wrap4 + (Evaluator.get_pause_criteria ~debug_mode:false ~outputs:(outputs t) + ~sharing:t.patternSharing ~syntax_version:Ast.V4) + t.contact_map t.env t.graph pause + >>= fun (env', graph', b'') -> let () = t.env <- env' in let () = t.graph <- graph' in let () = t.pause_condition <- b'' in let () = - Counter.set_plot_period - t.counter - (Configuration.DT parameter.Api_types_t.simulation_plot_period) in + Counter.set_plot_period t.counter + (Configuration.DT parameter.Api_types_t.simulation_plot_period) + in let () = - Lwt.async - (fun () -> - try (* exception raised by build_initial_state must have been - raised with Lwt.fail. Something is wrong for now... *) - Eval.build_initial_state - ~bind:(fun x f -> - (time_yield ~system_process:system_process ~t:t) >>= - (fun () -> x >>= f)) - ~return:Lwt.return ~debugMode:false ~outputs:(outputs t) - ~with_trace:parameter.Api_types_t.simulation_store_trace - ~with_delta_activities:false - t.counter - t.env - random_state - t.init_l >>= - (fun (stop,graph,state) -> - let () = t.graph <- graph; t.state <- state in - let first_obs = - State_interpreter.observables_values - t.env graph t.counter in - let () = - t.plot <- Data.add_plot_line first_obs t.plot in - run_simulation ~system_process:system_process ~t:t stop) - with e -> - catch_error - (fun e -> - let () = t.error_messages <- [e] in - Lwt.return_unit) e - ) in + Lwt.async (fun () -> + try + (* exception raised by build_initial_state must have been + raised with Lwt.fail. Something is wrong for now... *) + Eval.build_initial_state + ~bind:(fun x f -> + time_yield ~system_process ~t >>= fun () -> x >>= f) + ~return:Lwt.return ~debug_mode:false ~outputs:(outputs t) + ~with_trace:parameter.Api_types_t.simulation_store_trace + ~with_delta_activities:false t.counter t.env random_state + t.init_l + >>= fun (stop, graph, state) -> + let () = + t.graph <- graph; + t.state <- state + in + let first_obs = + State_interpreter.observables_values t.env graph t.counter + in + let () = t.plot <- Data.add_plot_line first_obs t.plot in + run_simulation ~system_process ~t stop + with e -> + catch_error + (fun e -> + let () = t.error_messages <- [ e ] in + Lwt.return_unit) + e) + in Lwt.return (Result_util.ok ()) - with ExceptionDefn.Syntax_Error (message,range) -> + with ExceptionDefn.Syntax_Error (message, range) -> Lwt.return (Api_common.result_error_msg ~range message)) - (catch_error - (fun e -> - let () = t.error_messages <- [e] in - Lwt.return (Result_util.error [e]))) + (catch_error (fun e -> + let () = t.error_messages <- [ e ] in + Lwt.return (Result_util.error [ e ]))) -let pause - ~(system_process : system_process) - ~(t : t) : (unit,Result_util.message list) Result_util.t Lwt.t = - let () = ignore(system_process) in - let () = ignore(t) in - let () = if t.is_running then +let pause ~(system_process : system_process) ~(t : t) : + (unit, Result_util.message list) Result_util.t Lwt.t = + let () = ignore system_process in + let () = ignore t in + let () = + if t.is_running then t.is_running <- false else () in Lwt.return (Result_util.ok ()) -let stop - ~(system_process : system_process) - ~(t : t) : (unit,Result_util.message list) Result_util.t Lwt.t = - let () = ignore(system_process) in - let () = ignore(t) in +let stop ~(system_process : system_process) ~(t : t) : + (unit, Result_util.message list) Result_util.t Lwt.t = + let () = ignore system_process in + let () = ignore t in Lwt.catch (fun () -> - let () = t.run_finalize <- true in - (if t.is_running then - pause ~system_process:system_process ~t:t - else - let () = finalize_simulation ~t:t in - Lwt.return (Result_util.ok ())) - ) - (catch_error (fun e -> Lwt.return (Result_util.error [e]))) + let () = t.run_finalize <- true in + if t.is_running then + pause ~system_process ~t + else ( + let () = finalize_simulation ~t in + Lwt.return (Result_util.ok ()) + )) + (catch_error (fun e -> Lwt.return (Result_util.error [ e ]))) -let perturbation - ~(system_process : system_process) - ~(t : t) - ~(perturbation:Api_types_t.simulation_intervention) - : (string, Result_util.message list) Result_util.t Lwt.t = - let () = ignore(system_process) in - let lexbuf = - Lexing.from_string perturbation - in +let perturbation ~(system_process : system_process) ~(t : t) + ~(perturbation : Api_types_t.simulation_intervention) : + (string, Result_util.message list) Result_util.t Lwt.t = + let () = ignore system_process in + let lexbuf = Lexing.from_string perturbation in Lwt.catch (fun () -> - if t.is_running then - Lwt.return (Api_common.result_error_msg msg_process_not_paused) - else - try - let e = Kparser4.standalone_effect_list Klexer4.token lexbuf in - let log_buffer = Buffer.create 512 in - let log_form = Format.formatter_of_buffer log_buffer in - Lwt.wrap6 - (Evaluator.do_interactive_directives - ~debugMode:false ~outputs:(interactive_outputs log_form t) - ~sharing:t.patternSharing ~syntax_version:Ast.V4) - t.contact_map t.env t.counter t.graph t.state e >>= - fun (e',(env',(_,graph'',state'))) -> - let () = t.env <- env' in - let () = t.graph <- graph'' in - let () = t.state <- state' in - let () = - Format.fprintf - t.log_form "%%mod: [E] = %i do %a@." - (Counter.current_event t.counter) - (Pp.list ~trailing:Pp.colon Pp.colon - (Kappa_printer.modification ~noCounters:false ~env:t.env)) - e' in - let () = - Format.fprintf - t.inputs_form "%%mod: [E] = %i do %a@." - (Counter.current_event t.counter) - (Pp.list ~trailing:Pp.colon Pp.colon - (Kappa_printer.modification ~noCounters:false ~env:t.env)) - e' in - Lwt.return (Result_util.ok (Buffer.contents log_buffer)) - with ExceptionDefn.Syntax_Error (message,range) -> - Lwt.return (Api_common.result_error_msg ~range message)) - (catch_error (fun e -> Lwt.return (Result_util.error [e]))) + if t.is_running then + Lwt.return (Api_common.result_error_msg msg_process_not_paused) + else ( + try + let e = Kparser4.standalone_effect_list Klexer4.token lexbuf in + let log_buffer = Buffer.create 512 in + let log_form = Format.formatter_of_buffer log_buffer in + Lwt.wrap6 + (Evaluator.do_interactive_directives ~debug_mode:false + ~outputs:(interactive_outputs log_form t) + ~sharing:t.patternSharing ~syntax_version:Ast.V4) + t.contact_map t.env t.counter t.graph t.state e + >>= fun (e', (env', (_, graph'', state'))) -> + let () = t.env <- env' in + let () = t.graph <- graph'' in + let () = t.state <- state' in + let () = + Format.fprintf t.log_form "%%mod: [E] = %i do %a@." + (Counter.current_event t.counter) + (Pp.list ~trailing:Pp.colon Pp.colon + (Kappa_printer.modification ~noCounters:false ~env:t.env)) + e' + in + let () = + Format.fprintf t.inputs_form "%%mod: [E] = %i do %a@." + (Counter.current_event t.counter) + (Pp.list ~trailing:Pp.colon Pp.colon + (Kappa_printer.modification ~noCounters:false ~env:t.env)) + e' + in + Lwt.return (Result_util.ok (Buffer.contents log_buffer)) + with ExceptionDefn.Syntax_Error (message, range) -> + Lwt.return (Api_common.result_error_msg ~range message) + )) + (catch_error (fun e -> Lwt.return (Result_util.error [ e ]))) -let continue - ~(system_process : system_process) - ~(t : t) - ~(pause_condition : string) - : (unit,Result_util.message list) Result_util.t Lwt.t = - let lexbuf = - Lexing.from_string pause_condition in +let continue ~(system_process : system_process) ~(t : t) + ~(pause_condition : string) : + (unit, Result_util.message list) Result_util.t Lwt.t = + let lexbuf = Lexing.from_string pause_condition in Lwt.catch (fun () -> - if t.is_running then - Lwt.return (Result_util.ok ()) - else - try - let pause = Kparser4.standalone_bool_expr Klexer4.token lexbuf in - Lwt.wrap4 (Evaluator.get_pause_criteria - ~debugMode:false ~outputs:(outputs t) - ~sharing:t.patternSharing ~syntax_version:Ast.V4) - t.contact_map t.env t.graph pause >>= - fun (env',graph',b'') -> - let () = t.env <- env' in - let () = t.graph <- graph' in - let () = t.pause_condition <- b'' in - (*let () = - Counter.set_max_time - t.counter - parameter.Api_types_t.simulation_max_time - in - let () = - Counter.set_max_events - t.counter - parameter.Api_types_t.simulation_max_events - in*) - let () = - Lwt.async - (fun () -> - run_simulation ~system_process:system_process ~t:t false) in - Lwt.return (Result_util.ok ()) - with ExceptionDefn.Syntax_Error (message,range) -> - Lwt.return (Api_common.result_error_msg ~range message)) - (catch_error (fun e -> Lwt.return (Result_util.error [e]))) + if t.is_running then + Lwt.return (Result_util.ok ()) + else ( + try + let pause = Kparser4.standalone_bool_expr Klexer4.token lexbuf in + Lwt.wrap4 + (Evaluator.get_pause_criteria ~debug_mode:false ~outputs:(outputs t) + ~sharing:t.patternSharing ~syntax_version:Ast.V4) + t.contact_map t.env t.graph pause + >>= fun (env', graph', b'') -> + let () = t.env <- env' in + let () = t.graph <- graph' in + let () = t.pause_condition <- b'' in + (*let () = + Counter.set_max_time + t.counter + parameter.Api_types_t.simulation_max_time + in + let () = + Counter.set_max_events + t.counter + parameter.Api_types_t.simulation_max_events + in*) + let () = + Lwt.async (fun () -> run_simulation ~system_process ~t false) + in + Lwt.return (Result_util.ok ()) + with ExceptionDefn.Syntax_Error (message, range) -> + Lwt.return (Api_common.result_error_msg ~range message) + )) + (catch_error (fun e -> Lwt.return (Result_util.error [ e ]))) -let progress - ~(system_process : system_process) - ~(t : t) : - (Api_types_t.simulation_progress,Result_util.message list) Result_util.t Lwt.t = - let () = ignore(system_process) in - let () = ignore(t) in +let progress ~(system_process : system_process) ~(t : t) : + (Api_types_t.simulation_progress, Result_util.message list) Result_util.t + Lwt.t = + let () = ignore system_process in + let () = ignore t in match t.error_messages with | [] -> Lwt.catch (fun () -> - Lwt.return (Result_util.ok { - Api_types_t.simulation_progress_time = - Counter.current_time t.counter ; - Api_types_t.simulation_progress_time_percentage = - Option_util.map - (fun x -> int_of_float ( x *. 100.)) - (Counter.time_ratio t.counter) ; - Api_types_t.simulation_progress_event = - Counter.current_event t.counter ; - Api_types_t.simulation_progress_event_percentage = - Option_util.map - (fun x -> int_of_float ( x *. 100.)) - (Counter.event_ratio t.counter) ; - Api_types_t.simulation_progress_tracked_events = - Counter.tracked_events t.counter ; - Api_types_t.simulation_progress_is_running = - t.is_running ; - })) - (catch_error (fun e -> Lwt.return (Result_util.error [e]))) + Lwt.return + (Result_util.ok + { + Api_types_t.simulation_progress_time = + Counter.current_time t.counter; + Api_types_t.simulation_progress_time_percentage = + Option_util.map + (fun x -> int_of_float (x *. 100.)) + (Counter.time_ratio t.counter); + Api_types_t.simulation_progress_event = + Counter.current_event t.counter; + Api_types_t.simulation_progress_event_percentage = + Option_util.map + (fun x -> int_of_float (x *. 100.)) + (Counter.event_ratio t.counter); + Api_types_t.simulation_progress_tracked_events = + Counter.tracked_events t.counter; + Api_types_t.simulation_progress_is_running = t.is_running; + })) + (catch_error (fun e -> Lwt.return (Result_util.error [ e ]))) | _ -> Lwt.return (Result_util.error t.error_messages) -let outputs - ~(system_process : system_process) - ~(t : t) : - (Api_data.simulation_detail_output,Result_util.message list) Result_util.t Lwt.t = - let () = ignore(system_process) in - let () = ignore(t) in +let outputs ~(system_process : system_process) ~(t : t) : + (Api_data.simulation_detail_output, Result_util.message list) Result_util.t + Lwt.t = + let () = ignore system_process in + let () = ignore t in match t.error_messages with | [] -> Lwt.catch (fun () -> - Lwt.return (Result_util.ok { - Api_types_t.simulation_output_plot = - Some t.plot ; - Api_types_t.simulation_output_dins = - t.dins ; - Api_types_t.simulation_output_file_lines = - t.files ; - Api_types_t.simulation_output_snapshots = - t.snapshots ; - Api_types_t.simulation_output_inputs = - Buffer.contents t.inputs_buffer ; - Api_types_t.simulation_output_log_messages = - Buffer.contents t.log_buffer ; - })) - (catch_error (fun e -> Lwt.return (Result_util.error [e]))) + Lwt.return + (Result_util.ok + { + Api_types_t.simulation_output_plot = Some t.plot; + Api_types_t.simulation_output_dins = t.dins; + Api_types_t.simulation_output_file_lines = t.files; + Api_types_t.simulation_output_snapshots = t.snapshots; + Api_types_t.simulation_output_inputs = + Buffer.contents t.inputs_buffer; + Api_types_t.simulation_output_log_messages = + Buffer.contents t.log_buffer; + })) + (catch_error (fun e -> Lwt.return (Result_util.error [ e ]))) | _ -> Lwt.return (Result_util.error t.error_messages) let efficiency t = Counter.get_efficiency t.counter @@ -559,28 +561,34 @@ let efficiency t = Counter.get_efficiency t.counter let get_raw_trace t = JsonUtil.string_of_write (fun ob t -> - let () = Buffer.add_char ob '{' in - let () = JsonUtil.write_field - "dict" (fun ob () -> - let () = Buffer.add_char ob '{' in - let () = Buffer.add_string ob Agent.json_dictionnary in - let () = JsonUtil.write_comma ob in - let () = Buffer.add_string ob Instantiation.json_dictionnary in - let () = JsonUtil.write_comma ob in - let () = Buffer.add_string - ob Trace.Simulation_info.json_dictionnary in - let () = JsonUtil.write_comma ob in - let () = Buffer.add_string ob Trace.json_dictionnary in - Buffer.add_char ob '}' - ) ob () in - let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "model" Yojson.Basic.write_json ob (Model.to_yojson t.env) in - let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "trace" Buffer.add_string ob (Buffer.contents t.trace) in - Buffer.add_string ob "]}" - ) t + let () = Buffer.add_char ob '{' in + let () = + JsonUtil.write_field "dict" + (fun ob () -> + let () = Buffer.add_char ob '{' in + let () = Buffer.add_string ob Agent.json_dictionnary in + let () = JsonUtil.write_comma ob in + let () = Buffer.add_string ob Instantiation.json_dictionnary in + let () = JsonUtil.write_comma ob in + let () = + Buffer.add_string ob Trace.Simulation_info.json_dictionnary + in + let () = JsonUtil.write_comma ob in + let () = Buffer.add_string ob Trace.json_dictionnary in + Buffer.add_char ob '}') + ob () + in + let () = JsonUtil.write_comma ob in + let () = + JsonUtil.write_field "model" Yojson.Basic.write_json ob + (Model.to_yojson t.env) + in + let () = JsonUtil.write_comma ob in + let () = + JsonUtil.write_field "trace" Buffer.add_string ob + (Buffer.contents t.trace) + in + Buffer.add_string ob "]}") + t -let get_raw_ast t = - Yojson.Basic.to_string (Ast.compil_to_json t.ast) +let get_raw_ast t = Yojson.Basic.to_string (Ast.compil_to_json t.ast) diff --git a/core/api/kappa_facade.mli b/core/api/kappa_facade.mli index ea46bece98..28e862e878 100644 --- a/core/api/kappa_facade.mli +++ b/core/api/kappa_facade.mli @@ -11,23 +11,24 @@ These are system process implementation details that vary. *) -class type system_process = - object - method log : ?exn:exn -> string -> unit Lwt.t - method yield : unit -> unit Lwt.t - method min_run_duration : unit -> float - end +class type system_process = object + method log : ?exn:exn -> string -> unit Lwt.t + method yield : unit -> unit Lwt.t + method min_run_duration : unit -> float +end +type t (** State of the running simulation. *) -type t -(** Trivial implementation *) class null_process : system_process +(** Trivial implementation *) val parse : patternSharing:Pattern.sharing_level -> - Ast.parsing_compil -> (string * Nbr.t) list -> system_process -> + Ast.parsing_compil -> + (string * Nbr.t) list -> + system_process -> (t, Result_util.message list) Result_util.t Lwt.t val start : @@ -38,11 +39,13 @@ val start : val pause : system_process:system_process -> - t:t -> (unit, Result_util.message list) Result_util.t Lwt.t + t:t -> + (unit, Result_util.message list) Result_util.t Lwt.t val stop : system_process:system_process -> - t:t -> (unit, Result_util.message list) Result_util.t Lwt.t + t:t -> + (unit, Result_util.message list) Result_util.t Lwt.t val perturbation : system_process:system_process -> @@ -51,19 +54,23 @@ val perturbation : (string, Result_util.message list) Result_util.t Lwt.t val continue : - system_process:system_process -> t:t -> pause_condition:string -> + system_process:system_process -> + t:t -> + pause_condition:string -> (unit, Result_util.message list) Result_util.t Lwt.t val progress : - system_process:system_process -> t:t -> - (Api_types_t.simulation_progress, Result_util.message list) Result_util.t Lwt.t + system_process:system_process -> + t:t -> + (Api_types_t.simulation_progress, Result_util.message list) Result_util.t + Lwt.t val outputs : - system_process:system_process -> t:t -> - (Api_data.simulation_detail_output, Result_util.message list) Result_util.t Lwt.t + system_process:system_process -> + t:t -> + (Api_data.simulation_detail_output, Result_util.message list) Result_util.t + Lwt.t val efficiency : t -> Counter.Efficiency.t - val get_raw_trace : t -> string - val get_raw_ast : t -> string diff --git a/core/api/kasa_client.ml b/core/api/kasa_client.ml index 129ce1f7ff..1da620fc98 100644 --- a/core/api/kasa_client.ml +++ b/core/api/kasa_client.ml @@ -9,25 +9,27 @@ open Lwt.Infix type mailbox = - (int, - (Yojson.Basic.t, - Exception_without_parameter.method_handler) Result.result Lwt.u) - Hashtbl.t + ( int, + (Yojson.Basic.t, Exception_without_parameter.method_handler) Result.result + Lwt.u ) + Hashtbl.t let reply_of_string x = match Yojson.Basic.from_string x with - | `Assoc [ "id", ` Int id; "code", `String "ERROR"; "data", err ] -> - Some id,Result.Error (Exception_without_parameter.of_json err) - | `Assoc [ "id", ` Int id; "code", `String "SUCCESS"; "data", data ] -> - Some id,Result.Ok data + | `Assoc [ ("id", `Int id); ("code", `String "ERROR"); ("data", err) ] -> + Some id, Result.Error (Exception_without_parameter.of_json err) + | `Assoc [ ("id", `Int id); ("code", `String "SUCCESS"); ("data", data) ] -> + Some id, Result.Ok data | x -> - None, Result.Error - (Exception_without_parameter.add_uncaught_error - (Exception_without_parameter.build_uncaught_exception - ~file_name:"kasa_client" - ~message:("Invalid response from KaSa: "^Yojson.Basic.to_string x) - Exit) - Exception_without_parameter.empty_error_handler) + ( None, + Result.Error + (Exception_without_parameter.add_uncaught_error + (Exception_without_parameter.build_uncaught_exception + ~file_name:"kasa_client" + ~message: + ("Invalid response from KaSa: " ^ Yojson.Basic.to_string x) + Exit) + Exception_without_parameter.empty_error_handler) ) let receive mailbox x = match reply_of_string x with @@ -38,17 +40,16 @@ let receive mailbox x = | None, _ -> () let new_mailbox () = Hashtbl.create 2 - let is_computing mailbox = Hashtbl.length mailbox <> 0 class new_client ~is_running ~post (mailbox : mailbox) : Api.manager_static_analysis = - object(self) + object (self) val mutable id = 0 method private raw_message post request = - if is_running () then - let result,feeder = Lwt.task () in + if is_running () then ( + let result, feeder = Lwt.task () in let outbuf = Buffer.create 1024 in let () = Buffer.add_string outbuf "{id:" in let () = Buffer.add_string outbuf (string_of_int id) in @@ -57,16 +58,15 @@ class new_client ~is_running ~post (mailbox : mailbox) : let () = Buffer.add_string outbuf "}" in let () = post (Buffer.contents outbuf) in let () = Hashtbl.replace mailbox id feeder in - let () = id <- id+1 in + let () = id <- id + 1 in result - else + ) else Lwt.return_error (Exception_without_parameter.add_uncaught_error (Exception_without_parameter.build_uncaught_exception - ~file_name:"kasa_client" - ~message:"KaSa agent is dead" - Exit) + ~file_name:"kasa_client" ~message:"KaSa agent is dead" Exit) Exception_without_parameter.empty_error_handler) + method private message request = self#raw_message post (fun outb -> Yojson.Basic.to_buffer outb request) @@ -74,185 +74,205 @@ class new_client ~is_running ~post (mailbox : mailbox) : let request outbuf = let () = Buffer.add_string outbuf "[ \"INIT\", " in let () = Buffer.add_string outbuf compil in - Buffer.add_string outbuf "]" in - Lwt_result.bind_result - (self#raw_message post request) - (function - | `Null -> Result.Ok () - | x -> Result.Error - (Exception_without_parameter.add_uncaught_error - (Exception_without_parameter.build_uncaught_exception - ~file_name:"kasa_client" - ~message:("Not a KaSa INIT response: "^ - Yojson.Basic.to_string x) - Exit) - Exception_without_parameter.empty_error_handler)) + Buffer.add_string outbuf "]" + in + Lwt_result.bind_result (self#raw_message post request) (function + | `Null -> Result.Ok () + | x -> + Result.Error + (Exception_without_parameter.add_uncaught_error + (Exception_without_parameter.build_uncaught_exception + ~file_name:"kasa_client" + ~message: + ("Not a KaSa INIT response: " ^ Yojson.Basic.to_string x) + Exit) + Exception_without_parameter.empty_error_handler)) + method init_static_analyser compil = self#init_static_analyser_raw (Yojson.Basic.to_string (Ast.compil_to_json compil)) method get_contact_map accuracy = let request = - `List ( `String "CONTACT_MAP" :: match accuracy with + `List + (`String "CONTACT_MAP" + :: + (match accuracy with | None -> [] - | Some a -> [Public_data.accuracy_to_json a]) in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok x) + | Some a -> [ Public_data.accuracy_to_json a ])) + in + Lwt_result.bind_result (self#message request) (fun x -> Result.Ok x) method get_pos_of_rules_and_vars = let request = `List [ `String "INFLUENCE_MAP_NODES_LOCATION" ] in - Lwt_result.bind_result - (self#message request) - (fun x -> - Result.Ok - (Public_data.pos_of_rules_and_vars_of_json x)) + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Public_data.pos_of_rules_and_vars_of_json x)) method get_influence_map_raw accuracy = let request = - `List ( `String "INFLUENCE_MAP" :: match accuracy with + `List + (`String "INFLUENCE_MAP" + :: + (match accuracy with | None -> [] - | Some a -> [Public_data.accuracy_to_json a]) in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok (Yojson.Basic.to_string x)) + | Some a -> [ Public_data.accuracy_to_json a ])) + in + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Yojson.Basic.to_string x)) + method get_local_influence_map ?fwd ?bwd ?origin ~total accuracy = - let request = - `List ( `String "INFLUENCE_MAP" :: ( - (fun accuracy l -> - match accuracy with - | None -> l - | Some a -> (Public_data.accuracy_to_json a)::l) - accuracy - [JsonUtil.of_option JsonUtil.of_int fwd; - JsonUtil.of_option JsonUtil.of_int bwd; - JsonUtil.of_int total; - JsonUtil.of_option Public_data.short_influence_node_to_json origin] - )) - in - Lwt_result.bind_result - (self#message request) - (fun x -> - let o = Public_data.local_influence_map_of_json x in - Result.Ok o) - method get_initial_node = let request = - `List [`String "INFLUENCE_MAP_ORIGINAL_NODE"] + `List + (`String "INFLUENCE_MAP" + :: (fun accuracy l -> + match accuracy with + | None -> l + | Some a -> Public_data.accuracy_to_json a :: l) + accuracy + [ + JsonUtil.of_option JsonUtil.of_int fwd; + JsonUtil.of_option JsonUtil.of_int bwd; + JsonUtil.of_int total; + JsonUtil.of_option Public_data.short_influence_node_to_json + origin; + ]) in - Lwt_result.bind_result - (self#message request) - (fun x -> - let o = JsonUtil.to_option - Public_data.refined_influence_node_of_json x in - Result.Ok o) + Lwt_result.bind_result (self#message request) (fun x -> + let o = Public_data.local_influence_map_of_json x in + Result.Ok o) + + method get_initial_node = + let request = `List [ `String "INFLUENCE_MAP_ORIGINAL_NODE" ] in + Lwt_result.bind_result (self#message request) (fun x -> + let o = + JsonUtil.to_option Public_data.refined_influence_node_of_json x + in + Result.Ok o) + method get_next_node json = let request = - `List [`String "INFLUENCE_MAP_NEXT_NODE"; - JsonUtil.of_option Public_data.short_influence_node_to_json json] + `List + [ + `String "INFLUENCE_MAP_NEXT_NODE"; + JsonUtil.of_option Public_data.short_influence_node_to_json json; + ] in - Lwt_result.bind_result - (self#message request) - (fun x -> - let o = JsonUtil.to_option - Public_data.refined_influence_node_of_json x in - Result.Ok o) + Lwt_result.bind_result (self#message request) (fun x -> + let o = + JsonUtil.to_option Public_data.refined_influence_node_of_json x + in + Result.Ok o) method get_previous_node json = let request = - `List [`String "INFLUENCE_MAP_PREVIOUS_NODE"; - JsonUtil.of_option Public_data.short_influence_node_to_json json] + `List + [ + `String "INFLUENCE_MAP_PREVIOUS_NODE"; + JsonUtil.of_option Public_data.short_influence_node_to_json json; + ] in - Lwt_result.bind_result - (self#message request) - (fun x -> - let o = JsonUtil.to_option - Public_data.refined_influence_node_of_json x in - Result.Ok o) + Lwt_result.bind_result (self#message request) (fun x -> + let o = + JsonUtil.to_option Public_data.refined_influence_node_of_json x + in + Result.Ok o) + method get_nodes_of_influence_map accuracy = - let request = `List ( `String "INFLUENCE_MAP_ALL_NODES" :: - (match accuracy with - | None -> [] - | Some a -> [Public_data.accuracy_to_json a])) + let request = + `List + (`String "INFLUENCE_MAP_ALL_NODES" + :: + (match accuracy with + | None -> [] + | Some a -> [ Public_data.accuracy_to_json a ])) in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok (Public_data.nodes_of_influence_map_of_json x)) + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Public_data.nodes_of_influence_map_of_json x)) + method get_dead_rules = let request = `List [ `String "DEAD_RULES" ] in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok (Public_data.dead_rules_of_json x)) + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Public_data.dead_rules_of_json x)) + method get_dead_agents = let request = `List [ `String "DEAD_AGENTS" ] in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok (Public_data.json_to_dead_agents x)) + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Public_data.json_to_dead_agents x)) + method get_non_weakly_reversible_transitions = - let request = - `List [ `String "NON_WEAKLY_REVERSIBLE_TRANSITIONS" ] - in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok (Public_data.separating_transitions_of_json x)) + let request = `List [ `String "NON_WEAKLY_REVERSIBLE_TRANSITIONS" ] in + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Public_data.separating_transitions_of_json x)) + method get_constraints_list = let request = `List [ `String "CONSTRAINTS" ] in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok (Public_data.lemmas_list_of_json x)) + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Public_data.lemmas_list_of_json x)) + method get_potential_polymers accuracy_cm accuracy_scc = - let request = `List ( `String "POLYMERS" :: ( - match accuracy_cm, accuracy_scc with - | None,None -> [] - | Some a,None -> [Public_data.accuracy_to_json a] - | Some a, Some b -> - [ - Public_data.accuracy_to_json a; - Public_data.accuracy_to_json b - ] - | None, Some b -> - [ - Public_data.accuracy_to_json Public_data.Low ; - Public_data.accuracy_to_json b - ] )) + let request = + `List + (`String "POLYMERS" + :: + (match accuracy_cm, accuracy_scc with + | None, None -> [] + | Some a, None -> [ Public_data.accuracy_to_json a ] + | Some a, Some b -> + [ Public_data.accuracy_to_json a; Public_data.accuracy_to_json b ] + | None, Some b -> + [ + Public_data.accuracy_to_json Public_data.Low; + Public_data.accuracy_to_json b; + ])) in - Lwt_result.bind_result - (self#message request) - (fun x -> Result.Ok (Public_data.scc_of_json x)) + Lwt_result.bind_result (self#message request) (fun x -> + Result.Ok (Public_data.scc_of_json x)) end -class new_uniform_client ~is_running ~post (mailbox : mailbox): +class new_uniform_client ~is_running ~post (mailbox : mailbox) : Api.uniform_manager_static_analysis = let raw = new new_client ~is_running ~post mailbox in object method init_static_analyser_raw compil = raw#init_static_analyser_raw compil >|= Api_common.result_kasa + method init_static_analyser compil = raw#init_static_analyser compil >|= Api_common.result_kasa + method get_contact_map accuracy = raw#get_contact_map accuracy >|= Api_common.result_kasa + method get_influence_map_raw accuracy = raw#get_influence_map_raw accuracy >|= Api_common.result_kasa + method get_local_influence_map ?fwd ?bwd ?origin ~total accuracy = - raw#get_local_influence_map ?fwd ?bwd ?origin ~total accuracy >|= - Api_common.result_kasa - method get_initial_node = - raw#get_initial_node >|= Api_common.result_kasa + raw#get_local_influence_map ?fwd ?bwd ?origin ~total accuracy + >|= Api_common.result_kasa + + method get_initial_node = raw#get_initial_node >|= Api_common.result_kasa + method get_next_node json = raw#get_next_node json >|= Api_common.result_kasa + method get_previous_node json = raw#get_previous_node json >|= Api_common.result_kasa + method secret_get_pos_of_rules_and_vars = - raw# get_pos_of_rules_and_vars >|= Api_common.result_kasa + raw#get_pos_of_rules_and_vars >|= Api_common.result_kasa + method get_nodes_of_influence_map accuracy = raw#get_nodes_of_influence_map accuracy >|= Api_common.result_kasa - method get_dead_rules = - raw#get_dead_rules >|= Api_common.result_kasa - method get_dead_agents = - raw#get_dead_agents >|= Api_common.result_kasa + + method get_dead_rules = raw#get_dead_rules >|= Api_common.result_kasa + method get_dead_agents = raw#get_dead_agents >|= Api_common.result_kasa + method get_non_weakly_reversible_transitions = raw#get_non_weakly_reversible_transitions >|= Api_common.result_kasa + method get_constraints_list = raw#get_constraints_list >|= Api_common.result_kasa + method get_potential_polymers accuracy_cm accuracy_scc = - raw#get_potential_polymers accuracy_cm accuracy_scc >|= Api_common.result_kasa + raw#get_potential_polymers accuracy_cm accuracy_scc + >|= Api_common.result_kasa end diff --git a/core/api/kasa_client.mli b/core/api/kasa_client.mli index 7c1971301c..eba8ea029a 100644 --- a/core/api/kasa_client.mli +++ b/core/api/kasa_client.mli @@ -9,13 +9,17 @@ type mailbox val receive : mailbox -> string -> unit - val new_mailbox : unit -> mailbox val is_computing : mailbox -> bool class new_client : - is_running:(unit -> bool) -> post:(string -> unit) -> mailbox -> + is_running:(unit -> bool) -> + post:(string -> unit) -> + mailbox -> Api.manager_static_analysis + class new_uniform_client : - is_running:(unit -> bool) -> post:(string -> unit) -> mailbox -> + is_running:(unit -> bool) -> + post:(string -> unit) -> + mailbox -> Api.uniform_manager_static_analysis diff --git a/core/api/kastor_client.ml b/core/api/kastor_client.ml index ff5c79a007..182490f484 100644 --- a/core/api/kastor_client.ml +++ b/core/api/kastor_client.ml @@ -21,20 +21,30 @@ let add_compression_mode { Api.causal; Api.weak; Api.strong } = function let print_compression_modes f { Api.causal; Api.weak; Api.strong } = let () = if causal then Format.pp_print_string f "CAUSAL" in - let () = if weak then - Format.pp_print_string f (if causal then ", WEAK" else "WEAK") in + let () = + if weak then + Format.pp_print_string f + (if causal then + ", WEAK" + else + "WEAK") + in if strong then - Format.pp_print_string f (if causal || weak then ", STRONG" - else "STRONG") + Format.pp_print_string f + (if causal || weak then + ", STRONG" + else + "STRONG") type state_t = { - running : bool; - progress : Story_json.progress_bar option; - log : string list; - stories : - (Api.compression_modes * - unit Trace.Simulation_info.t list list * - Graph_loggers_sig.graph) Mods.IntMap.t + running: bool; + progress: Story_json.progress_bar option; + log: string list; + stories: + (Api.compression_modes + * unit Trace.Simulation_info.t list list + * Graph_loggers_sig.graph) + Mods.IntMap.t; } type state = state_t ref @@ -46,98 +56,111 @@ type state = state_t ref with Invalid_argument _ -> false) && Mods.IntMap.equal (=) a.stories b.stories*) -let initial_state = { - running = false; - progress = None; - log = []; - stories = Mods.IntMap.empty; -} +let initial_state = + { running = false; progress = None; log = []; stories = Mods.IntMap.empty } let controller s = function - | Story_json.Progress p -> { - running = s.running; progress = Some p; log = s.log; stories = s.stories; - } - | Story_json.Phase (Story_json.Start,m) -> { - running = true; progress = None; log = [m]; stories = Mods.IntMap.empty; + | Story_json.Progress p -> + { running = s.running; progress = Some p; log = s.log; stories = s.stories } + | Story_json.Phase (Story_json.Start, m) -> + { + running = true; + progress = None; + log = [ m ]; + stories = Mods.IntMap.empty; } - | Story_json.Phase (Story_json.Inprogress,m) -> { + | Story_json.Phase (Story_json.Inprogress, m) -> + { running = s.running; progress = s.progress; - log = m::s.log; + log = m :: s.log; stories = s.stories; } - | Story_json.Phase (Story_json.Faillure,m) -> { + | Story_json.Phase (Story_json.Faillure, m) -> + { running = s.running; progress = s.progress; - log = m::s.log; + log = m :: s.log; stories = s.stories; } - | Story_json.Phase (Story_json.Success,m) -> { - running = false; progress = s.progress; log = m::s.log; stories = s.stories; + | Story_json.Phase (Story_json.Success, m) -> + { + running = false; + progress = s.progress; + log = m :: s.log; + stories = s.stories; } | Story_json.Story c -> - match c.Story_json.story with - | Story_json.New e -> { + (match c.Story_json.story with + | Story_json.New e -> + { running = s.running; progress = s.progress; log = s.log; stories = - Mods.IntMap.add - e.Story_json.id - (init_compression_mode c.Story_json.story_mode, - [c.Story_json.log_info], - e.Story_json.graph) + Mods.IntMap.add e.Story_json.id + ( init_compression_mode c.Story_json.story_mode, + [ c.Story_json.log_info ], + e.Story_json.graph ) s.stories; } | Story_json.Same_as i -> - match Mods.IntMap.find_option i s.stories with - | Some (cm,infos,graph) -> - { - running = s.running; - progress = s.progress; - log = s.log; - stories = - Mods.IntMap.add - i - (add_compression_mode cm c.Story_json.story_mode, - c.Story_json.log_info::infos, - graph) - s.stories; - } - | None -> assert false + (match Mods.IntMap.find_option i s.stories with + | Some (cm, infos, graph) -> + { + running = s.running; + progress = s.progress; + log = s.log; + stories = + Mods.IntMap.add i + ( add_compression_mode cm c.Story_json.story_mode, + c.Story_json.log_info :: infos, + graph ) + s.stories; + } + | None -> assert false)) let receive update_state x = update_state (Story_json.message_of_json (Yojson.Basic.from_string x)) let init_state () = let current_state = ref initial_state in - current_state, (fun x -> current_state := (controller (!current_state) x)) + current_state, fun x -> current_state := controller !current_state x class virtual new_client ~post current_state = - object(self) + object (self) method virtual is_running : bool method config_story_computation { Api.causal; Api.weak; Api.strong } = - if self#is_running then - let () = post + if self#is_running then ( + let () = + post (Yojson.Basic.to_string - (`List [ `String "CONFIG"; - `Assoc [ "none", `Bool causal; - "weak", `Bool weak; - "strong", `Bool strong]])) in + (`List + [ + `String "CONFIG"; + `Assoc + [ + "none", `Bool causal; + "weak", `Bool weak; + "strong", `Bool strong; + ]; + ])) + in Lwt.return_ok () - else + ) else Lwt.return_error "KaStor agent is dead" + method raw_launch_story_computation trace_text = - if self#is_running then + if self#is_running then ( let () = current_state := { initial_state with running = true } in - let () = post ("[\"RUN\", "^trace_text^"]") in + let () = post ("[\"RUN\", " ^ trace_text ^ "]") in Lwt.return_ok () - else + ) else Lwt.return_error "KaStor agent is dead" - method story_log = (!current_state).log - method story_is_computing = (!current_state).running - method story_progress = (!current_state).progress - method story_list = (!current_state).stories + method story_log = !current_state.log + method story_is_computing = !current_state.running + method story_progress = !current_state.progress + method story_list = !current_state.stories end diff --git a/core/api/kastor_client.mli b/core/api/kastor_client.mli index 50b47f0202..65064e1da7 100644 --- a/core/api/kastor_client.mli +++ b/core/api/kastor_client.mli @@ -9,10 +9,7 @@ type state val print_compression_modes : Format.formatter -> Api.compression_modes -> unit - val init_state : unit -> state * (unit Story_json.message -> unit) - val receive : (unit Story_json.message -> 'a) -> string -> 'a -class virtual new_client : - post:(string -> unit) -> state -> Api.manager_stories +class virtual new_client : post:(string -> unit) -> state -> Api.manager_stories diff --git a/core/api/manager_simulation.ml b/core/api/manager_simulation.ml index 7dbfadabfe..1cd87edd0d 100644 --- a/core/api/manager_simulation.ml +++ b/core/api/manager_simulation.ml @@ -7,139 +7,126 @@ (******************************************************************************) open Lwt.Infix + (* addd seed to parameter *) let patch_parameter (simulation_parameter : Api_types_t.simulation_parameter) : - (Api_types_t.simulation_parameter*int) = + Api_types_t.simulation_parameter * int = match simulation_parameter.Api_types_t.simulation_seed with | None -> let () = Random.self_init () in let seed = Random.bits () in - ({ simulation_parameter with Api_types_t.simulation_seed = Some seed } , - seed) - | Some seed -> (simulation_parameter,seed) + { simulation_parameter with Api_types_t.simulation_seed = Some seed }, seed + | Some seed -> simulation_parameter, seed let bind_simulation simulation handler = match simulation with - | Some (_,simulation) -> handler simulation + | Some (_, simulation) -> handler simulation | None -> - let m = "No simulation available" in + let m = "No simulation available" in Lwt.return (Api_common.result_error_msg ~result_code:`Not_found m) -let detail_projection - ~simulation - ~(system_process:Kappa_facade.system_process) - ~(projection:(Api_data.simulation_detail_output -> 'a Api.result)) - : 'a Api.result Lwt.t = - bind_simulation - simulation - (fun t -> - (Kappa_facade.outputs - ~system_process:system_process - ~t:t) >>= - (Result_util.fold - ~ok:(fun (simulation_detail : Api_data.simulation_detail_output) -> - Lwt.return (projection simulation_detail): - (Api_data.simulation_detail_output -> 'a Api.result Lwt.t)) - ~error:(fun errors -> - Lwt.return (Api_common.result_messages errors)) - )) - -class virtual manager_file_line - (system_process : Kappa_facade.system_process) = object(self) - - val mutable virtual simulation : - (Api_types_t.simulation_parameter * Kappa_facade.t) option - - method private info_file_line - (detail : Api_data.simulation_detail_output) : - Api_types_t.file_line_catalog Api.result = - let file_lines : string list Mods.StringMap.t = - detail.Api_types_t.simulation_output_file_lines in - let file_line_catalog : string list = - List.map fst (Mods.StringMap.bindings file_lines) in - Result_util.ok file_line_catalog - - method private get_file_line - ~file_line_id - (status : Api_data.simulation_detail_output) : - (string list) Api.result = - let file_line_list = status.Api_types_t.simulation_output_file_lines in - match Mods.StringMap.find_option file_line_id file_line_list with - | None -> - let m : string = Format.sprintf "id %s not found" file_line_id in - Api_common.result_error_msg ~result_code:`Not_found m - | Some lines -> Result_util.ok (List.rev lines) - - method simulation_catalog_file_line : - Api_types_t.file_line_catalog Api.result Lwt.t = - detail_projection ~simulation ~system_process ~projection:self#info_file_line - - method simulation_detail_file_line - (file_line_id : string) : string list Api.result Lwt.t = - detail_projection - ~simulation ~system_process ~projection:(self#get_file_line ~file_line_id) -end - -class virtual manager_flux_map - (system_process : Kappa_facade.system_process) = object(self) - - val mutable virtual simulation : - (Api_types_t.simulation_parameter * Kappa_facade.t) option - - method private info_flux_map - (detail : Api_data.simulation_detail_output) : - Api_types_t.din_catalog Api.result = - let flux_map_catalog = - List.map fst detail.Api_types_t.simulation_output_dins in - Result_util.ok flux_map_catalog - - method private get_flux_map - (flux_map_id : Api_types_t.din_id) - (detail : Api_data.simulation_detail_output) : - Api_types_t.din Api.result = - let flux_maps_list = - detail.Api_types_t.simulation_output_dins in - try Result_util.ok (List.assoc flux_map_id flux_maps_list) - with Not_found -> - let m : string = Format.sprintf "id %s not found" flux_map_id in - Api_common.result_error_msg ~result_code:`Not_found m - - method simulation_catalog_din : - Api_types_t.din_catalog Api.result Lwt.t = - detail_projection ~simulation ~system_process ~projection:self#info_flux_map - - method simulation_detail_din - (flux_map_id : Api_types_t.din_id) : - Api_types_t.din Api.result Lwt.t = - detail_projection - ~simulation ~system_process ~projection:(self#get_flux_map flux_map_id) -end - -class virtual manager_log_message - (system_process : Kappa_facade.system_process) = object(self) - - val mutable virtual simulation : - (Api_types_t.simulation_parameter * Kappa_facade.t) option - - method private log_message - (detail : Api_data.simulation_detail_output) : - Api_types_t.log_message Api.result = - Result_util.ok detail.Api_types_t.simulation_output_log_messages - - method simulation_detail_log_message : - Api_types_t.log_message Api.result Lwt.t = - detail_projection - ~simulation ~system_process ~projection:self#log_message -end - -let select_observables - (plot_limit : Api_types_t.plot_limit) +let detail_projection ~simulation + ~(system_process : Kappa_facade.system_process) + ~(projection : Api_data.simulation_detail_output -> 'a Api.result) : + 'a Api.result Lwt.t = + bind_simulation simulation (fun t -> + Kappa_facade.outputs ~system_process ~t + >>= Result_util.fold + ~ok: + (fun (simulation_detail : Api_data.simulation_detail_output) -> + Lwt.return (projection simulation_detail) + : Api_data.simulation_detail_output -> 'a Api.result Lwt.t) + ~error:(fun errors -> + Lwt.return (Api_common.result_messages errors))) + +class virtual manager_file_line (system_process : Kappa_facade.system_process) = + object (self) + val mutable virtual simulation + : (Api_types_t.simulation_parameter * Kappa_facade.t) option + + method private info_file_line (detail : Api_data.simulation_detail_output) + : Api_types_t.file_line_catalog Api.result = + let file_lines : string list Mods.StringMap.t = + detail.Api_types_t.simulation_output_file_lines + in + let file_line_catalog : string list = + List.map fst (Mods.StringMap.bindings file_lines) + in + Result_util.ok file_line_catalog + + method private get_file_line ~file_line_id + (status : Api_data.simulation_detail_output) : string list Api.result = + let file_line_list = status.Api_types_t.simulation_output_file_lines in + match Mods.StringMap.find_option file_line_id file_line_list with + | None -> + let m : string = Format.sprintf "id %s not found" file_line_id in + Api_common.result_error_msg ~result_code:`Not_found m + | Some lines -> Result_util.ok (List.rev lines) + + method simulation_catalog_file_line + : Api_types_t.file_line_catalog Api.result Lwt.t = + detail_projection ~simulation ~system_process + ~projection:self#info_file_line + + method simulation_detail_file_line (file_line_id : string) + : string list Api.result Lwt.t = + detail_projection ~simulation ~system_process + ~projection:(self#get_file_line ~file_line_id) + end + +class virtual manager_flux_map (system_process : Kappa_facade.system_process) = + object (self) + val mutable virtual simulation + : (Api_types_t.simulation_parameter * Kappa_facade.t) option + + method private info_flux_map (detail : Api_data.simulation_detail_output) + : Api_types_t.din_catalog Api.result = + let flux_map_catalog = + List.map fst detail.Api_types_t.simulation_output_dins + in + Result_util.ok flux_map_catalog + + method private get_flux_map (flux_map_id : Api_types_t.din_id) + (detail : Api_data.simulation_detail_output) + : Api_types_t.din Api.result = + let flux_maps_list = detail.Api_types_t.simulation_output_dins in + try Result_util.ok (List.assoc flux_map_id flux_maps_list) + with Not_found -> + let m : string = Format.sprintf "id %s not found" flux_map_id in + Api_common.result_error_msg ~result_code:`Not_found m + + method simulation_catalog_din : Api_types_t.din_catalog Api.result Lwt.t = + detail_projection ~simulation ~system_process + ~projection:self#info_flux_map + + method simulation_detail_din (flux_map_id : Api_types_t.din_id) + : Api_types_t.din Api.result Lwt.t = + detail_projection ~simulation ~system_process + ~projection:(self#get_flux_map flux_map_id) + end + +class virtual manager_log_message (system_process : Kappa_facade.system_process) + = + object (self) + val mutable virtual simulation + : (Api_types_t.simulation_parameter * Kappa_facade.t) option + + method private log_message (detail : Api_data.simulation_detail_output) + : Api_types_t.log_message Api.result = + Result_util.ok detail.Api_types_t.simulation_output_log_messages + + method simulation_detail_log_message + : Api_types_t.log_message Api.result Lwt.t = + detail_projection ~simulation ~system_process ~projection:self#log_message + end + +let select_observables (plot_limit : Api_types_t.plot_limit) (plot : Api_types_t.plot) : Api_types_t.plot = let plot_time_series = Tools.array_rev_of_list plot.Data.plot_series in let plot_detail_size = Array.length plot_time_series in let plot_limit_offset = plot_limit.Api_types_t.plot_limit_offset in let plot_limit_points = plot_limit.Api_types_t.plot_limit_points in - let start,len = + let start, len = match plot_limit_offset, plot_limit_points with | None, None -> 0, plot_detail_size | Some offset, None -> offset, max 0 (plot_detail_size - offset) @@ -147,297 +134,279 @@ let select_observables | Some offset, Some nb -> offset, min nb (max 0 (plot_detail_size - offset)) in let new_plot_time_series = - (List.rev (Array.to_list (Array.sub plot_time_series start len))) in + List.rev (Array.to_list (Array.sub plot_time_series start len)) + in { plot with Data.plot_series = new_plot_time_series } -class virtual manager_plot - (system_process : Kappa_facade.system_process) = object(self) - - val mutable virtual simulation : - (Api_types_t.simulation_parameter * Kappa_facade.t) option - - method private get_plot - (plot_limit : Api_types_t.plot_parameter) - (detail : Api_data.simulation_detail_output) : - Api_types_t.plot Api.result = - match detail.Api_types_t.simulation_output_plot with - | Some plot -> - Result_util.ok - (select_observables plot_limit plot) - | None -> let m : string = "plot not available" in - Api_common.result_error_msg ~result_code:`Not_found m - - method simulation_detail_plot - (plot_parameter : Api_types_t.plot_parameter) : - Api_types_t.plot Api.result Lwt.t = - detail_projection - ~simulation ~system_process ~projection:(self#get_plot plot_parameter) -end - -class virtual manager_snapshot - (system_process : Kappa_facade.system_process) = object(self) - - val mutable virtual simulation : - (Api_types_t.simulation_parameter * Kappa_facade.t) option - - method private info_snapshot - (detail : Api_data.simulation_detail_output) : - Api_types_t.snapshot_catalog Api.result = - let snapshots = - detail.Api_types_t.simulation_output_snapshots in - let snapshot_catalog = - Mods.StringMap.fold (fun x _ acc -> x::acc) snapshots [] in - Result_util.ok snapshot_catalog - method private get_snapshot - (snapshot_id : Api_types_t.snapshot_id) - (detail : Api_data.simulation_detail_output) - : Api_types_t.snapshot Api.result = - let snapshot_list = - detail.Api_types_t.simulation_output_snapshots in - match Mods.StringMap.find_option snapshot_id snapshot_list with - | Some x -> Result_util.ok x - | None -> - let m : string = Format.sprintf "id %s not found" snapshot_id in - Api_common.result_error_msg ~result_code:`Not_found m - - method simulation_catalog_snapshot : - Api_types_t.snapshot_catalog Api.result Lwt.t = - (detail_projection - ~simulation ~system_process ~projection:self#info_snapshot - : Api_types_t.snapshot_catalog Api.result Lwt.t) - - method simulation_detail_snapshot - (snapshot_id : Api_types_t.snapshot_id): - Api_types_t.snapshot Api.result Lwt.t = - ((detail_projection - ~simulation ~system_process ~projection:(self#get_snapshot snapshot_id)) - : Api_types_t.snapshot Api.result Lwt.t) -end - -class manager_simulation - project - (system_process : Kappa_facade.system_process) : - Api.manager_simulation = object(self) - val mutable simulation = None - - method secret_simulation_load patternSharing text overwrites = - let ast = text in - let harakiri,_ = Lwt.task () in - let _ = - project#set_state - (Lwt.pick [ Kappa_facade.parse - ~patternSharing ast overwrites system_process; - harakiri >>= fun () -> - Lwt.return (Result_util.error - [Api_common.error_msg - "Parse cancelled by modified files"]) - ]) in - Lwt.return (Result_util.ok ()) - - method simulation_delete : unit Api.result Lwt.t = - self#simulation_stop >>= - (fun _ -> - let () = simulation <- None in - Lwt.return (Result_util.ok ())) - - method simulation_start - (simulation_parameter : Api_types_t.simulation_parameter) : - Api_types_t.simulation_artifact Api.result Lwt.t = - let (simulation_parameter,simulation_seed) = - patch_parameter simulation_parameter in - match simulation with - | Some _ -> - Lwt.return - (Api_common.result_error_msg - ~result_code:`Conflict "A simulation already exists") - | None -> - project#get_state () >>= function +class virtual manager_plot (system_process : Kappa_facade.system_process) = + object (self) + val mutable virtual simulation + : (Api_types_t.simulation_parameter * Kappa_facade.t) option + + method private get_plot (plot_limit : Api_types_t.plot_parameter) + (detail : Api_data.simulation_detail_output) + : Api_types_t.plot Api.result = + match detail.Api_types_t.simulation_output_plot with + | Some plot -> Result_util.ok (select_observables plot_limit plot) + | None -> + let m : string = "plot not available" in + Api_common.result_error_msg ~result_code:`Not_found m + + method simulation_detail_plot (plot_parameter : Api_types_t.plot_parameter) + : Api_types_t.plot Api.result Lwt.t = + detail_projection ~simulation ~system_process + ~projection:(self#get_plot plot_parameter) + end + +class virtual manager_snapshot (system_process : Kappa_facade.system_process) = + object (self) + val mutable virtual simulation + : (Api_types_t.simulation_parameter * Kappa_facade.t) option + + method private info_snapshot (detail : Api_data.simulation_detail_output) + : Api_types_t.snapshot_catalog Api.result = + let snapshots = detail.Api_types_t.simulation_output_snapshots in + let snapshot_catalog = + Mods.StringMap.fold (fun x _ acc -> x :: acc) snapshots [] + in + Result_util.ok snapshot_catalog + + method private get_snapshot (snapshot_id : Api_types_t.snapshot_id) + (detail : Api_data.simulation_detail_output) + : Api_types_t.snapshot Api.result = + let snapshot_list = detail.Api_types_t.simulation_output_snapshots in + match Mods.StringMap.find_option snapshot_id snapshot_list with + | Some x -> Result_util.ok x | None -> - Lwt.return (Api_common.result_error_msg - "Cannot start simulation: Parse not done") - | Some parse -> - Result_util.fold - ~ok: - (fun (facade : Kappa_facade.t) -> - (Kappa_facade.start - ~system_process - ~parameter:simulation_parameter - ~t:facade) - >>= - (Result_util.fold - ~ok: - (fun () -> - let () = - simulation <- Some (simulation_parameter,facade) in - Lwt.return - (Result_util.ok { - Api_types_t.simulation_artifact_simulation_seed = simulation_seed ; + let m : string = Format.sprintf "id %s not found" snapshot_id in + Api_common.result_error_msg ~result_code:`Not_found m + + method simulation_catalog_snapshot + : Api_types_t.snapshot_catalog Api.result Lwt.t = + (detail_projection ~simulation ~system_process + ~projection:self#info_snapshot + : Api_types_t.snapshot_catalog Api.result Lwt.t) + + method simulation_detail_snapshot (snapshot_id : Api_types_t.snapshot_id) + : Api_types_t.snapshot Api.result Lwt.t = + (detail_projection ~simulation ~system_process + ~projection:(self#get_snapshot snapshot_id) + : Api_types_t.snapshot Api.result Lwt.t) + end + +class manager_simulation project (system_process : Kappa_facade.system_process) : + Api.manager_simulation = + object (self) + val mutable simulation = None + + method secret_simulation_load patternSharing text overwrites = + let ast = text in + let harakiri, _ = Lwt.task () in + let _ = + project#set_state + (Lwt.pick + [ + Kappa_facade.parse ~patternSharing ast overwrites system_process; + ( harakiri >>= fun () -> + Lwt.return + (Result_util.error + [ + Api_common.error_msg "Parse cancelled by modified files"; + ]) ); + ]) + in + Lwt.return (Result_util.ok ()) + + method simulation_delete : unit Api.result Lwt.t = + self#simulation_stop >>= fun _ -> + let () = simulation <- None in + Lwt.return (Result_util.ok ()) + + method simulation_start + (simulation_parameter : Api_types_t.simulation_parameter) + : Api_types_t.simulation_artifact Api.result Lwt.t = + let simulation_parameter, simulation_seed = + patch_parameter simulation_parameter + in + match simulation with + | Some _ -> + Lwt.return + (Api_common.result_error_msg ~result_code:`Conflict + "A simulation already exists") + | None -> + project#get_state () >>= ( function + | None -> + Lwt.return + (Api_common.result_error_msg + "Cannot start simulation: Parse not done") + | Some parse -> + Result_util.fold + ~ok:(fun (facade : Kappa_facade.t) -> + Kappa_facade.start ~system_process ~parameter:simulation_parameter + ~t:facade + >>= Result_util.fold + ~ok:(fun () -> + let () = + simulation <- Some (simulation_parameter, facade) + in + Lwt.return + (Result_util.ok + { + Api_types_t.simulation_artifact_simulation_seed = + simulation_seed; })) - ~error: - (fun errors -> - Lwt.return (Api_common.result_messages errors))) - ) - ~error: - (fun errors -> - Lwt.return (Api_common.result_messages errors)) - parse - - method simulation_parameter : - Api_types_t.simulation_parameter Api.result Lwt.t = + ~error:(fun errors -> + Lwt.return (Api_common.result_messages errors))) + ~error:(fun errors -> + Lwt.return (Api_common.result_messages errors)) + parse ) + + method simulation_parameter + : Api_types_t.simulation_parameter Api.result Lwt.t = match simulation with - | Some (parameter,_) -> - Lwt.return (Result_util.ok parameter) + | Some (parameter, _) -> Lwt.return (Result_util.ok parameter) | None -> - let m = "No simulation available" in + let m = "No simulation available" in Lwt.return (Api_common.result_error_msg ~result_code:`Not_found m) method simulation_raw_trace : string Api.result Lwt.t = - bind_simulation - simulation - (fun t -> - Lwt.return (Result_util.ok - (Kappa_facade.get_raw_trace t))) + bind_simulation simulation (fun t -> + Lwt.return (Result_util.ok (Kappa_facade.get_raw_trace t))) method simulation_outputs_zip = let add_snapshot file filename name snapshot = if Filename.check_suffix name ".dot" then Fakezip.add_entry - (Format.asprintf "%a@." (Data.print_dot_snapshot ?uuid:None) snapshot) - file (filename^"/"^name) + (Format.asprintf "%a@." + (Data.print_dot_snapshot ?uuid:None) + snapshot) + file + (filename ^ "/" ^ name) else if Filename.check_suffix name ".json" then - Fakezip.add_entry (Data.string_of_snapshot ?len:None snapshot) - file (filename^"/"^name) else + Fakezip.add_entry + (Data.string_of_snapshot ?len:None snapshot) + file + (filename ^ "/" ^ name) + else ( let name' = Tools.chop_suffix_or_extension name ".ka" in Fakezip.add_entry (Format.asprintf "%a@." (Data.print_snapshot ?uuid:None) snapshot) - file (filename^"/"^name') in - let add_din file filename (din_name,flux) = + file + (filename ^ "/" ^ name') + ) + in + let add_din file filename (din_name, flux) = Fakezip.add_entry - (if Filename.check_suffix din_name ".html" - then Format.asprintf "%a@." Data.print_html_din flux - else if Filename.check_suffix din_name ".json" - then Data.string_of_din flux - else Format.asprintf "%a@." (Data.print_dot_din ?uuid:None) flux) - file (filename^"/"^din_name) in + (if Filename.check_suffix din_name ".html" then + Format.asprintf "%a@." Data.print_html_din flux + else if Filename.check_suffix din_name ".json" then + Data.string_of_din flux + else + Format.asprintf "%a@." (Data.print_dot_din ?uuid:None) flux) + file + (filename ^ "/" ^ din_name) + in let projection t = try let filename = "simulation_outputs" in - let file = Fakezip.open_out (filename^".zip") in - let () = Fakezip.add_entry - t.Api_types_t.simulation_output_inputs - file (filename^"/inputs.ka") in - let () = Fakezip.add_entry - t.Api_types_t.simulation_output_log_messages - file (filename^"/log.txt") in + let file = Fakezip.open_out (filename ^ ".zip") in + let () = + Fakezip.add_entry t.Api_types_t.simulation_output_inputs file + (filename ^ "/inputs.ka") + in + let () = + Fakezip.add_entry t.Api_types_t.simulation_output_log_messages file + (filename ^ "/log.txt") + in let () = match t.Api_types_t.simulation_output_plot with | None -> () | Some plot -> Fakezip.add_entry (Data.export_plot ~is_tsv:false plot) - file (filename^"/data.csv") in + file (filename ^ "/data.csv") + in let () = Mods.StringMap.iter (fun name content -> - Fakezip.add_entry (String.concat "\n" (List.rev content)) - file (filename^"/"^name)) - t.Api_types_t.simulation_output_file_lines in + Fakezip.add_entry + (String.concat "\n" (List.rev content)) + file + (filename ^ "/" ^ name)) + t.Api_types_t.simulation_output_file_lines + in let () = - List.iter - (add_din file filename) - t.Api_types_t.simulation_output_dins in + List.iter (add_din file filename) + t.Api_types_t.simulation_output_dins + in let () = Mods.StringMap.iter (add_snapshot file filename) - t.Api_types_t.simulation_output_snapshots in + t.Api_types_t.simulation_output_snapshots + in let out = Fakezip.close_out file in Result_util.ok out - with Fakezip.Error (_,f,e) -> - Api_common.result_error_msg ("Zip error in "^f^": "^e) in + with Fakezip.Error (_, f, e) -> + Api_common.result_error_msg ("Zip error in " ^ f ^ ": " ^ e) + in detail_projection ~simulation ~system_process ~projection method simulation_pause : unit Api.result Lwt.t = - bind_simulation - simulation - (fun t -> - (Kappa_facade.pause ~system_process ~t) >>= - (fun _ -> - Lwt.return (Result_util.ok ()))) + bind_simulation simulation (fun t -> + Kappa_facade.pause ~system_process ~t >>= fun _ -> + Lwt.return (Result_util.ok ())) method private simulation_stop : unit Api.result Lwt.t = - bind_simulation - simulation - (fun t -> - (Kappa_facade.stop ~system_process ~t) >>= - (Result_util.fold - ~ok:((fun () -> - Lwt.return (Result_util.ok ()))) - ~error:((fun errors -> - Lwt.return (Api_common.result_messages errors))) - ) - ) + bind_simulation simulation (fun t -> + Kappa_facade.stop ~system_process ~t + >>= Result_util.fold + ~ok:(fun () -> Lwt.return (Result_util.ok ())) + ~error:(fun errors -> + Lwt.return (Api_common.result_messages errors))) method simulation_intervention - (simulation_perturbation : Api_types_t.simulation_intervention) : - string Api.result Lwt.t = - bind_simulation - simulation - (fun t -> - (Kappa_facade.perturbation - ~system_process:system_process - ~t:t - ~perturbation:simulation_perturbation) >>= - (Result_util.fold - ~ok:((fun s -> Lwt.return (Result_util.ok s))) + (simulation_perturbation : Api_types_t.simulation_intervention) + : string Api.result Lwt.t = + bind_simulation simulation (fun t -> + Kappa_facade.perturbation ~system_process ~t + ~perturbation:simulation_perturbation + >>= Result_util.fold + ~ok:(fun s -> Lwt.return (Result_util.ok s)) ~error:(fun errors -> - Lwt.return (Api_common.result_messages errors)) - ) - ) + Lwt.return (Api_common.result_messages errors))) - method simulation_continue (pause_condition : string) : - unit Api.result Lwt.t = - bind_simulation - simulation - (fun t -> - (Kappa_facade.continue - ~system_process:system_process - ~t:t ~pause_condition) >>= - (Result_util.fold - ~ok:((fun () -> Lwt.return (Result_util.ok ()))) - ~error:((fun errors -> - Lwt.return (Api_common.result_messages errors))) - ) - ) + method simulation_continue (pause_condition : string) + : unit Api.result Lwt.t = + bind_simulation simulation (fun t -> + Kappa_facade.continue ~system_process ~t ~pause_condition + >>= Result_util.fold + ~ok:(fun () -> Lwt.return (Result_util.ok ())) + ~error:(fun errors -> + Lwt.return (Api_common.result_messages errors))) method simulation_info : Api_types_t.simulation_info Api.result Lwt.t = - bind_simulation - simulation - (fun t -> - Kappa_facade.progress ~system_process ~t >>= - (Result_util.fold - ~ok:(fun progress -> - Kappa_facade.outputs ~system_process ~t >>= - (Result_util.fold - ~ok:(fun outputs -> - Lwt.return - (Result_util.ok - (Api_data.api_simulation_status progress outputs)) - ) - ~error:(fun errors -> - Lwt.return (Api_common.result_messages errors))) - ) - ~error:(fun errors -> + bind_simulation simulation (fun t -> + Kappa_facade.progress ~system_process ~t + >>= Result_util.fold + ~ok:(fun progress -> + Kappa_facade.outputs ~system_process ~t + >>= Result_util.fold + ~ok:(fun outputs -> + Lwt.return + (Result_util.ok + (Api_data.api_simulation_status progress outputs))) + ~error:(fun errors -> + Lwt.return (Api_common.result_messages errors))) + ~error:(fun errors -> Lwt.return (Api_common.result_messages errors))) - ) method simulation_efficiency = - bind_simulation simulation - (fun t -> - Lwt.return (Result_util.ok (Kappa_facade.efficiency t))) - - inherit manager_file_line system_process - inherit manager_flux_map system_process - inherit manager_log_message system_process - inherit manager_plot system_process - inherit manager_snapshot system_process + bind_simulation simulation (fun t -> + Lwt.return (Result_util.ok (Kappa_facade.efficiency t))) + + inherit manager_file_line system_process + inherit manager_flux_map system_process + inherit manager_log_message system_process + inherit manager_plot system_process + inherit manager_snapshot system_process end diff --git a/core/api/manager_simulation.mli b/core/api/manager_simulation.mli index a006fc51cb..326f7d7eed 100644 --- a/core/api/manager_simulation.mli +++ b/core/api/manager_simulation.mli @@ -1,4 +1,4 @@ class manager_simulation : - Api_environment.project -> - Kappa_facade.system_process -> + Api_environment.project -> + Kappa_facade.system_process -> Api.manager_simulation diff --git a/core/api/mpi_api.ml b/core/api/mpi_api.ml index 2a577f3824..06d13d6eef 100644 --- a/core/api/mpi_api.ml +++ b/core/api/mpi_api.ml @@ -10,390 +10,327 @@ open Lwt.Infix exception BadResponse of Mpi_message_j.response_content -let on_message - (manager: Api.manager_simulation) - (post_message : (string -> unit Lwt.t)) - (text_message : string) : unit Lwt.t = +let on_message (manager : Api.manager_simulation) + (post_message : string -> unit Lwt.t) (text_message : string) : unit Lwt.t = let message : Mpi_message_j.request Mpi_message_j.message = - Mpi_message_j.message_of_string - Mpi_message_j.read_request text_message + Mpi_message_j.message_of_string Mpi_message_j.read_request text_message in let handler : - 'a. ('a -> Mpi_message_j.response_content)-> 'a Api.result -> unit Lwt.t = - (fun pack result -> - let message : Mpi_message_j.response Mpi_message_j.message = - { Mpi_message_j.id = message.Mpi_message_j.id ; - Mpi_message_j.data = - Result_util.map pack result } in - let text : string = - Mpi_message_j.string_of_message - Mpi_message_j.write_response message - in - post_message text) + 'a. + ('a -> Mpi_message_j.response_content) -> 'a Api.result -> unit Lwt.t = + fun pack result -> + let message : Mpi_message_j.response Mpi_message_j.message = + { + Mpi_message_j.id = message.Mpi_message_j.id; + Mpi_message_j.data = Result_util.map pack result; + } + in + let text : string = + Mpi_message_j.string_of_message Mpi_message_j.write_response message + in + post_message text in match message.Mpi_message_j.data with - | `ProjectLoad Api_types_t.{pattern_sharing; ast; variable_overwritten} -> - manager#secret_simulation_load pattern_sharing ast variable_overwritten >>= - (handler (fun () -> `ProjectLoad)) + | `ProjectLoad Api_types_t.{ pattern_sharing; ast; variable_overwritten } -> + manager#secret_simulation_load pattern_sharing ast variable_overwritten + >>= handler (fun () -> `ProjectLoad) | `SimulationContinue simulation_parameter -> - (manager#simulation_continue simulation_parameter) >>= - (handler (fun () -> `SimulationContinue)) + manager#simulation_continue simulation_parameter + >>= handler (fun () -> `SimulationContinue) | `SimulationDelete -> - manager#simulation_delete >>= - (handler (fun () -> `SimulationDelete)) + manager#simulation_delete >>= handler (fun () -> `SimulationDelete) | `SimulationDetailFileLine file_line_id -> - (manager#simulation_detail_file_line file_line_id) >>= - (handler (fun result -> `SimulationDetailFileLine result)) + manager#simulation_detail_file_line file_line_id + >>= handler (fun result -> `SimulationDetailFileLine result) | `SimulationDetailDIN din_id -> - (manager#simulation_detail_din din_id) >>= - (handler (fun result -> `SimulationDetailDIN result)) + manager#simulation_detail_din din_id + >>= handler (fun result -> `SimulationDetailDIN result) | `SimulationDetailLogMessage -> - manager#simulation_detail_log_message >>= - (handler (fun result -> `SimulationDetailLogMessage result)) + manager#simulation_detail_log_message + >>= handler (fun result -> `SimulationDetailLogMessage result) | `SimulationDetailPlot plot_parameter -> - (manager#simulation_detail_plot plot_parameter) >>= - (handler (fun result -> `SimulationDetailPlot result)) + manager#simulation_detail_plot plot_parameter + >>= handler (fun result -> `SimulationDetailPlot result) | `SimulationDetailSnapshot snapshot_id -> - (manager#simulation_detail_snapshot snapshot_id) >>= - (handler (fun result -> `SimulationDetailSnapshot result)) + manager#simulation_detail_snapshot snapshot_id + >>= handler (fun result -> `SimulationDetailSnapshot result) | `SimulationInfo -> - manager#simulation_info >>= - (handler (fun result -> `SimulationInfo result)) + manager#simulation_info >>= handler (fun result -> `SimulationInfo result) | `SimulationEfficiency -> - manager#simulation_efficiency >>= - (handler (fun result -> `SimulationEfficiency result)) + manager#simulation_efficiency + >>= handler (fun result -> `SimulationEfficiency result) | `SimulationCatalogFileLine -> - manager#simulation_catalog_file_line >>= - (handler (fun result -> `SimulationCatalogFileLine result)) + manager#simulation_catalog_file_line + >>= handler (fun result -> `SimulationCatalogFileLine result) | `SimulationCatalogDIN -> - manager#simulation_catalog_din >>= - (handler (fun result -> `SimulationCatalogDIN result)) + manager#simulation_catalog_din + >>= handler (fun result -> `SimulationCatalogDIN result) | `SimulationCatalogSnapshot -> - manager#simulation_catalog_snapshot >>= - (handler (fun result -> `SimulationCatalogSnapshot result)) + manager#simulation_catalog_snapshot + >>= handler (fun result -> `SimulationCatalogSnapshot result) | `SimulationParameter -> - manager#simulation_parameter >>= - (handler (fun result -> `SimulationParameter result)) + manager#simulation_parameter + >>= handler (fun result -> `SimulationParameter result) | `SimulationTrace -> - manager#simulation_raw_trace >>= - (handler (fun result -> `SimulationTrace result)) + manager#simulation_raw_trace + >>= handler (fun result -> `SimulationTrace result) | `SimulationOutputsZip -> - manager#simulation_outputs_zip >>= - (handler (fun result -> `SimulationOutputsZip (Base64.encode result))) + manager#simulation_outputs_zip + >>= handler (fun result -> `SimulationOutputsZip (Base64.encode result)) | `SimulationPause -> - manager#simulation_pause >>= - (handler (fun () -> `SimulationPause)) + manager#simulation_pause >>= handler (fun () -> `SimulationPause) | `SimulationIntervention simulation_intervention -> - (manager#simulation_intervention simulation_intervention) >>= - (handler (fun s -> `SimulationIntervention s)) + manager#simulation_intervention simulation_intervention + >>= handler (fun s -> `SimulationIntervention s) | `SimulationStart simulation_parameter -> - (manager#simulation_start simulation_parameter) >>= - (handler (fun result -> `SimulationStart result)) + manager#simulation_start simulation_parameter + >>= handler (fun result -> `SimulationStart result) +class type virtual manager_base_type = object + method private virtual message : + Mpi_message_j.request -> Mpi_message_j.response Lwt.t -class type virtual manager_base_type = - object - method private virtual message : - Mpi_message_j.request -> Mpi_message_j.response Lwt.t - - inherit Api.manager_simulation + inherit Api.manager_simulation end -class virtual manager_base () : manager_base_type = - object(self) - - method private virtual message : - Mpi_message_j.request -> Mpi_message_j.response Lwt.t +class virtual manager_base () : manager_base_type = + object (self) + method private virtual message + : Mpi_message_j.request -> Mpi_message_j.response Lwt.t - method secret_simulation_load - pattern_sharing ast variable_overwritten : unit Api.result Lwt.t = + method secret_simulation_load pattern_sharing ast variable_overwritten + : unit Api.result Lwt.t = self#message (`ProjectLoad - Api_types_t.{pattern_sharing; ast; variable_overwritten}) >>= - Api_common.result_bind_lwt - ~ok:(function - | `ProjectLoad -> - Lwt.return (Result_util.ok ()) + Api_types_t.{ pattern_sharing; ast; variable_overwritten }) + >>= Api_common.result_bind_lwt ~ok:(function + | `ProjectLoad -> Lwt.return (Result_util.ok ()) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_continue (pause_condition : string) : - unit Api.result Lwt.t = - self#message (`SimulationContinue pause_condition) >>= - Api_common.result_bind_lwt - ~ok:(function - | `SimulationContinue -> - Lwt.return (Result_util.ok ()) + (Api_common.result_error_exception (BadResponse response))) + + method simulation_continue (pause_condition : string) + : unit Api.result Lwt.t = + self#message (`SimulationContinue pause_condition) + >>= Api_common.result_bind_lwt ~ok:(function + | `SimulationContinue -> Lwt.return (Result_util.ok ()) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - + (Api_common.result_error_exception (BadResponse response))) method simulation_delete : unit Api.result Lwt.t = - self#message `SimulationDelete >>= - Api_common.result_bind_lwt - ~ok:(function - | `SimulationDelete -> - Lwt.return (Result_util.ok ()) + self#message `SimulationDelete + >>= Api_common.result_bind_lwt ~ok:(function + | `SimulationDelete -> Lwt.return (Result_util.ok ()) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_detail_file_line - (file_line_id : string) : - string list Api.result Lwt.t = - self#message (`SimulationDetailFileLine file_line_id) >>= - Api_common.result_bind_lwt - ~ok:(function + (Api_common.result_error_exception (BadResponse response))) + + method simulation_detail_file_line (file_line_id : string) + : string list Api.result Lwt.t = + self#message (`SimulationDetailFileLine file_line_id) + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationDetailFileLine file_line_list -> Lwt.return (Result_util.ok file_line_list) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - + (Api_common.result_error_exception (BadResponse response))) - method simulation_detail_din - (flux_map_id : Api_types_t.din_id) : - Api_types_t.din Api.result Lwt.t = - self#message (`SimulationDetailDIN flux_map_id) >>= - Api_common.result_bind_lwt - ~ok:(function + method simulation_detail_din (flux_map_id : Api_types_t.din_id) + : Api_types_t.din Api.result Lwt.t = + self#message (`SimulationDetailDIN flux_map_id) + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationDetailDIN flux_map -> Lwt.return (Result_util.ok flux_map) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_detail_log_message : - Api_types_j.log_message Api.result Lwt.t = - self#message `SimulationDetailLogMessage >>= - Api_common.result_bind_lwt - ~ok:(function + (Api_common.result_error_exception (BadResponse response))) + + method simulation_detail_log_message + : Api_types_j.log_message Api.result Lwt.t = + self#message `SimulationDetailLogMessage + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationDetailLogMessage log_message -> Lwt.return (Result_util.ok log_message) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_detail_plot - (plot_parameter : Api_types_j.plot_parameter): - Api_types_j.plot Api.result Lwt.t = - self#message (`SimulationDetailPlot plot_parameter) >>= - Api_common.result_bind_lwt - ~ok:(function - | `SimulationDetailPlot plot -> - Lwt.return (Result_util.ok plot) + (Api_common.result_error_exception (BadResponse response))) + + method simulation_detail_plot (plot_parameter : Api_types_j.plot_parameter) + : Api_types_j.plot Api.result Lwt.t = + self#message (`SimulationDetailPlot plot_parameter) + >>= Api_common.result_bind_lwt ~ok:(function + | `SimulationDetailPlot plot -> Lwt.return (Result_util.ok plot) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_detail_snapshot - (snapshot_id : Api_types_j.snapshot_id) : - Api_types_j.snapshot Api.result Lwt.t = - self#message (`SimulationDetailSnapshot snapshot_id) >>= - Api_common.result_bind_lwt - ~ok:(function + (Api_common.result_error_exception (BadResponse response))) + + method simulation_detail_snapshot (snapshot_id : Api_types_j.snapshot_id) + : Api_types_j.snapshot Api.result Lwt.t = + self#message (`SimulationDetailSnapshot snapshot_id) + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationDetailSnapshot snapshot -> Lwt.return (Result_util.ok snapshot) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_info : - Api_types_j.simulation_info Api.result Lwt.t = - self#message `SimulationInfo >>= - Api_common.result_bind_lwt - ~ok:(function + (Api_common.result_error_exception (BadResponse response))) + + method simulation_info : Api_types_j.simulation_info Api.result Lwt.t = + self#message `SimulationInfo + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationInfo simulation_status -> Lwt.return (Result_util.ok simulation_status) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) + (Api_common.result_error_exception (BadResponse response))) method simulation_efficiency : Counter.Efficiency.t Api.result Lwt.t = - self#message `SimulationEfficiency >>= - Api_common.result_bind_lwt - ~ok:(function + self#message `SimulationEfficiency + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationEfficiency efficiency -> Lwt.return (Result_util.ok efficiency) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_catalog_file_line : - Api_types_j.file_line_catalog Api.result Lwt.t = - self#message `SimulationCatalogFileLine >>= - Api_common.result_bind_lwt - ~ok:(function + (Api_common.result_error_exception (BadResponse response))) + + method simulation_catalog_file_line + : Api_types_j.file_line_catalog Api.result Lwt.t = + self#message `SimulationCatalogFileLine + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationCatalogFileLine info -> Lwt.return (Result_util.ok info) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_catalog_din : - Api_types_j.din_catalog Api.result Lwt.t = - self#message `SimulationCatalogDIN >>= - Api_common.result_bind_lwt - ~ok:(function - | `SimulationCatalogDIN info -> - Lwt.return (Result_util.ok info) + (Api_common.result_error_exception (BadResponse response))) + + method simulation_catalog_din : Api_types_j.din_catalog Api.result Lwt.t = + self#message `SimulationCatalogDIN + >>= Api_common.result_bind_lwt ~ok:(function + | `SimulationCatalogDIN info -> Lwt.return (Result_util.ok info) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_catalog_snapshot : - Api_types_j.snapshot_catalog Api.result Lwt.t = - self#message `SimulationCatalogSnapshot >>= - Api_common.result_bind_lwt - ~ok:(function + (Api_common.result_error_exception (BadResponse response))) + + method simulation_catalog_snapshot + : Api_types_j.snapshot_catalog Api.result Lwt.t = + self#message `SimulationCatalogSnapshot + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationCatalogSnapshot info -> Lwt.return (Result_util.ok info) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) + (Api_common.result_error_exception (BadResponse response))) method simulation_pause : unit Api.result Lwt.t = - self#message `SimulationPause >>= - Api_common.result_bind_lwt - ~ok:(function - | `SimulationPause -> - Lwt.return (Result_util.ok ()) + self#message `SimulationPause + >>= Api_common.result_bind_lwt ~ok:(function + | `SimulationPause -> Lwt.return (Result_util.ok ()) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) + (Api_common.result_error_exception (BadResponse response))) method simulation_raw_trace : string Api.result Lwt.t = - self#message `SimulationTrace >>= - Api_common.result_bind_lwt - ~ok:(function - | `SimulationTrace result -> - Lwt.return (Result_util.ok result) + self#message `SimulationTrace + >>= Api_common.result_bind_lwt ~ok:(function + | `SimulationTrace result -> Lwt.return (Result_util.ok result) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) + (Api_common.result_error_exception (BadResponse response))) method simulation_outputs_zip = - self#message `SimulationOutputsZip >>= - Api_common.result_bind_lwt - ~ok:(function + self#message `SimulationOutputsZip + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationOutputsZip result -> Lwt.return (Result_util.ok (Base64.decode result)) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method simulation_parameter : - Api_types_j.simulation_parameter Api.result Lwt.t = - self#message `SimulationParameter >>= - Api_common.result_bind_lwt - ~ok:(function + (Api_common.result_error_exception (BadResponse response))) + + method simulation_parameter + : Api_types_j.simulation_parameter Api.result Lwt.t = + self#message `SimulationParameter + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationParameter result -> Lwt.return (Result_util.ok result) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) + (Api_common.result_error_exception (BadResponse response))) method simulation_intervention - (simulation_intervention : Api_types_j.simulation_intervention) : - string Api.result Lwt.t = - self#message (`SimulationIntervention simulation_intervention) >>= - Api_common.result_bind_lwt - ~ok:(function - | `SimulationIntervention s -> - Lwt.return (Result_util.ok s) + (simulation_intervention : Api_types_j.simulation_intervention) + : string Api.result Lwt.t = + self#message (`SimulationIntervention simulation_intervention) + >>= Api_common.result_bind_lwt ~ok:(function + | `SimulationIntervention s -> Lwt.return (Result_util.ok s) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - + (Api_common.result_error_exception (BadResponse response))) method simulation_start - (simulation_parameter : Api_types_j.simulation_parameter) - : Api_types_j.simulation_artifact Api.result Lwt.t = - self#message (`SimulationStart simulation_parameter) >>= - Api_common.result_bind_lwt - ~ok:(function + (simulation_parameter : Api_types_j.simulation_parameter) + : Api_types_j.simulation_artifact Api.result Lwt.t = + self#message (`SimulationStart simulation_parameter) + >>= Api_common.result_bind_lwt ~ok:(function | `SimulationStart simulation_id -> Lwt.return (Result_util.ok simulation_id) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) + (Api_common.result_error_exception (BadResponse response))) end module IntMap = Mods.IntMap -type context = { mailboxes : Mpi_message_j.response Lwt.u IntMap.t ; - id : int } - -class type virtual manager_mpi_type = - object - method private virtual sleep : float -> unit Lwt.t - method private virtual post_message : string -> unit - method private message : Mpi_message_j.request -> Mpi_message_j.response Lwt.t - method private receive : string -> unit - inherit Api.manager_simulation - method private sim_is_computing : bool +type context = { mailboxes: Mpi_message_j.response Lwt.u IntMap.t; id: int } - method virtual is_running : bool - end +class type virtual manager_mpi_type = object + method private virtual sleep : float -> unit Lwt.t + method private virtual post_message : string -> unit + method private message : Mpi_message_j.request -> Mpi_message_j.response Lwt.t + method private receive : string -> unit + inherit Api.manager_simulation + method private sim_is_computing : bool + method virtual is_running : bool +end class virtual manager () : manager_mpi_type = - object(self) - val mutable context = { mailboxes = IntMap.empty ; id = 0 } - + object (self) + val mutable context = { mailboxes = IntMap.empty; id = 0 } method private virtual sleep : float -> unit Lwt.t method private virtual post_message : string -> unit method virtual is_running : bool method private receive (response_text : string) = let message : Mpi_message_j.response Mpi_message_j.message = - Mpi_message_j.message_of_string - Mpi_message_j.read_response response_text in + Mpi_message_j.message_of_string Mpi_message_j.read_response + response_text + in match IntMap.pop message.Mpi_message_j.id context.mailboxes with | Some value, mailboxes -> let () = context <- { context with mailboxes } in Lwt.wakeup value message.Mpi_message_j.data | None, mailboxes -> context <- { context with mailboxes } - method private message (request : Mpi_message_j.request) : - Mpi_message_j.response Lwt.t = - if self#is_running then - let result,feeder = Lwt.task () in + method private message (request : Mpi_message_j.request) + : Mpi_message_j.response Lwt.t = + if self#is_running then ( + let result, feeder = Lwt.task () in let () = context <- { context with id = context.id + 1 } in let message : Mpi_message_j.request Mpi_message_j.message = - { Mpi_message_j.id = context.id ; - Mpi_message_j.data = request } in + { Mpi_message_j.id = context.id; Mpi_message_j.data = request } + in let message_text : string = - Mpi_message_j.string_of_message - Mpi_message_j.write_request message + Mpi_message_j.string_of_message Mpi_message_j.write_request message in let () = self#post_message message_text in - let () = context <- - { context with - mailboxes = IntMap.add context.id feeder context.mailboxes } in + let () = + context <- + { + context with + mailboxes = IntMap.add context.id feeder context.mailboxes; + } + in result - else - Lwt.return - (Api_common.result_error_msg "Kappa has died") + ) else + Lwt.return (Api_common.result_error_msg "Kappa has died") method private sim_is_computing = not (IntMap.is_empty context.mailboxes) inherit manager_base () diff --git a/core/api/mpi_api.mli b/core/api/mpi_api.mli index 5c2800ee9b..5603a317d1 100644 --- a/core/api/mpi_api.mli +++ b/core/api/mpi_api.mli @@ -11,29 +11,24 @@ exception BadResponse of Mpi_message_j.response_content val on_message : Api.manager_simulation -> (string -> unit Lwt.t) -> string -> unit Lwt.t -class type virtual manager_base_type = - object - method private virtual message : - Mpi_message_j.request -> - Mpi_message_j.response_content Mpi_message_j.result Lwt.t +class type virtual manager_base_type = object + method private virtual message : + Mpi_message_j.request -> + Mpi_message_j.response_content Mpi_message_j.result Lwt.t - inherit Api.manager_simulation + inherit Api.manager_simulation end class virtual manager_base : unit -> manager_base_type -class type virtual manager_mpi_type = - object - method private virtual post_message : string -> unit - method private virtual sleep : float -> unit Lwt.t - method private message : - Mpi_message_j.request -> Mpi_message_j.response Lwt.t - method private receive : string -> unit - - inherit Api.manager_simulation - method private sim_is_computing : bool - - method virtual is_running : bool - end +class type virtual manager_mpi_type = object + method private virtual post_message : string -> unit + method private virtual sleep : float -> unit Lwt.t + method private message : Mpi_message_j.request -> Mpi_message_j.response Lwt.t + method private receive : string -> unit + inherit Api.manager_simulation + method private sim_is_computing : bool + method virtual is_running : bool +end class virtual manager : unit -> manager_mpi_type diff --git a/core/api/switchman_client.ml b/core/api/switchman_client.ml index b562b4ff0a..8e3d69d4d6 100644 --- a/core/api/switchman_client.ml +++ b/core/api/switchman_client.ml @@ -15,23 +15,32 @@ type _ handle = | Info : (string * int) handle (* | Ast : Ast.parsing_compil handle*) | JSON : Yojson.Basic.t handle - | Influence_map : - (Public_data.accuracy_level * int * int option * int option * - (Public_data.rule, Public_data.var) Public_data.influence_node option * - Public_data.influence_map) handle - | Short_influence_node : (int,int) Public_data.influence_node option handle - | Influence_node : - (Public_data.rule, Public_data.var) Public_data.influence_node option handle - | Influence_nodes : - (Public_data.accuracy_level * - (Public_data.rule, Public_data.var) Public_data.influence_node list) handle + | Influence_map + : (Public_data.accuracy_level + * int + * int option + * int option + * (Public_data.rule, Public_data.var) Public_data.influence_node option + * Public_data.influence_map) + handle + | Short_influence_node : (int, int) Public_data.influence_node option handle + | Influence_node + : (Public_data.rule, Public_data.var) Public_data.influence_node option + handle + | Influence_nodes + : (Public_data.accuracy_level + * (Public_data.rule, Public_data.var) Public_data.influence_node list) + handle | Rules_kasa : Public_data.rule list handle | Agents_kasa : Public_data.dead_agents handle - | Transitions_kasa : (Public_data.rule * (string*string) list) list handle - | Constraints_kasa : - (string * Public_data.agent list Public_data.lemma list) list handle - | Polymers_kasa : - (Public_data.accuracy_level * Public_data.accuracy_level * Public_data.scc) handle + | Transitions_kasa : (Public_data.rule * (string * string) list) list handle + | Constraints_kasa + : (string * Public_data.agent list Public_data.lemma list) list handle + | Polymers_kasa + : (Public_data.accuracy_level + * Public_data.accuracy_level + * Public_data.scc) + handle | DIN : Data.din handle | Plot : Data.plot handle | Snapshot : Data.snapshot handle @@ -41,426 +50,498 @@ type _ handle = | Simulation_artifact : Api_types_t.simulation_artifact handle type box = - B : 'a handle * ('a,Result_util.message list) Result_util.t Lwt.u -> box + | B : 'a handle * ('a, Result_util.message list) Result_util.t Lwt.u -> box -type mailbox = - (int, box) Hashtbl.t +type mailbox = (int, box) Hashtbl.t let new_mailbox () = Hashtbl.create 2 let read_result f p lb = JsonUtil.read_next_item - (Result_util.read_t - f (Yojson.Basic.read_list Result_util.read_message)) p lb + (Result_util.read_t f (Yojson.Basic.read_list Result_util.read_message)) + p lb let receive mailbox x = JsonUtil.read_of_string - (JsonUtil.read_variant Yojson.Basic.read_int - (fun p lb id -> - let () = - match Hashtbl.find mailbox id with - | B (Nothing, thread) -> - Lwt.wakeup thread (read_result Yojson.Basic.read_null p lb) - | B (BigString, thread) -> - let out = read_result Yojson.Basic.read_string p lb in - Lwt.wakeup thread (Result_util.map (Base64.decode ?alphabet:None) out) - | B (String, thread) -> - Lwt.wakeup thread (read_result Yojson.Basic.read_string p lb) - | B (Strings, thread) -> - Lwt.wakeup thread - (read_result - (Yojson.Basic.read_list Yojson.Basic.read_string) p lb) - | B (Catalog, thread) -> - Lwt.wakeup thread - (read_result - (Yojson.Basic.read_list Kfiles.read_catalog_item) p lb) - | B (Info, thread) -> - Lwt.wakeup thread - (read_result - (JsonUtil.read_compact_pair - Yojson.Basic.read_string Yojson.Basic.read_int) p lb) - (* | B (Ast, thread) -> - Lwt.wakeup thread - (read_result Ast.read_parsing_compil p lb)*) - | B (JSON, thread) -> - Lwt.wakeup thread (read_result Yojson.Basic.read_json p lb) - | B (Influence_map, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup thread - (Result_util.map Public_data.local_influence_map_of_json json) - | B (Short_influence_node, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup thread - (Result_util.map - (JsonUtil.to_option - Public_data.short_influence_node_of_json) - json) - | B (Influence_node, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup thread - (Result_util.map - (JsonUtil.to_option - Public_data.refined_influence_node_of_json) - json) - | B (Influence_nodes, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup thread - (Result_util.map Public_data.nodes_of_influence_map_of_json json) - | B (Rules_kasa, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup - thread (Result_util.map Public_data.dead_rules_of_json json) - | B (Agents_kasa, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup - thread (Result_util.map Public_data.json_to_dead_agents json) - | B (Transitions_kasa, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup thread - (Result_util.map Public_data.separating_transitions_of_json json) - | B (Constraints_kasa, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup - thread (Result_util.map Public_data.lemmas_list_of_json json) - | B (Polymers_kasa, thread) -> - let json = read_result Yojson.Basic.read_json p lb in - Lwt.wakeup thread (Result_util.map Public_data.scc_of_json json) - | B (DIN, thread) -> - Lwt.wakeup thread (read_result Data.read_din p lb) - | B (Plot, thread) -> - Lwt.wakeup thread (read_result Data.read_plot p lb) - | B (Snapshot, thread) -> - Lwt.wakeup thread (read_result Data.read_snapshot p lb) - | B (Simulation_efficiency, thread) -> - Lwt.wakeup thread (read_result Counter.Efficiency.read_t p lb) - | B (Simulation_info, thread) -> - Lwt.wakeup - thread (read_result Api_types_j.read_simulation_info p lb) - | B (Simulation_parameter, thread) -> - Lwt.wakeup - thread (read_result Api_types_j.read_simulation_parameter p lb) - | B (Simulation_artifact, thread) -> - Lwt.wakeup - thread (read_result Api_types_j.read_simulation_artifact p lb) - in - Hashtbl.remove mailbox id)) + (JsonUtil.read_variant Yojson.Basic.read_int (fun p lb id -> + let () = + match Hashtbl.find mailbox id with + | B (Nothing, thread) -> + Lwt.wakeup thread (read_result Yojson.Basic.read_null p lb) + | B (BigString, thread) -> + let out = read_result Yojson.Basic.read_string p lb in + Lwt.wakeup thread + (Result_util.map (Base64.decode ?alphabet:None) out) + | B (String, thread) -> + Lwt.wakeup thread (read_result Yojson.Basic.read_string p lb) + | B (Strings, thread) -> + Lwt.wakeup thread + (read_result + (Yojson.Basic.read_list Yojson.Basic.read_string) + p lb) + | B (Catalog, thread) -> + Lwt.wakeup thread + (read_result + (Yojson.Basic.read_list Kfiles.read_catalog_item) + p lb) + | B (Info, thread) -> + Lwt.wakeup thread + (read_result + (JsonUtil.read_compact_pair Yojson.Basic.read_string + Yojson.Basic.read_int) + p lb) + (* | B (Ast, thread) -> + Lwt.wakeup thread + (read_result Ast.read_parsing_compil p lb)*) + | B (JSON, thread) -> + Lwt.wakeup thread (read_result Yojson.Basic.read_json p lb) + | B (Influence_map, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map Public_data.local_influence_map_of_json json) + | B (Short_influence_node, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map + (JsonUtil.to_option Public_data.short_influence_node_of_json) + json) + | B (Influence_node, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map + (JsonUtil.to_option Public_data.refined_influence_node_of_json) + json) + | B (Influence_nodes, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map Public_data.nodes_of_influence_map_of_json json) + | B (Rules_kasa, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map Public_data.dead_rules_of_json json) + | B (Agents_kasa, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map Public_data.json_to_dead_agents json) + | B (Transitions_kasa, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map Public_data.separating_transitions_of_json json) + | B (Constraints_kasa, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread + (Result_util.map Public_data.lemmas_list_of_json json) + | B (Polymers_kasa, thread) -> + let json = read_result Yojson.Basic.read_json p lb in + Lwt.wakeup thread (Result_util.map Public_data.scc_of_json json) + | B (DIN, thread) -> + Lwt.wakeup thread (read_result Data.read_din p lb) + | B (Plot, thread) -> + Lwt.wakeup thread (read_result Data.read_plot p lb) + | B (Snapshot, thread) -> + Lwt.wakeup thread (read_result Data.read_snapshot p lb) + | B (Simulation_efficiency, thread) -> + Lwt.wakeup thread (read_result Counter.Efficiency.read_t p lb) + | B (Simulation_info, thread) -> + Lwt.wakeup thread + (read_result Api_types_j.read_simulation_info p lb) + | B (Simulation_parameter, thread) -> + Lwt.wakeup thread + (read_result Api_types_j.read_simulation_parameter p lb) + | B (Simulation_artifact, thread) -> + Lwt.wakeup thread + (read_result Api_types_j.read_simulation_artifact p lb) + in + Hashtbl.remove mailbox id)) x let is_computing mailbox = Hashtbl.length mailbox <> 0 -class virtual new_client ~is_running ~post mailbox = object(self) - val mutable id = 0 - - method private message : - type a. a handle -> (Buffer.t -> unit) -> - (a, Result_util.message list) Result_util.t Lwt.t = - fun handle request -> - if is_running () then - let result,feeder = Lwt.task () in - let message = - JsonUtil.string_of_write - (fun b () -> - JsonUtil.write_sequence b - [(fun b -> Yojson.Basic.write_int b id); request]) () in - let () = post message in - let () = Hashtbl.replace mailbox id (B (handle,feeder)) in - let () = id <- succ id in - result - else - Lwt.return (Result_util.error - [{ Result_util.severity = Logs.Error; - Result_util.range = None; - Result_util.text = "kamoha agent has died"; - }]) - (* KaMoHa *) - method file_delete file_id = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileDelete"); - (fun b -> Yojson.Basic.write_string b file_id); - ]) - method file_update file_id file_content = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileUpdate"); - (fun b -> Yojson.Basic.write_string b file_id); - (fun b -> Yojson.Basic.write_string b file_content); - ]) - method file_move file_position file_id = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileMove"); - (fun b -> Yojson.Basic.write_int b file_position); - (fun b -> Yojson.Basic.write_string b file_id); - ]) - method file_get file_id = - self#message Info - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileGet"); - (fun b -> Yojson.Basic.write_string b file_id); - ]) - method file_create file_position file_id file_content = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileCreate"); - (fun b -> Yojson.Basic.write_int b file_position); - (fun b -> Yojson.Basic.write_string b file_id); - (fun b -> Yojson.Basic.write_string b file_content); - ]) - method file_catalog = - self#message Catalog - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "FileCatalog"); - ]) - method secret_project_parse : Ast.parsing_compil Api.result Lwt.t = - Lwt.return - (Api_common.result_error_msg "low level project_parse mustn't be used") - - method secret_get_pos_of_rules_and_vars - : Public_data.pos_of_rules_and_vars Api.result Lwt.t = - Lwt.return - (Api_common.result_error_msg - "low level get_pos_of_rules_and_vars mustn't be used") - - method project_overwrite file_id ast = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "ProjectOverwrite"); - (fun b -> Yojson.Basic.write_string b file_id); - (fun b -> Ast.write_parsing_compil b ast); - ]) - (* KaSa *) +class virtual new_client ~is_running ~post mailbox = + object (self) + val mutable id = 0 + + method private message : type a. + a handle -> + (Buffer.t -> unit) -> + (a, Result_util.message list) Result_util.t Lwt.t = + fun handle request -> + if is_running () then ( + let result, feeder = Lwt.task () in + let message = + JsonUtil.string_of_write + (fun b () -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_int b id); request ]) + () + in + let () = post message in + let () = Hashtbl.replace mailbox id (B (handle, feeder)) in + let () = id <- succ id in + result + ) else + Lwt.return + (Result_util.error + [ + { + Result_util.severity = Logs.Error; + Result_util.range = None; + Result_util.text = "kamoha agent has died"; + }; + ]) + + (* KaMoHa *) + method file_delete file_id = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileDelete"); + (fun b -> Yojson.Basic.write_string b file_id); + ]) + + method file_update file_id file_content = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileUpdate"); + (fun b -> Yojson.Basic.write_string b file_id); + (fun b -> Yojson.Basic.write_string b file_content); + ]) + + method file_move file_position file_id = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileMove"); + (fun b -> Yojson.Basic.write_int b file_position); + (fun b -> Yojson.Basic.write_string b file_id); + ]) + + method file_get file_id = + self#message Info (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileGet"); + (fun b -> Yojson.Basic.write_string b file_id); + ]) + + method file_create file_position file_id file_content = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "FileCreate"); + (fun b -> Yojson.Basic.write_int b file_position); + (fun b -> Yojson.Basic.write_string b file_id); + (fun b -> Yojson.Basic.write_string b file_content); + ]) + + method file_catalog = + self#message Catalog (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "FileCatalog") ]) + + method secret_project_parse : Ast.parsing_compil Api.result Lwt.t = + Lwt.return + (Api_common.result_error_msg "low level project_parse mustn't be used") + + method secret_get_pos_of_rules_and_vars + : Public_data.pos_of_rules_and_vars Api.result Lwt.t = + Lwt.return + (Api_common.result_error_msg + "low level get_pos_of_rules_and_vars mustn't be used") + + method project_overwrite file_id ast = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "ProjectOverwrite"); + (fun b -> Yojson.Basic.write_string b file_id); + (fun b -> Ast.write_parsing_compil b ast); + ]) + + (* KaSa *) method init_static_analyser_raw compil = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "INIT"); - (fun b -> Yojson.Basic.write_string b compil); - ]) + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "INIT"); + (fun b -> Yojson.Basic.write_string b compil); + ]) + method init_static_analyser compil = self#init_static_analyser_raw (Yojson.Basic.to_string (Ast.compil_to_json compil)) method get_contact_map accuracy = - self#message JSON - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "CONTACT_MAP"); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); - ]) + self#message JSON (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "CONTACT_MAP"); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); + ]) + method get_influence_map_raw accuracy = - self#message String - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP"); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); - ]) + self#message String (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP"); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); + ]) + method get_local_influence_map ?fwd ?bwd ?origin ~total accuracy = - self#message Influence_map - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "LOCAL_INFLUENCE_MAP"); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); - (fun b -> JsonUtil.write_option Yojson.Basic.write_int b fwd); - (fun b -> JsonUtil.write_option Yojson.Basic.write_int b bwd); - (fun b -> Yojson.Basic.write_int b total); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.short_influence_node_to_json origin)); - ]) + self#message Influence_map (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "LOCAL_INFLUENCE_MAP"); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); + (fun b -> JsonUtil.write_option Yojson.Basic.write_int b fwd); + (fun b -> JsonUtil.write_option Yojson.Basic.write_int b bwd); + (fun b -> Yojson.Basic.write_int b total); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.short_influence_node_to_json + origin)); + ]) + method get_initial_node = - self#message Influence_node - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_ORIGINAL_NODE"); - ]) + self#message Influence_node (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> + Yojson.Basic.write_string b "INFLUENCE_MAP_ORIGINAL_NODE"); + ]) + method get_next_node json = - self#message Influence_node - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_NEXT_NODE"); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.short_influence_node_to_json json)); - ]) + self#message Influence_node (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_NEXT_NODE"); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.short_influence_node_to_json + json)); + ]) + method get_previous_node json = - self#message Influence_node - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_PREVIOUS_NODE"); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.short_influence_node_to_json json)); - ]) + self#message Influence_node (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> + Yojson.Basic.write_string b "INFLUENCE_MAP_PREVIOUS_NODE"); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.short_influence_node_to_json + json)); + ]) + method get_influence_map_node_at ~filename pos = - self#message Short_influence_node - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_NODE_AT"); - (fun b -> Yojson.Basic.write_string b filename); - (fun b -> Locality.write_position b pos); - ]) + self#message Short_influence_node (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_NODE_AT"); + (fun b -> Yojson.Basic.write_string b filename); + (fun b -> Loc.write_position b pos); + ]) + method get_nodes_of_influence_map accuracy = - self#message Influence_nodes - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_ALL_NODE"); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); - ]) + self#message Influence_nodes (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "INFLUENCE_MAP_ALL_NODE"); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.accuracy_to_json accuracy)); + ]) + method get_dead_rules = - self#message Rules_kasa - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "DEAD_RULES"); - ]) + self#message Rules_kasa (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "DEAD_RULES") ]) + method get_dead_agents = - self#message Agents_kasa - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "DEAD_AGENTS"); - ]) + self#message Agents_kasa (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "DEAD_AGENTS") ]) + method get_non_weakly_reversible_transitions = - self#message Transitions_kasa - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "NON_WEAKLY_REVERSIBLE_TRANSITIONS"); - ]) + self#message Transitions_kasa (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> + Yojson.Basic.write_string b "NON_WEAKLY_REVERSIBLE_TRANSITIONS"); + ]) + method get_constraints_list = - self#message Constraints_kasa - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "CONSTRAINTS") - ]) + self#message Constraints_kasa (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "CONSTRAINTS") ]) + method get_potential_polymers accuracy_cm accuracy_scc = - self#message Polymers_kasa - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "POLYMERS"); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.accuracy_to_json accuracy_cm)); - (fun b -> - Yojson.Basic.write_json - b (JsonUtil.of_option Public_data.accuracy_to_json accuracy_scc)); - ]) - (* KaSim *) - method secret_simulation_load - (_ : Pattern.sharing_level) (_ : Ast.parsing_compil) (_ : (string * Nbr.t) list) : - unit Api.result Lwt.t = + self#message Polymers_kasa (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "POLYMERS"); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.accuracy_to_json accuracy_cm)); + (fun b -> + Yojson.Basic.write_json b + (JsonUtil.of_option Public_data.accuracy_to_json accuracy_scc)); + ]) + + (* KaSim *) + method secret_simulation_load (_ : Pattern.sharing_level) + (_ : Ast.parsing_compil) (_ : (string * Nbr.t) list) + : unit Api.result Lwt.t = Lwt.return - (Api_common.result_error_msg "low level simulation_load mustn't be used") + (Api_common.result_error_msg "low level simulation_load mustn't be used") method project_parse ~patternSharing overwrites = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "ProjectParse"); - (fun b -> Pattern.write_sharing_level b patternSharing); - (fun b -> + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "ProjectParse"); + (fun b -> Pattern.write_sharing_level b patternSharing); + (fun b -> JsonUtil.write_list - (JsonUtil.write_compact_pair Yojson.Basic.write_string Nbr.write_t) + (JsonUtil.write_compact_pair Yojson.Basic.write_string + Nbr.write_t) b overwrites); - ]) - method simulation_continue pause = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationContinue"); - (fun b -> Yojson.Basic.write_string b pause); - ]) - method simulation_delete = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationDelete"); - ]) - method simulation_detail_din id = - self#message DIN - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationDetailDIN"); - (fun b -> Yojson.Basic.write_string b id); - ]) - method simulation_detail_file_line id = - self#message Strings - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationDetailFileLine"); - (fun b -> Yojson.Basic.write_string b id); - ]) - method simulation_detail_snapshot id = - self#message Snapshot - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationDetailSnapshot"); - (fun b -> Yojson.Basic.write_string b id); - ]) - method simulation_detail_log_message = - self#message String - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationDetailLogMessage"); - ]) - method simulation_detail_plot parameter = - self#message Plot - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationDetailPlot"); - (fun b -> Api_types_j.write_plot_parameter b parameter); - ]) - method simulation_catalog_din = - self#message Strings - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationCatalogDIN"); - ]) - method simulation_catalog_file_line = - self#message Strings - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationCatalogFileLine"); - ]) - method simulation_catalog_snapshot = - self#message Strings - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationCatalogSnapshot"); - ]) - method simulation_efficiency = - self#message Simulation_efficiency - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationEfficiency"); - ]) - method simulation_info = - self#message Simulation_info - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationInfo"); - ]) - method simulation_intervention intervention = - self#message String - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationIntervention"); - (fun b -> Yojson.Basic.write_string b intervention); - ]) - method simulation_outputs_zip = - self#message BigString - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationOutputsZip"); - ]) - method simulation_pause = - self#message Nothing - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationPause"); - ]) - method simulation_parameter = - self#message Simulation_parameter - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationParameter"); - ]) - method simulation_start parameter = - self#message Simulation_artifact - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationStart"); - (fun b -> Api_types_j.write_simulation_parameter b parameter); - ]) - method simulation_raw_trace = - self#message String - (fun b -> JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_string b "SimulationTrace"); - ]) - -(* method project_parse overwrite = () - - method raw_launch_story_computation = () - method config_story_computation modes = Lwt_result.return () - method story_is_computing = false - method story_list = () - method story_log = () - method story_progress = () - - method is_computing = true - method terminate = ()*) -end + ]) + + method simulation_continue pause = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationContinue"); + (fun b -> Yojson.Basic.write_string b pause); + ]) + + method simulation_delete = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationDelete") ]) + + method simulation_detail_din id = + self#message DIN (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationDetailDIN"); + (fun b -> Yojson.Basic.write_string b id); + ]) + + method simulation_detail_file_line id = + self#message Strings (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationDetailFileLine"); + (fun b -> Yojson.Basic.write_string b id); + ]) + + method simulation_detail_snapshot id = + self#message Snapshot (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationDetailSnapshot"); + (fun b -> Yojson.Basic.write_string b id); + ]) + + method simulation_detail_log_message = + self#message String (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> + Yojson.Basic.write_string b "SimulationDetailLogMessage"); + ]) + + method simulation_detail_plot parameter = + self#message Plot (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationDetailPlot"); + (fun b -> Api_types_j.write_plot_parameter b parameter); + ]) + + method simulation_catalog_din = + self#message Strings (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationCatalogDIN") ]) + + method simulation_catalog_file_line = + self#message Strings (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationCatalogFileLine"); + ]) + + method simulation_catalog_snapshot = + self#message Strings (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationCatalogSnapshot"); + ]) + + method simulation_efficiency = + self#message Simulation_efficiency (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationEfficiency") ]) + + method simulation_info = + self#message Simulation_info (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationInfo") ]) + + method simulation_intervention intervention = + self#message String (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationIntervention"); + (fun b -> Yojson.Basic.write_string b intervention); + ]) + + method simulation_outputs_zip = + self#message BigString (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationOutputsZip") ]) + + method simulation_pause = + self#message Nothing (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationPause") ]) + + method simulation_parameter = + self#message Simulation_parameter (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationParameter") ]) + + method simulation_start parameter = + self#message Simulation_artifact (fun b -> + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_string b "SimulationStart"); + (fun b -> Api_types_j.write_simulation_parameter b parameter); + ]) + + method simulation_raw_trace = + self#message String (fun b -> + JsonUtil.write_sequence b + [ (fun b -> Yojson.Basic.write_string b "SimulationTrace") ]) + + (* method project_parse overwrite = () + + method raw_launch_story_computation = () + method config_story_computation modes = Lwt_result.return () + method story_is_computing = false + method story_list = () + method story_log = () + method story_progress = () + + method is_computing = true + method terminate = ()*) + end diff --git a/core/api/switchman_client.mli b/core/api/switchman_client.mli index 7eb416aa2a..91811af74d 100644 --- a/core/api/switchman_client.mli +++ b/core/api/switchman_client.mli @@ -1,228 +1,345 @@ type box type 'a handle + class virtual new_client : is_running:(unit -> bool) -> post:(string -> unit) -> (int, box) Hashtbl.t -> - object - val mutable id : int - method file_catalog : - (Kappa_grammar.Kfiles.catalog_item list, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method file_create : - int -> - string -> - string -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method file_delete : - string -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method file_get : - string -> - (string * int, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method file_move : - int -> - string -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method file_update : - string -> - string -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_constraints_list : - ((string * - Kappa_kasa_type_interface.Public_data.agent list - Kappa_kasa_type_interface.Public_data.lemma list) - list, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_contact_map : - Kappa_kasa_type_interface.Public_data.accuracy_level option -> - (Yojson.Basic.t, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_dead_agents : - (Kappa_kasa_type_interface.Public_data.dead_agents, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_dead_rules : - (Kappa_kasa_type_interface.Public_data.rule list, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_influence_map_node_at : - filename:string -> - Kappa_generic_toolset.Locality.position -> - ((int, int) Kappa_kasa_type_interface.Public_data.influence_node option, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_influence_map_raw : - Kappa_kasa_type_interface.Public_data.accuracy_level option -> - (string, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_initial_node : - ((Kappa_kasa_type_interface.Public_data.rule, - Kappa_kasa_type_interface.Public_data.var) - Kappa_kasa_type_interface.Public_data.influence_node option, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_local_influence_map : - ?fwd:int -> - ?bwd:int -> - ?origin:(int, int) Kappa_kasa_type_interface.Public_data.influence_node -> - total:int -> - Kappa_kasa_type_interface.Public_data.accuracy_level option -> - (Kappa_kasa_type_interface.Public_data.accuracy_level * int * - int option * int option * - (Kappa_kasa_type_interface.Public_data.rule, - Kappa_kasa_type_interface.Public_data.var) - Kappa_kasa_type_interface.Public_data.influence_node option * - Kappa_kasa_type_interface.Public_data.influence_map, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_next_node : - (int, int) Kappa_kasa_type_interface.Public_data.influence_node option -> - ((Kappa_kasa_type_interface.Public_data.rule, - Kappa_kasa_type_interface.Public_data.var) - Kappa_kasa_type_interface.Public_data.influence_node option, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_nodes_of_influence_map : - Kappa_kasa_type_interface.Public_data.accuracy_level option -> - (Kappa_kasa_type_interface.Public_data.accuracy_level * - (Kappa_kasa_type_interface.Public_data.rule, - Kappa_kasa_type_interface.Public_data.var) - Kappa_kasa_type_interface.Public_data.influence_node list, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_non_weakly_reversible_transitions : - ((Kappa_kasa_type_interface.Public_data.rule * (string * string) list) - list, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_potential_polymers : - Kappa_kasa_type_interface.Public_data.accuracy_level option -> - Kappa_kasa_type_interface.Public_data.accuracy_level option -> - (Kappa_kasa_type_interface.Public_data.accuracy_level * - Kappa_kasa_type_interface.Public_data.accuracy_level * - Kappa_kasa_type_interface.Public_data.scc, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method get_previous_node : - (int, int) Kappa_kasa_type_interface.Public_data.influence_node option -> - ((Kappa_kasa_type_interface.Public_data.rule, - Kappa_kasa_type_interface.Public_data.var) - Kappa_kasa_type_interface.Public_data.influence_node option, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method init_static_analyser : - Kappa_grammar.Ast.parsing_compil -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method init_static_analyser_raw : - string -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method private message : - 'a. - 'a handle -> - (Buffer.t -> unit) -> - ('a, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method project_overwrite : - string -> - Kappa_grammar.Ast.parsing_compil -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method project_parse : - patternSharing:Kappa_terms.Pattern.sharing_level -> - (string * Kappa_generic_toolset.Nbr.t) list -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method secret_get_pos_of_rules_and_vars : - Public_data.pos_of_rules_and_vars Api.result Lwt.t - method secret_project_parse : - Ast.parsing_compil Api.result Lwt.t - method secret_simulation_load : - Kappa_terms.Pattern.sharing_level -> - Kappa_grammar.Ast.parsing_compil -> - (string * Kappa_generic_toolset.Nbr.t) list -> - unit Api.result Lwt.t - method simulation_catalog_din : - (string list, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_catalog_file_line : - (string list, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_catalog_snapshot : - (string list, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_continue : - string -> - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_delete : - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_detail_din : - string -> - (Kappa_runtime.Data.din, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_detail_file_line : - string -> - (string list, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_detail_log_message : - (string, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_detail_plot : - Api_types_j.plot_parameter -> - (Kappa_runtime.Data.plot, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_detail_snapshot : - string -> - (Kappa_runtime.Data.snapshot, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_efficiency : - (Kappa_runtime.Counter.Efficiency.t, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_info : - (Api_types_t.simulation_info, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_intervention : - string -> - (string, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_outputs_zip : - (Kappa_generic_toolset.Bigbuffer.bigstring, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_parameter : - (Api_types_t.simulation_parameter, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_pause : - (unit, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_raw_trace : - (string, Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - method simulation_start : - Api_types_j.simulation_parameter -> - (Api_types_t.simulation_artifact, - Kappa_generic_toolset.Result_util.message list) - Kappa_generic_toolset.Result_util.t Lwt.t - end - -type mailbox = - (int, box) Hashtbl.t - -val new_mailbox: unit -> mailbox -val receive: mailbox -> string -> unit -val is_computing: mailbox -> bool +object + val mutable id : int + + method file_catalog : + ( Kappa_grammar.Kfiles.catalog_item list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method file_create : + int -> + string -> + string -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method file_delete : + string -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method file_get : + string -> + ( string * int, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method file_move : + int -> + string -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method file_update : + string -> + string -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_constraints_list : + ( (string + * Kappa_kasa_type_interface.Public_data.agent list + Kappa_kasa_type_interface.Public_data.lemma + list) + list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_contact_map : + Kappa_kasa_type_interface.Public_data.accuracy_level option -> + ( Yojson.Basic.t, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_dead_agents : + ( Kappa_kasa_type_interface.Public_data.dead_agents, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_dead_rules : + ( Kappa_kasa_type_interface.Public_data.rule list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_influence_map_node_at : + filename:string -> + Kappa_generic_toolset.Loc.position -> + ( (int, int) Kappa_kasa_type_interface.Public_data.influence_node option, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_influence_map_raw : + Kappa_kasa_type_interface.Public_data.accuracy_level option -> + ( string, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_initial_node : + ( ( Kappa_kasa_type_interface.Public_data.rule, + Kappa_kasa_type_interface.Public_data.var ) + Kappa_kasa_type_interface.Public_data.influence_node + option, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_local_influence_map : + ?fwd:int -> + ?bwd:int -> + ?origin:(int, int) Kappa_kasa_type_interface.Public_data.influence_node -> + total:int -> + Kappa_kasa_type_interface.Public_data.accuracy_level option -> + ( Kappa_kasa_type_interface.Public_data.accuracy_level + * int + * int option + * int option + * ( Kappa_kasa_type_interface.Public_data.rule, + Kappa_kasa_type_interface.Public_data.var ) + Kappa_kasa_type_interface.Public_data.influence_node + option + * Kappa_kasa_type_interface.Public_data.influence_map, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_next_node : + (int, int) Kappa_kasa_type_interface.Public_data.influence_node option -> + ( ( Kappa_kasa_type_interface.Public_data.rule, + Kappa_kasa_type_interface.Public_data.var ) + Kappa_kasa_type_interface.Public_data.influence_node + option, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_nodes_of_influence_map : + Kappa_kasa_type_interface.Public_data.accuracy_level option -> + ( Kappa_kasa_type_interface.Public_data.accuracy_level + * ( Kappa_kasa_type_interface.Public_data.rule, + Kappa_kasa_type_interface.Public_data.var ) + Kappa_kasa_type_interface.Public_data.influence_node + list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_non_weakly_reversible_transitions : + ( (Kappa_kasa_type_interface.Public_data.rule * (string * string) list) list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_potential_polymers : + Kappa_kasa_type_interface.Public_data.accuracy_level option -> + Kappa_kasa_type_interface.Public_data.accuracy_level option -> + ( Kappa_kasa_type_interface.Public_data.accuracy_level + * Kappa_kasa_type_interface.Public_data.accuracy_level + * Kappa_kasa_type_interface.Public_data.scc, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method get_previous_node : + (int, int) Kappa_kasa_type_interface.Public_data.influence_node option -> + ( ( Kappa_kasa_type_interface.Public_data.rule, + Kappa_kasa_type_interface.Public_data.var ) + Kappa_kasa_type_interface.Public_data.influence_node + option, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method init_static_analyser : + Kappa_grammar.Ast.parsing_compil -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method init_static_analyser_raw : + string -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method private message : + 'a. + 'a handle -> + (Buffer.t -> unit) -> + ( 'a, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method project_overwrite : + string -> + Kappa_grammar.Ast.parsing_compil -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method project_parse : + patternSharing:Kappa_terms.Pattern.sharing_level -> + (string * Kappa_generic_toolset.Nbr.t) list -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method secret_get_pos_of_rules_and_vars : + Public_data.pos_of_rules_and_vars Api.result Lwt.t + + method secret_project_parse : Ast.parsing_compil Api.result Lwt.t + + method secret_simulation_load : + Kappa_terms.Pattern.sharing_level -> + Kappa_grammar.Ast.parsing_compil -> + (string * Kappa_generic_toolset.Nbr.t) list -> + unit Api.result Lwt.t + + method simulation_catalog_din : + ( string list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_catalog_file_line : + ( string list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_catalog_snapshot : + ( string list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_continue : + string -> + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_delete : + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_detail_din : + string -> + ( Kappa_runtime.Data.din, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_detail_file_line : + string -> + ( string list, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_detail_log_message : + ( string, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_detail_plot : + Api_types_j.plot_parameter -> + ( Kappa_runtime.Data.plot, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_detail_snapshot : + string -> + ( Kappa_runtime.Data.snapshot, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_efficiency : + ( Kappa_runtime.Counter.Efficiency.t, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_info : + ( Api_types_t.simulation_info, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_intervention : + string -> + ( string, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_outputs_zip : + ( Kappa_generic_toolset.Bigbuffer.bigstring, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_parameter : + ( Api_types_t.simulation_parameter, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_pause : + ( unit, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_raw_trace : + ( string, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t + + method simulation_start : + Api_types_j.simulation_parameter -> + ( Api_types_t.simulation_artifact, + Kappa_generic_toolset.Result_util.message list ) + Kappa_generic_toolset.Result_util.t + Lwt.t +end + +type mailbox = (int, box) Hashtbl.t + +val new_mailbox : unit -> mailbox +val receive : mailbox -> string -> unit +val is_computing : mailbox -> bool diff --git a/core/cflow/black_list.ml b/core/cflow/black_list.ml index 783b1dfcdc..f30eb67378 100644 --- a/core/cflow/black_list.ml +++ b/core/cflow/black_list.ml @@ -20,47 +20,47 @@ * This file is distributed under the terms of the GNU Library * General Public License *) -module type Event = - sig - type event - type eid - type 'a t - val key_of_event: event -> eid option - val init: int -> 'a -> 'a t - val set: 'a t -> eid -> 'a -> 'a t - val get: 'a t -> eid -> 'a - end -module type Blacklist = - sig - type t - module Event: Event +module type Event = sig + type event + type eid + type 'a t - val init: int -> t - val black_list: Event.event -> t -> t - val is_black_listed: Event.event -> t -> bool - end + val key_of_event : event -> eid option + val init : int -> 'a -> 'a t + val set : 'a t -> eid -> 'a -> 'a t + val get : 'a t -> eid -> 'a +end + +module type Blacklist = sig + type t + + module Event : Event + + val init : int -> t + val black_list : Event.event -> t -> t + val is_black_listed : Event.event -> t -> bool +end module Make = - functor (Event:Event) -> - struct - module Event = Event - type t = bool Event.t - let init n = Event.init n false +functor + (Event : Event) + -> + struct + module Event = Event + + type t = bool Event.t - let black_list event t = - match - Event.key_of_event event - with - | None -> t - | Some eid -> - let t = Event.set t eid true in - t + let init n = Event.init n false - let is_black_listed event t = - match - Event.key_of_event event - with - | None -> false - | Some eid -> Event.get t eid + let black_list event t = + match Event.key_of_event event with + | None -> t + | Some eid -> + let t = Event.set t eid true in + t - end + let is_black_listed event t = + match Event.key_of_event event with + | None -> false + | Some eid -> Event.get t eid + end diff --git a/core/cflow/black_list.mli b/core/cflow/black_list.mli index 9e5e639346..1210da141a 100644 --- a/core/cflow/black_list.mli +++ b/core/cflow/black_list.mli @@ -20,26 +20,26 @@ * This file is distributed under the terms of the GNU Library * General Public License *) -module type Event = - sig - type event - type eid - type 'a t - val key_of_event: event -> eid option - val init: int -> 'a -> 'a t - val set: 'a t -> eid -> 'a -> 'a t - val get: 'a t -> eid -> 'a - end +module type Event = sig + type event + type eid + type 'a t -module type Blacklist = - sig - type t - module Event: Event + val key_of_event : event -> eid option + val init : int -> 'a -> 'a t + val set : 'a t -> eid -> 'a -> 'a t + val get : 'a t -> eid -> 'a +end - val init: int -> t - val black_list: Event.event -> t -> t - val is_black_listed: Event.event -> t -> bool - end +module type Blacklist = sig + type t -module Make: - functor (Event:Event) -> (Blacklist with type Event.event = Event.event) + module Event : Event + + val init : int -> t + val black_list : Event.event -> t -> t + val is_black_listed : Event.event -> t -> bool +end + +module Make : functor (Event : Event) -> + Blacklist with type Event.event = Event.event diff --git a/core/cflow/blackboard.ml b/core/cflow/blackboard.ml index 15f86d4c2e..05f9e42e53 100644 --- a/core/cflow/blackboard.ml +++ b/core/cflow/blackboard.ml @@ -21,12 +21,12 @@ let debug_mode = false -module type Blackboard = -sig - module PB:Blackboard_generation.PreBlackboard +module type Blackboard = sig + module PB : Blackboard_generation.PreBlackboard - (** blackboard matrix *) type event_case_address + (** blackboard matrix *) + type case_info type case_value type case_address @@ -34,1743 +34,1976 @@ sig (** blackboard*) - type blackboard (*blackboard, once finalized*) + type blackboard (*blackboard, once finalized*) type assign_result - val is_failed: assign_result -> bool - val is_succeeded: assign_result -> bool - val is_ignored: assign_result -> bool - val success: assign_result - val ignore: assign_result - val fail: assign_result - - val predicate_id_of_case_address: event_case_address -> PB.predicate_id - val build_pointer: PB.step_short_id -> pointer - val is_before_blackboard: pointer -> bool - val get_event: blackboard -> PB.step_id -> Trace.step - val get_n_eid: blackboard -> int - val get_npredicate_id: blackboard -> int - val get_n_unresolved_events_of_pid_by_level: blackboard -> PB.predicate_id -> Priority.level -> int - val get_n_unresolved_events_of_pid: blackboard -> PB.predicate_id -> int - val get_n_unresolved_events: blackboard -> int - val get_first_linked_event: blackboard -> PB.predicate_id -> PB.step_short_id option - val get_last_linked_event: blackboard -> PB.predicate_id -> PB.step_short_id option - val get_stack_depth: blackboard -> int - val is_selected_event: (PB.step_id,blackboard,bool option) PB.CI.Po.K.H.binary - val case_address_of_case_event_address : event_case_address -> case_address - val predicate_value_of_case_value: (case_value, PB.predicate_value) PB.CI.Po.K.H.unary - val follow_pointer_up: (blackboard, event_case_address, event_case_address) PB.CI.Po.K.H.binary - val follow_pointer_down: (blackboard, event_case_address, event_case_address) PB.CI.Po.K.H.binary - val is_boundary: (blackboard, event_case_address, bool) PB.CI.Po.K.H.binary - - val build_event_case_address: PB.predicate_id -> pointer -> event_case_address - val exist_case: (blackboard, event_case_address, bool option) PB.CI.Po.K.H.binary - val get_static: (blackboard, event_case_address, (PB.step_short_id * PB.step_id * PB.predicate_value * PB.predicate_value)) PB.CI.Po.K.H.binary - - val set: (case_address, case_value, blackboard, blackboard) PB.CI.Po.K.H.ternary - val get: (case_address, blackboard, case_value) PB.CI.Po.K.H.binary - val dec: (case_address, blackboard, blackboard) PB.CI.Po.K.H.binary - val overwrite: (case_address, case_value, blackboard, blackboard) PB.CI.Po.K.H.ternary - val refine: (case_address, case_value, blackboard, blackboard * assign_result) PB.CI.Po.K.H.ternary - val branch: (blackboard, blackboard) PB.CI.Po.K.H.unary - val reset_last_branching: (blackboard, blackboard) PB.CI.Po.K.H.unary - val reset_init: (blackboard, blackboard) PB.CI.Po.K.H.unary - - (** initialisation*) - val import: ?heuristic:Priority.priorities -> (Trace.step list, blackboard) PB.CI.Po.K.H.unary - - - (** output result*) - type result = (Trace.step * PB.CI.Po.K.side_effect) list - - (** iteration*) - val is_maximal_solution: (blackboard, bool) PB.CI.Po.K.H.unary - - (** exporting result*) - val translate_blackboard: (blackboard, result) PB.CI.Po.K.H.unary - - (**pretty printing*) - val print_blackboard:(blackboard,unit) PB.CI.Po.K.H.unary - val export_blackboard_to_xls: (string,int,int,blackboard,unit) PB.CI.Po.K.H.quaternary - val print_event_case_address:(blackboard,event_case_address,unit) PB.CI.Po.K.H.binary - val print_stack: (blackboard,unit) PB.CI.Po.K.H.unary - val exist: event_case_address -> case_address - val boolean: bool option -> case_value - val pointer_to_previous: event_case_address -> case_address - val pointer_to_next: event_case_address -> case_address - val pointer: event_case_address -> case_value - val value_after: event_case_address -> case_address - val case_list_of_eid: (blackboard,PB.step_id,event_case_address list) PB.CI.Po.K.H.binary - val state: PB.predicate_value -> case_value - val is_exist_event: PB.step_id -> case_address - val n_unresolved_events_at_level: Priority.level -> case_address - val n_unresolved_events: case_address - val n_unresolved_events_in_column_at_level: event_case_address -> Priority.level -> case_address - val n_unresolved_events_in_column: event_case_address -> case_address - val forced_events: blackboard -> (PB.step_id list * unit Trace.Simulation_info.t option) list - val side_effect_of_event: blackboard -> PB.step_id -> PB.CI.Po.K.side_effect - val cut: (blackboard,PB.step_id list,blackboard * PB.step_id list) PB.CI.Po.K.H.binary - val tick: StoryProfiling.StoryStats.log_info -> bool * StoryProfiling.StoryStats.log_info (* to do: move to the module StoryProfiling.StoryStats*) - val level_of_event: (blackboard,PB.step_id,Priority.level) PB.CI.Po.K.H.binary -end - -module Blackboard = - (struct - module PB = Blackboard_generation.Preblackboard - (** blackboard matrix*) + val is_failed : assign_result -> bool + val is_succeeded : assign_result -> bool + val is_ignored : assign_result -> bool + val success : assign_result + val ignore : assign_result + val fail : assign_result + val predicate_id_of_case_address : event_case_address -> PB.predicate_id + val build_pointer : PB.step_short_id -> pointer + val is_before_blackboard : pointer -> bool + val get_event : blackboard -> PB.step_id -> Trace.step + val get_n_eid : blackboard -> int + val get_npredicate_id : blackboard -> int - type assign_result = Fail | Success | Ignore - type pointer = PB.step_short_id - - let warn parameter log_info error pos ?message:(message="") exn default = - let error,a = - Exception.warn - (PB.CI.Po.K.H.get_kasa_parameters parameter) error pos ~message exn default - in - error,log_info,a + val get_n_unresolved_events_of_pid_by_level : + blackboard -> PB.predicate_id -> Priority.level -> int - let success = Success - let ignore = Ignore - let fail = Fail + val get_n_unresolved_events_of_pid : blackboard -> PB.predicate_id -> int + val get_n_unresolved_events : blackboard -> int - let is_ignored x = - match x - with - | Ignore -> true - | _ -> false + val get_first_linked_event : + blackboard -> PB.predicate_id -> PB.step_short_id option - let is_failed x = - match x - with - | Fail -> true - | Success | Ignore -> false + val get_last_linked_event : + blackboard -> PB.predicate_id -> PB.step_short_id option + val get_stack_depth : blackboard -> int - let is_succeeded x = - match x - with - | Success -> true - | Fail | Ignore -> false + val is_selected_event : + (PB.step_id, blackboard, bool option) PB.CI.Po.K.H.binary - let null_pointer = PB.dummy_step_short_id - let is_null_pointer x = x=null_pointer - let pointer_before_blackboard = PB.zero_step_short_id - let is_null_pointer_step_id x = x = PB.dummy_step_id + val case_address_of_case_event_address : event_case_address -> case_address - let is_before_blackboard x = - x= pointer_before_blackboard - let build_pointer i = i + val predicate_value_of_case_value : + (case_value, PB.predicate_value) PB.CI.Po.K.H.unary - type event_case_address = - { - column_predicate_id:PB.predicate_id; - row_short_event_id: pointer; - } + val follow_pointer_up : + (blackboard, event_case_address, event_case_address) PB.CI.Po.K.H.binary - let predicate_id_of_case_address x = x.column_predicate_id + val follow_pointer_down : + (blackboard, event_case_address, event_case_address) PB.CI.Po.K.H.binary - let is_boundary _parameter _handler log_info error _blackboard event_address = - error,log_info,is_before_blackboard event_address.row_short_event_id + val is_boundary : (blackboard, event_case_address, bool) PB.CI.Po.K.H.binary - let build_event_case_address pid seid = - { - column_predicate_id = pid ; - row_short_event_id = seid - } + val build_event_case_address : + PB.predicate_id -> pointer -> event_case_address - type case_address = - | N_unresolved_events_in_column_at_level of int * Priority.level - | N_unresolved_events_in_column of int - | Pointer_to_next of event_case_address - | Value_after of event_case_address - | Value_before of event_case_address - | Pointer_to_previous of event_case_address - | N_unresolved_events - | N_unresolved_events_at_level of Priority.level - | Exist of event_case_address - | Keep_event of PB.step_id - - let is_exist_event i = Keep_event i - let n_unresolved_events_in_column i = N_unresolved_events_in_column (i.column_predicate_id) - let n_unresolved_events_in_column_at_level i j = N_unresolved_events_in_column_at_level (i.column_predicate_id,j) - let pointer_to_next e = Pointer_to_next e - let value_after e = Value_after e - let value_before e = Value_before e - let pointer_to_previous e = Pointer_to_previous e - let n_unresolved_events = N_unresolved_events - let n_unresolved_events_at_level i = N_unresolved_events_at_level i - let exist e = Exist e - - - type case_value = - | State of PB.predicate_value - | Counter of int - | Pointer of pointer - | Boolean of bool option - - let print_case_value parameter x = - match x with - | State x -> - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "State! " in - let () = PB.print_predicate_value (PB.CI.Po.K.H.get_debugging_channel parameter) x in - let () = Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) in - () - | Counter i -> - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "Counter %i" i in - let () = Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) in - () - | Pointer i -> - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "Pointer %i" (PB.int_of_step_short_id i) in - let () = Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) in - () - | Boolean b -> - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "Boolean %s" (match b with None -> "?" | Some true -> "true" | _ -> "false") in - let () = Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) in - () + val exist_case : + (blackboard, event_case_address, bool option) PB.CI.Po.K.H.binary - let string_of_pointer seid = - "event seid "^(string_of_int (PB.int_of_step_short_id seid)) - let print_pointer log seid = - Loggers.fprintf log "%s" (string_of_pointer seid) + val get_static : + ( blackboard, + event_case_address, + PB.step_short_id * PB.step_id * PB.predicate_value * PB.predicate_value + ) + PB.CI.Po.K.H.binary - let state predicate_value = State predicate_value - let pointer p = Pointer p.row_short_event_id - let boolean b = Boolean b + val set : + (case_address, case_value, blackboard, blackboard) PB.CI.Po.K.H.ternary - let case_address_of_case_event_address event_address = - Value_after (event_address) + val get : (case_address, blackboard, case_value) PB.CI.Po.K.H.binary + val dec : (case_address, blackboard, blackboard) PB.CI.Po.K.H.binary - let predicate_value_of_case_value parameter _handler log_info error case_value = - match case_value - with - | State x -> error,log_info,x - | Counter _ | Pointer _ | Boolean _ -> - let _ = print_case_value parameter case_value in - warn parameter log_info error __POS__ - ~message:"wrong kind of case_value in predicate_value_of_case_value" (Failure "predicate_value_of_case_value") PB.unknown + val overwrite : + (case_address, case_value, blackboard, blackboard) PB.CI.Po.K.H.ternary - type assignment = (case_address * case_value) + val refine : + ( case_address, + case_value, + blackboard, + blackboard * assign_result ) + PB.CI.Po.K.H.ternary - let bool_strictly_more_refined x y = - match x,y - with - | Some _ , None -> true - | _,_ -> false + val branch : (blackboard, blackboard) PB.CI.Po.K.H.unary + val reset_last_branching : (blackboard, blackboard) PB.CI.Po.K.H.unary + val reset_init : (blackboard, blackboard) PB.CI.Po.K.H.unary - let g p p2 pos parameter _handler log_info error x y = - match - x,y - with - | State x,State y -> error,log_info,p x y - | Boolean x,Boolean y -> error,log_info,p2 x y - | State _,_ | Boolean _, _ | Counter _, _ | Pointer _, _ -> - let file, line, _, _ = pos in - let string = file^", line: "^(string_of_int line) in - warn parameter log_info error pos ~message:"Counters and/or Pointers should not be compared" (Failure (string^" Comparison between pointers and counters")) false + val import : + ?heuristic:Priority.priorities -> + (Trace.step list, blackboard) PB.CI.Po.K.H.unary + (** initialisation*) - let strictly_more_refined = - g PB.strictly_more_refined bool_strictly_more_refined __POS__ + type result = (Trace.step * PB.CI.Po.K.side_effect) list + (** output result*) - type case_info_static = - { - row_short_id: PB.step_short_id; - event_id: PB.step_id; - test: PB.predicate_value; - action: PB.predicate_value - } + val is_maximal_solution : (blackboard, bool) PB.CI.Po.K.H.unary + (** iteration*) - type case_info_dynamic = - { - pointer_previous: pointer; - pointer_next: pointer; - state_after: PB.predicate_value; - selected: bool option; - } + val translate_blackboard : (blackboard, result) PB.CI.Po.K.H.unary + (** exporting result*) - type case_info = - { - static: case_info_static; - dynamic: case_info_dynamic - } + val print_blackboard : (blackboard, unit) PB.CI.Po.K.H.unary + (**pretty printing*) - let dummy_case_info_static = - { - row_short_id = PB.dummy_step_short_id ; - event_id = PB.dummy_step_id ; - test = PB.unknown ; - action = PB.unknown ; - } + val export_blackboard_to_xls : + (string, int, int, blackboard, unit) PB.CI.Po.K.H.quaternary - let dummy_case_info_dynamic = - { - pointer_previous = null_pointer ; - pointer_next = null_pointer ; - state_after = PB.unknown ; - selected = None ; - } + val print_event_case_address : + (blackboard, event_case_address, unit) PB.CI.Po.K.H.binary - let correct_pointer seid size = - let int_seid = PB.int_of_step_short_id seid in - if int_seid < 0 - then pointer_before_blackboard - else if int_seid >= size - then PB.step_short_id_of_int size - else seid + val print_stack : (blackboard, unit) PB.CI.Po.K.H.unary + val exist : event_case_address -> case_address + val boolean : bool option -> case_value + val pointer_to_previous : event_case_address -> case_address + val pointer_to_next : event_case_address -> case_address + val pointer : event_case_address -> case_value + val value_after : event_case_address -> case_address - let init_info_dynamic seid size= - { - pointer_previous = correct_pointer (PB.dec_step_short_id seid) size ; - pointer_next = correct_pointer (PB.inc_step_short_id seid) size ; - state_after = PB.unknown ; - selected = None ; - } + val case_list_of_eid : + (blackboard, PB.step_id, event_case_address list) PB.CI.Po.K.H.binary - let init_info_static _p_id seid (eid,_,test,action) = - { - row_short_id = seid ; - event_id = eid ; - test = test ; - action = action ; - } + val state : PB.predicate_value -> case_value + val is_exist_event : PB.step_id -> case_address + val n_unresolved_events_at_level : Priority.level -> case_address + val n_unresolved_events : case_address - let get_eid_of_triple (x,_,_,_) = x - let dummy_case_info = - { - static = dummy_case_info_static ; - dynamic = dummy_case_info_dynamic - } + val n_unresolved_events_in_column_at_level : + event_case_address -> Priority.level -> case_address - let init_info p_id seid size triple = - { - static = init_info_static p_id seid triple ; - dynamic = init_info_dynamic seid size - } + val n_unresolved_events_in_column : event_case_address -> case_address - (** blackboard *) - type stack = assignment list - type blackboard = - { - event: Trace.step PB.A.t; - pre_column_map_inv: PB.predicate_info PB.A.t; (** maps each wire id to its wire label *) - forced_events: (PB.step_id list * unit Trace.Simulation_info.t option) list; - n_predicate_id: int ; - n_eid:int; - n_seid: int PB.A.t; - current_stack: stack ; - stack: stack list ; - blackboard: case_info PB.A.t PB.A.t ; - selected_events: bool option PB.A.t ; - weigth_of_predicate_id: int PB.A.t; - weigth_of_predicate_id_by_level: int PB.A.t Priority.LevelMap.t; - used_predicate_id: bool PB.A.t ; - n_unresolved_events: int ; - n_unresolved_events_by_level: int Priority.LevelMap.t; - last_linked_event_of_predicate_id: PB.step_short_id PB.A.t; - event_case_list: event_case_address list PB.A.t; - side_effect_of_event: PB.CI.Po.K.side_effect PB.A.t; - fictitious_observable: PB.step_id option; - level_of_event: Priority.level PB.A.t; - } + val forced_events : + blackboard -> (PB.step_id list * unit Trace.Simulation_info.t option) list + val side_effect_of_event : blackboard -> PB.step_id -> PB.CI.Po.K.side_effect - let tick profiling_info = StoryProfiling.StoryStats.tick profiling_info - let level_of_event parameter _handler log_info error blackboard eid = - try - error,log_info, - PB.A.get blackboard.level_of_event (PB.int_of_step_id eid) - with - Not_found -> - warn - parameter log_info error __POS__ ~message:"Unknown event id" (Failure "Unknown event id") Priority.highest - - let get_event blackboard k = PB.A.get blackboard.event (PB.int_of_step_id k) - let get_n_eid blackboard = blackboard.n_eid - let get_stack_depth blackboard = List.length blackboard.stack - let forced_events blackboard = blackboard.forced_events - let side_effect_of_event blackboard i = - PB.A.get blackboard.side_effect_of_event (PB.int_of_step_id i) - - let case_list_of_eid parameter _handler log_info error blackboard eid = - try - error,log_info,PB.A.get blackboard.event_case_list (PB.int_of_step_id eid) - with - | _ -> - warn - parameter log_info error __POS__ - ~message:"Dereferencing Null pointer" - (Failure "Dereferencing null pointer") [] - - let get_case parameter _handler log_info error case_address blackboard = - try - error,log_info,PB.A.get - (PB.A.get blackboard.blackboard case_address.column_predicate_id) - (PB.int_of_step_short_id (case_address.row_short_event_id)) - with - | _ -> - warn - parameter log_info error __POS__ - ~message:"Dereferencing Null pointer" (Failure "Dereferencing null pointer") dummy_case_info - - let get_static parameter handler log_info error blackboard address = - let error,log_info,case = get_case parameter handler log_info error address blackboard in - let static = case.static in - error,log_info,(static.row_short_id,static.event_id,static.test,static.action) - - let print_event_case_address parameter handler log_info error blackboard case = - let error,log_info,(_,eid,_,_) = get_static parameter handler log_info error blackboard case in - let () = Loggers.fprintf (PB.CI.Po.K.H.get_logger parameter) "Event: %i, Predicate: %i@." (PB.int_of_step_id eid) (predicate_id_of_case_address case) in - error,log_info,() - - let print_case_address parameter handler log_info error blackboard x = - match x - with - | N_unresolved_events_in_column_at_level (i,j) -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "n_unresolved_events_in_pred %i %s@." - i - (Priority.string_of_level j) - in - error,log_info,() - | N_unresolved_events_in_column i -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "n_unresolved_events_in_pred %i @." i in - error,log_info,() - | Pointer_to_next e -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "Pointer" - in - print_event_case_address parameter handler log_info error blackboard e - | Value_after e -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "Value_after " - in - print_event_case_address parameter handler log_info error blackboard e - | Value_before e -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "Value_before " - in - print_event_case_address parameter handler log_info error blackboard e - | Pointer_to_previous e -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "Pointer_before " - in - print_event_case_address parameter handler log_info error blackboard e - | N_unresolved_events_at_level i -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) - "Unresolved_events_at_level %s" - (Priority.string_of_level i) - in - error,log_info,() - | N_unresolved_events -> - let _ = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "Unresolved_events" - in - error,log_info,() - | Exist e -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "Exist " in - print_event_case_address parameter handler log_info error blackboard e - | Keep_event i -> - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_logger parameter) - "Keep %i" (PB.int_of_step_id i) - in - error,log_info,() - - let get_npredicate_id blackboard = blackboard.n_predicate_id - let get_n_unresolved_events_of_pid_by_level blackboard pid level = - match Priority.LevelMap.find_option - level blackboard.weigth_of_predicate_id_by_level with - | Some x -> PB.A.get x pid - | None -> 0 - let get_n_unresolved_events_of_pid blackboard pid = - PB.A.get - blackboard.weigth_of_predicate_id - pid + val cut : + ( blackboard, + PB.step_id list, + blackboard * PB.step_id list ) + PB.CI.Po.K.H.binary - let get_n_unresolved_events blackboard = blackboard.n_unresolved_events - let get_pointer_next case = case.dynamic.pointer_next + val tick : + StoryProfiling.StoryStats.log_info -> + bool * StoryProfiling.StoryStats.log_info + (* to do: move to the module StoryProfiling.StoryStats*) - let follow_pointer_down parameter handler log_info error blackboard address = - let error,log_info,case = get_case parameter handler log_info error address blackboard in - error,log_info,{address with row_short_event_id = case.dynamic.pointer_next} + val level_of_event : + (blackboard, PB.step_id, Priority.level) PB.CI.Po.K.H.binary +end - let follow_pointer_up parameter handler log_info error blackboard address = - let error,log_info,case = get_case parameter handler log_info error address blackboard in - error,log_info,{address with row_short_event_id = case.dynamic.pointer_previous} +module Blackboard : Blackboard = struct + module PB = Blackboard_generation.Preblackboard + (** blackboard matrix*) - let get_first_linked_event blackboard pid = - if pid <0 || pid >= blackboard.n_predicate_id - then - None - else - Some (PB.zero_step_short_id) + type assign_result = Fail | Success | Ignore + type pointer = PB.step_short_id - let get_last_linked_event blackboard pid = - if pid<0 || pid >= blackboard.n_predicate_id - then - None - else - Some - (PB.A.get blackboard.last_linked_event_of_predicate_id pid) - - (**pretty printing*) - let print_known_case log pref inf suf case = - let _ = Loggers.fprintf log "%stest:" pref in - let _ = PB.print_predicate_value log case.static.test in - let _ = Loggers.fprintf log "/eid:%i/action:" (PB.int_of_step_id case.static.event_id) in - let _ = PB.print_predicate_value log case.static.action in - let _ = Loggers.fprintf log "%s" inf in - let _ = PB.print_predicate_value log case.dynamic.state_after in - let _ = Loggers.fprintf log "%s" suf in + let warn parameter log_info error pos ?(message = "") exn default = + let error, a = + Exception.warn + (PB.CI.Po.K.H.get_kasa_parameters parameter) + error pos ~message exn default + in + error, log_info, a + + let success = Success + let ignore = Ignore + let fail = Fail + + let is_ignored x = + match x with + | Ignore -> true + | _ -> false + + let is_failed x = + match x with + | Fail -> true + | Success | Ignore -> false + + let is_succeeded x = + match x with + | Success -> true + | Fail | Ignore -> false + + let null_pointer = PB.dummy_step_short_id + let is_null_pointer x = x = null_pointer + let pointer_before_blackboard = PB.zero_step_short_id + let is_null_pointer_step_id x = x = PB.dummy_step_id + let is_before_blackboard x = x = pointer_before_blackboard + let build_pointer i = i + + type event_case_address = { + column_predicate_id: PB.predicate_id; + row_short_event_id: pointer; + } + + let predicate_id_of_case_address x = x.column_predicate_id + + let is_boundary _parameter _handler log_info error _blackboard event_address = + error, log_info, is_before_blackboard event_address.row_short_event_id + + let build_event_case_address pid seid = + { column_predicate_id = pid; row_short_event_id = seid } + + type case_address = + | N_unresolved_events_in_column_at_level of int * Priority.level + | N_unresolved_events_in_column of int + | Pointer_to_next of event_case_address + | Value_after of event_case_address + | Value_before of event_case_address + | Pointer_to_previous of event_case_address + | N_unresolved_events + | N_unresolved_events_at_level of Priority.level + | Exist of event_case_address + | Keep_event of PB.step_id + + let is_exist_event i = Keep_event i + + let n_unresolved_events_in_column i = + N_unresolved_events_in_column i.column_predicate_id + + let n_unresolved_events_in_column_at_level i j = + N_unresolved_events_in_column_at_level (i.column_predicate_id, j) + + let pointer_to_next e = Pointer_to_next e + let value_after e = Value_after e + let value_before e = Value_before e + let pointer_to_previous e = Pointer_to_previous e + let n_unresolved_events = N_unresolved_events + let n_unresolved_events_at_level i = N_unresolved_events_at_level i + let exist e = Exist e + + type case_value = + | State of PB.predicate_value + | Counter of int + | Pointer of pointer + | Boolean of bool option + + let print_case_value parameter x = + match x with + | State x -> + let () = + Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "State! " + in + let () = + PB.print_predicate_value + (PB.CI.Po.K.H.get_debugging_channel parameter) + x + in + let () = + Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) + in + () + | Counter i -> + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "Counter %i" i + in + let () = + Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) + in + () + | Pointer i -> + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "Pointer %i" + (PB.int_of_step_short_id i) + in + let () = + Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) + in + () + | Boolean b -> + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "Boolean %s" + (match b with + | None -> "?" + | Some true -> "true" + | _ -> "false") + in + let () = + Loggers.print_newline (PB.CI.Po.K.H.get_debugging_channel parameter) + in () - let print_case log case = - let status = case.dynamic.selected in - match status - with - | Some false -> () - | Some true -> - print_known_case log "" " " " " case - | None -> - print_known_case log "?(" ") " " " case - - let print_address parameter handler log_info error blackboard address = - let log = (PB.CI.Po.K.H.get_debugging_channel parameter) in - match address - with - | Keep_event i -> - let () = Loggers.fprintf log "Is the event %i selected ? " (PB.int_of_step_id i) in - error,log_info, () - | Exist i -> - let () = Loggers.fprintf log "Is the case " in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard i in - let () = Loggers.fprintf log "selected ? " in - error,log_info,() - | N_unresolved_events_in_column_at_level (i,j) -> - let () = - Loggers.fprintf log "Number of unresolved events for the predicate %i at level %s" - i (Priority.string_of_level j) - in - error,log_info,() - | N_unresolved_events_in_column i -> - let () = Loggers.fprintf log "Number of unresolved events for the predicate %i" i in - error,log_info,() - | Pointer_to_next i -> - let () = Loggers.fprintf log "Prochain événement agissant sur " in - print_event_case_address parameter handler log_info error blackboard i - | Value_after i -> - let () = Loggers.fprintf log "Valeur après " in - print_event_case_address parameter handler log_info error blackboard i - | Value_before i -> - let () = Loggers.fprintf log "Valeur avant " in - print_event_case_address parameter handler log_info error blackboard i - | Pointer_to_previous i -> - let () = Loggers.fprintf log "Evenement précésent agissant sur " in - print_event_case_address parameter handler log_info error blackboard i - | N_unresolved_events -> - let () = Loggers.fprintf log "Nombre d'événements non résolu" in - error,log_info,() - | N_unresolved_events_at_level i -> - let () = Loggers.fprintf log "Nombre d'événements non résolu at level %s" (Priority.string_of_level i) in - error,log_info,() - + let string_of_pointer seid = + "event seid " ^ string_of_int (PB.int_of_step_short_id seid) + + let print_pointer log seid = Loggers.fprintf log "%s" (string_of_pointer seid) + let state predicate_value = State predicate_value + let pointer p = Pointer p.row_short_event_id + let boolean b = Boolean b + + let case_address_of_case_event_address event_address = + Value_after event_address + + let predicate_value_of_case_value parameter _handler log_info error case_value + = + match case_value with + | State x -> error, log_info, x + | Counter _ | Pointer _ | Boolean _ -> + let _ = print_case_value parameter case_value in + warn parameter log_info error __POS__ + ~message:"wrong kind of case_value in predicate_value_of_case_value" + (Failure "predicate_value_of_case_value") PB.unknown + + type assignment = case_address * case_value + + let bool_strictly_more_refined x y = + match x, y with + | Some _, None -> true + | _, _ -> false + + let g p p2 pos parameter _handler log_info error x y = + match x, y with + | State x, State y -> error, log_info, p x y + | Boolean x, Boolean y -> error, log_info, p2 x y + | State _, _ | Boolean _, _ | Counter _, _ | Pointer _, _ -> + let file, line, _, _ = pos in + let string = file ^ ", line: " ^ string_of_int line in + warn parameter log_info error pos + ~message:"Counters and/or Pointers should not be compared" + (Failure (string ^ " Comparison between pointers and counters")) + false + + let strictly_more_refined = + g PB.strictly_more_refined bool_strictly_more_refined __POS__ + + type case_info_static = { + row_short_id: PB.step_short_id; + event_id: PB.step_id; + test: PB.predicate_value; + action: PB.predicate_value; + } + + type case_info_dynamic = { + pointer_previous: pointer; + pointer_next: pointer; + state_after: PB.predicate_value; + selected: bool option; + } + + type case_info = { static: case_info_static; dynamic: case_info_dynamic } + + let dummy_case_info_static = + { + row_short_id = PB.dummy_step_short_id; + event_id = PB.dummy_step_id; + test = PB.unknown; + action = PB.unknown; + } + + let dummy_case_info_dynamic = + { + pointer_previous = null_pointer; + pointer_next = null_pointer; + state_after = PB.unknown; + selected = None; + } + + let correct_pointer seid size = + let int_seid = PB.int_of_step_short_id seid in + if int_seid < 0 then + pointer_before_blackboard + else if int_seid >= size then + PB.step_short_id_of_int size + else + seid + + let init_info_dynamic seid size = + { + pointer_previous = correct_pointer (PB.dec_step_short_id seid) size; + pointer_next = correct_pointer (PB.inc_step_short_id seid) size; + state_after = PB.unknown; + selected = None; + } + + let init_info_static _p_id seid (eid, _, test, action) = + { row_short_id = seid; event_id = eid; test; action } + + let get_eid_of_triple (x, _, _, _) = x + + let dummy_case_info = + { static = dummy_case_info_static; dynamic = dummy_case_info_dynamic } + + let init_info p_id seid size triple = + { + static = init_info_static p_id seid triple; + dynamic = init_info_dynamic seid size; + } + + type stack = assignment list + (** blackboard *) + + type blackboard = { + event: Trace.step PB.A.t; + pre_column_map_inv: PB.predicate_info PB.A.t; + (** maps each wire id to its wire label *) + forced_events: (PB.step_id list * unit Trace.Simulation_info.t option) list; + n_predicate_id: int; + n_eid: int; + n_seid: int PB.A.t; + current_stack: stack; + stack: stack list; + blackboard: case_info PB.A.t PB.A.t; + selected_events: bool option PB.A.t; + weigth_of_predicate_id: int PB.A.t; + weigth_of_predicate_id_by_level: int PB.A.t Priority.LevelMap.t; + used_predicate_id: bool PB.A.t; + n_unresolved_events: int; + n_unresolved_events_by_level: int Priority.LevelMap.t; + last_linked_event_of_predicate_id: PB.step_short_id PB.A.t; + event_case_list: event_case_address list PB.A.t; + side_effect_of_event: PB.CI.Po.K.side_effect PB.A.t; + fictitious_observable: PB.step_id option; + level_of_event: Priority.level PB.A.t; + } + + let tick profiling_info = StoryProfiling.StoryStats.tick profiling_info + + let level_of_event parameter _handler log_info error blackboard eid = + try + ( error, + log_info, + PB.A.get blackboard.level_of_event (PB.int_of_step_id eid) ) + with Not_found -> + warn parameter log_info error __POS__ ~message:"Unknown event id" + (Failure "Unknown event id") Priority.highest + + let get_event blackboard k = PB.A.get blackboard.event (PB.int_of_step_id k) + let get_n_eid blackboard = blackboard.n_eid + let get_stack_depth blackboard = List.length blackboard.stack + let forced_events blackboard = blackboard.forced_events + + let side_effect_of_event blackboard i = + PB.A.get blackboard.side_effect_of_event (PB.int_of_step_id i) + + let case_list_of_eid parameter _handler log_info error blackboard eid = + try + ( error, + log_info, + PB.A.get blackboard.event_case_list (PB.int_of_step_id eid) ) + with _ -> + warn parameter log_info error __POS__ + ~message:"Dereferencing Null pointer" + (Failure "Dereferencing null pointer") [] + + let get_case parameter _handler log_info error case_address blackboard = + try + ( error, + log_info, + PB.A.get + (PB.A.get blackboard.blackboard case_address.column_predicate_id) + (PB.int_of_step_short_id case_address.row_short_event_id) ) + with _ -> + warn parameter log_info error __POS__ + ~message:"Dereferencing Null pointer" + (Failure "Dereferencing null pointer") dummy_case_info + + let get_static parameter handler log_info error blackboard address = + let error, log_info, case = + get_case parameter handler log_info error address blackboard + in + let static = case.static in + ( error, + log_info, + (static.row_short_id, static.event_id, static.test, static.action) ) - let string_of_value value = - match value - with - | State pb -> PB.string_of_predicate_value pb - | Counter i -> "Counter "^(string_of_int i) - | Pointer i -> string_of_pointer i - | Boolean bool -> - (match bool - with - | None -> "?" - | Some true -> "Yes" - | Some false -> "No") + let print_event_case_address parameter handler log_info error blackboard case + = + let error, log_info, (_, eid, _, _) = + get_static parameter handler log_info error blackboard case + in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_logger parameter) + "Event: %i, Predicate: %i@." (PB.int_of_step_id eid) + (predicate_id_of_case_address case) + in + error, log_info, () - let print_value log value = - match value - with - | State pb -> PB.print_predicate_value log pb - | Counter i -> Loggers.fprintf log "Counter %i" i - | Pointer i -> print_pointer log i - | Boolean bool -> - Loggers.fprintf log "%s" - (match bool - with - | None -> "?" - | Some true -> "Yes" - | Some false -> "No") - - - let print_assignment parameter handler log_info error blackboard (address,value) = - let error,log_info,() = print_address parameter handler log_info error blackboard address in - let _ = print_value (PB.CI.Po.K.H.get_debugging_channel parameter) value in - error,log_info - - let print_blackboard parameter handler log_info error blackboard = - let log = PB.CI.Po.K.H.get_debugging_channel parameter in - let () = Loggers.fprintf log "**BLACKBOARD**" in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log "%i wires, %i events" blackboard.n_predicate_id blackboard.n_eid in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log "*wires:*" in - let () = Loggers.print_newline log in - let err = ref error in + let print_case_address parameter handler log_info error blackboard x = + match x with + | N_unresolved_events_in_column_at_level (i, j) -> let () = - PB.A.iteri - (fun i array -> - let () = Loggers.fprintf log "%i" i in - let () = Loggers.print_newline log in - let () = - if PB.A.get blackboard.used_predicate_id i - then - let () = Loggers.fprintf log "*wires %i: " i in - let () = Loggers.print_newline log in - let rec aux j error = - let () = Loggers.fprintf log "* %i:" j in - let () = Loggers.print_newline log in - let case = PB.A.get array j in - let () = print_case log case in - let j' = get_pointer_next case in - let j' = PB.int_of_step_short_id j' in - if j=j' - then error - else aux j' error - in - let error = - aux (PB.int_of_step_short_id pointer_before_blackboard) (!err) in - let _ = err := error in - () - else - () - in - Loggers.print_newline log) - blackboard.blackboard + Loggers.fprintf + (PB.CI.Po.K.H.get_logger parameter) + "n_unresolved_events_in_pred %i %s@." i + (Priority.string_of_level j) in - let error = !err in - let () = Loggers.fprintf log "*stacks*" in - let () = Loggers.print_newline log in - let error,log_info = List.fold_left (fun (error,log_info) -> print_assignment parameter handler log_info error blackboard) (error,log_info) (List.rev blackboard.current_stack) in - let () = Loggers.print_newline log in - let _ = - List.fold_left - (fun (error,log_info) stack -> - let error,log_info = List.fold_left (fun (error,log_info) -> print_assignment parameter handler log_info error blackboard) (error,log_info) stack in - let () = Loggers.print_newline log in - (error,log_info)) - (error,log_info) blackboard.stack - in - let () = Loggers.fprintf log "*selected_events*" in - let () = Loggers.print_newline log in + error, log_info, () + | N_unresolved_events_in_column i -> let () = - PB.A.iteri - (fun i bool -> - match bool - with - | None -> () - | Some b -> - let () = Loggers.fprintf log " Event:%i (%s)" i (if b then "KEPT" else "REMOVED") in - Loggers.print_newline log) - blackboard.selected_events + Loggers.fprintf + (PB.CI.Po.K.H.get_logger parameter) + "n_unresolved_events_in_pred %i @." i in - let () = Loggers.fprintf log "*unsolved_events*" in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log " %i" blackboard.n_unresolved_events in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log "*weight of predicate_id*" in - let () = Loggers.print_newline log in + error, log_info, () + | Pointer_to_next e -> + let () = Loggers.fprintf (PB.CI.Po.K.H.get_logger parameter) "Pointer" in + print_event_case_address parameter handler log_info error blackboard e + | Value_after e -> let () = - PB.A.iteri - (fun a b -> - let () = Loggers.fprintf log " %i:%i" a b in - Loggers.print_newline log) - blackboard.weigth_of_predicate_id + Loggers.fprintf (PB.CI.Po.K.H.get_logger parameter) "Value_after " in - let () = Loggers.fprintf log "*weight of predicate_id_by_level*" in + print_event_case_address parameter handler log_info error blackboard e + | Value_before e -> let () = - Priority.LevelMap.iter - (fun l -> - let () = Loggers.fprintf log " Level:%s" (Priority.string_of_level l) in - let () = Loggers.print_newline log in - PB.A.iteri - (fun a b -> - let () = Loggers.fprintf log " %i:%i" a b in - Loggers.print_newline log) - ) - blackboard.weigth_of_predicate_id_by_level - in - let () = Loggers.fprintf log "**" in - let () = Loggers.print_newline log in - error,log_info,() - - - - (** propagation request *) - - let add_event eid (pid,seid) array level unsolved = - let event_case_address = build_event_case_address pid seid in - let old = PB.A.get array (PB.int_of_step_id eid) in - let unsolved = - Priority.LevelMap.add - level ((Priority.LevelMap.find_default 0 level unsolved)+1) unsolved in - PB.A.set array (PB.int_of_step_id eid) (event_case_address::old),unsolved - - let empty_stack = [] - - let import ?heuristic:(_) parameter handler log_info error pre_blackboard = - let error,log_info,n_predicates = PB.n_predicates parameter handler log_info error pre_blackboard in - let error,log_info,n_events = PB.n_events parameter handler log_info error pre_blackboard in - let stack = [] in - let current_stack = empty_stack in - let event_case_list = PB.A.make n_events [] in - let n_seid = PB.A.make n_predicates 0 in - let unsolved_by_level = Priority.LevelMap.empty in - let blackboard = PB.A.make n_predicates (PB.A.make 1 dummy_case_info) in - let weigth_of_predicate_id_by_level = - let rec aux level_opt map = - match - level_opt - with - | None -> map - | Some level -> - aux (Priority.higher level) (Priority.LevelMap.add level (PB.A.make 0 0) map) - in - aux (Some Priority.lowest) Priority.LevelMap.empty + Loggers.fprintf (PB.CI.Po.K.H.get_logger parameter) "Value_before " in - let inc_depth level p_id = - match Priority.LevelMap.find_option - level weigth_of_predicate_id_by_level with - | Some a -> - let old = - try - PB.A.get a p_id - with - | Not_found -> 0 - in - PB.A.set a p_id (old+1) - | None -> () + print_event_case_address parameter handler log_info error blackboard e + | Pointer_to_previous e -> + let () = + Loggers.fprintf (PB.CI.Po.K.H.get_logger parameter) "Pointer_before " in - - let weigth_of_predicate_id = PB.A.make 0 0 in - let last_linked_event_of_predicate_id = PB.A.make n_predicates PB.zero_step_short_id in - let error,log_info = - let rec aux1 p_id log_info error = - if p_id < 0 - then error,log_info - else - let error,log_info,size = PB.n_events_per_predicate parameter handler log_info error pre_blackboard p_id in - let size = size + 1 in - let _ = PB.A.set last_linked_event_of_predicate_id p_id (PB.step_short_id_of_int (size-1)) in - let _ = PB.A.set weigth_of_predicate_id p_id (size-2) in - let _ = PB.A.set n_seid p_id size in - let error,log_info,list = PB.event_list_of_predicate parameter handler log_info error pre_blackboard p_id in - let array = PB.A.make size dummy_case_info in - let _ = PB.A.set blackboard p_id array in - let rec aux2 seid l log_info = - match l - with - | [] -> - let info = - {dynamic = - { - pointer_previous = PB.zero_step_short_id ; - pointer_next = PB.inc_step_short_id (PB.zero_step_short_id) ; - state_after = PB.undefined ; - selected = Some true - }; - static = - { - row_short_id = PB.zero_step_short_id ; - event_id = PB.dummy_step_id ; - test = PB.unknown ; - action = PB.unknown ; - }} - in - let _ = PB.A.set array 0 info in - let pred_size = PB.dec_step_short_id (PB.step_short_id_of_int size) in - let info = - {dynamic = - { - pointer_previous = pred_size ; - pointer_next = pred_size ; - state_after = PB.unknown ; - selected = Some true - } ; - static = - { - row_short_id = pred_size ; - event_id = PB.dummy_step_id ; - test = PB.unknown ; - action = PB.unknown ; - }} - in - let _ = PB.A.set array (size-1) info in - log_info - | triple::q -> - let info = init_info p_id seid (size-1) triple in - let eid = get_eid_of_triple triple in - let error,log_info,_events = - PB.get_pre_event parameter handler log_info error pre_blackboard in - let _error,log_info,level = - PB.get_level_of_event parameter handler log_info error pre_blackboard eid in - let () = inc_depth level p_id in - let (),_ = add_event eid (p_id,seid) event_case_list level Priority.LevelMap.empty in - let () = PB.A.set array (PB.int_of_step_short_id seid) info in - aux2 (PB.dec_step_short_id seid) q log_info - in - let log_info = aux2 (PB.step_short_id_of_int (size-2)) list log_info in - aux1 (p_id-1) log_info error - in aux1 (n_predicates-1) log_info error + print_event_case_address parameter handler log_info error blackboard e + | N_unresolved_events_at_level i -> + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "Unresolved_events_at_level %s" + (Priority.string_of_level i) in - let error,log_info,forced_events = PB.mandatory_events parameter handler log_info error pre_blackboard in - let error,log_info,event = PB.get_pre_event parameter handler log_info error pre_blackboard in - let error,log_info,unsolved_by_level = - let rec aux k error log_info map = - if k=0 - then - error,log_info,map - else - let error,log_info,level = - PB.get_level_of_event parameter handler log_info error pre_blackboard (PB.step_id_of_int k) in - let map = - Priority.LevelMap.add level ((Priority.LevelMap.find_default 0 level map)+1) map - in aux (k-1) error log_info map - in aux n_events error log_info unsolved_by_level + error, log_info, () + | N_unresolved_events -> + let _ = + Loggers.fprintf (PB.CI.Po.K.H.get_logger parameter) "Unresolved_events" in - let error,log_info,side_effects = PB.get_side_effect parameter handler log_info error pre_blackboard in - let error,log_info,fictitious_obs = PB.get_fictitious_observable parameter handler log_info error pre_blackboard in - let b = - { - event = event ; - side_effect_of_event = side_effects ; - pre_column_map_inv = PB.get_pre_column_map_inv pre_blackboard; - level_of_event = PB.levels pre_blackboard; - forced_events = forced_events; - n_eid = n_events; - n_seid = n_seid; - event_case_list = event_case_list; - last_linked_event_of_predicate_id = last_linked_event_of_predicate_id ; - n_predicate_id = n_predicates; - current_stack=current_stack; - stack=stack; - blackboard=blackboard; - selected_events= PB.A.make n_events None; - weigth_of_predicate_id = weigth_of_predicate_id; - weigth_of_predicate_id_by_level= weigth_of_predicate_id_by_level; - used_predicate_id = PB.A.make n_predicates true; - n_unresolved_events = n_events ; - n_unresolved_events_by_level = unsolved_by_level ; - fictitious_observable = fictitious_obs ; - } + error, log_info, () + | Exist e -> + let () = Loggers.fprintf (PB.CI.Po.K.H.get_logger parameter) "Exist " in + print_event_case_address parameter handler log_info error blackboard e + | Keep_event i -> + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_logger parameter) + "Keep %i" (PB.int_of_step_id i) in - error,log_info,b + error, log_info, () + let get_npredicate_id blackboard = blackboard.n_predicate_id - let exist_case parameter handler log_info error blackboard case_address = - let error,log_info,info = get_case parameter handler log_info error case_address blackboard in - error,log_info,info.dynamic.selected + let get_n_unresolved_events_of_pid_by_level blackboard pid level = + match + Priority.LevelMap.find_option level + blackboard.weigth_of_predicate_id_by_level + with + | Some x -> PB.A.get x pid + | None -> 0 - let set_case parameter _handler log_info error case_address case_value blackboard = - try - let _ = - PB.A.set - (PB.A.get blackboard.blackboard case_address.column_predicate_id) (PB.int_of_step_short_id (case_address.row_short_event_id)) case_value - in error,log_info,blackboard - with - | _ -> - warn parameter log_info error __POS__ - ~message:"Dereferencing Null pointer" - (Failure "Dereferencing null pointer") blackboard + let get_n_unresolved_events_of_pid blackboard pid = + PB.A.get blackboard.weigth_of_predicate_id pid - let set parameter handler log_info error case_address case_value blackboard = - match - case_address - with - | N_unresolved_events_in_column_at_level (int,level) -> - begin - match case_value - with - | Counter int2 -> - begin - match - Priority.LevelMap.find_option level blackboard.weigth_of_predicate_id_by_level - with - | Some a -> - let () = PB.A.set a int int2 in - error,log_info,blackboard - | None -> - begin - warn - parameter log_info error __POS__ - ~message:"Incompatible address and value in function set" - (Failure"Incompatible address and value in function Blackboard.set") - blackboard - end - end - | Pointer _ | State _ | Boolean _ -> - warn - parameter log_info error __POS__ - ~message:"Incompatible address and value in function set" (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | N_unresolved_events_in_column int -> - begin - match case_value - with - | Counter int2 -> - let _ = PB.A.set blackboard.weigth_of_predicate_id int int2 in - error,log_info,blackboard - | Pointer _ | Boolean _ | State _ -> - warn - parameter log_info error __POS__ - ~message:"Incompatible address and value in function set" (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | Pointer_to_next case_address -> - begin - match case_value - with - | Pointer int2 -> - let error,log_info,old = get_case parameter handler log_info error case_address blackboard in - let case_value = {old with dynamic = {old.dynamic with pointer_next = int2}} in - let error,log_info,blackboard = set_case parameter handler log_info error case_address case_value blackboard in - error,log_info,blackboard - | Counter _ | Boolean _ | State _ -> - warn - parameter log_info error __POS__ - ~message:"Incompatible address and value in function set" (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | Value_after case_address -> - begin - match case_value - with - | State state -> - let error,log_info,old = get_case parameter handler log_info error case_address blackboard in - let case_value = {old with dynamic = {old.dynamic with state_after = state}} in - let error,log_info,blackboard = set_case parameter handler log_info error case_address case_value blackboard in - error,log_info,blackboard - | Boolean _ | Counter _ | Pointer _ -> - warn - parameter log_info error __POS__ - ~message:"set should not be called with value_after" - (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | Value_before _case_address -> - warn - parameter log_info error __POS__ - ~message:"set should not be called with value_before" - (Failure "Incompatible address and value in function Blackboard.set") - blackboard - | Pointer_to_previous case_address -> - begin - match case_value - with - | Pointer int2 -> - let error,log_info,old = get_case parameter handler log_info error case_address blackboard in - let case_value = {old with dynamic = {old.dynamic with pointer_previous = int2}} in - let error,log_info,blackboard = set_case parameter handler log_info error case_address case_value blackboard in - error,log_info,blackboard - | Boolean _ | State _ | Counter _ -> - warn - parameter log_info error __POS__ - ~message:"set, line 896, Incompatible address and value in function set" - (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | N_unresolved_events -> - begin - match case_value - with - | Counter int -> - error,log_info,{blackboard with n_unresolved_events = int} - | Boolean _ | Pointer _ | State _ -> - warn - parameter log_info error __POS__ - ~message:"set, line 905, Incompatible address and value in function set" - (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | N_unresolved_events_at_level level -> - begin - match case_value - with - | Counter int -> - error,log_info,{blackboard - with n_unresolved_events_by_level = - Priority.LevelMap.add level int blackboard.n_unresolved_events_by_level} - | Boolean _ | State _ | Pointer _ -> - warn - parameter log_info error __POS__ - ~message:"Incompatible address and value in function set" (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | Keep_event step_id -> - begin - match case_value - with - | Boolean b -> - let _ = - PB.A.set - blackboard.selected_events - (PB.int_of_step_id step_id) - b - in - error,log_info,blackboard - | Pointer _ | State _ | Counter _ -> - warn - parameter log_info error __POS__ - ~message:"Incompatible address and value in function set" - (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end - | Exist case_address -> - begin - match case_value - with - | Boolean b -> - let error,log_info,old = get_case parameter handler log_info error case_address blackboard in - let case_value = {old with dynamic = {old.dynamic with selected = b}} in - let error,log_info,blackboard = set_case parameter handler log_info error case_address case_value blackboard in - error,log_info,blackboard - | Pointer _ | Counter _ | State _ -> - warn - parameter log_info error __POS__ - ~message:"Incompatible address and value in function set" (Failure "Incompatible address and value in function Blackboard.set") - blackboard - end + let get_n_unresolved_events blackboard = blackboard.n_unresolved_events + let get_pointer_next case = case.dynamic.pointer_next - let is_selected_event - _parameter _handler log_info error step_id blackboard = - error, log_info, PB.A.get blackboard.selected_events (PB.int_of_step_id step_id) + let follow_pointer_down parameter handler log_info error blackboard address = + let error, log_info, case = + get_case parameter handler log_info error address blackboard + in + ( error, + log_info, + { address with row_short_event_id = case.dynamic.pointer_next } ) - let rec get parameter handler log_info error case_address blackboard = - match - case_address - with - | Keep_event step_id -> - error,log_info, - Boolean - (PB.A.get - blackboard.selected_events - (PB.int_of_step_id step_id)) - | N_unresolved_events_in_column_at_level (int,level) -> - let n = - match Priority.LevelMap.find_option - level blackboard.weigth_of_predicate_id_by_level - with - | Some a -> PB.A.get a int - | None -> 0 - in - error,log_info,Counter n - | N_unresolved_events_in_column int -> error,log_info,Counter (PB.A.get blackboard.weigth_of_predicate_id int) - | Exist case_address -> - let error,log_info,case = get_case parameter handler log_info error case_address blackboard in - error,log_info,Boolean case.dynamic.selected - | Pointer_to_next case_address -> - let error,log_info,case = get_case parameter handler log_info error case_address blackboard in - error,log_info,Pointer case.dynamic.pointer_next - | Value_after case_address -> - let error,log_info,case = get_case parameter handler log_info error case_address blackboard in - error,log_info,State case.dynamic.state_after - | Value_before case_address -> - let error,log_info,case = get_case parameter handler log_info error case_address blackboard in - let pointer = case.dynamic.pointer_previous in - if is_null_pointer pointer - then - warn - parameter log_info error __POS__ - ~message:"Value before an unexisting element requested" - (Failure "Value before an unexisting element requested") - (State PB.undefined) - else - get parameter handler log_info error (Value_after {case_address with row_short_event_id = pointer}) blackboard - | Pointer_to_previous case_address -> - let error,log_info,case = get_case parameter handler log_info error case_address blackboard in - error,log_info,Pointer case.dynamic.pointer_previous - | N_unresolved_events -> error,log_info,Counter blackboard.n_unresolved_events - | N_unresolved_events_at_level lvl -> - error, - log_info, - Counter(Priority.LevelMap.find_default - 0 lvl blackboard.n_unresolved_events_by_level) - - let export_blackboard_to_xls parameter handler log_info error prefix int int2 blackboard = - let file_name = prefix^"_"^(string_of_int int)^"_"^(string_of_int int2)^".sxw" in - let desc_chan = Kappa_files.open_out file_name in - let desc = Loggers.open_logger_from_channel ~mode:Loggers.XLS desc_chan in - let parameter = PB.CI.Po.K.H.set_logger parameter desc in - let ncolumns_left = 3 in - let nrows_head = 2 in - let row_of_precondition eid = nrows_head + 3*eid in - let row_of_postcondition eid = 1+(row_of_precondition eid) in - let column_of_pid pid = pid + ncolumns_left in - let () = Loggers.fprintf desc "REM ***** BASIC *****" in - let () = Loggers.print_newline desc in - let colors = PB.A.make blackboard.n_eid None in - let backcolor log color = - match - color - with - | Some color -> - let r,g,b=Color.triple_of_color color in - let () = Loggers.fprintf log "C.CellBackColor = RGB(%i,%i,%i)" r g b in - let () = Loggers.print_newline log in - () - | None -> () - in - let textcolor log color = - match - color - with - | Some color -> - let r,g,b=Color.triple_of_color color in - let () = Loggers.fprintf log "C.CharColor = RGB(%i,%i,%i)" r g b in - Loggers.print_newline log - | None -> () - in - let getcell log row col = - let () = Loggers.fprintf log "C = S.getCellByPosition(%i,%i)" col row in - Loggers.print_newline log - in - let overline_case log row _col _color = - let () = Loggers.fprintf log "R=S.Rows(%i)" row in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log "R.TopBorder = withBord" in - Loggers.print_newline log + let follow_pointer_up parameter handler log_info error blackboard address = + let error, log_info, case = + get_case parameter handler log_info error address blackboard + in + ( error, + log_info, + { address with row_short_event_id = case.dynamic.pointer_previous } ) + + let get_first_linked_event blackboard pid = + if pid < 0 || pid >= blackboard.n_predicate_id then + None + else + Some PB.zero_step_short_id + + let get_last_linked_event blackboard pid = + if pid < 0 || pid >= blackboard.n_predicate_id then + None + else + Some (PB.A.get blackboard.last_linked_event_of_predicate_id pid) + + (**pretty printing*) + let print_known_case log pref inf suf case = + let _ = Loggers.fprintf log "%stest:" pref in + let _ = PB.print_predicate_value log case.static.test in + let _ = + Loggers.fprintf log "/eid:%i/action:" + (PB.int_of_step_id case.static.event_id) + in + let _ = PB.print_predicate_value log case.static.action in + let _ = Loggers.fprintf log "%s" inf in + let _ = PB.print_predicate_value log case.dynamic.state_after in + let _ = Loggers.fprintf log "%s" suf in + () + + let print_case log case = + let status = case.dynamic.selected in + match status with + | Some false -> () + | Some true -> print_known_case log "" " " " " case + | None -> print_known_case log "?(" ") " " " case + + let print_address parameter handler log_info error blackboard address = + let log = PB.CI.Po.K.H.get_debugging_channel parameter in + match address with + | Keep_event i -> + let () = + Loggers.fprintf log "Is the event %i selected ? " (PB.int_of_step_id i) in - let print_case log row col color_font color_back string = - if string <> "" - then - let () = getcell log row col in - let () = textcolor log color_font in - let () = backcolor log color_back in - let () = Loggers.fprintf log "C.setFormula(\"%s\")" string in - Loggers.print_newline log + error, log_info, () + | Exist i -> + let () = Loggers.fprintf log "Is the case " in + let error, log_info, () = + print_event_case_address parameter handler log_info error blackboard i in - let print_case_fun log row col color_font color_back f error = - let () = getcell log row col in - let () = textcolor log color_font in - let () = backcolor log color_back in - let () = Loggers.fprintf log "C.setFormula(\""in - let error = f error in - let () = Loggers.fprintf log "\")" in - let () = Loggers.print_newline log in - error + let () = Loggers.fprintf log "selected ? " in + error, log_info, () + | N_unresolved_events_in_column_at_level (i, j) -> + let () = + Loggers.fprintf log + "Number of unresolved events for the predicate %i at level %s" i + (Priority.string_of_level j) in - let () = Loggers.fprintf desc "Sub Main" in - let () = Loggers.print_newline desc in - let () = Loggers.print_newline desc in - let r,g,b = Color.triple_of_color Color.Black in - let () = Loggers.fprintf desc "Dim withBord As New com.sun.star.table.BorderLine" in - let () = Loggers.print_newline desc in - let () = Loggers.fprintf desc "With withBord withBord.Color = RGB(%i,%i,%i)" r g b in - let () = Loggers.print_newline desc in - let () = Loggers.fprintf desc "withBord.OuterLineWidth = 60" in - let () = Loggers.print_newline desc in - let () = Loggers.fprintf desc "End With" in - let () = Loggers.print_newline desc in - let () = Loggers.fprintf desc "S = ThisComponent.Sheets(0)" in - let () = Loggers.print_newline desc in - let _ = - match forced_events blackboard - with - | [list,_] -> - List.iter - (fun eid -> - PB.A.set - colors (PB.int_of_step_id eid) (Some Color.Red)) - list - | _ -> () + error, log_info, () + | N_unresolved_events_in_column i -> + let () = + Loggers.fprintf log "Number of unresolved events for the predicate %i" i in - let _ = - PB.A.iteri - (fun pid p_info -> - print_case_fun desc 0 (column_of_pid pid) None None - (fun _error -> PB.print_predicate_info desc p_info) - error) - blackboard.pre_column_map_inv + error, log_info, () + | Pointer_to_next i -> + let () = Loggers.fprintf log "Prochain événement agissant sur " in + print_event_case_address parameter handler log_info error blackboard i + | Value_after i -> + let () = Loggers.fprintf log "Valeur après " in + print_event_case_address parameter handler log_info error blackboard i + | Value_before i -> + let () = Loggers.fprintf log "Valeur avant " in + print_event_case_address parameter handler log_info error blackboard i + | Pointer_to_previous i -> + let () = Loggers.fprintf log "Evenement précésent agissant sur " in + print_event_case_address parameter handler log_info error blackboard i + | N_unresolved_events -> + let () = Loggers.fprintf log "Nombre d'événements non résolu" in + error, log_info, () + | N_unresolved_events_at_level i -> + let () = + Loggers.fprintf log "Nombre d'événements non résolu at level %s" + (Priority.string_of_level i) in - let rec aux eid error log_info stack = - if eid>=blackboard.n_eid - then error,log_info - else - begin - let error,log_info,list = - case_list_of_eid - parameter handler log_info error - blackboard - (PB.step_id_of_int eid) - in - let row_precondition = row_of_precondition eid in - let row_postcondition = row_of_postcondition eid in - let color,maybekept = - match - PB.A.get blackboard.selected_events eid - with - | None -> PB.A.get colors eid,true - | Some true -> Some Color.Red,true - | Some false -> Some Color.Grey,false - in - let rec aux2 f g l error log_info = - match l - with - | [] -> error,log_info - | t::q -> - let _ = overline_case desc row_postcondition (column_of_pid t.column_predicate_id) None in - let _ = print_case desc row_precondition (column_of_pid t.column_predicate_id) None color (f t) in - let _ = print_case desc row_postcondition (column_of_pid t.column_predicate_id) None color (g t) in - let error,log_info = - if maybekept - then - let error,log_info,value_before = - try - let error,log_info,case_value = get parameter handler log_info error (value_before t) blackboard in - error,log_info,string_of_value case_value - with - Not_found -> error,log_info,"Undefined" - in - let _ = print_case desc (row_precondition-1) (column_of_pid t.column_predicate_id) (Some Color.Lightblue) None value_before - in - let error,log_info,value_after = - try - let error,log_info,case_value = get parameter handler log_info error (value_after t) blackboard in - error,log_info,string_of_value case_value - with - Not_found -> error,log_info,"Undefined" - in - let _ = print_case desc (row_postcondition+1) (column_of_pid t.column_predicate_id) (Some Color.Lightblue) None value_after - in error,log_info - else - error,log_info - in - aux2 f g q error log_info - in - let print_test t = - let column = PB.A.get blackboard.blackboard t.column_predicate_id in - let case = - PB.A.get - column - (PB.int_of_step_short_id t.row_short_event_id) - in - PB.string_of_predicate_value case.static.test - in - let print_action t = - let column = PB.A.get blackboard.blackboard t.column_predicate_id in - let case = - PB.A.get - column - (PB.int_of_step_short_id t.row_short_event_id) + error, log_info, () + + let string_of_value value = + match value with + | State pb -> PB.string_of_predicate_value pb + | Counter i -> "Counter " ^ string_of_int i + | Pointer i -> string_of_pointer i + | Boolean bool -> + (match bool with + | None -> "?" + | Some true -> "Yes" + | Some false -> "No") + + let print_value log value = + match value with + | State pb -> PB.print_predicate_value log pb + | Counter i -> Loggers.fprintf log "Counter %i" i + | Pointer i -> print_pointer log i + | Boolean bool -> + Loggers.fprintf log "%s" + (match bool with + | None -> "?" + | Some true -> "Yes" + | Some false -> "No") + + let print_assignment parameter handler log_info error blackboard + (address, value) = + let error, log_info, () = + print_address parameter handler log_info error blackboard address + in + let _ = print_value (PB.CI.Po.K.H.get_debugging_channel parameter) value in + error, log_info + + let print_blackboard parameter handler log_info error blackboard = + let log = PB.CI.Po.K.H.get_debugging_channel parameter in + let () = Loggers.fprintf log "**BLACKBOARD**" in + let () = Loggers.print_newline log in + let () = + Loggers.fprintf log "%i wires, %i events" blackboard.n_predicate_id + blackboard.n_eid + in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log "*wires:*" in + let () = Loggers.print_newline log in + let err = ref error in + let () = + PB.A.iteri + (fun i array -> + let () = Loggers.fprintf log "%i" i in + let () = Loggers.print_newline log in + let () = + if PB.A.get blackboard.used_predicate_id i then ( + let () = Loggers.fprintf log "*wires %i: " i in + let () = Loggers.print_newline log in + let rec aux j error = + let () = Loggers.fprintf log "* %i:" j in + let () = Loggers.print_newline log in + let case = PB.A.get array j in + let () = print_case log case in + let j' = get_pointer_next case in + let j' = PB.int_of_step_short_id j' in + if j = j' then + error + else + aux j' error in - PB.string_of_predicate_value case.static.action - in - let string_eid error = - let () = - try - Loggers.print_as_logger - desc - (fun f -> Trace.print_step ~compact:true ~env:handler.PB.CI.Po.K.H.env f (PB.A.get blackboard.event eid)) - with - | Not_found -> Loggers.fprintf desc "Event:%i" eid + let error = + aux (PB.int_of_step_short_id pointer_before_blackboard) !err in - error - in - let error = print_case_fun desc row_precondition 1 None color string_eid error in - let error = print_case_fun desc row_postcondition 1 None color string_eid error in - let () = print_case desc row_precondition 2 None color "PRECONDITION" in - let () = print_case desc row_postcondition 2 None color "POSTCONDITION" in - let error,log_info = aux2 print_test print_action list error log_info in - let bool = - try - let cand = PB.A.get blackboard.event eid in - Trace.step_is_rule cand || - Trace.step_is_pert cand || - Trace.step_is_obs cand || - Trace.step_is_init cand - with Not_found -> false in - let error,stack = - if bool - then - let error = List.fold_left (fun error row -> print_case_fun desc row 0 None color string_eid error) error (List.rev stack) in - error,[] - else - error,row_precondition::row_postcondition::stack - in - aux (eid+1) error log_info stack - end + let _ = err := error in + () + ) else + () + in + Loggers.print_newline log) + blackboard.blackboard + in + let error = !err in + let () = Loggers.fprintf log "*stacks*" in + let () = Loggers.print_newline log in + let error, log_info = + List.fold_left + (fun (error, log_info) -> + print_assignment parameter handler log_info error blackboard) + (error, log_info) + (List.rev blackboard.current_stack) + in + let () = Loggers.print_newline log in + let _ = + List.fold_left + (fun (error, log_info) stack -> + let error, log_info = + List.fold_left + (fun (error, log_info) -> + print_assignment parameter handler log_info error blackboard) + (error, log_info) stack + in + let () = Loggers.print_newline log in + error, log_info) + (error, log_info) blackboard.stack + in + let () = Loggers.fprintf log "*selected_events*" in + let () = Loggers.print_newline log in + let () = + PB.A.iteri + (fun i bool -> + match bool with + | None -> () + | Some b -> + let () = + Loggers.fprintf log " Event:%i (%s)" i + (if b then + "KEPT" + else + "REMOVED") + in + Loggers.print_newline log) + blackboard.selected_events + in + let () = Loggers.fprintf log "*unsolved_events*" in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log " %i" blackboard.n_unresolved_events in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log "*weight of predicate_id*" in + let () = Loggers.print_newline log in + let () = + PB.A.iteri + (fun a b -> + let () = Loggers.fprintf log " %i:%i" a b in + Loggers.print_newline log) + blackboard.weigth_of_predicate_id + in + let () = Loggers.fprintf log "*weight of predicate_id_by_level*" in + let () = + Priority.LevelMap.iter + (fun l -> + let () = + Loggers.fprintf log " Level:%s" (Priority.string_of_level l) + in + let () = Loggers.print_newline log in + PB.A.iteri (fun a b -> + let () = Loggers.fprintf log " %i:%i" a b in + Loggers.print_newline log)) + blackboard.weigth_of_predicate_id_by_level + in + let () = Loggers.fprintf log "**" in + let () = Loggers.print_newline log in + error, log_info, () + + (** propagation request *) + + let add_event eid (pid, seid) array level unsolved = + let event_case_address = build_event_case_address pid seid in + let old = PB.A.get array (PB.int_of_step_id eid) in + let unsolved = + Priority.LevelMap.add level + (Priority.LevelMap.find_default 0 level unsolved + 1) + unsolved + in + PB.A.set array (PB.int_of_step_id eid) (event_case_address :: old), unsolved + + let empty_stack = [] + + let import ?heuristic:_ parameter handler log_info error pre_blackboard = + let error, log_info, n_predicates = + PB.n_predicates parameter handler log_info error pre_blackboard + in + let error, log_info, n_events = + PB.n_events parameter handler log_info error pre_blackboard + in + let stack = [] in + let current_stack = empty_stack in + let event_case_list = PB.A.make n_events [] in + let n_seid = PB.A.make n_predicates 0 in + let unsolved_by_level = Priority.LevelMap.empty in + let blackboard = PB.A.make n_predicates (PB.A.make 1 dummy_case_info) in + let weigth_of_predicate_id_by_level = + let rec aux level_opt map = + match level_opt with + | None -> map + | Some level -> + aux (Priority.higher level) + (Priority.LevelMap.add level (PB.A.make 0 0) map) in - let error,log_info = aux 0 error log_info [] in - let () = Loggers.fprintf desc "End Sub" in - let () = Loggers.print_newline desc in - let () = close_out desc_chan in - error,log_info,() - - let record_modif _parameter _handler error case_address case_value blackboard = - error, - {blackboard - with current_stack = (case_address,case_value)::blackboard.current_stack} - - let refine parameter handler log_info error case_address case_value blackboard = - let error,log_info,old = get parameter handler log_info error case_address blackboard in - if case_value = old - then - let error,log_info = - if debug_mode - then - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "@.***@.REFINE_VALUE@.Value before: " in - let error,log_info,() = print_case_address parameter handler log_info error blackboard case_address in - let () = print_case_value parameter old in - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "@.New value: " in - let () = print_case_value parameter case_value in - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "@.IGNORED***@." in - error,log_info - else - error,log_info - in - error,log_info,(blackboard,Ignore) - else - let error,log_info,bool = strictly_more_refined parameter handler log_info error old case_value in - if bool - then - let error,log_info = - if debug_mode - then - let () = - Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) - "@.***@.REFINE_VALUE@.Value before: " + aux (Some Priority.lowest) Priority.LevelMap.empty + in + let inc_depth level p_id = + match + Priority.LevelMap.find_option level weigth_of_predicate_id_by_level + with + | Some a -> + let old = try PB.A.get a p_id with Not_found -> 0 in + PB.A.set a p_id (old + 1) + | None -> () + in + + let weigth_of_predicate_id = PB.A.make 0 0 in + let last_linked_event_of_predicate_id = + PB.A.make n_predicates PB.zero_step_short_id + in + let error, log_info = + let rec aux1 p_id log_info error = + if p_id < 0 then + error, log_info + else ( + let error, log_info, size = + PB.n_events_per_predicate parameter handler log_info error + pre_blackboard p_id + in + let size = size + 1 in + let _ = + PB.A.set last_linked_event_of_predicate_id p_id + (PB.step_short_id_of_int (size - 1)) + in + let _ = PB.A.set weigth_of_predicate_id p_id (size - 2) in + let _ = PB.A.set n_seid p_id size in + let error, log_info, list = + PB.event_list_of_predicate parameter handler log_info error + pre_blackboard p_id + in + let array = PB.A.make size dummy_case_info in + let _ = PB.A.set blackboard p_id array in + let rec aux2 seid l log_info = + match l with + | [] -> + let info = + { + dynamic = + { + pointer_previous = PB.zero_step_short_id; + pointer_next = PB.inc_step_short_id PB.zero_step_short_id; + state_after = PB.undefined; + selected = Some true; + }; + static = + { + row_short_id = PB.zero_step_short_id; + event_id = PB.dummy_step_id; + test = PB.unknown; + action = PB.unknown; + }; + } in - let error,log_info,() = - print_case_address - parameter handler log_info error blackboard case_address + let _ = PB.A.set array 0 info in + let pred_size = + PB.dec_step_short_id (PB.step_short_id_of_int size) in - let () = print_case_value parameter old in - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) "@.New value: " + let info = + { + dynamic = + { + pointer_previous = pred_size; + pointer_next = pred_size; + state_after = PB.unknown; + selected = Some true; + }; + static = + { + row_short_id = pred_size; + event_id = PB.dummy_step_id; + test = PB.unknown; + action = PB.unknown; + }; + } in - let () = print_case_value parameter case_value in - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) "@.IGNORED***@." + let _ = PB.A.set array (size - 1) info in + log_info + | triple :: q -> + let info = init_info p_id seid (size - 1) triple in + let eid = get_eid_of_triple triple in + let error, log_info, _events = + PB.get_pre_event parameter handler log_info error pre_blackboard + in + let _error, log_info, level = + PB.get_level_of_event parameter handler log_info error + pre_blackboard eid + in + let () = inc_depth level p_id in + let (), _ = + add_event eid (p_id, seid) event_case_list level + Priority.LevelMap.empty in - error,log_info - else - error,log_info + let () = PB.A.set array (PB.int_of_step_short_id seid) info in + aux2 (PB.dec_step_short_id seid) q log_info in - error,log_info,(blackboard,Ignore) - else - let error,log_info,bool = strictly_more_refined parameter handler log_info error case_value old + let log_info = + aux2 (PB.step_short_id_of_int (size - 2)) list log_info in - if bool - then - let error,log_info,blackboard = set parameter handler log_info error case_address case_value blackboard in - let error,blackboard = record_modif parameter handler error case_address old blackboard in - let error,log_info = - if debug_mode - then - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) - "@.***@.REFINE_VALUE@.Value before: " - in - let error,log_info,() = - print_case_address - parameter handler log_info error blackboard case_address - in - let () = print_case_value parameter old in - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) - "@.New value: " - in - let () = print_case_value parameter case_value in - let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) "@.SUCCESS***@." in - error,log_info - else - error,log_info + aux1 (p_id - 1) log_info error + ) + in + aux1 (n_predicates - 1) log_info error + in + let error, log_info, forced_events = + PB.mandatory_events parameter handler log_info error pre_blackboard + in + let error, log_info, event = + PB.get_pre_event parameter handler log_info error pre_blackboard + in + let error, log_info, unsolved_by_level = + let rec aux k error log_info map = + if k = 0 then + error, log_info, map + else ( + let error, log_info, level = + PB.get_level_of_event parameter handler log_info error + pre_blackboard (PB.step_id_of_int k) + in + let map = + Priority.LevelMap.add level + (Priority.LevelMap.find_default 0 level map + 1) + map + in + aux (k - 1) error log_info map + ) + in + aux n_events error log_info unsolved_by_level + in + let error, log_info, side_effects = + PB.get_side_effect parameter handler log_info error pre_blackboard + in + let error, log_info, fictitious_obs = + PB.get_fictitious_observable parameter handler log_info error + pre_blackboard + in + let b = + { + event; + side_effect_of_event = side_effects; + pre_column_map_inv = PB.get_pre_column_map_inv pre_blackboard; + level_of_event = PB.levels pre_blackboard; + forced_events; + n_eid = n_events; + n_seid; + event_case_list; + last_linked_event_of_predicate_id; + n_predicate_id = n_predicates; + current_stack; + stack; + blackboard; + selected_events = PB.A.make n_events None; + weigth_of_predicate_id; + weigth_of_predicate_id_by_level; + used_predicate_id = PB.A.make n_predicates true; + n_unresolved_events = n_events; + n_unresolved_events_by_level = unsolved_by_level; + fictitious_observable = fictitious_obs; + } + in + error, log_info, b + + let exist_case parameter handler log_info error blackboard case_address = + let error, log_info, info = + get_case parameter handler log_info error case_address blackboard + in + error, log_info, info.dynamic.selected + + let set_case parameter _handler log_info error case_address case_value + blackboard = + try + let _ = + PB.A.set + (PB.A.get blackboard.blackboard case_address.column_predicate_id) + (PB.int_of_step_short_id case_address.row_short_event_id) + case_value + in + error, log_info, blackboard + with _ -> + warn parameter log_info error __POS__ + ~message:"Dereferencing Null pointer" + (Failure "Dereferencing null pointer") blackboard + + let set parameter handler log_info error case_address case_value blackboard = + match case_address with + | N_unresolved_events_in_column_at_level (int, level) -> + (match case_value with + | Counter int2 -> + (match + Priority.LevelMap.find_option level + blackboard.weigth_of_predicate_id_by_level + with + | Some a -> + let () = PB.A.set a int int2 in + error, log_info, blackboard + | None -> + warn parameter log_info error __POS__ + ~message:"Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | Pointer _ | State _ | Boolean _ -> + warn parameter log_info error __POS__ + ~message:"Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | N_unresolved_events_in_column int -> + (match case_value with + | Counter int2 -> + let _ = PB.A.set blackboard.weigth_of_predicate_id int int2 in + error, log_info, blackboard + | Pointer _ | Boolean _ | State _ -> + warn parameter log_info error __POS__ + ~message:"Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | Pointer_to_next case_address -> + (match case_value with + | Pointer int2 -> + let error, log_info, old = + get_case parameter handler log_info error case_address blackboard + in + let case_value = + { old with dynamic = { old.dynamic with pointer_next = int2 } } + in + let error, log_info, blackboard = + set_case parameter handler log_info error case_address case_value + blackboard + in + error, log_info, blackboard + | Counter _ | Boolean _ | State _ -> + warn parameter log_info error __POS__ + ~message:"Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | Value_after case_address -> + (match case_value with + | State state -> + let error, log_info, old = + get_case parameter handler log_info error case_address blackboard + in + let case_value = + { old with dynamic = { old.dynamic with state_after = state } } + in + let error, log_info, blackboard = + set_case parameter handler log_info error case_address case_value + blackboard + in + error, log_info, blackboard + | Boolean _ | Counter _ | Pointer _ -> + warn parameter log_info error __POS__ + ~message:"set should not be called with value_after" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | Value_before _case_address -> + warn parameter log_info error __POS__ + ~message:"set should not be called with value_before" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard + | Pointer_to_previous case_address -> + (match case_value with + | Pointer int2 -> + let error, log_info, old = + get_case parameter handler log_info error case_address blackboard + in + let case_value = + { old with dynamic = { old.dynamic with pointer_previous = int2 } } + in + let error, log_info, blackboard = + set_case parameter handler log_info error case_address case_value + blackboard + in + error, log_info, blackboard + | Boolean _ | State _ | Counter _ -> + warn parameter log_info error __POS__ + ~message: + "set, line 896, Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | N_unresolved_events -> + (match case_value with + | Counter int -> + error, log_info, { blackboard with n_unresolved_events = int } + | Boolean _ | Pointer _ | State _ -> + warn parameter log_info error __POS__ + ~message: + "set, line 905, Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | N_unresolved_events_at_level level -> + (match case_value with + | Counter int -> + ( error, + log_info, + { + blackboard with + n_unresolved_events_by_level = + Priority.LevelMap.add level int + blackboard.n_unresolved_events_by_level; + } ) + | Boolean _ | State _ | Pointer _ -> + warn parameter log_info error __POS__ + ~message:"Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | Keep_event step_id -> + (match case_value with + | Boolean b -> + let _ = + PB.A.set blackboard.selected_events (PB.int_of_step_id step_id) b + in + error, log_info, blackboard + | Pointer _ | State _ | Counter _ -> + warn parameter log_info error __POS__ + ~message:"Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + | Exist case_address -> + (match case_value with + | Boolean b -> + let error, log_info, old = + get_case parameter handler log_info error case_address blackboard + in + let case_value = + { old with dynamic = { old.dynamic with selected = b } } + in + let error, log_info, blackboard = + set_case parameter handler log_info error case_address case_value + blackboard + in + error, log_info, blackboard + | Pointer _ | Counter _ | State _ -> + warn parameter log_info error __POS__ + ~message:"Incompatible address and value in function set" + (Failure "Incompatible address and value in function Blackboard.set") + blackboard) + + let is_selected_event _parameter _handler log_info error step_id blackboard = + ( error, + log_info, + PB.A.get blackboard.selected_events (PB.int_of_step_id step_id) ) + + let rec get parameter handler log_info error case_address blackboard = + match case_address with + | Keep_event step_id -> + ( error, + log_info, + Boolean + (PB.A.get blackboard.selected_events (PB.int_of_step_id step_id)) ) + | N_unresolved_events_in_column_at_level (int, level) -> + let n = + match + Priority.LevelMap.find_option level + blackboard.weigth_of_predicate_id_by_level + with + | Some a -> PB.A.get a int + | None -> 0 + in + error, log_info, Counter n + | N_unresolved_events_in_column int -> + error, log_info, Counter (PB.A.get blackboard.weigth_of_predicate_id int) + | Exist case_address -> + let error, log_info, case = + get_case parameter handler log_info error case_address blackboard + in + error, log_info, Boolean case.dynamic.selected + | Pointer_to_next case_address -> + let error, log_info, case = + get_case parameter handler log_info error case_address blackboard + in + error, log_info, Pointer case.dynamic.pointer_next + | Value_after case_address -> + let error, log_info, case = + get_case parameter handler log_info error case_address blackboard + in + error, log_info, State case.dynamic.state_after + | Value_before case_address -> + let error, log_info, case = + get_case parameter handler log_info error case_address blackboard + in + let pointer = case.dynamic.pointer_previous in + if is_null_pointer pointer then + warn parameter log_info error __POS__ + ~message:"Value before an unexisting element requested" + (Failure "Value before an unexisting element requested") + (State PB.undefined) + else + get parameter handler log_info error + (Value_after { case_address with row_short_event_id = pointer }) + blackboard + | Pointer_to_previous case_address -> + let error, log_info, case = + get_case parameter handler log_info error case_address blackboard + in + error, log_info, Pointer case.dynamic.pointer_previous + | N_unresolved_events -> + error, log_info, Counter blackboard.n_unresolved_events + | N_unresolved_events_at_level lvl -> + ( error, + log_info, + Counter + (Priority.LevelMap.find_default 0 lvl + blackboard.n_unresolved_events_by_level) ) + + let export_blackboard_to_xls parameter handler log_info error prefix int int2 + blackboard = + let file_name = + prefix ^ "_" ^ string_of_int int ^ "_" ^ string_of_int int2 ^ ".sxw" + in + let desc_chan = Kappa_files.open_out file_name in + let desc = Loggers.open_logger_from_channel ~mode:Loggers.XLS desc_chan in + let parameter = PB.CI.Po.K.H.set_logger parameter desc in + let ncolumns_left = 3 in + let nrows_head = 2 in + let row_of_precondition eid = nrows_head + (3 * eid) in + let row_of_postcondition eid = 1 + row_of_precondition eid in + let column_of_pid pid = pid + ncolumns_left in + let () = Loggers.fprintf desc "REM ***** BASIC *****" in + let () = Loggers.print_newline desc in + let colors = PB.A.make blackboard.n_eid None in + let backcolor log color = + match color with + | Some color -> + let r, g, b = Color.triple_of_color color in + let () = Loggers.fprintf log "C.CellBackColor = RGB(%i,%i,%i)" r g b in + let () = Loggers.print_newline log in + () + | None -> () + in + let textcolor log color = + match color with + | Some color -> + let r, g, b = Color.triple_of_color color in + let () = Loggers.fprintf log "C.CharColor = RGB(%i,%i,%i)" r g b in + Loggers.print_newline log + | None -> () + in + let getcell log row col = + let () = Loggers.fprintf log "C = S.getCellByPosition(%i,%i)" col row in + Loggers.print_newline log + in + let overline_case log row _col _color = + let () = Loggers.fprintf log "R=S.Rows(%i)" row in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log "R.TopBorder = withBord" in + Loggers.print_newline log + in + let print_case log row col color_font color_back string = + if string <> "" then ( + let () = getcell log row col in + let () = textcolor log color_font in + let () = backcolor log color_back in + let () = Loggers.fprintf log "C.setFormula(\"%s\")" string in + Loggers.print_newline log + ) + in + let print_case_fun log row col color_font color_back f error = + let () = getcell log row col in + let () = textcolor log color_font in + let () = backcolor log color_back in + let () = Loggers.fprintf log "C.setFormula(\"" in + let error = f error in + let () = Loggers.fprintf log "\")" in + let () = Loggers.print_newline log in + error + in + let () = Loggers.fprintf desc "Sub Main" in + let () = Loggers.print_newline desc in + let () = Loggers.print_newline desc in + let r, g, b = Color.triple_of_color Color.Black in + let () = + Loggers.fprintf desc "Dim withBord As New com.sun.star.table.BorderLine" + in + let () = Loggers.print_newline desc in + let () = + Loggers.fprintf desc "With withBord withBord.Color = RGB(%i,%i,%i)" r g b + in + let () = Loggers.print_newline desc in + let () = Loggers.fprintf desc "withBord.OuterLineWidth = 60" in + let () = Loggers.print_newline desc in + let () = Loggers.fprintf desc "End With" in + let () = Loggers.print_newline desc in + let () = Loggers.fprintf desc "S = ThisComponent.Sheets(0)" in + let () = Loggers.print_newline desc in + let _ = + match forced_events blackboard with + | [ (list, _) ] -> + List.iter + (fun eid -> PB.A.set colors (PB.int_of_step_id eid) (Some Color.Red)) + list + | _ -> () + in + let _ = + PB.A.iteri + (fun pid p_info -> + print_case_fun desc 0 (column_of_pid pid) None None + (fun _error -> PB.print_predicate_info desc p_info) + error) + blackboard.pre_column_map_inv + in + let rec aux eid error log_info stack = + if eid >= blackboard.n_eid then + error, log_info + else ( + let error, log_info, list = + case_list_of_eid parameter handler log_info error blackboard + (PB.step_id_of_int eid) + in + let row_precondition = row_of_precondition eid in + let row_postcondition = row_of_postcondition eid in + let color, maybekept = + match PB.A.get blackboard.selected_events eid with + | None -> PB.A.get colors eid, true + | Some true -> Some Color.Red, true + | Some false -> Some Color.Grey, false + in + let rec aux2 f g l error log_info = + match l with + | [] -> error, log_info + | t :: q -> + let _ = + overline_case desc row_postcondition + (column_of_pid t.column_predicate_id) + None in - error,log_info,(blackboard,Success) - else - let error,log_info = - if debug_mode - then - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) "@.***@.REFINE_VALUE@.Value before: " + let _ = + print_case desc row_precondition + (column_of_pid t.column_predicate_id) + None color (f t) + in + let _ = + print_case desc row_postcondition + (column_of_pid t.column_predicate_id) + None color (g t) + in + let error, log_info = + if maybekept then ( + let error, log_info, value_before = + try + let error, log_info, case_value = + get parameter handler log_info error (value_before t) + blackboard + in + error, log_info, string_of_value case_value + with Not_found -> error, log_info, "Undefined" in - let error,log_info,() = - print_case_address - parameter handler log_info error blackboard case_address + let _ = + print_case desc (row_precondition - 1) + (column_of_pid t.column_predicate_id) + (Some Color.Lightblue) None value_before in - let () = print_case_value parameter old in - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) - "@.New value: " + let error, log_info, value_after = + try + let error, log_info, case_value = + get parameter handler log_info error (value_after t) + blackboard + in + error, log_info, string_of_value case_value + with Not_found -> error, log_info, "Undefined" in - let () = print_case_value parameter case_value in - let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) "@.FAIL***@." + let _ = + print_case desc (row_postcondition + 1) + (column_of_pid t.column_predicate_id) + (Some Color.Lightblue) None value_after in - error,log_info - else - error,log_info + error, log_info + ) else + error, log_info in - error,log_info,(blackboard,Fail) - - let overwrite parameter handler log_info error case_address case_value blackboard = - let error,log_info,old = get parameter handler log_info error case_address blackboard in - if case_value = old - then - error,log_info,blackboard - else - let error,log_info,blackboard = set parameter handler log_info error case_address case_value blackboard in - let error,blackboard = record_modif parameter handler error case_address old blackboard in - error,log_info,blackboard - - let dec parameter handler log_info error case_address blackboard = - let error,log_info,old = get parameter handler log_info error case_address blackboard in - match old - with - | Counter k -> - if k=0 - then - error,log_info,blackboard - else - let error,log_info,blackboard = set parameter handler log_info error case_address (Counter (k-1)) blackboard in - let error,blackboard = record_modif parameter handler error case_address old blackboard in - error,log_info,blackboard - | Pointer _ | Boolean _ | State _ -> - warn - parameter log_info error __POS__ - ~message:"Wrong type of case value" - (Failure "Wrong type of case value") - blackboard - - let branch parameter handler log_info error blackboard = - let error,log_info = - if debug_mode - then + aux2 f g q error log_info + in + let print_test t = + let column = PB.A.get blackboard.blackboard t.column_predicate_id in + let case = + PB.A.get column (PB.int_of_step_short_id t.row_short_event_id) + in + PB.string_of_predicate_value case.static.test + in + let print_action t = + let column = PB.A.get blackboard.blackboard t.column_predicate_id in + let case = + PB.A.get column (PB.int_of_step_short_id t.row_short_event_id) + in + PB.string_of_predicate_value case.static.action + in + let string_eid error = let () = - Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) "*******@. * BRANCH *@.*******@." in - let error,log_info,() = print_blackboard parameter handler log_info error blackboard in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.inc_branch log_info in - error, - log_info, + try + Loggers.print_as_logger desc (fun f -> + Trace.print_step ~compact:true ~env:handler.PB.CI.Po.K.H.env f + (PB.A.get blackboard.event eid)) + with Not_found -> Loggers.fprintf desc "Event:%i" eid + in + error + in + let error = + print_case_fun desc row_precondition 1 None color string_eid error + in + let error = + print_case_fun desc row_postcondition 1 None color string_eid error + in + let () = print_case desc row_precondition 2 None color "PRECONDITION" in + let () = + print_case desc row_postcondition 2 None color "POSTCONDITION" + in + let error, log_info = + aux2 print_test print_action list error log_info + in + let bool = + try + let cand = PB.A.get blackboard.event eid in + Trace.step_is_rule cand || Trace.step_is_pert cand + || Trace.step_is_obs cand || Trace.step_is_init cand + with Not_found -> false + in + let error, stack = + if bool then ( + let error = + List.fold_left + (fun error row -> + print_case_fun desc row 0 None color string_eid error) + error (List.rev stack) + in + error, [] + ) else + error, row_precondition :: row_postcondition :: stack + in + aux (eid + 1) error log_info stack + ) + in + let error, log_info = aux 0 error log_info [] in + let () = Loggers.fprintf desc "End Sub" in + let () = Loggers.print_newline desc in + let () = close_out desc_chan in + error, log_info, () + + let record_modif _parameter _handler error case_address case_value blackboard + = + ( error, { - blackboard - with - stack = blackboard.current_stack::blackboard.stack ; - current_stack = [] - } - - let reset_last_branching parameter handler log_info error blackboard = - let error,log_info = - if debug_mode - then + blackboard with + current_stack = (case_address, case_value) :: blackboard.current_stack; + } ) + + let refine parameter handler log_info error case_address case_value blackboard + = + let error, log_info, old = + get parameter handler log_info error case_address blackboard + in + if case_value = old then ( + let error, log_info = + if debug_mode then ( let () = Loggers.fprintf - (PB.CI.Po.K.H.get_debugging_channel parameter) "*******@.* Cut *@.*******" + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.***@.REFINE_VALUE@.Value before: " in - let error,log_info,() = print_blackboard parameter handler log_info error blackboard in - error,log_info - else - error,log_info - in - let stack = blackboard.current_stack in - let error,log_info,blackboard = - List.fold_left - (fun (error,log_info,blackboard) (case_address,case_value) -> - set parameter handler log_info error case_address case_value blackboard) - (error,log_info,blackboard) - stack - in - let error,log_info = - if debug_mode - then + let error, log_info, () = + print_case_address parameter handler log_info error blackboard + case_address + in + let () = print_case_value parameter old in let () = Loggers.fprintf (PB.CI.Po.K.H.get_debugging_channel parameter) - "*******@.* After_Cut *@.*******" + "@.New value: " in - let error, log_info, () = - print_blackboard parameter handler log_info error blackboard in - error,log_info - else - error,log_info + let () = print_case_value parameter case_value in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.IGNORED***@." + in + error, log_info + ) else + error, log_info in - let log_info = StoryProfiling.StoryStats.inc_cut log_info in - match blackboard.stack - with - | [] -> error,log_info,{blackboard with current_stack = []} - | t::q -> - error,log_info,{blackboard with current_stack = t ; stack = q } - - let reset_init parameter handler log_info error blackboard = - let rec aux (error,log_info,blackboard) = - match blackboard.current_stack - with - | [] -> error,log_info,blackboard - | _ -> aux (reset_last_branching parameter handler log_info error blackboard) + error, log_info, (blackboard, Ignore) + ) else ( + let error, log_info, bool = + strictly_more_refined parameter handler log_info error old case_value in - let error,log_info,blackboard = aux (error,log_info,blackboard) in - let log_info = StoryProfiling.StoryStats.reset_log log_info in - error,log_info,blackboard - - (** output result*) - type result = (Trace.step * PB.CI.Po.K.side_effect) list - - (** iteration*) - let is_maximal_solution _parameter _handler log_info error blackboard = - error,log_info,blackboard.n_unresolved_events = 0 - - - (** exporting result*) - - let translate_blackboard _parameter _handler log_info error blackboard = - let array = blackboard.selected_events in - let step_array = blackboard.event in - let side_array = blackboard.side_effect_of_event in - let size = PB.A.length array in - let rec aux k list = - if k=size - then (List.rev list) - else - let bool = PB.A.get array k in - match bool - with - | None -> aux (k+1) list - | Some false -> aux (k+1) list - | Some true -> - begin - let step = - PB.A.get step_array k + if bool then ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.***@.REFINE_VALUE@.Value before: " + in + let error, log_info, () = + print_case_address parameter handler log_info error blackboard + case_address + in + let () = print_case_value parameter old in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.New value: " + in + let () = print_case_value parameter case_value in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.IGNORED***@." + in + error, log_info + ) else + error, log_info + in + error, log_info, (blackboard, Ignore) + ) else ( + let error, log_info, bool = + strictly_more_refined parameter handler log_info error case_value old + in + if bool then ( + let error, log_info, blackboard = + set parameter handler log_info error case_address case_value + blackboard + in + let error, blackboard = + record_modif parameter handler error case_address old blackboard + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.***@.REFINE_VALUE@.Value before: " in - let side = - PB.A.get side_array k + let error, log_info, () = + print_case_address parameter handler log_info error blackboard + case_address + in + let () = print_case_value parameter old in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.New value: " in - aux (k+1) ((step,side)::list) - end + let () = print_case_value parameter case_value in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.SUCCESS***@." + in + error, log_info + ) else + error, log_info + in + error, log_info, (blackboard, Success) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.***@.REFINE_VALUE@.Value before: " + in + let error, log_info, () = + print_case_address parameter handler log_info error blackboard + case_address + in + let () = print_case_value parameter old in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.New value: " + in + let () = print_case_value parameter case_value in + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "@.FAIL***@." + in + error, log_info + ) else + error, log_info + in + error, log_info, (blackboard, Fail) + ) + ) + ) + + let overwrite parameter handler log_info error case_address case_value + blackboard = + let error, log_info, old = + get parameter handler log_info error case_address blackboard + in + if case_value = old then + error, log_info, blackboard + else ( + let error, log_info, blackboard = + set parameter handler log_info error case_address case_value blackboard in - let list = aux 0 [] in - error,log_info,list - - let print_stack parameter handler log_info error blackboard = - let stack = blackboard.current_stack in - let log = (PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = - Loggers.fprintf log "Current_stack_level %i " (List.length stack) in - let error,log_info = - List.fold_left - (fun (error,log_info) i -> - let error = - print_assignment parameter handler log_info error blackboard i - in - let () = Loggers.fprintf log "@." in - error ) - (error,log_info) - (List.rev stack) in - let error,log_info = - List.fold_left - (fun (error,log_info) x -> - let () = Loggers.fprintf log "Other level %i " (List.length x) in - List.fold_left - (fun (error,log_info) -> - print_assignment parameter handler log_info error blackboard) (error,log_info) - (List.rev x)) - (error,log_info) - (List.rev blackboard.stack) + let error, blackboard = + record_modif parameter handler error case_address old blackboard in - error,log_info,() + error, log_info, blackboard + ) -let is_fictitious_obs blackboard eid = - Some eid = blackboard.fictitious_observable + let dec parameter handler log_info error case_address blackboard = + let error, log_info, old = + get parameter handler log_info error case_address blackboard + in + match old with + | Counter k -> + if k = 0 then + error, log_info, blackboard + else ( + let error, log_info, blackboard = + set parameter handler log_info error case_address + (Counter (k - 1)) + blackboard + in + let error, blackboard = + record_modif parameter handler error case_address old blackboard + in + error, log_info, blackboard + ) + | Pointer _ | Boolean _ | State _ -> + warn parameter log_info error __POS__ ~message:"Wrong type of case value" + (Failure "Wrong type of case value") blackboard + + let branch parameter handler log_info error blackboard = + let error, log_info = + if debug_mode then ( + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "*******@. * BRANCH *@.*******@." + in + let error, log_info, () = + print_blackboard parameter handler log_info error blackboard + in + error, log_info + ) else + error, log_info + in + let log_info = StoryProfiling.StoryStats.inc_branch log_info in + ( error, + log_info, + { + blackboard with + stack = blackboard.current_stack :: blackboard.stack; + current_stack = []; + } ) + + let reset_last_branching parameter handler log_info error blackboard = + let error, log_info = + if debug_mode then ( + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "*******@.* Cut *@.*******" + in + let error, log_info, () = + print_blackboard parameter handler log_info error blackboard + in + error, log_info + ) else + error, log_info + in + let stack = blackboard.current_stack in + let error, log_info, blackboard = + List.fold_left + (fun (error, log_info, blackboard) (case_address, case_value) -> + set parameter handler log_info error case_address case_value + blackboard) + (error, log_info, blackboard) + stack + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.fprintf + (PB.CI.Po.K.H.get_debugging_channel parameter) + "*******@.* After_Cut *@.*******" + in + let error, log_info, () = + print_blackboard parameter handler log_info error blackboard + in + error, log_info + ) else + error, log_info + in + let log_info = StoryProfiling.StoryStats.inc_cut log_info in + match blackboard.stack with + | [] -> error, log_info, { blackboard with current_stack = [] } + | t :: q -> + error, log_info, { blackboard with current_stack = t; stack = q } + + let reset_init parameter handler log_info error blackboard = + let rec aux (error, log_info, blackboard) = + match blackboard.current_stack with + | [] -> error, log_info, blackboard + | _ -> + aux (reset_last_branching parameter handler log_info error blackboard) + in + let error, log_info, blackboard = aux (error, log_info, blackboard) in + let log_info = StoryProfiling.StoryStats.reset_log log_info in + error, log_info, blackboard + + type result = (Trace.step * PB.CI.Po.K.side_effect) list + (** output result*) + + (** iteration*) + let is_maximal_solution _parameter _handler log_info error blackboard = + error, log_info, blackboard.n_unresolved_events = 0 + + (** exporting result*) + + let translate_blackboard _parameter _handler log_info error blackboard = + let array = blackboard.selected_events in + let step_array = blackboard.event in + let side_array = blackboard.side_effect_of_event in + let size = PB.A.length array in + let rec aux k list = + if k = size then + List.rev list + else ( + let bool = PB.A.get array k in + match bool with + | None -> aux (k + 1) list + | Some false -> aux (k + 1) list + | Some true -> + let step = PB.A.get step_array k in + let side = PB.A.get side_array k in + aux (k + 1) ((step, side) :: list) + ) + in + let list = aux 0 [] in + error, log_info, list + + let print_stack parameter handler log_info error blackboard = + let stack = blackboard.current_stack in + let log = PB.CI.Po.K.H.get_debugging_channel parameter in + let () = + Loggers.fprintf log "Current_stack_level %i " (List.length stack) + in + let error, log_info = + List.fold_left + (fun (error, log_info) i -> + let error = + print_assignment parameter handler log_info error blackboard i + in + let () = Loggers.fprintf log "@." in + error) + (error, log_info) (List.rev stack) + in + let error, log_info = + List.fold_left + (fun (error, log_info) x -> + let () = Loggers.fprintf log "Other level %i " (List.length x) in + List.fold_left + (fun (error, log_info) -> + print_assignment parameter handler log_info error blackboard) + (error, log_info) (List.rev x)) + (error, log_info) + (List.rev blackboard.stack) + in + error, log_info, () + let is_fictitious_obs blackboard eid = + Some eid = blackboard.fictitious_observable -let useless_predicate_id parameter handler log_info error blackboard list = - let n_events = blackboard.n_eid in - if Parameter.do_local_cut - then - begin + let useless_predicate_id parameter handler log_info error blackboard list = + let n_events = blackboard.n_eid in + if Parameter.do_local_cut then ( let event_array = PB.A.make n_events false in let kept_events = [] in let kept_events = List.fold_left (fun kept_events i -> - let _ = - PB.A.set event_array (PB.int_of_step_id i) true - in i::kept_events) - kept_events - list + let _ = PB.A.set event_array (PB.int_of_step_id i) true in + i :: kept_events) + kept_events list in let rec aux log_info error event_list kept_events = - match event_list - with - | [] -> error,log_info,kept_events - | eid::q -> - begin - if is_fictitious_obs blackboard eid - then - aux log_info error q kept_events - else - let list = - PB.A.get - blackboard.event_case_list - (PB.int_of_step_id eid) - in - let error,log_info,q,kept_events = - List.fold_left - (fun (error,log_info,q,kept_events) event_case_address -> - let error,log_info,case = get_case parameter handler log_info error event_case_address blackboard in - if PB.is_undefined case.static.test - then error,log_info,q,kept_events - else - let pointer = case.dynamic.pointer_previous in - let eid = - let rec scan_down pointer = - let prev_event_case_address = - {event_case_address with row_short_event_id = pointer} - in - let _error,_log_info,prev_case = - get_case parameter handler log_info error prev_event_case_address blackboard in - let prev_eid = prev_case.static.event_id in - if is_null_pointer_step_id prev_eid - then None - else - if PB.is_unknown prev_case.static.action - then - let pointer = prev_case.dynamic.pointer_previous in - scan_down pointer - else Some prev_eid - in - scan_down pointer - in - match - eid - with - | None -> error,log_info,q,kept_events - | Some prev_eid -> - let bool = - try - PB.A.get event_array (PB.int_of_step_id prev_eid) - with - | _ -> false - in - let q,kept_events = - if - bool - then - q,kept_events - else - let _ = - PB.A.set - event_array - (PB.int_of_step_id prev_eid) - true - in - prev_eid::q,prev_eid::kept_events - in error,log_info,q,kept_events) - (error,log_info,q,kept_events) - list - in - aux log_info error q kept_events - end - in - let error,log_info,rep = aux log_info error list kept_events in - error,log_info,List.sort compare rep,n_events-List.length rep - end - else - let events_to_keep = - let rec aux k list = - if k<0 then list - else aux (k-1) ((PB.step_id_of_int k)::list) - in - aux (n_events-1) [] - in - error, - log_info, - events_to_keep, - 0 - -let cut parameter handler log_info error blackboard list = - let error,log_info,cut_causal_flow,n_events_removed = useless_predicate_id parameter handler log_info error blackboard list in - let log_info = StoryProfiling.StoryStats.set_concurrent_event_detection_time log_info in - let log_info = StoryProfiling.StoryStats.set_step_time log_info in - let log_info = StoryProfiling.StoryStats.inc_k_cut_events n_events_removed log_info in - error,log_info,(blackboard,cut_causal_flow) - -let import ?heuristic parameter handler log_info error list = - let error,log_info,preblackboard = PB.init parameter handler log_info error in - let error,log_info,(preblackboard,_step_id,string,to_xls) = - match - parameter.PB.CI.Po.K.H.current_compression_mode - with - | None -> - warn - parameter log_info error __POS__ - ~message:"Compression mode has not been set up" - (Failure "Compression mode has not been set up.") (preblackboard,PB.zero_step_id,"None",false) - | Some Story_json.Strong -> - let error,log_info,(preblackboard,int) = - List.fold_left - (fun (error,log_info,(preblackboard,int)) refined_event -> - PB.add_step_up_to_iso parameter handler log_info error refined_event preblackboard int) - (error,log_info,(preblackboard,PB.zero_step_id)) - list + match event_list with + | [] -> error, log_info, kept_events + | eid :: q -> + if is_fictitious_obs blackboard eid then + aux log_info error q kept_events + else ( + let list = + PB.A.get blackboard.event_case_list (PB.int_of_step_id eid) + in + let error, log_info, q, kept_events = + List.fold_left + (fun (error, log_info, q, kept_events) event_case_address -> + let error, log_info, case = + get_case parameter handler log_info error event_case_address + blackboard + in + if PB.is_undefined case.static.test then + error, log_info, q, kept_events + else ( + let pointer = case.dynamic.pointer_previous in + let eid = + let rec scan_down pointer = + let prev_event_case_address = + { + event_case_address with + row_short_event_id = pointer; + } + in + let _error, _log_info, prev_case = + get_case parameter handler log_info error + prev_event_case_address blackboard + in + let prev_eid = prev_case.static.event_id in + if is_null_pointer_step_id prev_eid then + None + else if PB.is_unknown prev_case.static.action then ( + let pointer = prev_case.dynamic.pointer_previous in + scan_down pointer + ) else + Some prev_eid + in + scan_down pointer + in + match eid with + | None -> error, log_info, q, kept_events + | Some prev_eid -> + let bool = + try PB.A.get event_array (PB.int_of_step_id prev_eid) + with _ -> false + in + let q, kept_events = + if bool then + q, kept_events + else ( + let _ = + PB.A.set event_array + (PB.int_of_step_id prev_eid) + true + in + prev_eid :: q, prev_eid :: kept_events + ) + in + error, log_info, q, kept_events + )) + (error, log_info, q, kept_events) + list + in + aux log_info error q kept_events + ) in - error,log_info,(preblackboard,int,Parameter.xlsstrongFileName,Parameter.dump_grid_before_strong_compression) - | Some Story_json.Weak | Some Story_json.Causal -> - let error,log_info,(preblackboard,int) = - List.fold_left - (fun (error,log_info,(preblackboard,int)) refined_event -> - PB.add_step parameter handler log_info error refined_event preblackboard int) - (error,log_info,(preblackboard,PB.zero_step_id)) - list + let error, log_info, rep = aux log_info error list kept_events in + error, log_info, List.sort compare rep, n_events - List.length rep + ) else ( + let events_to_keep = + let rec aux k list = + if k < 0 then + list + else + aux (k - 1) (PB.step_id_of_int k :: list) + in + aux (n_events - 1) [] in - error,log_info,(preblackboard,int,Parameter.xlsweakFileName,Parameter.dump_grid_before_weak_compression) - in - let error,log_info,preblackboard = - PB.finalize heuristic parameter handler log_info error preblackboard - in - let error,log_info,blackboard = import parameter handler log_info error preblackboard in - let _ = Priority.n_story:=(!Priority.n_story)+1 in - let _ = Priority.n_branch:=1 in - let error,log_info,() = - if to_xls - then - export_blackboard_to_xls parameter handler log_info error string (!Priority.n_story) 0 blackboard - else - error,log_info,() - in - error,log_info,blackboard + error, log_info, events_to_keep, 0 + ) + let cut parameter handler log_info error blackboard list = + let error, log_info, cut_causal_flow, n_events_removed = + useless_predicate_id parameter handler log_info error blackboard list + in + let log_info = + StoryProfiling.StoryStats.set_concurrent_event_detection_time log_info + in + let log_info = StoryProfiling.StoryStats.set_step_time log_info in + let log_info = + StoryProfiling.StoryStats.inc_k_cut_events n_events_removed log_info + in + error, log_info, (blackboard, cut_causal_flow) -end:Blackboard) + let import ?heuristic parameter handler log_info error list = + let error, log_info, preblackboard = + PB.init parameter handler log_info error + in + let error, log_info, (preblackboard, _step_id, string, to_xls) = + match parameter.PB.CI.Po.K.H.current_compression_mode with + | None -> + warn parameter log_info error __POS__ + ~message:"Compression mode has not been set up" + (Failure "Compression mode has not been set up.") + (preblackboard, PB.zero_step_id, "None", false) + | Some Story_json.Strong -> + let error, log_info, (preblackboard, int) = + List.fold_left + (fun (error, log_info, (preblackboard, int)) refined_event -> + PB.add_step_up_to_iso parameter handler log_info error + refined_event preblackboard int) + (error, log_info, (preblackboard, PB.zero_step_id)) + list + in + ( error, + log_info, + ( preblackboard, + int, + Parameter.xlsstrongFileName, + Parameter.dump_grid_before_strong_compression ) ) + | Some Story_json.Weak | Some Story_json.Causal -> + let error, log_info, (preblackboard, int) = + List.fold_left + (fun (error, log_info, (preblackboard, int)) refined_event -> + PB.add_step parameter handler log_info error refined_event + preblackboard int) + (error, log_info, (preblackboard, PB.zero_step_id)) + list + in + ( error, + log_info, + ( preblackboard, + int, + Parameter.xlsweakFileName, + Parameter.dump_grid_before_weak_compression ) ) + in + let error, log_info, preblackboard = + PB.finalize heuristic parameter handler log_info error preblackboard + in + let error, log_info, blackboard = + import parameter handler log_info error preblackboard + in + let _ = Priority.n_story := !Priority.n_story + 1 in + let _ = Priority.n_branch := 1 in + let error, log_info, () = + if to_xls then + export_blackboard_to_xls parameter handler log_info error string + !Priority.n_story 0 blackboard + else + error, log_info, () + in + error, log_info, blackboard +end diff --git a/core/cflow/blackboard_generation.ml b/core/cflow/blackboard_generation.ml index 24ea60c054..02c621bc67 100644 --- a/core/cflow/blackboard_generation.ml +++ b/core/cflow/blackboard_generation.ml @@ -20,2813 +20,3406 @@ let debug_mode = false -module type PreBlackboard = -sig - module A:GenArray.GenArray - module CI:Pseudo_inverse.Cut_pseudo_inverse +module type PreBlackboard = sig + module A : GenArray.GenArray + module CI : Pseudo_inverse.Cut_pseudo_inverse type step_id - val zero_step_id: step_id - val dummy_step_id: step_id - val int_of_step_id: step_id -> int - val step_id_of_int: int -> step_id - val dec_step_id: step_id -> step_id - val inc_step_id: step_id -> step_id + + val zero_step_id : step_id + val dummy_step_id : step_id + val int_of_step_id : step_id -> int + val step_id_of_int : int -> step_id + val dec_step_id : step_id -> step_id + val inc_step_id : step_id -> step_id type step_short_id - val zero_step_short_id: step_short_id - val dummy_step_short_id: step_short_id - val int_of_step_short_id: step_short_id -> int - val step_short_id_of_int: int -> step_short_id - val inc_step_short_id: step_short_id -> step_short_id - val dec_step_short_id: step_short_id -> step_short_id -(** blackboard predicates*) + val zero_step_short_id : step_short_id + val dummy_step_short_id : step_short_id + val int_of_step_short_id : step_short_id -> int + val step_short_id_of_int : int -> step_short_id + val inc_step_short_id : step_short_id -> step_short_id + val dec_step_short_id : step_short_id -> step_short_id + + (** blackboard predicates*) type predicate_id = int type predicate_info type predicate_value - module C:(Cache.Cache with type O.t = predicate_value) + module C : Cache.Cache with type O.t = predicate_value + type pre_blackboard (*blackboard during its construction*) - type pre_blackboard (*blackboard during its construction*) + val weakening : predicate_value -> predicate_value list - val weakening: predicate_value -> predicate_value list - val conj: (predicate_value,predicate_value,predicate_value) CI.Po.K.H.binary - val disjunction: (predicate_value,predicate_value,predicate_value) CI.Po.K.H.binary + val conj : + (predicate_value, predicate_value, predicate_value) CI.Po.K.H.binary - val defined: predicate_value - val undefined: predicate_value - val unknown: predicate_value - val is_unknown: predicate_value -> bool - val is_undefined: predicate_value -> bool - val more_refined: predicate_value -> predicate_value -> bool - val compatible: predicate_value -> predicate_value -> bool - val strictly_more_refined: predicate_value -> predicate_value -> bool - val get_pre_column_map_inv: pre_blackboard -> predicate_info A.t + val disjunction : + (predicate_value, predicate_value, predicate_value) CI.Po.K.H.binary + + val defined : predicate_value + val undefined : predicate_value + val unknown : predicate_value + val is_unknown : predicate_value -> bool + val is_undefined : predicate_value -> bool + val more_refined : predicate_value -> predicate_value -> bool + val compatible : predicate_value -> predicate_value -> bool + val strictly_more_refined : predicate_value -> predicate_value -> bool + val get_pre_column_map_inv : pre_blackboard -> predicate_info A.t (** generation*) - val init: pre_blackboard CI.Po.K.H.zeroary - val add_step: (Trace.step,pre_blackboard,step_id,pre_blackboard * step_id) CI.Po.K.H.ternary - val add_step_up_to_iso: (Trace.step,pre_blackboard,step_id,pre_blackboard * step_id) CI.Po.K.H.ternary - val finalize: Priority.priorities option -> (pre_blackboard,pre_blackboard) CI.Po.K.H.unary + val init : pre_blackboard CI.Po.K.H.zeroary + + val add_step : + ( Trace.step, + pre_blackboard, + step_id, + pre_blackboard * step_id ) + CI.Po.K.H.ternary + + val add_step_up_to_iso : + ( Trace.step, + pre_blackboard, + step_id, + pre_blackboard * step_id ) + CI.Po.K.H.ternary + + val finalize : + Priority.priorities option -> + (pre_blackboard, pre_blackboard) CI.Po.K.H.unary (**pretty printing*) - val string_of_predicate_value: predicate_value -> string - val print_predicate_value: Loggers.t -> predicate_value -> unit - val print_preblackboard: (pre_blackboard,unit) CI.Po.K.H.unary + val string_of_predicate_value : predicate_value -> string + val print_predicate_value : Loggers.t -> predicate_value -> unit + val print_preblackboard : (pre_blackboard, unit) CI.Po.K.H.unary (**interface*) - val n_events: (pre_blackboard, int) CI.Po.K.H.unary - val n_predicates: (pre_blackboard, int) CI.Po.K.H.unary - val n_events_per_predicate: (pre_blackboard, int, predicate_id) CI.Po.K.H.binary - val event_list_of_predicate: (pre_blackboard, predicate_id, (step_id * int * predicate_value * predicate_value ) list) CI.Po.K.H.binary - val mandatory_events: (pre_blackboard, ((step_id list * unit Trace.Simulation_info.t option) list)) CI.Po.K.H.unary - val get_pre_event: (pre_blackboard, Trace.step A.t) CI.Po.K.H.unary - val get_side_effect: (pre_blackboard, CI.Po.K.side_effect A.t) CI.Po.K.H.unary - val get_fictitious_observable: (pre_blackboard, step_id option) CI.Po.K.H.unary - val get_level_of_event: (pre_blackboard, step_id, Priority.level) CI.Po.K.H.binary - val levels: pre_blackboard -> Priority.level A.t - val print_predicate_info: Loggers.t -> predicate_info -> unit -end + val n_events : (pre_blackboard, int) CI.Po.K.H.unary + val n_predicates : (pre_blackboard, int) CI.Po.K.H.unary -module Preblackboard = - (struct + val n_events_per_predicate : + (pre_blackboard, int, predicate_id) CI.Po.K.H.binary - (** Useful modules *) + val event_list_of_predicate : + ( pre_blackboard, + predicate_id, + (step_id * int * predicate_value * predicate_value) list ) + CI.Po.K.H.binary - module A = Mods.DynArray - module CI = Pseudo_inverse.Pseudo_inv + val mandatory_events : + ( pre_blackboard, + (step_id list * unit Trace.Simulation_info.t option) list ) + CI.Po.K.H.unary - let warn parameter log_info error pos ?message:(message="") exn default = - let error,x = - Exception.warn (CI.Po.K.H.get_kasa_parameters parameter) error pos ~message exn default - in - error,log_info,x - - (** blackboard matrix*) - - type step_id = int (** global id of an event *) - - let zero_step_id = 0 - let dummy_step_id = -1 - let int_of_step_id i = i - let step_id_of_int i = i - let dec_step_id i = i-1 - let inc_step_id i = i+1 - - type step_short_id = int (** position of an event on a wire *) - - let zero_step_short_id = 0 - let dummy_step_short_id = -1 - let int_of_step_short_id i = i - let step_short_id_of_int i = i - let inc_step_short_id i = i+1 - let dec_step_short_id i = i-1 - -(** blackboard predicates*) - - (** kind of events*) - type rule_type = - | Subs - | Dummy - | Init - | Observable - | Rule - | Side_effect_of of (step_id * (CI.Po.K.agent_id * Instantiation.site_name) list) - - type predicate_id = int (** wire identifiers *) - - type mutex = - | Lock_side_effect of step_id * CI.Po.K.agent_id * CI.Po.K.agent_id * Instantiation.site_name - | Lock_agent of step_id * CI.Po.K.agent_id - | Lock_rectangular of step_id * CI.Po.K.agent_id - | Lock_links of step_id * (CI.Po.K.agent_id * CI.Po.K.agent_id) - - (** wire labels *) - type predicate_info = - | Fictitious (*to handle with ambiguous site effects *) - | Here of CI.Po.K.agent_id - | Bound_site of CI.Po.K.agent_id * Instantiation.site_name - | Internal_state of CI.Po.K.agent_id * Instantiation.site_name - | Pointer of step_id * CI.Po.K.agent_id - | Mutex of mutex - | Link of step_id * CI.Po.K.agent_id * CI.Po.K.agent_id - - let _ = Link (0,0,0) (* do not remove, it will be necessary for dealing effectively with unary/binary rule *) - - type predicate_value = - | Counter of int - | Pointer_to_agent of Instantiation.agent_name - | Internal_state_is of CI.Po.K.internal_state - | Defined (** the wire does exist, but we do not know what the value is *) - | Undefined (** the wire does not exist yet *) - | Present (** for agent presence *) - | Free (** for binding sites *) - | Bound (** for binding sites (partial information) *) - | Bound_to of predicate_id * CI.Po.K.agent_id * Instantiation.agent_name * Instantiation.site_name - (** for bindinf sites (complete information) *) - | Bound_to_type of Instantiation.agent_name * Instantiation.site_name (** for binding sites (partial information *) - | Unknown (** for agent presence, internal states, binding states (partial information *) - - module C : Cache.Cache with type O.t = predicate_value = - Cache.Cache(struct type t = predicate_value - let compare = compare - let print _ _ = () end) - - let weakening p = - match p - with - | Pointer_to_agent _ | Counter _ | Internal_state_is _ | Present | Free | Bound -> [p;Defined] - | Bound_to (_,_,ag,site) -> [p;Bound_to_type (ag,site);Bound;Defined] - | Bound_to_type _ -> [p;Bound;Defined] - | Defined | Undefined -> [p] - | Unknown -> [] - - let defined = Defined - let undefined = Undefined - let unknown = Unknown - let is_unknown x = x=Unknown - let is_undefined x = x=Undefined - - (** maps and sets *) - - module PredicateSetMap = SetMap.Make (struct type t = predicate_info let compare = compare let print _ _ = () end) - module PredicateSet = PredicateSetMap.Set - module PredicateMap = PredicateSetMap.Map - module CaseValueSetMap = SetMap.Make (struct type t = predicate_value let compare = compare let print _ _ = () end) - module CaseValueSet = CaseValueSetMap.Set - module PredicateidSet = Mods.IntSet - module PredicateidMap = Mods.IntMap - module SidMap = Mods.IntMap - - module AgentIdMap = Mods.IntMap - module AgentId2Map = Mods.Int2Map - module AgentIdSet = Mods.IntSet - module AgentId2Set = Mods.Int2Set - module SiteIdSet = Mods.Int2Set - module SiteIdMap = Mods.Int2Map - - type pre_blackboard = - { - pre_fictitious_list: predicate_id list ; (** list of wire for mutual exclusions, the state must be undefined at the end of the trace *) - pre_steps_by_column: (step_short_id * (step_id * step_short_id * predicate_value * predicate_value) list) A.t; (** maps each wire to the last known value and the list of step (step id,test,action)*) - pre_kind_of_event: rule_type A.t; (** maps each event id to the kind of event *) - pre_event: Trace.step A.t; (** maps each event to the step *) - pre_nsteps: step_id; (**id of the last event *) - pre_ncolumn: predicate_id; (**id of the last wire *) - pre_column_map: predicate_id PredicateMap.t; (** maps each wire label to its wire id *) - pre_column_map_inv: predicate_info A.t; (** maps each wire id to its wire label *) - predicate_id_list_related_to_predicate_id: PredicateidSet.t A.t; (** maps each wire id for the presence of an agent to the set of wires for its attibute (useful, when an agent get removed, all its attributes get undefined *) - history_of_predicate_values_to_predicate_id: C.t A.t; (* maps each wire to the set of its previous states, this summarize the potential state of a site that is freed, so as to overapproximate the set of potential side effects*) - history_of_agent_ids_of_type: (CI.Po.K.agent_id list) A.t; - pre_observable_list: (step_id list * unit Trace.Simulation_info.t option) list ; - pre_side_effect_of_event: CI.Po.K.side_effect A.t; - pre_fictitious_observable: step_id option; (*id of the step that closes all the side-effect mutex *) - pre_level_of_event: Priority.level A.t; - } + val get_pre_event : (pre_blackboard, Trace.step A.t) CI.Po.K.H.unary - let levels b = b.pre_level_of_event - let get_pre_column_map_inv x = x.pre_column_map_inv - let get_pre_event _parameter _handler log_info error x = error,log_info,x.pre_event - - (** pretty printing *) - - let print_predicate_info log x = - match x - with - | Here i -> Loggers.fprintf log "Agent_Here %i" i - | Bound_site (i,s) -> Loggers.fprintf log "Binding_state (%i,%i)" i s - | Internal_state (i,s) -> Loggers.fprintf log "Internal_state (%i,%i)" i s - | Pointer (eid,id) -> Loggers.fprintf log "Pointer(eid:%i,ag_id:%i)" eid id - | Link (eid,id1,id2) -> Loggers.fprintf log "Link(eid:%i,%i-%i)" eid id1 id2 - | Mutex (Lock_agent (int,int2)) -> Loggers.fprintf log "Mutex (Step-id:%i,Agent_id:%i)" int int2 - | Mutex (Lock_rectangular (int,int2)) -> Loggers.fprintf log "Mutex_inv (Step-id:%i,Agent_id:%i)" int int2 - | Mutex (Lock_links(int,(int2,int3))) -> Loggers.fprintf log "Mutex_links (Step-id:%i,%i-%i)" int int2 int3 - | Mutex (Lock_side_effect (int,int2,int3,int4)) -> Loggers.fprintf log "Mutex_side_effect (Step-id:%i,%i/%i.%i)" int int2 int3 int4 - | Fictitious -> Loggers.fprintf log "Fictitious" - - let print_known log t x = - match t with - | Unknown -> () - | Pointer_to_agent _ | Counter _ | Internal_state_is _ | Present | Free - | Bound | Bound_to _ | Bound_to_type _ | Defined | Undefined -> - Loggers.fprintf log "%s" x - - let string_of_predicate_value x = - match x - with - | Counter int -> "Counter "^(string_of_int int) - | Defined -> "Defined" - | Internal_state_is internal_state -> - (string_of_int internal_state) - | Undefined -> - "Undefined" - | Present -> - "Present" - | Free -> - "Free" - | Bound -> - "Bound" - | Bound_to (id,agent_id,agent_name,site) -> - "Bound("^(string_of_int id)^","^(string_of_int agent_id)^"("^(string_of_int agent_name)^")@"^(string_of_int site)^")" - | Bound_to_type (agent,site)-> - "Bound("^(string_of_int agent)^"@"^(string_of_int site)^")" - | Pointer_to_agent (agent_id) -> - "Pointer("^(string_of_int agent_id)^")" - | Unknown -> "" - - let print_predicate_value log x = - Loggers.fprintf log "%s" (string_of_predicate_value x) - let print_predicate_id log blackboard i = - let predicate_info = A.get blackboard.pre_column_map_inv i in - let () = Loggers.fprintf log "Predicate: %i " i in - let () = print_predicate_info log predicate_info in - let () = Loggers.print_newline log in - () - - let print_preblackboard parameter _handler log_info error blackboard = - let log = CI.Po.K.H.get_debugging_channel parameter in - let () = Loggers.fprintf log "**PREBLACKBOARD**" in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log "* agent types *" in - let () = Loggers.print_newline log in - let () = - A.iteri - (fun name -> - let () = Loggers.fprintf log "Agent name: %i " name in - let () = Loggers.print_newline log in - List.iter - (fun x -> - let () = Loggers.fprintf log " id: %i " x in - let () = Loggers.print_newline log in ())) - blackboard.history_of_agent_ids_of_type - in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log "* steps by column *" in - let () = Loggers.print_newline log in - let () = - A.iteri - (fun id (nevents,list) -> - let () = print_predicate_id log blackboard id in - let () = Loggers.fprintf log "nevents: %i " nevents in - let () = Loggers.print_newline log in - let () = - List.iter - (fun (eid,seid,test,action) -> - let () = Loggers.fprintf log "Event id: %i " eid in - let () = Loggers.print_newline log in - let () = Loggers.fprintf log "Short id: %i " seid in - let () = Loggers.print_newline log in - let () = print_known log test "TEST: " in - let () = print_predicate_value log test in - let () = Loggers.print_newline log in - let () = print_known log action "ACTION: " in - let () = print_predicate_value log action in - let () = Loggers.print_newline log in - ()) - (List.rev list) - in - let () = Loggers.fprintf log "---" in - let () = Loggers.print_newline log in - ()) - blackboard.pre_steps_by_column - in - let () = Loggers.fprintf log "* Side effects *" in - let () = Loggers.print_newline log in - let () = A.iteri - (fun i list -> - let () = Loggers.fprintf log "event %i:, " i in - let () = CI.Po.K.print_side_effect log list in - ()) - blackboard.pre_side_effect_of_event in - let () = Loggers.fprintf log "*Predicate_id related to the predicate *" in - let () = Loggers.print_newline log in - let () = - A.iteri - (fun i s -> - let () = print_predicate_id log blackboard i in - let () = - PredicateidSet.iter - (fun s -> - let () = Loggers.fprintf log "%i" s in - Loggers.print_newline log) - s - in - let () = Loggers.fprintf log "---" in - let () = Loggers.print_newline log in - () - ) - blackboard.predicate_id_list_related_to_predicate_id - in - let () = Loggers.fprintf log "*Past values of a predicate*" in - let () = Loggers.print_newline log in - let () = - A.iteri - (fun i s -> - let () = print_predicate_id log blackboard i in - let () = - C.iter - (fun s -> print_predicate_value log s) - s - in - let () = Loggers.fprintf log "---" in - let () = Loggers.print_newline log in - () - ) - blackboard.history_of_predicate_values_to_predicate_id - in - let () = Loggers.fprintf log "*Observables*" in - let () = - List.iter - (fun (l,_) -> - let _ = List.iter (Loggers.fprintf log "%i,") l in - let _ = Loggers.print_newline log in - () - ) - blackboard.pre_observable_list - in - let () = Loggers.fprintf log "**" in - let () = Loggers.print_newline log in - error,log_info,() - - (** information lattice *) - - let strictly_more_refined x y = - match y - with - | Undefined - | Pointer_to_agent _ - | Counter _ - | Internal_state_is _ - | Present - | Free - | Bound_to (_) -> false - | Bound_to_type (ag,s) -> - begin - match x - with - | Bound_to(_,_,ag',s') when ag=ag' && s=s' -> true - | _ -> false - end - | Bound -> - begin - match x - with - | Bound_to _ | Bound_to_type _ -> true - | _ -> false - end - | Defined -> - begin - match x - with - | Unknown | Defined | Undefined -> false - | _ -> true - end - | Unknown -> - begin - match x - with - | Unknown -> false - | _ -> true - end - - let more_refined x y = x=y || strictly_more_refined x y - - let conj parameter _handler log_info error x y = - if more_refined x y then error, log_info, x - else - if strictly_more_refined y x then error, log_info, y - else - warn parameter log_info error __POS__ - ~message:"conj, Arguments have no greatest lower bound" - (Failure "Arguments have no greatest lower bound") Undefined - let compatible x y = - x=y || more_refined x y || more_refined y x - - let disjunction _parameter _handler log_info error x y = - error, log_info, - if x=y then x - else - match x,y - with - | Unknown,_ | _,Unknown | Undefined,_ | _,Undefined -> Unknown - | Defined,_ | _,Defined -> Defined - | Counter _,_ | _,Counter _ | Free,_ | _,Free | Present,_ | _,Present | Internal_state_is _,_ |_,Internal_state_is _ -> Defined - | Bound,_ | _,Bound -> Bound - | Bound_to_type (a,b), Bound_to (_,_,c,d) - | Bound_to (_,_,a,b),Bound_to (_,_,c,d) - | Bound_to (_,_,a,b),Bound_to_type (c,d) when a=c && b=d -> Bound_to_type(a,b) - | _ -> Bound + val get_side_effect : + (pre_blackboard, CI.Po.K.side_effect A.t) CI.Po.K.H.unary - (** predicate id allocation *) + val get_fictitious_observable : + (pre_blackboard, step_id option) CI.Po.K.H.unary - (** if a wire concerns an agent, which one it is *) - let agent_id_of_predicate x = - match x - with - | Here x -> Some x - | Bound_site (x,_) -> Some x - | Internal_state (x,_) -> Some x - | Pointer _ | Mutex _ | Link _ | Fictitious -> None + val get_level_of_event : + (pre_blackboard, step_id, Priority.level) CI.Po.K.H.binary + + val levels : pre_blackboard -> Priority.level A.t + val print_predicate_info : Loggers.t -> predicate_info -> unit +end +module Preblackboard : PreBlackboard = struct + (** Useful modules *) + + module A = Mods.DynArray + module CI = Pseudo_inverse.Pseudo_inv + + let warn parameter log_info error pos ?(message = "") exn default = + let error, x = + Exception.warn + (CI.Po.K.H.get_kasa_parameters parameter) + error pos ~message exn default + in + error, log_info, x + + (** blackboard matrix*) + + type step_id = int + (** global id of an event *) + + let zero_step_id = 0 + let dummy_step_id = -1 + let int_of_step_id i = i + let step_id_of_int i = i + let dec_step_id i = i - 1 + let inc_step_id i = i + 1 + + type step_short_id = int + (** position of an event on a wire *) + + let zero_step_short_id = 0 + let dummy_step_short_id = -1 + let int_of_step_short_id i = i + let step_short_id_of_int i = i + let inc_step_short_id i = i + 1 + let dec_step_short_id i = i - 1 + + (** blackboard predicates*) + + (** kind of events*) + type rule_type = + | Subs + | Dummy + | Init + | Observable + | Rule + | Side_effect_of of + (step_id * (CI.Po.K.agent_id * Instantiation.site_name) list) - let rec bind parameter handler log_info error blackboard _predicate predicate_id ag_id = - let error,log_info,blackboard,sid = allocate parameter handler log_info error blackboard (Here ag_id) + type predicate_id = int + (** wire identifiers *) + + type mutex = + | Lock_side_effect of + step_id * CI.Po.K.agent_id * CI.Po.K.agent_id * Instantiation.site_name + | Lock_agent of step_id * CI.Po.K.agent_id + | Lock_rectangular of step_id * CI.Po.K.agent_id + | Lock_links of step_id * (CI.Po.K.agent_id * CI.Po.K.agent_id) + + (** wire labels *) + type predicate_info = + | Fictitious (*to handle with ambiguous site effects *) + | Here of CI.Po.K.agent_id + | Bound_site of CI.Po.K.agent_id * Instantiation.site_name + | Internal_state of CI.Po.K.agent_id * Instantiation.site_name + | Pointer of step_id * CI.Po.K.agent_id + | Mutex of mutex + | Link of step_id * CI.Po.K.agent_id * CI.Po.K.agent_id + + let _ = Link (0, 0, 0) + (* do not remove, it will be necessary for dealing effectively with unary/binary rule *) + + type predicate_value = + | Counter of int + | Pointer_to_agent of Instantiation.agent_name + | Internal_state_is of CI.Po.K.internal_state + | Defined (** the wire does exist, but we do not know what the value is *) + | Undefined (** the wire does not exist yet *) + | Present (** for agent presence *) + | Free (** for binding sites *) + | Bound (** for binding sites (partial information) *) + | Bound_to of + predicate_id + * CI.Po.K.agent_id + * Instantiation.agent_name + * Instantiation.site_name + (** for bindinf sites (complete information) *) + | Bound_to_type of Instantiation.agent_name * Instantiation.site_name + (** for binding sites (partial information *) + | Unknown + (** for agent presence, internal states, binding states (partial information *) + + module C : Cache.Cache with type O.t = predicate_value = Cache.Cache (struct + type t = predicate_value + + let compare = compare + let print _ _ = () + end) + + let weakening p = + match p with + | Pointer_to_agent _ | Counter _ | Internal_state_is _ | Present | Free + | Bound -> + [ p; Defined ] + | Bound_to (_, _, ag, site) -> + [ p; Bound_to_type (ag, site); Bound; Defined ] + | Bound_to_type _ -> [ p; Bound; Defined ] + | Defined | Undefined -> [ p ] + | Unknown -> [] + + let defined = Defined + let undefined = Undefined + let unknown = Unknown + let is_unknown x = x = Unknown + let is_undefined x = x = Undefined + + (** maps and sets *) + + module PredicateSetMap = SetMap.Make (struct + type t = predicate_info + + let compare = compare + let print _ _ = () + end) + + module PredicateSet = PredicateSetMap.Set + module PredicateMap = PredicateSetMap.Map + + module CaseValueSetMap = SetMap.Make (struct + type t = predicate_value + + let compare = compare + let print _ _ = () + end) + + module CaseValueSet = CaseValueSetMap.Set + module PredicateidSet = Mods.IntSet + module PredicateidMap = Mods.IntMap + module SidMap = Mods.IntMap + module AgentIdMap = Mods.IntMap + module AgentId2Map = Mods.Int2Map + module AgentIdSet = Mods.IntSet + module AgentId2Set = Mods.Int2Set + module SiteIdSet = Mods.Int2Set + module SiteIdMap = Mods.Int2Map + + type pre_blackboard = { + pre_fictitious_list: predicate_id list; + (** list of wire for mutual exclusions, the state must be undefined at the end of the trace *) + pre_steps_by_column: + (step_short_id + * (step_id * step_short_id * predicate_value * predicate_value) list) + A.t; + (** maps each wire to the last known value and the list of step (step id,test,action)*) + pre_kind_of_event: rule_type A.t; + (** maps each event id to the kind of event *) + pre_event: Trace.step A.t; (** maps each event to the step *) + pre_nsteps: step_id; (**id of the last event *) + pre_ncolumn: predicate_id; (**id of the last wire *) + pre_column_map: predicate_id PredicateMap.t; + (** maps each wire label to its wire id *) + pre_column_map_inv: predicate_info A.t; + (** maps each wire id to its wire label *) + predicate_id_list_related_to_predicate_id: PredicateidSet.t A.t; + (** maps each wire id for the presence of an agent to the set of wires for its attibute (useful, when an agent get removed, all its attributes get undefined *) + history_of_predicate_values_to_predicate_id: C.t A.t; + (* maps each wire to the set of its previous states, this summarize the potential state of a site that is freed, so as to overapproximate the set of potential side effects*) + history_of_agent_ids_of_type: CI.Po.K.agent_id list A.t; + pre_observable_list: + (step_id list * unit Trace.Simulation_info.t option) list; + pre_side_effect_of_event: CI.Po.K.side_effect A.t; + pre_fictitious_observable: step_id option; + (*id of the step that closes all the side-effect mutex *) + pre_level_of_event: Priority.level A.t; + } + + let levels b = b.pre_level_of_event + let get_pre_column_map_inv x = x.pre_column_map_inv + + let get_pre_event _parameter _handler log_info error x = + error, log_info, x.pre_event + + (** pretty printing *) + + let print_predicate_info log x = + match x with + | Here i -> Loggers.fprintf log "Agent_Here %i" i + | Bound_site (i, s) -> Loggers.fprintf log "Binding_state (%i,%i)" i s + | Internal_state (i, s) -> Loggers.fprintf log "Internal_state (%i,%i)" i s + | Pointer (eid, id) -> Loggers.fprintf log "Pointer(eid:%i,ag_id:%i)" eid id + | Link (eid, id1, id2) -> + Loggers.fprintf log "Link(eid:%i,%i-%i)" eid id1 id2 + | Mutex (Lock_agent (int, int2)) -> + Loggers.fprintf log "Mutex (Step-id:%i,Agent_id:%i)" int int2 + | Mutex (Lock_rectangular (int, int2)) -> + Loggers.fprintf log "Mutex_inv (Step-id:%i,Agent_id:%i)" int int2 + | Mutex (Lock_links (int, (int2, int3))) -> + Loggers.fprintf log "Mutex_links (Step-id:%i,%i-%i)" int int2 int3 + | Mutex (Lock_side_effect (int, int2, int3, int4)) -> + Loggers.fprintf log "Mutex_side_effect (Step-id:%i,%i/%i.%i)" int int2 + int3 int4 + | Fictitious -> Loggers.fprintf log "Fictitious" + + let print_known log t x = + match t with + | Unknown -> () + | Pointer_to_agent _ | Counter _ | Internal_state_is _ | Present | Free + | Bound | Bound_to _ | Bound_to_type _ | Defined | Undefined -> + Loggers.fprintf log "%s" x + + let string_of_predicate_value x = + match x with + | Counter int -> "Counter " ^ string_of_int int + | Defined -> "Defined" + | Internal_state_is internal_state -> string_of_int internal_state + | Undefined -> "Undefined" + | Present -> "Present" + | Free -> "Free" + | Bound -> "Bound" + | Bound_to (id, agent_id, agent_name, site) -> + "Bound(" ^ string_of_int id ^ "," ^ string_of_int agent_id ^ "(" + ^ string_of_int agent_name ^ ")@" ^ string_of_int site ^ ")" + | Bound_to_type (agent, site) -> + "Bound(" ^ string_of_int agent ^ "@" ^ string_of_int site ^ ")" + | Pointer_to_agent agent_id -> "Pointer(" ^ string_of_int agent_id ^ ")" + | Unknown -> "" + + let print_predicate_value log x = + Loggers.fprintf log "%s" (string_of_predicate_value x) + + let print_predicate_id log blackboard i = + let predicate_info = A.get blackboard.pre_column_map_inv i in + let () = Loggers.fprintf log "Predicate: %i " i in + let () = print_predicate_info log predicate_info in + let () = Loggers.print_newline log in + () + + let print_preblackboard parameter _handler log_info error blackboard = + let log = CI.Po.K.H.get_debugging_channel parameter in + let () = Loggers.fprintf log "**PREBLACKBOARD**" in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log "* agent types *" in + let () = Loggers.print_newline log in + let () = + A.iteri + (fun name -> + let () = Loggers.fprintf log "Agent name: %i " name in + let () = Loggers.print_newline log in + List.iter (fun x -> + let () = Loggers.fprintf log " id: %i " x in + let () = Loggers.print_newline log in + ())) + blackboard.history_of_agent_ids_of_type + in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log "* steps by column *" in + let () = Loggers.print_newline log in + let () = + A.iteri + (fun id (nevents, list) -> + let () = print_predicate_id log blackboard id in + let () = Loggers.fprintf log "nevents: %i " nevents in + let () = Loggers.print_newline log in + let () = + List.iter + (fun (eid, seid, test, action) -> + let () = Loggers.fprintf log "Event id: %i " eid in + let () = Loggers.print_newline log in + let () = Loggers.fprintf log "Short id: %i " seid in + let () = Loggers.print_newline log in + let () = print_known log test "TEST: " in + let () = print_predicate_value log test in + let () = Loggers.print_newline log in + let () = print_known log action "ACTION: " in + let () = print_predicate_value log action in + let () = Loggers.print_newline log in + ()) + (List.rev list) + in + let () = Loggers.fprintf log "---" in + let () = Loggers.print_newline log in + ()) + blackboard.pre_steps_by_column + in + let () = Loggers.fprintf log "* Side effects *" in + let () = Loggers.print_newline log in + let () = + A.iteri + (fun i list -> + let () = Loggers.fprintf log "event %i:, " i in + let () = CI.Po.K.print_side_effect log list in + ()) + blackboard.pre_side_effect_of_event + in + let () = Loggers.fprintf log "*Predicate_id related to the predicate *" in + let () = Loggers.print_newline log in + let () = + A.iteri + (fun i s -> + let () = print_predicate_id log blackboard i in + let () = + PredicateidSet.iter + (fun s -> + let () = Loggers.fprintf log "%i" s in + Loggers.print_newline log) + s + in + let () = Loggers.fprintf log "---" in + let () = Loggers.print_newline log in + ()) + blackboard.predicate_id_list_related_to_predicate_id + in + let () = Loggers.fprintf log "*Past values of a predicate*" in + let () = Loggers.print_newline log in + let () = + A.iteri + (fun i s -> + let () = print_predicate_id log blackboard i in + let () = C.iter (fun s -> print_predicate_value log s) s in + let () = Loggers.fprintf log "---" in + let () = Loggers.print_newline log in + ()) + blackboard.history_of_predicate_values_to_predicate_id + in + let () = Loggers.fprintf log "*Observables*" in + let () = + List.iter + (fun (l, _) -> + let _ = List.iter (Loggers.fprintf log "%i,") l in + let _ = Loggers.print_newline log in + ()) + blackboard.pre_observable_list + in + let () = Loggers.fprintf log "**" in + let () = Loggers.print_newline log in + error, log_info, () + + (** information lattice *) + + let strictly_more_refined x y = + match y with + | Undefined | Pointer_to_agent _ | Counter _ | Internal_state_is _ | Present + | Free | Bound_to _ -> + false + | Bound_to_type (ag, s) -> + (match x with + | Bound_to (_, _, ag', s') when ag = ag' && s = s' -> true + | _ -> false) + | Bound -> + (match x with + | Bound_to _ | Bound_to_type _ -> true + | _ -> false) + | Defined -> + (match x with + | Unknown | Defined | Undefined -> false + | _ -> true) + | Unknown -> + (match x with + | Unknown -> false + | _ -> true) + + let more_refined x y = x = y || strictly_more_refined x y + + let conj parameter _handler log_info error x y = + if more_refined x y then + error, log_info, x + else if strictly_more_refined y x then + error, log_info, y + else + warn parameter log_info error __POS__ + ~message:"conj, Arguments have no greatest lower bound" + (Failure "Arguments have no greatest lower bound") Undefined + + let compatible x y = x = y || more_refined x y || more_refined y x + + let disjunction _parameter _handler log_info error x y = + ( error, + log_info, + if x = y then + x + else ( + match x, y with + | Unknown, _ | _, Unknown | Undefined, _ | _, Undefined -> Unknown + | Defined, _ | _, Defined -> Defined + | Counter _, _ + | _, Counter _ + | Free, _ + | _, Free + | Present, _ + | _, Present + | Internal_state_is _, _ + | _, Internal_state_is _ -> + Defined + | Bound, _ | _, Bound -> Bound + | Bound_to_type (a, b), Bound_to (_, _, c, d) + | Bound_to (_, _, a, b), Bound_to (_, _, c, d) + | Bound_to (_, _, a, b), Bound_to_type (c, d) + when a = c && b = d -> + Bound_to_type (a, b) + | _ -> Bound + ) ) + + (** predicate id allocation *) + + (** if a wire concerns an agent, which one it is *) + let agent_id_of_predicate x = + match x with + | Here x -> Some x + | Bound_site (x, _) -> Some x + | Internal_state (x, _) -> Some x + | Pointer _ | Mutex _ | Link _ | Fictitious -> None + + let rec bind parameter handler log_info error blackboard _predicate + predicate_id ag_id = + let error, log_info, blackboard, sid = + allocate parameter handler log_info error blackboard (Here ag_id) + in + let old_set = + try A.get blackboard.predicate_id_list_related_to_predicate_id sid + with Not_found -> PredicateidSet.empty + in + let new_set = PredicateidSet.add predicate_id old_set in + try + let _ = + A.set blackboard.predicate_id_list_related_to_predicate_id sid new_set in - let old_set = - try - A.get blackboard.predicate_id_list_related_to_predicate_id sid - with - Not_found -> - PredicateidSet.empty + error, log_info, blackboard + with Not_found -> + warn parameter log_info error __POS__ ~message:"bind, Out of bound access" + (Failure "bind") blackboard + + and allocate parameter handler log_info error blackboard predicate = + let ag_id = agent_id_of_predicate predicate in + let map = blackboard.pre_column_map in + let map_inv = blackboard.pre_column_map_inv in + match PredicateMap.find_option predicate map with + | Some sid -> error, log_info, blackboard, sid + | None -> + let sid' = blackboard.pre_ncolumn + 1 in + let map' = PredicateMap.add predicate sid' map in + let _ = A.set map_inv sid' predicate in + let map_inv' = map_inv in + let _ = + A.set blackboard.history_of_predicate_values_to_predicate_id sid' + (C.create parameter.CI.Po.K.H.cache_size) in - let new_set = - PredicateidSet.add predicate_id old_set + let blackboard = + { + blackboard with + pre_ncolumn = sid'; + pre_column_map = map'; + pre_column_map_inv = map_inv'; + } in - try - let _ = A.set blackboard.predicate_id_list_related_to_predicate_id sid new_set in - error, log_info, blackboard - with - Not_found -> - warn - parameter log_info error __POS__ - ~message:"bind, Out of bound access" - (Failure "bind") blackboard - and - allocate parameter handler log_info error blackboard predicate = - let ag_id = agent_id_of_predicate predicate in - let map = blackboard.pre_column_map in - let map_inv = blackboard.pre_column_map_inv in - match PredicateMap.find_option predicate map with - | Some sid -> error,log_info,blackboard,sid - | None -> - let sid'= blackboard.pre_ncolumn + 1 in - let map' = PredicateMap.add predicate sid' map in - let _ = A.set map_inv sid' predicate in - let map_inv' = map_inv in - let _ = A.set blackboard.history_of_predicate_values_to_predicate_id sid' (C.create parameter.CI.Po.K.H.cache_size) in - let blackboard = - {blackboard - with - pre_ncolumn = sid' ; - pre_column_map = map' ; - pre_column_map_inv = map_inv' - } - in - let error,log_info,blackboard = - match ag_id - with - | None -> - error, log_info, blackboard - | Some ag_id -> - bind parameter handler log_info error blackboard predicate sid' ag_id - in - error,log_info,blackboard,sid' - - let create_agent _parameter _handler error blackboard agent_name agent_id = - let old_list = - try - A.get blackboard.history_of_agent_ids_of_type agent_name - with - Not_found -> - [] + let error, log_info, blackboard = + match ag_id with + | None -> error, log_info, blackboard + | Some ag_id -> + bind parameter handler log_info error blackboard predicate sid' ag_id in - let new_list = agent_id::old_list in - let _ = A.set blackboard.history_of_agent_ids_of_type agent_name new_list in - error,blackboard - - let free_agent parameter handler log_info error blackboard agent_id = - let error,log_info,blackboard,predicate_id = - allocate parameter handler log_info error blackboard (Here agent_id) in - let error,log_info,set = - try - error,log_info,A.get blackboard.predicate_id_list_related_to_predicate_id predicate_id - with - | _ -> - warn - parameter log_info error __POS__ - ~message:"free_agent, Try to free an unexisting agent" - (Failure "free_agent") PredicateidSet.empty + error, log_info, blackboard, sid' + + let create_agent _parameter _handler error blackboard agent_name agent_id = + let old_list = + try A.get blackboard.history_of_agent_ids_of_type agent_name + with Not_found -> [] + in + let new_list = agent_id :: old_list in + let _ = A.set blackboard.history_of_agent_ids_of_type agent_name new_list in + error, blackboard + + let free_agent parameter handler log_info error blackboard agent_id = + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard (Here agent_id) + in + let error, log_info, set = + try + ( error, + log_info, + A.get blackboard.predicate_id_list_related_to_predicate_id + predicate_id ) + with _ -> + warn parameter log_info error __POS__ + ~message:"free_agent, Try to free an unexisting agent" + (Failure "free_agent") PredicateidSet.empty + in + let map = + PredicateidSet.fold + (fun predicate_id map -> + let predicate = A.get blackboard.pre_column_map_inv predicate_id in + PredicateMap.remove predicate map) + set blackboard.pre_column_map + in + error, log_info, { blackboard with pre_column_map = map } + + let free_agent_if_it_exists parameter handler log_info error blackboard + agent_id = + if PredicateMap.mem (Here agent_id) blackboard.pre_column_map then + free_agent parameter handler log_info error blackboard agent_id + else + error, log_info, blackboard + + let predicates_of_action_no_subs parameter handler log_info error blackboard + init action = + match action with + | Instantiation.Create (ag, interface) -> + let ag_id = CI.Po.K.agent_id_of_agent ag in + let agent_name = CI.Po.K.agent_name_of_agent ag in + let error, blackboard = + create_agent parameter handler error blackboard agent_name ag_id in - let map = - PredicateidSet.fold - (fun predicate_id map -> - let predicate = A.get blackboard.pre_column_map_inv predicate_id in - PredicateMap.remove predicate map - ) - set - blackboard.pre_column_map + let error, log_info, blackboard = + if init then + error, log_info, blackboard + else + free_agent_if_it_exists parameter handler log_info error blackboard + ag_id in - error,log_info,{blackboard with pre_column_map = map} - - let free_agent_if_it_exists parameter handler log_info error blackboard agent_id = - if PredicateMap.mem (Here agent_id) blackboard.pre_column_map - then free_agent parameter handler log_info error blackboard agent_id - else error,log_info,blackboard - - let predicates_of_action_no_subs parameter handler log_info error blackboard init action = - match action with - | Instantiation.Create (ag,interface) -> - let ag_id = CI.Po.K.agent_id_of_agent ag in - let agent_name = CI.Po.K.agent_name_of_agent ag in - let error,blackboard = create_agent parameter handler error blackboard agent_name ag_id in - let error,log_info,blackboard = - if init - then - error,log_info,blackboard - else - free_agent_if_it_exists parameter handler log_info error blackboard ag_id in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Here ag_id) in - List.fold_left - (fun (error,log_info,blackboard,list1,list2) (s_id,opt) -> - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Bound_site(ag_id,s_id)) in - let list1 = (predicate_id,Free)::list1 in - let list2 = (predicate_id,Undefined)::list2 in - match opt - with - | None -> error,log_info,blackboard,list1,list2 - | Some x -> - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Internal_state (ag_id,s_id)) in - error, - log_info, - blackboard, - (predicate_id,Internal_state_is x)::list1, - (predicate_id,Undefined)::list2 - ) - (error,log_info,blackboard,[predicate_id,Present],[predicate_id,Undefined]) - interface - | Instantiation.Mod_internal (site,int) -> - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Internal_state (CI.Po.K.agent_id_of_site site,CI.Po.K.site_name_of_site site)) in - error,log_info,blackboard,[predicate_id,Internal_state_is int],[] - | Instantiation.Bind_to (s1,s2) -> - let ag_id1 = CI.Po.K.agent_id_of_site s1 in - let ag_id2 = CI.Po.K.agent_id_of_site s2 in - let agent_name2 = CI.Po.K.agent_name_of_site s2 in - let site_id1 = CI.Po.K.site_name_of_site s1 in - let site_id2 = CI.Po.K.site_name_of_site s2 in - let error,log_info,blackboard,predicate_id1 = allocate parameter handler log_info error blackboard (Bound_site (ag_id1,site_id1)) in - let error,log_info,blackboard,predicate_id2 = allocate parameter handler log_info error blackboard (Bound_site (ag_id2,site_id2)) in - error,log_info,blackboard, - [predicate_id1,Bound_to (predicate_id2,ag_id2,agent_name2,site_id2)],[] - | Instantiation.Bind (s1,s2) -> - let ag_id1 = CI.Po.K.agent_id_of_site s1 in - let ag_id2 = CI.Po.K.agent_id_of_site s2 in - let agent_name1 = CI.Po.K.agent_name_of_site s1 in - let agent_name2 = CI.Po.K.agent_name_of_site s2 in - let site_id1 = CI.Po.K.site_name_of_site s1 in - let site_id2 = CI.Po.K.site_name_of_site s2 in - let error,log_info,blackboard,predicate_id1 = allocate parameter handler log_info error blackboard (Bound_site (ag_id1,site_id1)) in - let error,log_info,blackboard,predicate_id2 = allocate parameter handler log_info error blackboard (Bound_site (ag_id2,site_id2)) in - error,log_info,blackboard, - [predicate_id1,Bound_to (predicate_id2,ag_id2,agent_name2,site_id2); - predicate_id2,Bound_to (predicate_id1,ag_id1,agent_name1,site_id1)],[] - | Instantiation.Free s -> - let ag_id = CI.Po.K.agent_id_of_site s in - let site_id = CI.Po.K.site_name_of_site s in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Bound_site (ag_id,site_id)) in - error,log_info,blackboard,[predicate_id,Free],[] - | Instantiation.Remove ag -> - let ag_id = CI.Po.K.agent_id_of_agent ag in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Here ag_id) in - let error,log_info,blackboard = free_agent parameter handler log_info error blackboard ag_id in - let set = - A.get - blackboard.predicate_id_list_related_to_predicate_id - predicate_id - in - let error,blackboard,list = - PredicateidSet.fold - (fun predicateid (error,blackboard,list) -> - error,blackboard,(predicateid,Undefined)::list) - set - (error,blackboard,[predicate_id,Undefined]) - in - error,log_info,blackboard,list,[] - - let predicates_of_action_subs parameter handler log_info error blackboard init action = - match action with - | Instantiation.Create (ag,interface) -> - let ag_id = CI.Po.K.agent_id_of_agent ag in - let agent_name = CI.Po.K.agent_name_of_agent ag in - let error,blackboard = create_agent parameter handler error blackboard agent_name ag_id in - let error,log_info,blackboard = - if init - then - error,log_info,blackboard - else - free_agent_if_it_exists parameter handler log_info error blackboard ag_id - in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Here ag_id) in - List.fold_left - (fun (error,log_info,blackboard,list1,list2) (s_id,opt) -> - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Bound_site(ag_id,s_id)) in - let list1 = (predicate_id,Free)::list1 in - let list2 = (predicate_id,Undefined)::list2 in - match opt - with - | None -> error,log_info,blackboard,list1,list2 - | Some x -> - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Internal_state (ag_id,s_id)) in - error, - log_info, - blackboard, - (predicate_id,Internal_state_is x)::list1, - (predicate_id,Undefined)::list2 - ) - (error,log_info,blackboard,[predicate_id,Present],[predicate_id,Undefined]) - interface - | Instantiation.Mod_internal (site,int) -> - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Internal_state (CI.Po.K.agent_id_of_site site,CI.Po.K.site_name_of_site site)) in - error,log_info,blackboard,[predicate_id,Internal_state_is int],[] - | Instantiation.Bind_to (s1,s2) -> - let ag_id1 = CI.Po.K.agent_id_of_site s1 in - let ag_id2 = CI.Po.K.agent_id_of_site s2 in - let agent_name2 = CI.Po.K.agent_name_of_site s2 in - let site_id1 = CI.Po.K.site_name_of_site s1 in - let site_id2 = CI.Po.K.site_name_of_site s2 in - let error,log_info,blackboard,predicate_id1 = allocate parameter handler log_info error blackboard (Bound_site (ag_id1,site_id1)) in - let error,log_info,blackboard,predicate_id2 = allocate parameter handler log_info error blackboard (Bound_site (ag_id2,site_id2)) in - error,log_info,blackboard, - [predicate_id1,Bound_to (predicate_id2,ag_id2,agent_name2,site_id2)],[] - | Instantiation.Bind (s1,s2) -> - let ag_id1 = CI.Po.K.agent_id_of_site s1 in - let ag_id2 = CI.Po.K.agent_id_of_site s2 in - let agent_name1 = CI.Po.K.agent_name_of_site s1 in - let agent_name2 = CI.Po.K.agent_name_of_site s2 in - let site_id1 = CI.Po.K.site_name_of_site s1 in - let site_id2 = CI.Po.K.site_name_of_site s2 in - let error,log_info,blackboard,predicate_id1 = allocate parameter handler log_info error blackboard (Bound_site (ag_id1,site_id1)) in - let error,log_info,blackboard,predicate_id2 = allocate parameter handler log_info error blackboard (Bound_site (ag_id2,site_id2)) in - error,log_info,blackboard, - [predicate_id1,Bound_to (predicate_id2,ag_id2,agent_name2,site_id2); - predicate_id2,Bound_to (predicate_id1,ag_id1,agent_name1,site_id1)],[] - | Instantiation.Free s -> - let ag_id = CI.Po.K.agent_id_of_site s in - let site_id = CI.Po.K.site_name_of_site s in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Bound_site (ag_id,site_id)) in - error,log_info,blackboard,[predicate_id,Free],[] - | Instantiation.Remove ag -> - let ag_id = CI.Po.K.agent_id_of_agent ag in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Here ag_id) in - (* let error,blackboard = free_agent parameter handler error blackboard ag_id in *) - let set = - A.get - blackboard.predicate_id_list_related_to_predicate_id - predicate_id - in - let error,log_info,blackboard,list = - PredicateidSet.fold - (fun predicateid (error,log_info,blackboard,list) -> - error,log_info,blackboard,(predicateid,Undefined)::list) - set - (error,log_info,blackboard,[predicate_id,Undefined]) - in - error,log_info,blackboard,list,[] - - let predicates_of_action bool = - if bool then predicates_of_action_subs - else predicates_of_action_no_subs - - let predicates_of_test parameter handler log_info error blackboard test = - match test - with - | Instantiation.Is_Here (agent) -> - let ag_id = CI.Po.K.agent_id_of_agent agent in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Here ag_id) in - error,log_info,blackboard,[predicate_id,Present] - | Instantiation.Has_Internal(site,int) -> - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Internal_state (CI.Po.K.agent_id_of_site site,CI.Po.K.site_name_of_site site)) in - error,log_info,blackboard,[predicate_id,Internal_state_is int] - | Instantiation.Is_Free s -> - let ag_id = CI.Po.K.agent_id_of_site s in - let site_id = CI.Po.K.site_name_of_site s in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Bound_site (ag_id,site_id)) in - error,log_info,blackboard,[predicate_id,Free] - | Instantiation.Is_Bound_to (s1,s2) -> - let ag_id1 = CI.Po.K.agent_id_of_site s1 in - let ag_id2 = CI.Po.K.agent_id_of_site s2 in - let agent_name1 = CI.Po.K.agent_name_of_site s1 in - let agent_name2 = CI.Po.K.agent_name_of_site s2 in - let site_id1 = CI.Po.K.site_name_of_site s1 in - let site_id2 = CI.Po.K.site_name_of_site s2 in - let error,log_info,blackboard,predicate_id1 = allocate parameter handler log_info error blackboard (Bound_site (ag_id1,site_id1)) in - let error,log_info,blackboard,predicate_id2 = allocate parameter handler log_info error blackboard (Bound_site (ag_id2,site_id2)) in - error,log_info,blackboard, - [predicate_id1,Bound_to (predicate_id2,ag_id2,agent_name2,site_id2); - predicate_id2,Bound_to (predicate_id1,ag_id1,agent_name1,site_id1)] - | Instantiation.Is_Bound s -> - let ag_id = CI.Po.K.agent_id_of_site s in - let site_id = CI.Po.K.site_name_of_site s in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Bound_site (ag_id,site_id)) in - error,log_info,blackboard, - [predicate_id,Bound] - | Instantiation.Has_Binding_type (s,(agent_name,site_name)) -> - let ag_id = CI.Po.K.agent_id_of_site s in - let site_id = CI.Po.K.site_name_of_site s in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard (Bound_site (ag_id,site_id)) in - error,log_info,blackboard, - [predicate_id,Bound_to_type (agent_name,site_name)] - - let type_of_step x = - if Trace.step_is_obs x then Observable - else if Trace.step_is_init x then Init - else if Trace.step_is_rule x then Rule - else if Trace.step_is_subs x then Subs - else Dummy - - (** initialisation*) - let init _parameter _handler log_info error = - error, - log_info, - { - pre_side_effect_of_event = A.make 1 CI.Po.K.empty_side_effect; - pre_event = A.make 1 (Trace.dummy_step ""); - pre_fictitious_list = [] ; - pre_steps_by_column = A.make 1 (1,[]) ; - pre_nsteps = -1 ; - pre_ncolumn = -1 ; - pre_column_map = PredicateMap.empty ; - pre_column_map_inv = A.make 1 (Fictitious) ; - pre_kind_of_event = A.make 1 (Side_effect_of (-1,[])) ; - history_of_predicate_values_to_predicate_id = A.make 1 (C.create None); - history_of_agent_ids_of_type = A.make 1 []; - predicate_id_list_related_to_predicate_id = A.make 1 PredicateidSet.empty; - pre_observable_list = []; - pre_fictitious_observable = None ; - pre_level_of_event = A.make 1 Priority.highest ; - } - - let get_level_of_event parameter _handler log_info error blackboard eid = - try - error,log_info,A.get blackboard.pre_level_of_event eid - with - | Not_found -> - warn - parameter log_info error __POS__ - (Failure "UNknown event") Priority.highest - - let init_fictitious_action log_info error predicate_id blackboard = - let nsid = blackboard.pre_nsteps+1 in - let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in - let test = Undefined in - let action = Counter 0 in - let _ = A.set blackboard.pre_steps_by_column predicate_id (2,[nsid,1,test,action]) in - error,log_info,{blackboard with pre_nsteps = nsid} - - let init_fictitious_action_at_nsid log_info error predicate_id blackboard nsid = - let test = Undefined in - let action = Counter 0 in - let _ = A.set blackboard.pre_steps_by_column predicate_id (2,[nsid,1,test,action]) in - error,log_info,blackboard - - let init_fictitious_action log_info error predicate_id blackboard init_step = - match - init_step - with - | None -> - let error,log_info,blackboard = init_fictitious_action log_info error predicate_id blackboard in - error,log_info,blackboard,Some blackboard.pre_nsteps - | Some nsid -> - let error,log_info,blackboard = init_fictitious_action_at_nsid log_info error predicate_id blackboard nsid in - error,log_info,blackboard,init_step - - - let add_fictitious_action error test action predicate_id blackboard = - let nsid = blackboard.pre_nsteps in - let map = blackboard.pre_steps_by_column in - let value,list = A.get map predicate_id in - let value' = value+1 in - let _ = A.set map predicate_id (value',(nsid,value,test,action)::list) in - error,blackboard - - let side_effect parameter _handler log_info error predicate_target_id s site = - match s - with - | Defined | Counter _ | Internal_state_is _ | Undefined | Pointer_to_agent _ - | Present | Bound | Bound_to_type _ | Unknown -> - warn - parameter log_info error __POS__ - ~message:"Illegal state for a side-effects" - (Failure "Blackboard_generation.side_effect") [] - | Free -> - error,log_info,[predicate_target_id,None,(Free,Unknown)] - | Bound_to (pid,ag,ag_na,sname) -> - error,log_info,[predicate_target_id,None,(s,Unknown); - pid,Some ((ag,ag_na),sname),(Bound_to (predicate_target_id,CI.Po.K.agent_id_of_site site,CI.Po.K.agent_name_of_site site,CI.Po.K.site_name_of_site site),Free)] - - - let predicate_value_of_binding_state parameter _handler log_info error = function - | Instantiation.ANY -> error,log_info,Unknown - | Instantiation.FREE -> error,log_info,Free - | Instantiation.BOUND -> error,log_info,Bound - | Instantiation.BOUND_TYPE bt -> - error,log_info,Bound_to_type (CI.Po.K.agent_name_of_binding_type bt,CI.Po.K.site_name_of_binding_type bt) - | Instantiation.BOUND_to _ -> - warn - parameter log_info error __POS__ - ~message:"Illegal binding state in predicate_value_of_binding_state" (Failure "predicate_value_of_binding_state") Unknown - - let potential_target parameter handler log_info error blackboard site binding_state = - let agent_id = CI.Po.K.agent_id_of_site site in - let site_name = CI.Po.K.site_name_of_site site in - let error,log_info,blackboard,predicate_target_id = - allocate parameter handler log_info error blackboard (Bound_site (agent_id,site_name)) in - let former_states = - A.get blackboard.history_of_predicate_values_to_predicate_id predicate_target_id + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard (Here ag_id) in - match - parameter.CI.Po.K.H.current_compression_mode - with - | None | Some Story_json.Causal -> - begin - let s = C.last former_states in - match s with - | None -> error,log_info,blackboard,[] - | Some s -> - let error,log_info,bt = predicate_value_of_binding_state parameter handler log_info error binding_state in - if more_refined s bt - then - let error,log_info,l=side_effect parameter handler log_info error predicate_target_id s site in - error,log_info,blackboard,[l] - else - error,log_info,blackboard,[] - end - | Some (Story_json.Strong | Story_json.Weak) -> - begin - let error,log_info,bt = predicate_value_of_binding_state parameter handler log_info error binding_state in - let error,log_info,list = - C.fold - (fun s (error,log_info,list) -> - if more_refined s bt - then - let error,log_info,l=side_effect parameter handler log_info error predicate_target_id s site in - error,log_info,l::list - else - error,log_info,list - ) - former_states - (error,log_info,[]) - in - error,log_info,blackboard,list - end - - type data_structure_strong = - { - new_agents: AgentIdSet.t ; - old_agents: Instantiation.agent_name AgentIdMap.t; - old_agents_potential_substitution: CI.Po.K.agent_id list AgentIdMap.t; - sure_agents: AgentIdSet.t; - sure_links: AgentId2Set.t; - other_links: AgentId2Set.t; - sites_in_other_links: SiteIdSet.t; - sites_in_other_action_links: SiteIdSet.t; - other_links_test_sites: (CI.Po.K.agent_id) SiteIdMap.t; - other_links_action_sites: (CI.Po.K.agent_id) SiteIdMap.t; - sure_tests: Instantiation.concrete Instantiation.test list ; - sure_actions: Instantiation.concrete Instantiation.action list ; - create_actions: Instantiation.concrete Instantiation.action list ; - sure_side_effects: (Instantiation.concrete Instantiation.site*Instantiation.concrete Instantiation.binding_state) list; - other_agents_tests: Instantiation.concrete Instantiation.test list AgentIdMap.t ; - other_agents_actions: Instantiation.concrete Instantiation.action list AgentIdMap.t ; - other_links_tests: Instantiation.concrete Instantiation.test list AgentId2Map.t; - other_links_actions: Instantiation.concrete Instantiation.action list AgentId2Map.t ; - other_links_priority: AgentId2Set.t ; - other_agents_side_effects: (Instantiation.concrete Instantiation.site*Instantiation.concrete Instantiation.binding_state) list AgentIdMap.t ; - subs_agents_involved_in_links: AgentIdSet.t; - rule_agent_id_mutex: predicate_id AgentIdMap.t; - rule_agent_id_subs: predicate_id AgentIdMap.t; - mixture_agent_id_mutex: predicate_id AgentIdMap.t; - links_mutex: predicate_id AgentId2Map.t; - removed_agents: AgentIdSet.t ; - removed_sites_in_other_links: SiteIdSet.t ; - } - - let init_data_structure_strong = - { - new_agents = AgentIdSet.empty; - old_agents = AgentIdMap.empty; - old_agents_potential_substitution = AgentIdMap.empty; - sure_agents = AgentIdSet.empty; - sure_links = AgentId2Set.empty; - other_links = AgentId2Set.empty; - other_links_test_sites = SiteIdMap.empty; - other_links_action_sites = SiteIdMap.empty; - sites_in_other_links = SiteIdSet.empty; - sites_in_other_action_links = SiteIdSet.empty; - sure_tests = []; - sure_actions = []; - create_actions = []; - sure_side_effects = []; - other_agents_tests = AgentIdMap.empty; - other_agents_actions = AgentIdMap.empty; - other_links_priority = AgentId2Set.empty ; - other_links_tests = AgentId2Map.empty; - other_links_actions = AgentId2Map.empty; - other_agents_side_effects = AgentIdMap.empty; - subs_agents_involved_in_links = AgentIdSet.empty; - rule_agent_id_mutex = AgentIdMap.empty; - rule_agent_id_subs = AgentIdMap.empty; - links_mutex = AgentId2Map.empty; - mixture_agent_id_mutex = AgentIdMap.empty; - removed_agents = AgentIdSet.empty ; - removed_sites_in_other_links = SiteIdSet.empty ; - } - - let print_data_structure _parameter _handler error _data = - (* let stderr = parameter.CI.Po.K.H.out_channel_err in - let sigs = Model.signatures handler.CI.Po.K.H.env in - let _ = Format.fprintf stderr "New agents: @." in - let _ = - AgentIdSet.iter (Format.fprintf stderr " %i @.") data.new_agents - in - let _ = Format.fprintf stderr "Old agents: @." in - let _ = - AgentIdMap.iter (Format.fprintf stderr " id:%i: type:%i @.") data.old_agents - in - let _ = Format.fprintf stderr "Old agents implied in links: @." in - let _ = - AgentIdSet.iter (Format.fprintf stderr " %i @.") data.subs_agents_involved_in_links - in - let _ = Format.fprintf stderr "Tested_links_map: @." in - let _ = - SiteIdMap.iter (fun (a,b) -> Format.fprintf stderr " %i.%i -> %i @." a b ) data.other_links_test_sites in - let _ = Format.fprintf stderr "Modified_links_map: @." in - let _ = - SiteIdMap.iter (fun (a,b) -> Format.fprintf stderr " %i.%i -> %i @." a b ) data.other_links_action_sites - in - let _ = Format.fprintf stderr "Potential substitution: @." in - let _ = - AgentIdMap.iter - (fun id l -> - let _ = - Format.fprintf stderr " id:%i@." id - in - List.iter (Format.fprintf stderr " %i@.") l) - data.old_agents_potential_substitution - in - let _ = Format.fprintf stderr "Sure agents:@." in - let _ = - AgentIdSet.iter (Format.fprintf stderr " %i@.") data.sure_agents - in - let () = - Format.fprintf stderr "Sure tests:@[%a@]@." - (Pp.list Pp.space (Instantiation.print_concrete_test ~sigs)) - data.sure_tests in - let () = - Format.fprintf stderr "Tests to be substituted:@[@,%a%a@]@." - (Pp.set ~trailing:Pp.space AgentIdMap.bindings Pp.space - (fun f (id,l) -> - Format.fprintf - f"%i@,%a" id - (Pp.list Pp.space (Instantiation.print_concrete_test ~sigs)) - l - )) - data.other_agents_tests - (Pp.set AgentId2Map.bindings Pp.space - (fun f ((id1,id2),l) -> - Format.fprintf - f "(%i,%i)@,%a" id1 id2 - (Pp.list Pp.space (Instantiation.print_concrete_test ~sigs)) - l)) - data.other_links_tests in - let () = - Format.fprintf stderr "Sure actions:@[%a@]@." - (Pp.list Pp.space (Instantiation.print_concrete_action ~sigs)) - data.sure_actions in - let () = - Format.fprintf stderr "Actions to be substituted:@[@,%a%a@]@." - (Pp.set ~trailing:Pp.space AgentIdMap.bindings Pp.space - (fun f (id,l) -> - Format.fprintf - f"%i@,%a" id - (Pp.list Pp.space (Instantiation.print_concrete_action ~sigs)) - l - )) - data.other_agents_actions - (Pp.set AgentId2Map.bindings Pp.space - (fun f ((id1,id2),l) -> - Format.fprintf - f "(%i,%i)@,%a" id1 id2 - (Pp.list Pp.space (Instantiation.print_concrete_action ~sigs)) - l)) - data.other_links_actions in - let _ = Format.fprintf stderr "Sure side_effects @." in - let _ = - List.iter - (CI.Po.K.print_side stderr handler " ") - data.sure_side_effects + List.fold_left + (fun (error, log_info, blackboard, list1, list2) (s_id, opt) -> + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id, s_id)) in - let _ = Format.fprintf stderr "Side effect to be substituted: @." in - let _ = - AgentIdMap.iter - (fun id l -> - let _ = Format.fprintf stderr " %i@." id in - let _ = - List.iter - (CI.Po.K.print_side stderr handler " ") - l - in ()) - data.other_agents_side_effects - in*) - error - - - let add_site_in_other_test_links site data_structure = - { - data_structure - with sites_in_other_links = SiteIdSet.add site data_structure.sites_in_other_links - } - let add_site_in_other_action_links site data_structure = - let data_structure = add_site_in_other_test_links site data_structure in - { - data_structure - with sites_in_other_action_links = SiteIdSet.add site data_structure.sites_in_other_action_links - } - - let mem_site_in_other_action_links site data_structure = - SiteIdSet.mem site data_structure.sites_in_other_action_links - - let add_sure_test test data_structure = - { - data_structure - with sure_tests = test::data_structure.sure_tests - } - let add_subs_test test ag_id data_structure = - let old = - AgentIdMap.find_default [] ag_id data_structure.other_agents_tests + let list1 = (predicate_id, Free) :: list1 in + let list2 = (predicate_id, Undefined) :: list2 in + match opt with + | None -> error, log_info, blackboard, list1, list2 + | Some x -> + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Internal_state (ag_id, s_id)) + in + ( error, + log_info, + blackboard, + (predicate_id, Internal_state_is x) :: list1, + (predicate_id, Undefined) :: list2 )) + ( error, + log_info, + blackboard, + [ predicate_id, Present ], + [ predicate_id, Undefined ] ) + interface + | Instantiation.Mod_internal (site, int) -> + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Internal_state + (CI.Po.K.agent_id_of_site site, CI.Po.K.site_name_of_site site)) in - { - data_structure - with - other_agents_tests = - AgentIdMap.add ag_id (test::old) data_structure.other_agents_tests - } - let add_subs_test_link test link data_structure = - let a,b=fst link,snd link in - let link = if a < b then link else b,a in - let data_structure,old = - match AgentId2Map.find_option link data_structure.other_links_tests with - | Some x -> data_structure,x - | None -> - {data_structure - with - other_links = AgentId2Set.add link data_structure.other_links; - }, - [] + error, log_info, blackboard, [ predicate_id, Internal_state_is int ], [] + | Instantiation.Bind_to (s1, s2) -> + let ag_id1 = CI.Po.K.agent_id_of_site s1 in + let ag_id2 = CI.Po.K.agent_id_of_site s2 in + let agent_name2 = CI.Po.K.agent_name_of_site s2 in + let site_id1 = CI.Po.K.site_name_of_site s1 in + let site_id2 = CI.Po.K.site_name_of_site s2 in + let error, log_info, blackboard, predicate_id1 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id1, site_id1)) in - { - data_structure - with - other_links_tests = - AgentId2Map.add link (test::old) data_structure.other_links_tests - } - let add_sure_action action data_structure = - { - data_structure - with sure_actions = action::data_structure.sure_actions - } - let add_create_action action data_structure = - { - data_structure - with create_actions = action::data_structure.create_actions - } - let add_subs_action action ag_id data_structure = - let old = - AgentIdMap.find_default [] ag_id data_structure.other_agents_actions + let error, log_info, blackboard, predicate_id2 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id2, site_id2)) in - { - data_structure - with - other_agents_actions = - AgentIdMap.add ag_id (action::old) data_structure.other_agents_actions - } - let add_subs_action_link action link data_structure = - let a,b=fst link,snd link in - let link = if a < b then link else b,a in - let data_structure,old = - match AgentId2Map.find_option link data_structure.other_links_actions with - | Some x -> data_structure,x - | None -> - { - data_structure - with - other_links = AgentId2Set.add link data_structure.other_links; }, - [] + ( error, + log_info, + blackboard, + [ + predicate_id1, Bound_to (predicate_id2, ag_id2, agent_name2, site_id2); + ], + [] ) + | Instantiation.Bind (s1, s2) -> + let ag_id1 = CI.Po.K.agent_id_of_site s1 in + let ag_id2 = CI.Po.K.agent_id_of_site s2 in + let agent_name1 = CI.Po.K.agent_name_of_site s1 in + let agent_name2 = CI.Po.K.agent_name_of_site s2 in + let site_id1 = CI.Po.K.site_name_of_site s1 in + let site_id2 = CI.Po.K.site_name_of_site s2 in + let error, log_info, blackboard, predicate_id1 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id1, site_id1)) in - { - data_structure - with - other_links_actions = - AgentId2Map.add link (action::old) data_structure.other_links_actions - } - - let add_sure_side_effect side_effect data_structure = - { - data_structure - with - sure_side_effects = side_effect::data_structure.sure_side_effects - } - - let add_subs_side_effect side_effect ag_id data_structure = - let site = fst side_effect in - let agent = CI.Po.K.agent_of_site site in - let agent_id = CI.Po.K.agent_id_of_agent agent in - let old = - AgentIdMap.find_default - [] agent_id data_structure.other_agents_side_effects + let error, log_info, blackboard, predicate_id2 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id2, site_id2)) in - { - data_structure - with - other_agents_side_effects = - AgentIdMap.add ag_id (side_effect::old) data_structure.other_agents_side_effects} - - - - - let add_step_strong parameter handler log_info error step blackboard step_id = - let init = Trace.step_is_init step in - let pre_event = blackboard.pre_event in - let test_list = Trace.tests_of_step step in - let (action_list,side_effect) = Trace.actions_of_step step in - let data_structure = init_data_structure_strong in - let data_structure = - List.fold_left - (fun data_structure action -> - match - action - with - | Instantiation.Create(ag,_) -> - {data_structure - with new_agents = AgentIdSet.add (CI.Po.K.agent_id_of_agent ag) data_structure.new_agents} - - | Instantiation.Bind(site1,site2) - -> - let ag1_id = CI.Po.K.agent_id_of_site site1 in - let ag2_id = CI.Po.K.agent_id_of_site site2 in - let site1_id = ag1_id,CI.Po.K.site_name_of_site site1 in - let site2_id = ag2_id,CI.Po.K.site_name_of_site site2 in - {data_structure - with - other_links_action_sites = - SiteIdMap.add site1_id ag2_id - (SiteIdMap.add site2_id ag1_id data_structure.other_links_action_sites)} - | Instantiation.Remove agent -> - {data_structure - with removed_agents = AgentIdSet.add (CI.Po.K.agent_id_of_agent agent) data_structure.removed_agents} - | (Instantiation.Bind_to _ | Instantiation.Free _ | Instantiation.Mod_internal _) -> data_structure) - data_structure - action_list + ( error, + log_info, + blackboard, + [ + predicate_id1, Bound_to (predicate_id2, ag_id2, agent_name2, site_id2); + predicate_id2, Bound_to (predicate_id1, ag_id1, agent_name1, site_id1); + ], + [] ) + | Instantiation.Free s -> + let ag_id = CI.Po.K.agent_id_of_site s in + let site_id = CI.Po.K.site_name_of_site s in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id, site_id)) in - let data_structure = - List.fold_left - (fun data_structure test -> - match - test - with - | Instantiation.Is_Here (ag) -> - {data_structure - with old_agents = AgentIdMap.add (CI.Po.K.agent_id_of_agent ag) (CI.Po.K.agent_name_of_agent ag) data_structure.old_agents} - | Instantiation.Is_Bound_to(site1,site2) - -> - let ag1_id = CI.Po.K.agent_id_of_site site1 in - let ag2_id = CI.Po.K.agent_id_of_site site2 in - let site1_id = ag1_id,CI.Po.K.site_name_of_site site1 in - let site2_id = ag2_id,CI.Po.K.site_name_of_site site2 in - let data_structure = - if AgentIdSet.mem ag1_id data_structure.removed_agents - then - {data_structure - with removed_sites_in_other_links = - SiteIdSet.add site1_id data_structure.removed_sites_in_other_links} - else - data_structure - in - let data_structure = - if AgentIdSet.mem ag2_id data_structure.removed_agents - then - {data_structure - with removed_sites_in_other_links = - SiteIdSet.add site2_id data_structure.removed_sites_in_other_links} - else - data_structure - in - {data_structure - with - other_links_test_sites = - SiteIdMap.add site1_id ag2_id - (SiteIdMap.add site2_id ag1_id data_structure.other_links_test_sites)} - - | Instantiation.Is_Free _ | Instantiation.Has_Binding_type _ - | Instantiation.Has_Internal _ | Instantiation.Is_Bound _ -> data_structure) - data_structure - test_list + error, log_info, blackboard, [ predicate_id, Free ], [] + | Instantiation.Remove ag -> + let ag_id = CI.Po.K.agent_id_of_agent ag in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard (Here ag_id) in - let tested_sites = - SiteIdMap.fold - (fun a _ -> SiteIdSet.add a) - data_structure.other_links_test_sites - SiteIdSet.empty + let error, log_info, blackboard = + free_agent parameter handler log_info error blackboard ag_id in - let mod_sites = - SiteIdMap.fold - (fun a _ -> SiteIdSet.add a) - data_structure.other_links_action_sites - SiteIdSet.empty + let set = + A.get blackboard.predicate_id_list_related_to_predicate_id predicate_id in - let priority_sites = - SiteIdSet.inter tested_sites mod_sites + let error, blackboard, list = + PredicateidSet.fold + (fun predicateid (error, blackboard, list) -> + error, blackboard, (predicateid, Undefined) :: list) + set + (error, blackboard, [ predicate_id, Undefined ]) in - let data_structure = - { data_structure - with old_agents_potential_substitution = - AgentIdMap.map - (A.get blackboard.history_of_agent_ids_of_type) - data_structure.old_agents} + error, log_info, blackboard, list, [] + + let predicates_of_action_subs parameter handler log_info error blackboard init + action = + match action with + | Instantiation.Create (ag, interface) -> + let ag_id = CI.Po.K.agent_id_of_agent ag in + let agent_name = CI.Po.K.agent_name_of_agent ag in + let error, blackboard = + create_agent parameter handler error blackboard agent_name ag_id in - let data_structure = - { data_structure with sure_agents = data_structure.new_agents } + let error, log_info, blackboard = + if init then + error, log_info, blackboard + else + free_agent_if_it_exists parameter handler log_info error blackboard + ag_id in - let data_structure = - { data_structure with - sure_agents = - AgentIdMap.fold - (fun id l sure_agents -> - match - l - with - | [_] -> AgentIdSet.add id sure_agents - | _ -> sure_agents) - data_structure.old_agents_potential_substitution - data_structure.sure_agents} + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard (Here ag_id) in - let sure_agent = - if init - then - (fun _ -> true) - else - (fun x -> AgentIdSet.mem x data_structure.sure_agents) + List.fold_left + (fun (error, log_info, blackboard, list1, list2) (s_id, opt) -> + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id, s_id)) + in + let list1 = (predicate_id, Free) :: list1 in + let list2 = (predicate_id, Undefined) :: list2 in + match opt with + | None -> error, log_info, blackboard, list1, list2 + | Some x -> + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Internal_state (ag_id, s_id)) + in + ( error, + log_info, + blackboard, + (predicate_id, Internal_state_is x) :: list1, + (predicate_id, Undefined) :: list2 )) + ( error, + log_info, + blackboard, + [ predicate_id, Present ], + [ predicate_id, Undefined ] ) + interface + | Instantiation.Mod_internal (site, int) -> + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Internal_state + (CI.Po.K.agent_id_of_site site, CI.Po.K.site_name_of_site site)) in - let data_structure = - { - data_structure - with - old_agents_potential_substitution = - AgentIdSet.fold AgentIdMap.remove - data_structure.sure_agents - data_structure.old_agents_potential_substitution - } + error, log_info, blackboard, [ predicate_id, Internal_state_is int ], [] + | Instantiation.Bind_to (s1, s2) -> + let ag_id1 = CI.Po.K.agent_id_of_site s1 in + let ag_id2 = CI.Po.K.agent_id_of_site s2 in + let agent_name2 = CI.Po.K.agent_name_of_site s2 in + let site_id1 = CI.Po.K.site_name_of_site s1 in + let site_id2 = CI.Po.K.site_name_of_site s2 in + let error, log_info, blackboard, predicate_id1 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id1, site_id1)) in - - - let data_structure = - List.fold_left - (fun data_structure test -> - match test - with - | Instantiation.Is_Here _ | Instantiation.Has_Internal _ - | Instantiation.Is_Free _ | Instantiation.Is_Bound _ - | Instantiation.Has_Binding_type _ -> data_structure - | Instantiation.Is_Bound_to (site1,site2) -> - let agent1 = CI.Po.K.agent_of_site site1 in - let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in - let agent2 = CI.Po.K.agent_of_site site2 in - let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in - let site_id1 = CI.Po.K.site_name_of_site site1 in - let site_id2 = CI.Po.K.site_name_of_site site2 in - if sure_agent ag_id1 && not (SiteIdSet.mem (ag_id1,site_id1) priority_sites) && sure_agent ag_id2 && not (SiteIdSet.mem (ag_id2,site_id2) priority_sites) - then - data_structure - else - let mix_site1 = ag_id1,CI.Po.K.site_name_of_site site1 in - let mix_site2 = ag_id2,CI.Po.K.site_name_of_site site2 in - let data_structure = - add_site_in_other_test_links mix_site1 - (add_site_in_other_test_links mix_site2 data_structure ) - in - let data_structure = - if SiteIdSet.mem mix_site1 priority_sites - || SiteIdSet.mem mix_site2 priority_sites - then - let ag_id1,ag_id2 = - if ag_id1 - match action - with - | Instantiation.Create _ - | Instantiation.Remove _ - | Instantiation.Mod_internal _ - | Instantiation.Free _ -> data_structure - | Instantiation.Bind(site1,site2) - | Instantiation.Bind_to (site1,site2) -> - let agent1 = CI.Po.K.agent_of_site site1 in - let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in - let agent2 = CI.Po.K.agent_of_site site2 in - let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in - if sure_agent ag_id1 && sure_agent ag_id2 - then - data_structure - else - add_site_in_other_action_links (ag_id1,CI.Po.K.site_name_of_site site1) - (add_site_in_other_action_links (ag_id2,CI.Po.K.site_name_of_site site2) - data_structure ) - - - ) - data_structure - (List.rev action_list) + ( error, + log_info, + blackboard, + [ + predicate_id1, Bound_to (predicate_id2, ag_id2, agent_name2, site_id2); + ], + [] ) + | Instantiation.Bind (s1, s2) -> + let ag_id1 = CI.Po.K.agent_id_of_site s1 in + let ag_id2 = CI.Po.K.agent_id_of_site s2 in + let agent_name1 = CI.Po.K.agent_name_of_site s1 in + let agent_name2 = CI.Po.K.agent_name_of_site s2 in + let site_id1 = CI.Po.K.site_name_of_site s1 in + let site_id2 = CI.Po.K.site_name_of_site s2 in + let error, log_info, blackboard, predicate_id1 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id1, site_id1)) in - let data_structure = - List.fold_left - (fun data_structure test -> - match test - with - | Instantiation.Is_Here (agent) -> - let ag_id = CI.Po.K.agent_id_of_agent agent in - if sure_agent ag_id - then - add_sure_test test data_structure - else - add_subs_test test ag_id data_structure - | Instantiation.Has_Internal(site,_) -> - let agent = CI.Po.K.agent_of_site site in - let ag_id = CI.Po.K.agent_id_of_agent agent in - if sure_agent ag_id - then - add_sure_test test data_structure - else - add_subs_test test ag_id data_structure - | Instantiation.Is_Free site | Instantiation.Is_Bound site - | Instantiation.Has_Binding_type (site,_) -> - let agent = CI.Po.K.agent_of_site site in - let ag_id = CI.Po.K.agent_id_of_agent agent in - if sure_agent ag_id && not (SiteIdSet.mem (ag_id,CI.Po.K.site_name_of_site site) data_structure.sites_in_other_links) - then - add_sure_test test data_structure - else - begin - let site_id1 = ag_id,CI.Po.K.site_name_of_site site in - match - SiteIdMap.find_option - site_id1 data_structure.other_links_action_sites - with - | Some ag_id2 -> - add_subs_test_link test (ag_id,ag_id2) data_structure - | None -> - add_subs_test test ag_id data_structure - end - - | Instantiation.Is_Bound_to (site1,site2) -> - let agent1 = CI.Po.K.agent_of_site site1 in - let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in - let ag_name1 = CI.Po.K.agent_name_of_agent agent1 in - let site_name1 = CI.Po.K.site_name_of_site site1 in - let agent2 = CI.Po.K.agent_of_site site2 in - let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in - let ag_name2 = CI.Po.K.agent_name_of_agent agent2 in - let site_name2 = CI.Po.K.site_name_of_site site2 in - let weak1 = Instantiation.Has_Binding_type (site1,(ag_name2,site_name2)) in - let weak2 = Instantiation.Has_Binding_type (site2,(ag_name1,site_name1)) in - match sure_agent ag_id1 && not (SiteIdSet.mem (ag_id1,site_name1) priority_sites), - sure_agent ag_id2 && not (SiteIdSet.mem (ag_id2,site_name2) priority_sites) - with - | true,true -> add_sure_test test data_structure - | true,false -> - add_sure_test weak1 - (add_subs_test weak2 ag_id2 - (add_subs_test_link test (ag_id1,ag_id2) data_structure)) - | false,true -> - add_subs_test weak1 ag_id1 - (add_sure_test weak2 - (add_subs_test_link test (ag_id1,ag_id2) data_structure)) - | false,false -> - add_subs_test weak1 ag_id1 - (add_subs_test weak2 ag_id2 - (add_subs_test_link test (ag_id1,ag_id2) data_structure)) - ) - data_structure - (List.rev test_list) + let error, log_info, blackboard, predicate_id2 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id2, site_id2)) in - let data_structure = - List.fold_left - (fun data_structure action -> - match action - with - | Instantiation.Create _ -> add_create_action action data_structure - | Instantiation.Remove agent -> - let ag_id = CI.Po.K.agent_id_of_agent agent in - if sure_agent ag_id - then - add_sure_action action data_structure - else - add_subs_action action ag_id data_structure - | Instantiation.Mod_internal (site,_) - -> - let agent = CI.Po.K.agent_of_site site in - let ag_id = CI.Po.K.agent_id_of_agent agent in - if sure_agent ag_id - then - add_sure_action action data_structure - else - add_subs_action action ag_id data_structure - | Instantiation.Free(site) -> - let agent = CI.Po.K.agent_of_site site in - let ag_id = CI.Po.K.agent_id_of_agent agent in - let site_id1 = ag_id,CI.Po.K.site_name_of_site site in - if mem_site_in_other_action_links site_id1 data_structure - then - data_structure - else - if sure_agent ag_id - then - add_sure_action action data_structure - else - begin - match SiteIdMap.find_option - site_id1 data_structure.other_links_test_sites with - | Some ag_id2 -> - add_subs_action_link action (ag_id,ag_id2) data_structure - | None -> - add_subs_action action ag_id data_structure - end - - | Instantiation.Bind(site1,site2) | Instantiation.Bind_to (site1,site2) -> - let agent1 = CI.Po.K.agent_of_site site1 in - let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in - let agent2 = CI.Po.K.agent_of_site site2 in - let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in - if sure_agent ag_id1 && sure_agent ag_id2 - then - add_sure_action action data_structure - else - add_subs_action_link action (ag_id1,ag_id2) data_structure - ) - data_structure - (List.rev action_list) + ( error, + log_info, + blackboard, + [ + predicate_id1, Bound_to (predicate_id2, ag_id2, agent_name2, site_id2); + predicate_id2, Bound_to (predicate_id1, ag_id1, agent_name1, site_id1); + ], + [] ) + | Instantiation.Free s -> + let ag_id = CI.Po.K.agent_id_of_site s in + let site_id = CI.Po.K.site_name_of_site s in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id, site_id)) in - - let data_structure = - List.fold_left - (fun data_structure side_effect -> - let (site,_) = side_effect in - let agent = CI.Po.K.agent_of_site site in - let ag_id = CI.Po.K.agent_id_of_agent agent in - if sure_agent ag_id - then - add_sure_side_effect side_effect data_structure - else - add_subs_side_effect side_effect ag_id data_structure) - data_structure - side_effect + error, log_info, blackboard, [ predicate_id, Free ], [] + | Instantiation.Remove ag -> + let ag_id = CI.Po.K.agent_id_of_agent ag in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard (Here ag_id) in - let data_structure = - { - data_structure - with - subs_agents_involved_in_links = - let f x set = - AgentId2Map.fold - (fun (a1,a2) _ set -> AgentIdSet.add a1 (AgentIdSet.add a2 set)) - x set - in - f - data_structure.other_links_tests - (f - data_structure.other_links_actions - AgentIdSet.empty)} + (* let error,blackboard = free_agent parameter handler error blackboard ag_id in *) + let set = + A.get blackboard.predicate_id_list_related_to_predicate_id predicate_id in - let init_step = None in - let error,log_info,blackboard,rule_agent_id_mutex,rule_agent_id_subs,mixture_agent_id_mutex,fictitious_list,fictitious_local_list,_,init_step = - AgentIdMap.fold - (fun x l (error,log_info,blackboard,rule_agent_id_mutex,rule_agent_id_subs,mixture_agent_id_mutex,fictitious_list,fictitious_local_list,set,init_step) -> - (* the following mutex is used to encode the fact that the agent x in the lhs of the rule must be associated with exactely one agent in the mixture *) - let predicate_info = Mutex (Lock_agent (step_id,x)) in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let error,log_info,blackboard,init_step = init_fictitious_action log_info error predicate_id blackboard init_step in - let rule_agent_id_mutex = AgentIdMap.add x predicate_id rule_agent_id_mutex in - let fictitious_local_list = predicate_id::fictitious_local_list in - let fictitious_list = predicate_id::fictitious_list in - let error,log_info,blackboard,rule_agent_id_subs,init_step = - if AgentIdSet.mem x data_structure.subs_agents_involved_in_links - then - begin - let predicate_info = Pointer (step_id,x) in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let rule_agent_id_subs = AgentIdMap.add x predicate_id rule_agent_id_subs in - let error,log_info,blackboard,init_step = init_fictitious_action log_info error predicate_id blackboard init_step in - error,log_info,blackboard,rule_agent_id_subs,init_step - end - else - error,log_info,blackboard,rule_agent_id_subs,init_step - in - let error,log_info,blackboard,mixture_agent_id_mutex,set,init_step = - List.fold_left - (fun (error,log_info,blackboard,mixture_agent_id_mutex,set,init_step) id -> - let _ = - if Remanent_parameters.get_trace (CI.Po.K.H.get_kasa_parameters parameter) || debug_mode - then - let () = Loggers.fprintf (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) "ID of agent in the rule: %i, ID of the agent in the mixture: %i" x id in - let () = Loggers.print_newline (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) in - () - in - let set' = AgentIdSet.add id set in - if set == set' - then - if AgentIdMap.mem id mixture_agent_id_mutex then - (* The mutex is already declared, nothing to do *) - let () = - if Remanent_parameters.get_trace (CI.Po.K.H.get_kasa_parameters parameter) || debug_mode - then - let () = Loggers.fprintf (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) "Mutex already exists" in - let () = Loggers.print_newline (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) in - () - in - (error,log_info,blackboard,mixture_agent_id_mutex,set,init_step) - else - begin - (* The mutex has to be allocated *) - let () = - if Remanent_parameters.get_trace (CI.Po.K.H.get_kasa_parameters parameter) || debug_mode - then - let () = Loggers.fprintf (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) "Create Mutex" in - let () = Loggers.print_newline (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) in - () - in - let predicate_info = Mutex (Lock_rectangular (step_id,id)) in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let mixture_agent_id_mutex = AgentIdMap.add id predicate_id mixture_agent_id_mutex in - let error,log_info,blackboard,init_step = init_fictitious_action log_info error predicate_id blackboard init_step in - error,log_info,blackboard,mixture_agent_id_mutex,set',init_step - end - else - (* The agent in the mixture is seen for the first time, no need for a mutex for the moment *) - let () = - if Remanent_parameters.get_trace (CI.Po.K.H.get_kasa_parameters parameter) || debug_mode - then - let () = Loggers.fprintf (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) "This agent is seen for the first time, no need for mutex yet" in - let () = Loggers.print_newline (Remanent_parameters.get_logger (CI.Po.K.H.get_kasa_parameters parameter)) - in () - in - (error,log_info,blackboard,mixture_agent_id_mutex,set',init_step)) - (error,log_info,blackboard,mixture_agent_id_mutex,set,init_step) - l - in - (error,log_info,blackboard,rule_agent_id_mutex,rule_agent_id_subs,mixture_agent_id_mutex,fictitious_list,fictitious_local_list,set,init_step)) - data_structure.old_agents_potential_substitution - (error,log_info,blackboard,AgentIdMap.empty,AgentIdMap.empty,AgentIdMap.empty,blackboard.pre_fictitious_list,[],AgentIdSet.empty,init_step) + let error, log_info, blackboard, list = + PredicateidSet.fold + (fun predicateid (error, log_info, blackboard, list) -> + error, log_info, blackboard, (predicateid, Undefined) :: list) + set + (error, log_info, blackboard, [ predicate_id, Undefined ]) in - let links_mutex = AgentId2Map.empty in - let error,log_info,blackboard,links_mutex,fictitious_list,fictitious_local_list,init_step = - AgentId2Set.fold - (fun x (error,log_info,blackboard,links_mutex,fictitious_list,fictitious_local_list,init_step) -> - let predicate_info = Mutex (Lock_links (step_id,x)) in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let error,log_info,blackboard,init_step = init_fictitious_action log_info error predicate_id blackboard init_step in - let links_mutex = AgentId2Map.add x predicate_id links_mutex in - let fictitious_local_list = predicate_id::fictitious_local_list in - let fictitious_list = predicate_id::fictitious_list in - (error,log_info,blackboard,links_mutex,fictitious_list,fictitious_local_list,init_step)) - data_structure.other_links - (error,log_info,blackboard,links_mutex,fictitious_list,fictitious_local_list,init_step) + error, log_info, blackboard, list, [] + + let predicates_of_action bool = + if bool then + predicates_of_action_subs + else + predicates_of_action_no_subs + + let predicates_of_test parameter handler log_info error blackboard test = + match test with + | Instantiation.Is_Here agent -> + let ag_id = CI.Po.K.agent_id_of_agent agent in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard (Here ag_id) in - let data_structure = - { - data_structure - with - links_mutex = links_mutex ; - rule_agent_id_mutex = rule_agent_id_mutex ; - rule_agent_id_subs = rule_agent_id_subs ; - mixture_agent_id_mutex = mixture_agent_id_mutex ; - } + error, log_info, blackboard, [ predicate_id, Present ] + | Instantiation.Has_Internal (site, int) -> + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Internal_state + (CI.Po.K.agent_id_of_site site, CI.Po.K.site_name_of_site site)) in - let blackboard = {blackboard with pre_fictitious_list = fictitious_list} in - let _ = - if debug_mode - then - let _ = print_data_structure parameter handler error data_structure in - () + error, log_info, blackboard, [ predicate_id, Internal_state_is int ] + | Instantiation.Is_Free s -> + let ag_id = CI.Po.K.agent_id_of_site s in + let site_id = CI.Po.K.site_name_of_site s in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id, site_id)) in - let fictitious_list = blackboard.pre_fictitious_list in - let build_map list map = - List.fold_left - (fun map (id,value) -> PredicateidMap.add id value map) - map - list + error, log_info, blackboard, [ predicate_id, Free ] + | Instantiation.Is_Bound_to (s1, s2) -> + let ag_id1 = CI.Po.K.agent_id_of_site s1 in + let ag_id2 = CI.Po.K.agent_id_of_site s2 in + let agent_name1 = CI.Po.K.agent_name_of_site s1 in + let agent_name2 = CI.Po.K.agent_name_of_site s2 in + let site_id1 = CI.Po.K.site_name_of_site s1 in + let site_id2 = CI.Po.K.site_name_of_site s2 in + let error, log_info, blackboard, predicate_id1 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id1, site_id1)) in - let add_state pid (test,action) map = - let test',action' = - PredicateidMap.find_default (Unknown,Unknown) pid map in - let test = - if strictly_more_refined test test' - then - test - else - test' - in - let action = - if strictly_more_refined action action' - then - action - else - action' + let error, log_info, blackboard, predicate_id2 = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id2, site_id2)) + in + ( error, + log_info, + blackboard, + [ + predicate_id1, Bound_to (predicate_id2, ag_id2, agent_name2, site_id2); + predicate_id2, Bound_to (predicate_id1, ag_id1, agent_name1, site_id1); + ] ) + | Instantiation.Is_Bound s -> + let ag_id = CI.Po.K.agent_id_of_site s in + let site_id = CI.Po.K.site_name_of_site s in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id, site_id)) + in + error, log_info, blackboard, [ predicate_id, Bound ] + | Instantiation.Has_Binding_type (s, (agent_name, site_name)) -> + let ag_id = CI.Po.K.agent_id_of_site s in + let site_id = CI.Po.K.site_name_of_site s in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + (Bound_site (ag_id, site_id)) + in + ( error, + log_info, + blackboard, + [ predicate_id, Bound_to_type (agent_name, site_name) ] ) + + let type_of_step x = + if Trace.step_is_obs x then + Observable + else if Trace.step_is_init x then + Init + else if Trace.step_is_rule x then + Rule + else if Trace.step_is_subs x then + Subs + else + Dummy + + (** initialisation*) + let init _parameter _handler log_info error = + ( error, + log_info, + { + pre_side_effect_of_event = A.make 1 CI.Po.K.empty_side_effect; + pre_event = A.make 1 (Trace.dummy_step ""); + pre_fictitious_list = []; + pre_steps_by_column = A.make 1 (1, []); + pre_nsteps = -1; + pre_ncolumn = -1; + pre_column_map = PredicateMap.empty; + pre_column_map_inv = A.make 1 Fictitious; + pre_kind_of_event = A.make 1 (Side_effect_of (-1, [])); + history_of_predicate_values_to_predicate_id = A.make 1 (C.create None); + history_of_agent_ids_of_type = A.make 1 []; + predicate_id_list_related_to_predicate_id = + A.make 1 PredicateidSet.empty; + pre_observable_list = []; + pre_fictitious_observable = None; + pre_level_of_event = A.make 1 Priority.highest; + } ) + + let get_level_of_event parameter _handler log_info error blackboard eid = + try error, log_info, A.get blackboard.pre_level_of_event eid + with Not_found -> + warn parameter log_info error __POS__ (Failure "UNknown event") + Priority.highest + + let init_fictitious_action log_info error predicate_id blackboard = + let nsid = blackboard.pre_nsteps + 1 in + let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in + let test = Undefined in + let action = Counter 0 in + let _ = + A.set blackboard.pre_steps_by_column predicate_id + (2, [ nsid, 1, test, action ]) + in + error, log_info, { blackboard with pre_nsteps = nsid } + + let init_fictitious_action_at_nsid log_info error predicate_id blackboard nsid + = + let test = Undefined in + let action = Counter 0 in + let _ = + A.set blackboard.pre_steps_by_column predicate_id + (2, [ nsid, 1, test, action ]) + in + error, log_info, blackboard + + let init_fictitious_action log_info error predicate_id blackboard init_step = + match init_step with + | None -> + let error, log_info, blackboard = + init_fictitious_action log_info error predicate_id blackboard + in + error, log_info, blackboard, Some blackboard.pre_nsteps + | Some nsid -> + let error, log_info, blackboard = + init_fictitious_action_at_nsid log_info error predicate_id blackboard + nsid + in + error, log_info, blackboard, init_step + + let add_fictitious_action error test action predicate_id blackboard = + let nsid = blackboard.pre_nsteps in + let map = blackboard.pre_steps_by_column in + let value, list = A.get map predicate_id in + let value' = value + 1 in + let _ = + A.set map predicate_id (value', (nsid, value, test, action) :: list) + in + error, blackboard + + let side_effect parameter _handler log_info error predicate_target_id s site = + match s with + | Defined | Counter _ | Internal_state_is _ | Undefined | Pointer_to_agent _ + | Present | Bound | Bound_to_type _ | Unknown -> + warn parameter log_info error __POS__ + ~message:"Illegal state for a side-effects" + (Failure "Blackboard_generation.side_effect") [] + | Free -> error, log_info, [ predicate_target_id, None, (Free, Unknown) ] + | Bound_to (pid, ag, agent_name, sname) -> + ( error, + log_info, + [ + predicate_target_id, None, (s, Unknown); + ( pid, + Some ((ag, agent_name), sname), + ( Bound_to + ( predicate_target_id, + CI.Po.K.agent_id_of_site site, + CI.Po.K.agent_name_of_site site, + CI.Po.K.site_name_of_site site ), + Free ) ); + ] ) + + let predicate_value_of_binding_state parameter _handler log_info error = + function + | Instantiation.ANY -> error, log_info, Unknown + | Instantiation.FREE -> error, log_info, Free + | Instantiation.BOUND -> error, log_info, Bound + | Instantiation.BOUND_TYPE bt -> + ( error, + log_info, + Bound_to_type + ( CI.Po.K.agent_name_of_binding_type bt, + CI.Po.K.site_name_of_binding_type bt ) ) + | Instantiation.BOUND_to _ -> + warn parameter log_info error __POS__ + ~message:"Illegal binding state in predicate_value_of_binding_state" + (Failure "predicate_value_of_binding_state") Unknown + + let potential_target parameter handler log_info error blackboard site + binding_state = + let agent_id = CI.Po.K.agent_id_of_site site in + let site_name = CI.Po.K.site_name_of_site site in + let error, log_info, blackboard, predicate_target_id = + allocate parameter handler log_info error blackboard + (Bound_site (agent_id, site_name)) + in + let former_states = + A.get blackboard.history_of_predicate_values_to_predicate_id + predicate_target_id + in + match parameter.CI.Po.K.H.current_compression_mode with + | None | Some Story_json.Causal -> + let s = C.last former_states in + (match s with + | None -> error, log_info, blackboard, [] + | Some s -> + let error, log_info, bt = + predicate_value_of_binding_state parameter handler log_info error + binding_state in - let map = PredicateidMap.add pid (test,action) map in - map + if more_refined s bt then ( + let error, log_info, l = + side_effect parameter handler log_info error predicate_target_id s + site + in + error, log_info, blackboard, [ l ] + ) else + error, log_info, blackboard, []) + | Some (Story_json.Strong | Story_json.Weak) -> + let error, log_info, bt = + predicate_value_of_binding_state parameter handler log_info error + binding_state in - let fadd pid p map = - match p with - | Counter _ | Internal_state_is _ | Undefined - | Defined | Present | Bound | Bound_to_type _ | Unknown -> () - | (Free | Pointer_to_agent _ | Bound_to _) -> - let old = A.get map pid in - A.set map pid (C.add p old) + let error, log_info, list = + C.fold + (fun s (error, log_info, list) -> + if more_refined s bt then ( + let error, log_info, l = + side_effect parameter handler log_info error predicate_target_id + s site + in + error, log_info, l :: list + ) else + error, log_info, list) + former_states (error, log_info, []) in - - - (* deal with created agents *) - let error,log_info,blackboard,step_id = - match init_step - with - | None -> error,log_info,blackboard,step_id - | Some nsid -> - begin - let nsid = nsid in - let nsid_void = nsid+1 in - let nsid_next = nsid+1 in - let side_effect = [] in - let action_list = data_structure.create_actions in - let test_list = [] in - let fictitious_list = [] in - - let error,log_info,blackboard,fictitious_list,_fictitious_local_list,unambiguous_side_effects,_init_step = - List.fold_left - (fun (error,log_info,blackboard,fictitious_list,fictitious_local_list,unambiguous_side_effects,init_step) (site,(binding_state)) -> - begin - let error,log_info,blackboard,potential_target = potential_target parameter handler log_info error blackboard site binding_state in - match - potential_target - with - | [l] -> - begin - let list = - List.fold_left - (fun list t -> t::list) - unambiguous_side_effects - l - in - error, - log_info, - blackboard, - fictitious_list, - fictitious_local_list, - list, - init_step - end - | _ -> - begin - let rule_ag_id = CI.Po.K.agent_id_of_agent (CI.Po.K.agent_of_site site) in - let predicate_info = Mutex (Lock_side_effect (step_id,rule_ag_id,rule_ag_id,CI.Po.K.site_name_of_site site)) in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let error,log_info,blackboard,_step_id = - init_fictitious_action log_info error predicate_id blackboard init_step - in - let error,log_info,blackboard = - List.fold_left - (fun (error,log_info,blackboard) list -> - let blackboard = {blackboard with pre_nsteps = blackboard.pre_nsteps+1} in - let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - list - in - let side_effect = CI.Po.K.side_effect_of_list - side_effect in - let _ = A.set blackboard.pre_side_effect_of_event - blackboard.pre_nsteps - side_effect in - let error,blackboard = - List.fold_left - (fun (error,blackboard) (predicate_id,_,(test,action)) -> - add_fictitious_action error test action predicate_id blackboard) - (error,blackboard) - ((predicate_id,None,(Counter 0,Counter 1))::list) - in - error,log_info,blackboard) - (error,log_info,blackboard) - potential_target - in - error, - log_info, - blackboard, - (predicate_id::fictitious_list), - (predicate_id::fictitious_local_list), - unambiguous_side_effects, - init_step - end - end) - (error,log_info,blackboard,fictitious_list,fictitious_local_list,[],init_step) - side_effect - in - let error,log_info,blackboard,test_map = - List.fold_left - (fun (error,log_info,blackboard,map) test -> - let error,log_info,blackboard,test_list = predicates_of_test parameter handler log_info error blackboard test in - error,log_info,blackboard,build_map test_list map) - (error,log_info,blackboard,PredicateidMap.empty) - test_list in - let error,log_info,blackboard,action_map,test_map = - List.fold_left - (fun (error,log_info,blackboard,action_map,test_map) action -> - let error,log_info,blackboard,action_list,test_list = predicates_of_action true parameter handler log_info error blackboard init action in - error,log_info,blackboard,build_map action_list action_map,build_map test_list test_map) - (error,log_info,blackboard,PredicateidMap.empty,test_map) - action_list in - let error,merged_map = - PredicateidMap.monadic_fold2 - parameter error - (fun _ e key test action acc -> - e,PredicateidMap.add key (test,action) acc) - (fun _ e key test acc -> - e,PredicateidMap.add key (test,Unknown) acc) - (fun _ e key action acc -> - e,PredicateidMap.add key (Unknown,action) acc) - test_map - action_map - PredicateidMap.empty - in - let merged_map = - List.fold_left - (fun map (pid,_,(test,action)) -> add_state pid (test,action) map) - merged_map - unambiguous_side_effects + error, log_info, blackboard, list + + type data_structure_strong = { + new_agents: AgentIdSet.t; + old_agents: Instantiation.agent_name AgentIdMap.t; + old_agents_potential_substitution: CI.Po.K.agent_id list AgentIdMap.t; + sure_agents: AgentIdSet.t; + sure_links: AgentId2Set.t; + other_links: AgentId2Set.t; + sites_in_other_links: SiteIdSet.t; + sites_in_other_action_links: SiteIdSet.t; + other_links_test_sites: CI.Po.K.agent_id SiteIdMap.t; + other_links_action_sites: CI.Po.K.agent_id SiteIdMap.t; + sure_tests: Instantiation.concrete Instantiation.test list; + sure_actions: Instantiation.concrete Instantiation.action list; + create_actions: Instantiation.concrete Instantiation.action list; + sure_side_effects: + (Instantiation.concrete Instantiation.site + * Instantiation.concrete Instantiation.binding_state) + list; + other_agents_tests: + Instantiation.concrete Instantiation.test list AgentIdMap.t; + other_agents_actions: + Instantiation.concrete Instantiation.action list AgentIdMap.t; + other_links_tests: + Instantiation.concrete Instantiation.test list AgentId2Map.t; + other_links_actions: + Instantiation.concrete Instantiation.action list AgentId2Map.t; + other_links_priority: AgentId2Set.t; + other_agents_side_effects: + (Instantiation.concrete Instantiation.site + * Instantiation.concrete Instantiation.binding_state) + list + AgentIdMap.t; + subs_agents_involved_in_links: AgentIdSet.t; + rule_agent_id_mutex: predicate_id AgentIdMap.t; + rule_agent_id_subs: predicate_id AgentIdMap.t; + mixture_agent_id_mutex: predicate_id AgentIdMap.t; + links_mutex: predicate_id AgentId2Map.t; + removed_agents: AgentIdSet.t; + removed_sites_in_other_links: SiteIdSet.t; + } + + let init_data_structure_strong = + { + new_agents = AgentIdSet.empty; + old_agents = AgentIdMap.empty; + old_agents_potential_substitution = AgentIdMap.empty; + sure_agents = AgentIdSet.empty; + sure_links = AgentId2Set.empty; + other_links = AgentId2Set.empty; + other_links_test_sites = SiteIdMap.empty; + other_links_action_sites = SiteIdMap.empty; + sites_in_other_links = SiteIdSet.empty; + sites_in_other_action_links = SiteIdSet.empty; + sure_tests = []; + sure_actions = []; + create_actions = []; + sure_side_effects = []; + other_agents_tests = AgentIdMap.empty; + other_agents_actions = AgentIdMap.empty; + other_links_priority = AgentId2Set.empty; + other_links_tests = AgentId2Map.empty; + other_links_actions = AgentId2Map.empty; + other_agents_side_effects = AgentIdMap.empty; + subs_agents_involved_in_links = AgentIdSet.empty; + rule_agent_id_mutex = AgentIdMap.empty; + rule_agent_id_subs = AgentIdMap.empty; + links_mutex = AgentId2Map.empty; + mixture_agent_id_mutex = AgentIdMap.empty; + removed_agents = AgentIdSet.empty; + removed_sites_in_other_links = SiteIdSet.empty; + } + + let print_data_structure _parameter _handler error _data = + (* let stderr = parameter.CI.Po.K.H.out_channel_err in + let sigs = Model.signatures handler.CI.Po.K.H.env in + let _ = Format.fprintf stderr "New agents: @." in + let _ = + AgentIdSet.iter (Format.fprintf stderr " %i @.") data.new_agents + in + let _ = Format.fprintf stderr "Old agents: @." in + let _ = + AgentIdMap.iter (Format.fprintf stderr " id:%i: type:%i @.") data.old_agents + in + let _ = Format.fprintf stderr "Old agents implied in links: @." in + let _ = + AgentIdSet.iter (Format.fprintf stderr " %i @.") data.subs_agents_involved_in_links + in + let _ = Format.fprintf stderr "Tested_links_map: @." in + let _ = + SiteIdMap.iter (fun (a,b) -> Format.fprintf stderr " %i.%i -> %i @." a b ) data.other_links_test_sites in + let _ = Format.fprintf stderr "Modified_links_map: @." in + let _ = + SiteIdMap.iter (fun (a,b) -> Format.fprintf stderr " %i.%i -> %i @." a b ) data.other_links_action_sites + in + let _ = Format.fprintf stderr "Potential substitution: @." in + let _ = + AgentIdMap.iter + (fun id l -> + let _ = + Format.fprintf stderr " id:%i@." id + in + List.iter (Format.fprintf stderr " %i@.") l) + data.old_agents_potential_substitution + in + let _ = Format.fprintf stderr "Sure agents:@." in + let _ = + AgentIdSet.iter (Format.fprintf stderr " %i@.") data.sure_agents + in + let () = + Format.fprintf stderr "Sure tests:@[%a@]@." + (Pp.list Pp.space (Instantiation.print_concrete_test ~sigs)) + data.sure_tests in + let () = + Format.fprintf stderr "Tests to be substituted:@[@,%a%a@]@." + (Pp.set ~trailing:Pp.space AgentIdMap.bindings Pp.space + (fun f (id,l) -> + Format.fprintf + f"%i@,%a" id + (Pp.list Pp.space (Instantiation.print_concrete_test ~sigs)) + l + )) + data.other_agents_tests + (Pp.set AgentId2Map.bindings Pp.space + (fun f ((id1,id2),l) -> + Format.fprintf + f "(%i,%i)@,%a" id1 id2 + (Pp.list Pp.space (Instantiation.print_concrete_test ~sigs)) + l)) + data.other_links_tests in + let () = + Format.fprintf stderr "Sure actions:@[%a@]@." + (Pp.list Pp.space (Instantiation.print_concrete_action ~sigs)) + data.sure_actions in + let () = + Format.fprintf stderr "Actions to be substituted:@[@,%a%a@]@." + (Pp.set ~trailing:Pp.space AgentIdMap.bindings Pp.space + (fun f (id,l) -> + Format.fprintf + f"%i@,%a" id + (Pp.list Pp.space (Instantiation.print_concrete_action ~sigs)) + l + )) + data.other_agents_actions + (Pp.set AgentId2Map.bindings Pp.space + (fun f ((id1,id2),l) -> + Format.fprintf + f "(%i,%i)@,%a" id1 id2 + (Pp.list Pp.space (Instantiation.print_concrete_action ~sigs)) + l)) + data.other_links_actions in + let _ = Format.fprintf stderr "Sure side_effects @." in + let _ = + List.iter + (CI.Po.K.print_side stderr handler " ") + data.sure_side_effects + in + let _ = Format.fprintf stderr "Side effect to be substituted: @." in + let _ = + AgentIdMap.iter + (fun id l -> + let _ = Format.fprintf stderr " %i@." id in + let _ = + List.iter + (CI.Po.K.print_side stderr handler " ") + l + in ()) + data.other_agents_side_effects + in*) + error + + let add_site_in_other_test_links site data_structure = + { + data_structure with + sites_in_other_links = + SiteIdSet.add site data_structure.sites_in_other_links; + } + + let add_site_in_other_action_links site data_structure = + let data_structure = add_site_in_other_test_links site data_structure in + { + data_structure with + sites_in_other_action_links = + SiteIdSet.add site data_structure.sites_in_other_action_links; + } + + let mem_site_in_other_action_links site data_structure = + SiteIdSet.mem site data_structure.sites_in_other_action_links + + let add_sure_test test data_structure = + { data_structure with sure_tests = test :: data_structure.sure_tests } + + let add_subs_test test ag_id data_structure = + let old = + AgentIdMap.find_default [] ag_id data_structure.other_agents_tests + in + { + data_structure with + other_agents_tests = + AgentIdMap.add ag_id (test :: old) data_structure.other_agents_tests; + } + + let add_subs_test_link test link data_structure = + let a, b = fst link, snd link in + let link = + if a < b then + link + else + b, a + in + let data_structure, old = + match AgentId2Map.find_option link data_structure.other_links_tests with + | Some x -> data_structure, x + | None -> + ( { + data_structure with + other_links = AgentId2Set.add link data_structure.other_links; + }, + [] ) + in + { + data_structure with + other_links_tests = + AgentId2Map.add link (test :: old) data_structure.other_links_tests; + } + + let add_sure_action action data_structure = + { data_structure with sure_actions = action :: data_structure.sure_actions } + + let add_create_action action data_structure = + { + data_structure with + create_actions = action :: data_structure.create_actions; + } + + let add_subs_action action ag_id data_structure = + let old = + AgentIdMap.find_default [] ag_id data_structure.other_agents_actions + in + { + data_structure with + other_agents_actions = + AgentIdMap.add ag_id (action :: old) data_structure.other_agents_actions; + } + + let add_subs_action_link action link data_structure = + let a, b = fst link, snd link in + let link = + if a < b then + link + else + b, a + in + let data_structure, old = + match AgentId2Map.find_option link data_structure.other_links_actions with + | Some x -> data_structure, x + | None -> + ( { + data_structure with + other_links = AgentId2Set.add link data_structure.other_links; + }, + [] ) + in + { + data_structure with + other_links_actions = + AgentId2Map.add link (action :: old) data_structure.other_links_actions; + } + + let add_sure_side_effect side_effect data_structure = + { + data_structure with + sure_side_effects = side_effect :: data_structure.sure_side_effects; + } + + let add_subs_side_effect side_effect ag_id data_structure = + let site = fst side_effect in + let agent = CI.Po.K.agent_of_site site in + let agent_id = CI.Po.K.agent_id_of_agent agent in + let old = + AgentIdMap.find_default [] agent_id + data_structure.other_agents_side_effects + in + { + data_structure with + other_agents_side_effects = + AgentIdMap.add ag_id (side_effect :: old) + data_structure.other_agents_side_effects; + } + + let add_step_strong parameter handler log_info error step blackboard step_id = + let init = Trace.step_is_init step in + let pre_event = blackboard.pre_event in + let test_list = Trace.tests_of_step step in + let action_list, side_effect = Trace.actions_of_step step in + let data_structure = init_data_structure_strong in + let data_structure = + List.fold_left + (fun data_structure action -> + match action with + | Instantiation.Create (ag, _) -> + { + data_structure with + new_agents = + AgentIdSet.add + (CI.Po.K.agent_id_of_agent ag) + data_structure.new_agents; + } + | Instantiation.Bind (site1, site2) -> + let ag1_id = CI.Po.K.agent_id_of_site site1 in + let ag2_id = CI.Po.K.agent_id_of_site site2 in + let site1_id = ag1_id, CI.Po.K.site_name_of_site site1 in + let site2_id = ag2_id, CI.Po.K.site_name_of_site site2 in + { + data_structure with + other_links_action_sites = + SiteIdMap.add site1_id ag2_id + (SiteIdMap.add site2_id ag1_id + data_structure.other_links_action_sites); + } + | Instantiation.Remove agent -> + { + data_structure with + removed_agents = + AgentIdSet.add + (CI.Po.K.agent_id_of_agent agent) + data_structure.removed_agents; + } + | Instantiation.Bind_to _ | Instantiation.Free _ + | Instantiation.Mod_internal _ -> + data_structure) + data_structure action_list + in + let data_structure = + List.fold_left + (fun data_structure test -> + match test with + | Instantiation.Is_Here ag -> + { + data_structure with + old_agents = + AgentIdMap.add + (CI.Po.K.agent_id_of_agent ag) + (CI.Po.K.agent_name_of_agent ag) + data_structure.old_agents; + } + | Instantiation.Is_Bound_to (site1, site2) -> + let ag1_id = CI.Po.K.agent_id_of_site site1 in + let ag2_id = CI.Po.K.agent_id_of_site site2 in + let site1_id = ag1_id, CI.Po.K.site_name_of_site site1 in + let site2_id = ag2_id, CI.Po.K.site_name_of_site site2 in + let data_structure = + if AgentIdSet.mem ag1_id data_structure.removed_agents then + { + data_structure with + removed_sites_in_other_links = + SiteIdSet.add site1_id + data_structure.removed_sites_in_other_links; + } + else + data_structure in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - unambiguous_side_effects + let data_structure = + if AgentIdSet.mem ag2_id data_structure.removed_agents then + { + data_structure with + removed_sites_in_other_links = + SiteIdSet.add site2_id + data_structure.removed_sites_in_other_links; + } + else + data_structure in - if side_effect = [] - && PredicateidMap.is_empty merged_map + { + data_structure with + other_links_test_sites = + SiteIdMap.add site1_id ag2_id + (SiteIdMap.add site2_id ag1_id + data_structure.other_links_test_sites); + } + | Instantiation.Is_Free _ | Instantiation.Has_Binding_type _ + | Instantiation.Has_Internal _ | Instantiation.Is_Bound _ -> + data_structure) + data_structure test_list + in + let tested_sites = + SiteIdMap.fold + (fun a _ -> SiteIdSet.add a) + data_structure.other_links_test_sites SiteIdSet.empty + in + let mod_sites = + SiteIdMap.fold + (fun a _ -> SiteIdSet.add a) + data_structure.other_links_action_sites SiteIdSet.empty + in + let priority_sites = SiteIdSet.inter tested_sites mod_sites in + let data_structure = + { + data_structure with + old_agents_potential_substitution = + AgentIdMap.map + (A.get blackboard.history_of_agent_ids_of_type) + data_structure.old_agents; + } + in + let data_structure = + { data_structure with sure_agents = data_structure.new_agents } + in + let data_structure = + { + data_structure with + sure_agents = + AgentIdMap.fold + (fun id l sure_agents -> + match l with + | [ _ ] -> AgentIdSet.add id sure_agents + | _ -> sure_agents) + data_structure.old_agents_potential_substitution + data_structure.sure_agents; + } + in + let sure_agent = + if init then + fun _ -> + true + else + fun x -> + AgentIdSet.mem x data_structure.sure_agents + in + let data_structure = + { + data_structure with + old_agents_potential_substitution = + AgentIdSet.fold AgentIdMap.remove data_structure.sure_agents + data_structure.old_agents_potential_substitution; + } + in + + let data_structure = + List.fold_left + (fun data_structure test -> + match test with + | Instantiation.Is_Here _ | Instantiation.Has_Internal _ + | Instantiation.Is_Free _ | Instantiation.Is_Bound _ + | Instantiation.Has_Binding_type _ -> + data_structure + | Instantiation.Is_Bound_to (site1, site2) -> + let agent1 = CI.Po.K.agent_of_site site1 in + let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in + let agent2 = CI.Po.K.agent_of_site site2 in + let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in + let site_id1 = CI.Po.K.site_name_of_site site1 in + let site_id2 = CI.Po.K.site_name_of_site site2 in + if + sure_agent ag_id1 + && (not (SiteIdSet.mem (ag_id1, site_id1) priority_sites)) + && sure_agent ag_id2 + && not (SiteIdSet.mem (ag_id2, site_id2) priority_sites) then - error,log_info,blackboard, - nsid_void - else - begin - let _ = A.set blackboard.pre_side_effect_of_event nsid (CI.Po.K.side_effect_of_list side_effect) in - let pre_steps_by_column = - PredicateidMap.fold - (fun id (test,action) map -> - begin - let value,list = A.get map id in - let value' = value + 1 in - let _ = fadd id action blackboard.history_of_predicate_values_to_predicate_id in - let _ = A.set map id (value',(nsid,value,test,action)::list) - in map - end) - merged_map - blackboard.pre_steps_by_column - in - let observable_list = - if Trace.step_is_obs step - then - ([nsid],Trace.simulation_info_of_step step)::blackboard.pre_observable_list - else - blackboard.pre_observable_list - in - let blackboard = + data_structure + else ( + let mix_site1 = ag_id1, CI.Po.K.site_name_of_site site1 in + let mix_site2 = ag_id2, CI.Po.K.site_name_of_site site2 in + let data_structure = + add_site_in_other_test_links mix_site1 + (add_site_in_other_test_links mix_site2 data_structure) + in + let data_structure = + if + SiteIdSet.mem mix_site1 priority_sites + || SiteIdSet.mem mix_site2 priority_sites + then ( + let ag_id1, ag_id2 = + if ag_id1 < ag_id2 then + ag_id1, ag_id2 + else + ag_id2, ag_id1 + in { - blackboard with - pre_event = pre_event ; - pre_fictitious_list = fictitious_list ; - pre_steps_by_column = pre_steps_by_column; - pre_nsteps = nsid; - pre_observable_list = observable_list; + data_structure with + other_links_priority = + AgentId2Set.add (ag_id1, ag_id2) + data_structure.other_links_priority; } + ) else + data_structure + in + data_structure + )) + data_structure (List.rev test_list) + in + let data_structure = + List.fold_left + (fun data_structure action -> + match action with + | Instantiation.Create _ | Instantiation.Remove _ + | Instantiation.Mod_internal _ | Instantiation.Free _ -> + data_structure + | Instantiation.Bind (site1, site2) + | Instantiation.Bind_to (site1, site2) -> + let agent1 = CI.Po.K.agent_of_site site1 in + let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in + let agent2 = CI.Po.K.agent_of_site site2 in + let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in + if sure_agent ag_id1 && sure_agent ag_id2 then + data_structure + else + add_site_in_other_action_links + (ag_id1, CI.Po.K.site_name_of_site site1) + (add_site_in_other_action_links + (ag_id2, CI.Po.K.site_name_of_site site2) + data_structure)) + data_structure (List.rev action_list) + in + let data_structure = + List.fold_left + (fun data_structure test -> + match test with + | Instantiation.Is_Here agent -> + let ag_id = CI.Po.K.agent_id_of_agent agent in + if sure_agent ag_id then + add_sure_test test data_structure + else + add_subs_test test ag_id data_structure + | Instantiation.Has_Internal (site, _) -> + let agent = CI.Po.K.agent_of_site site in + let ag_id = CI.Po.K.agent_id_of_agent agent in + if sure_agent ag_id then + add_sure_test test data_structure + else + add_subs_test test ag_id data_structure + | Instantiation.Is_Free site + | Instantiation.Is_Bound site + | Instantiation.Has_Binding_type (site, _) -> + let agent = CI.Po.K.agent_of_site site in + let ag_id = CI.Po.K.agent_id_of_agent agent in + if + sure_agent ag_id + && not + (SiteIdSet.mem + (ag_id, CI.Po.K.site_name_of_site site) + data_structure.sites_in_other_links) + then + add_sure_test test data_structure + else ( + let site_id1 = ag_id, CI.Po.K.site_name_of_site site in + match + SiteIdMap.find_option site_id1 + data_structure.other_links_action_sites + with + | Some ag_id2 -> + add_subs_test_link test (ag_id, ag_id2) data_structure + | None -> add_subs_test test ag_id data_structure + ) + | Instantiation.Is_Bound_to (site1, site2) -> + let agent1 = CI.Po.K.agent_of_site site1 in + let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in + let agent_name1 = CI.Po.K.agent_name_of_agent agent1 in + let site_name1 = CI.Po.K.site_name_of_site site1 in + let agent2 = CI.Po.K.agent_of_site site2 in + let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in + let agent_name2 = CI.Po.K.agent_name_of_agent agent2 in + let site_name2 = CI.Po.K.site_name_of_site site2 in + let weak1 = + Instantiation.Has_Binding_type (site1, (agent_name2, site_name2)) + in + let weak2 = + Instantiation.Has_Binding_type (site2, (agent_name1, site_name1)) + in + (match + ( sure_agent ag_id1 + && not (SiteIdSet.mem (ag_id1, site_name1) priority_sites), + sure_agent ag_id2 + && not (SiteIdSet.mem (ag_id2, site_name2) priority_sites) ) + with + | true, true -> add_sure_test test data_structure + | true, false -> + add_sure_test weak1 + (add_subs_test weak2 ag_id2 + (add_subs_test_link test (ag_id1, ag_id2) data_structure)) + | false, true -> + add_subs_test weak1 ag_id1 + (add_sure_test weak2 + (add_subs_test_link test (ag_id1, ag_id2) data_structure)) + | false, false -> + add_subs_test weak1 ag_id1 + (add_subs_test weak2 ag_id2 + (add_subs_test_link test (ag_id1, ag_id2) data_structure)))) + data_structure (List.rev test_list) + in + let data_structure = + List.fold_left + (fun data_structure action -> + match action with + | Instantiation.Create _ -> add_create_action action data_structure + | Instantiation.Remove agent -> + let ag_id = CI.Po.K.agent_id_of_agent agent in + if sure_agent ag_id then + add_sure_action action data_structure + else + add_subs_action action ag_id data_structure + | Instantiation.Mod_internal (site, _) -> + let agent = CI.Po.K.agent_of_site site in + let ag_id = CI.Po.K.agent_id_of_agent agent in + if sure_agent ag_id then + add_sure_action action data_structure + else + add_subs_action action ag_id data_structure + | Instantiation.Free site -> + let agent = CI.Po.K.agent_of_site site in + let ag_id = CI.Po.K.agent_id_of_agent agent in + let site_id1 = ag_id, CI.Po.K.site_name_of_site site in + if mem_site_in_other_action_links site_id1 data_structure then + data_structure + else if sure_agent ag_id then + add_sure_action action data_structure + else ( + match + SiteIdMap.find_option site_id1 + data_structure.other_links_test_sites + with + | Some ag_id2 -> + add_subs_action_link action (ag_id, ag_id2) data_structure + | None -> add_subs_action action ag_id data_structure + ) + | Instantiation.Bind (site1, site2) + | Instantiation.Bind_to (site1, site2) -> + let agent1 = CI.Po.K.agent_of_site site1 in + let ag_id1 = CI.Po.K.agent_id_of_agent agent1 in + let agent2 = CI.Po.K.agent_of_site site2 in + let ag_id2 = CI.Po.K.agent_id_of_agent agent2 in + if sure_agent ag_id1 && sure_agent ag_id2 then + add_sure_action action data_structure + else + add_subs_action_link action (ag_id1, ag_id2) data_structure) + data_structure (List.rev action_list) + in + + let data_structure = + List.fold_left + (fun data_structure side_effect -> + let site, _ = side_effect in + let agent = CI.Po.K.agent_of_site site in + let ag_id = CI.Po.K.agent_id_of_agent agent in + if sure_agent ag_id then + add_sure_side_effect side_effect data_structure + else + add_subs_side_effect side_effect ag_id data_structure) + data_structure side_effect + in + let data_structure = + { + data_structure with + subs_agents_involved_in_links = + (let f x set = + AgentId2Map.fold + (fun (a1, a2) _ set -> AgentIdSet.add a1 (AgentIdSet.add a2 set)) + x set + in + f data_structure.other_links_tests + (f data_structure.other_links_actions AgentIdSet.empty)); + } + in + let init_step = None in + let ( error, + log_info, + blackboard, + rule_agent_id_mutex, + rule_agent_id_subs, + mixture_agent_id_mutex, + fictitious_list, + fictitious_local_list, + _, + init_step ) = + AgentIdMap.fold + (fun x l + ( error, + log_info, + blackboard, + rule_agent_id_mutex, + rule_agent_id_subs, + mixture_agent_id_mutex, + fictitious_list, + fictitious_local_list, + set, + init_step ) -> + (* the following mutex is used to encode the fact that the agent x in the lhs of the rule must be associated with exactely one agent in the mixture *) + let predicate_info = Mutex (Lock_agent (step_id, x)) in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard predicate_info + in + let error, log_info, blackboard, init_step = + init_fictitious_action log_info error predicate_id blackboard + init_step + in + let rule_agent_id_mutex = + AgentIdMap.add x predicate_id rule_agent_id_mutex + in + let fictitious_local_list = predicate_id :: fictitious_local_list in + let fictitious_list = predicate_id :: fictitious_list in + let error, log_info, blackboard, rule_agent_id_subs, init_step = + if AgentIdSet.mem x data_structure.subs_agents_involved_in_links + then ( + let predicate_info = Pointer (step_id, x) in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + predicate_info + in + let rule_agent_id_subs = + AgentIdMap.add x predicate_id rule_agent_id_subs + in + let error, log_info, blackboard, init_step = + init_fictitious_action log_info error predicate_id blackboard + init_step + in + error, log_info, blackboard, rule_agent_id_subs, init_step + ) else + error, log_info, blackboard, rule_agent_id_subs, init_step + in + let ( error, + log_info, + blackboard, + mixture_agent_id_mutex, + set, + init_step ) = + List.fold_left + (fun ( error, + log_info, + blackboard, + mixture_agent_id_mutex, + set, + init_step ) id -> + let _ = + if + Remanent_parameters.get_trace + (CI.Po.K.H.get_kasa_parameters parameter) + || debug_mode + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) + "ID of agent in the rule: %i, ID of the agent in the \ + mixture: %i" + x id + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) + in + () + ) in - error,log_info,blackboard,nsid_next - end - end - in - - (*** deal with substitutable agents ***) - let error,log_info,blackboard,init_step,nlist = - AgentIdMap.fold - (fun rule_ag_id l (error,log_info,blackboard,init_step,nlist) -> - let test_list,action_list,side_effect = - AgentIdMap.find_default - [] rule_ag_id data_structure.other_agents_tests, - AgentIdMap.find_default - [] rule_ag_id data_structure.other_agents_actions, - AgentIdMap.find_default - [] rule_ag_id data_structure.other_agents_side_effects - in - List.fold_left - (fun (error,log_info,blackboard,init_step,nlist) mixture_ag_id -> - let step = Trace.subs_step rule_ag_id mixture_ag_id in - let test_list = - List_util.smart_map - (Instantiation.subst_agent_in_concrete_test rule_ag_id mixture_ag_id) - test_list - in - let action_list = - List_util.smart_map - (Instantiation.subst_agent_in_concrete_action rule_ag_id mixture_ag_id) - action_list - in - let side_effect = - List_util.smart_map - (Instantiation.subst_agent_in_concrete_side_effect rule_ag_id mixture_ag_id) - side_effect in - let fictitious_local_list = [] in - let error,log_info,blackboard,fictitious_list,fictitious_local_list,unambiguous_side_effects,init_step = - List.fold_left - (fun (error,log_info,blackboard,fictitious_list,fictitious_local_list,unambiguous_side_effects,init_step) (site,(binding_state)) -> - begin - let error,log_info,blackboard,potential_target = potential_target parameter handler log_info error blackboard site binding_state in - match - potential_target - with - | [l] -> - begin - let list = - List.fold_left - (fun list t -> t::list) - unambiguous_side_effects - l - in - error, - log_info, - blackboard, - fictitious_list, - fictitious_local_list, - list, - init_step - end - | _ -> - begin - let predicate_info = Mutex (Lock_side_effect (step_id,rule_ag_id,mixture_ag_id,CI.Po.K.site_name_of_site site)) in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let fictitious_list = predicate_id::fictitious_list in - let error,log_info,blackboard,init_step = init_fictitious_action log_info error predicate_id blackboard init_step in - let error,log_info,blackboard = - List.fold_left - (fun (error,log_info,blackboard) list -> - let blackboard = {blackboard with pre_nsteps = blackboard.pre_nsteps+1} in - let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - list - in - let side_effect = CI.Po.K.side_effect_of_list side_effect in - let _ = A.set blackboard.pre_side_effect_of_event blackboard.pre_nsteps side_effect in - let error,blackboard = - List.fold_left - (fun (error,blackboard) (predicate_id,_,(test,action)) -> - add_fictitious_action error test action predicate_id blackboard) - (error,blackboard) - ((predicate_id,None,(Counter 0,Counter 1))::list) - in - error,log_info,blackboard) - (error,log_info,blackboard) - potential_target - in - error, - log_info, - blackboard, - (predicate_id::fictitious_list), - (predicate_id::fictitious_local_list), - unambiguous_side_effects, - init_step - end - end) - (error,log_info,blackboard,fictitious_list,fictitious_local_list,[],init_step) - side_effect - in - let error,log_info,pid_rule_agent_mutex = - match AgentIdMap.find_option - rule_ag_id - data_structure.rule_agent_id_mutex - with - | Some x -> error,log_info,x - | None -> - warn - parameter log_info error __POS__ - (Failure "Unknown agent id") 0 - in - let error,log_info,blackboard,test_map = - List.fold_left - (fun (error,log_info,blackboard,map) test -> - let error,log_info,blackboard,test_list = predicates_of_test parameter handler log_info error blackboard test in - error,log_info,blackboard,build_map test_list map) - (error,log_info,blackboard,PredicateidMap.empty) - test_list in - let test_map = - PredicateidMap.add - pid_rule_agent_mutex - (Counter 0) - test_map - in - let error,log_info,blackboard,action_map,test_map = - List.fold_left - (fun (error,log_info,blackboard,action_map,test_map) action -> - let error,log_info,blackboard,action_list,test_list = predicates_of_action true parameter handler log_info error blackboard init action in - error,log_info,blackboard,build_map action_list action_map,build_map test_list test_map) - (error,log_info,blackboard,PredicateidMap.empty,test_map) - action_list in - let action_map = - PredicateidMap.add - pid_rule_agent_mutex - (Counter 1) - action_map - in - let test_map,action_map = - match - AgentIdMap.find_option - rule_ag_id - data_structure.rule_agent_id_subs - with - | Some m_id -> - PredicateidMap.add - m_id - (Counter 0) - test_map, - PredicateidMap.add - m_id - (Pointer_to_agent mixture_ag_id) - action_map - | None -> test_map,action_map - in - (* The following block should be logged and corrected *) - (* let test_map,action_map = - match - AgentIdMap.find_option - mixture_ag_id - data_structure.mixture_agent_id_mutex with - | Some m_id -> - PredicateidMap.add - m_id - (Counter 0) - test_map, - PredicateidMap.add - m_id - (Counter 1) - action_map - | None -> test_map,action_map - in*) - let error,merged_map = - PredicateidMap.monadic_fold2 - parameter error - (fun _ e key test action acc -> - e,PredicateidMap.add key (test,action) acc) - (fun _ e key test acc -> - e,PredicateidMap.add key (test,Unknown) acc) - (fun _ e key action acc -> - e,PredicateidMap.add key (Unknown,action) acc) - test_map - action_map - PredicateidMap.empty in - let merged_map,nlist = - (* enumeration of potential binding state, according to a substitution *) - (* If the event is selected, check that the wire end in the state 0*) - (* Undef->Counter 0 : opening event *) - (* Counter 0 -> Counter 1 : potential binding type *) - (* => Counter 1 -> Counter 0 : the corresponding substitution is applied *) - (* Counter 0 -> Undef : closing event, check that if the event has been selected (open and closed), then exactely one binding state has been selected, - according to the corresponding substitution *) - (* If the event is selected & the according substitution taken, then mutual exclusion among the potential binding state*) - List.fold_left - (fun (map,nlist) pid -> - (PredicateidMap.add pid (Counter 1,Counter 0) map),pid::nlist) - (merged_map,nlist) - fictitious_local_list - in - let merged_map = - List.fold_left - (fun map (pid,_,(test,action)) -> add_state pid (test,action) map) - merged_map - unambiguous_side_effects - in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - unambiguous_side_effects - in - let merged_map = - PredicateidMap.mapi - (fun pid (test,action) -> - if action = Undefined - && - begin - match A.get blackboard.pre_column_map_inv pid - with - | Bound_site (ag_id,site_id) -> - ag_id = mixture_ag_id && (SiteIdSet.mem (rule_ag_id,site_id) data_structure.removed_sites_in_other_links) - | Here _ | Pointer _ | Mutex _ | Link _ - | Internal_state _ | Fictitious -> false - end - then - (test,Unknown) - else - (test,action)) - merged_map - in - if side_effect = [] - && PredicateidMap.is_empty merged_map - then - error,log_info,blackboard,init_step,nlist - else - begin - let nsid = blackboard.pre_nsteps + 1 in - let _ = A.set blackboard.pre_side_effect_of_event nsid (CI.Po.K.side_effect_of_list side_effect) in - let _ = A.set pre_event nsid step in - let pre_steps_by_column = - PredicateidMap.fold - (fun id (test,action) map -> - begin - let value,list = A.get map id in - let value' = value + 1 in - let _ = fadd id action blackboard.history_of_predicate_values_to_predicate_id in - let _ = A.set map id (value',(nsid,value,test,action)::list) - in map - end) - merged_map - blackboard.pre_steps_by_column + let set' = AgentIdSet.add id set in + if set == set' then + if AgentIdMap.mem id mixture_agent_id_mutex then ( + (* The mutex is already declared, nothing to do *) + let () = + if + Remanent_parameters.get_trace + (CI.Po.K.H.get_kasa_parameters parameter) + || debug_mode + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) + "Mutex already exists" + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) + in + () + ) + in + ( error, + log_info, + blackboard, + mixture_agent_id_mutex, + set, + init_step ) + ) else ( + (* The mutex has to be allocated *) + let () = + if + Remanent_parameters.get_trace + (CI.Po.K.H.get_kasa_parameters parameter) + || debug_mode + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) + "Create Mutex" + in + let () = + Loggers.print_newline + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) + in + () + ) + in + let predicate_info = + Mutex (Lock_rectangular (step_id, id)) + in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + predicate_info + in + let mixture_agent_id_mutex = + AgentIdMap.add id predicate_id mixture_agent_id_mutex + in + let error, log_info, blackboard, init_step = + init_fictitious_action log_info error predicate_id + blackboard init_step + in + ( error, + log_info, + blackboard, + mixture_agent_id_mutex, + set', + init_step ) + ) + else ( + (* The agent in the mixture is seen for the first time, no need for a mutex for the moment *) + let () = + if + Remanent_parameters.get_trace + (CI.Po.K.H.get_kasa_parameters parameter) + || debug_mode + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) + "This agent is seen for the first time, no need for \ + mutex yet" in - let _ = A.set blackboard.pre_kind_of_event nsid (type_of_step step) in - let blackboard = - { - blackboard with - pre_event = pre_event ; - pre_fictitious_list = fictitious_list ; - pre_steps_by_column = pre_steps_by_column; - pre_nsteps = nsid; - } + let () = + Loggers.print_newline + (Remanent_parameters.get_logger + (CI.Po.K.H.get_kasa_parameters parameter)) in - error,log_info,blackboard,init_step,nlist - end ) - (error,log_info,blackboard,init_step,nlist) l - ) - data_structure.old_agents_potential_substitution - (error,log_info,blackboard,init_step,[]) - - in - - (* deal with substitutable agent in links*) - let f error log_info blackboard set = - AgentId2Set.fold - (fun link (error,log_info,blackboard) -> - let link_mutex = - match AgentId2Map.find_option link data_structure.links_mutex with - | Some x -> x - | None -> raise Not_found in - let rule_ag_id1,rule_ag_id2=link in - let l_ag_1 = - AgentIdMap.find_default - [rule_ag_id1] rule_ag_id1 data_structure.old_agents_potential_substitution in - let l_ag_2 = - AgentIdMap.find_default - [rule_ag_id2] rule_ag_id2 data_structure.old_agents_potential_substitution in - let test_list = - AgentId2Map.find_default [] link data_structure.other_links_tests in - let action_list = - AgentId2Map.find_default [] link data_structure.other_links_actions in - List.fold_left - (fun (error,log_info,blackboard) mixture_ag_1 -> - let subs = AgentIdMap.empty in - let subs = - (* if rule_ag_id1 = mixture_ag_1 - then - subs - else*) - AgentIdMap.add rule_ag_id1 mixture_ag_1 subs + () + ) in - List.fold_left - (fun (error,log_info,blackboard) mixture_ag_2 -> - if (rule_ag_id1 = rule_ag_id2) = (mixture_ag_1 = mixture_ag_2) - then - begin - let step = Trace.dummy_step ("LINK "^(string_of_int mixture_ag_1)^"/"^(string_of_int rule_ag_id1)^","^(string_of_int mixture_ag_2)^"/"^(string_of_int rule_ag_id2)^")") - in - let subs = - (* if rule_ag_id2 = mixture_ag_2 - then - subs - else*) - AgentIdMap.add rule_ag_id2 mixture_ag_2 subs - in - let test_list,action_list = - if subs = AgentIdMap.empty - then - test_list,action_list - else - let f x = - AgentIdMap.find_default x x subs - in - List_util.smart_map - (Instantiation.subst_map_agent_in_concrete_test f) - test_list, - List_util.smart_map - (Instantiation.subst_map_agent_in_concrete_action f) - action_list - in - let error,log_info,blackboard,test_map = - List.fold_left - (fun (error,log_info,blackboard,map) test -> - let error,log_info,blackboard,test_list = predicates_of_test parameter handler log_info error blackboard test in - error,log_info,blackboard,build_map test_list map) - (error,log_info,blackboard,PredicateidMap.empty) - test_list in - let error,log_info,blackboard,action_map,test_map = - List.fold_left - (fun (error,log_info,blackboard,action_map,test_map) action -> - let error,log_info,blackboard,action_list,test_list = predicates_of_action true parameter handler log_info error blackboard init action in - let action_list = - List.rev_map - (fun (pid,x) - -> - match x with - | Free -> - begin - match A.get blackboard.pre_column_map_inv pid - with - | Bound_site (ag_id,site_id) -> - if - (ag_id = mixture_ag_1 && (SiteIdSet.mem (rule_ag_id1,site_id) data_structure.removed_sites_in_other_links)) - || (ag_id = mixture_ag_2 && (SiteIdSet.mem (rule_ag_id2,site_id) data_structure.removed_sites_in_other_links)) - then (pid,Undefined) - else (pid,x) - | _ -> (pid,x) - end - | _ -> (pid,x)) - (List.rev action_list) - in - error,log_info,blackboard,build_map action_list action_map,build_map test_list test_map) - (error,log_info,blackboard,PredicateidMap.empty,test_map) - action_list in - let error,merged_map = - PredicateidMap.monadic_fold2 - parameter error - (fun _ e key test action acc -> - e,PredicateidMap.add key (test,action) acc) - (fun _ e key test acc -> - e,PredicateidMap.add key (test,Unknown) acc) - (fun _ e key action acc -> - e,PredicateidMap.add key (Unknown,action) acc) - test_map - action_map - PredicateidMap.empty in - let merged_map = - PredicateidMap.add link_mutex (Counter 0,Counter 1) merged_map - in - (* Pointer -> *) - let merged_map = - match AgentIdMap.find_option - rule_ag_id1 data_structure.rule_agent_id_subs with - | Some m_id -> - PredicateidMap.add - m_id - (Pointer_to_agent mixture_ag_1,Unknown) - merged_map - | None -> merged_map - in - let merged_map = - match AgentIdMap.find_option - rule_ag_id2 data_structure.rule_agent_id_subs with - | Some m_id -> - PredicateidMap.add - m_id - (Pointer_to_agent mixture_ag_2,Unknown) - merged_map - | None -> merged_map - in - if PredicateidMap.is_empty merged_map - then - error,log_info,blackboard else - begin - let nsid = blackboard.pre_nsteps + 1 in - let _ = A.set pre_event nsid step in - let pre_steps_by_column = - PredicateidMap.fold - (fun id (test,action) map -> - begin - let value,list = A.get map id in - let value' = value + 1 in - let _ = fadd id action blackboard.history_of_predicate_values_to_predicate_id in - let _ = A.set map id (value',(nsid,value,test,action)::list) - in map - end) - merged_map - blackboard.pre_steps_by_column - in - let _ = A.set blackboard.pre_kind_of_event nsid (type_of_step step) in - let blackboard = - { - blackboard with - pre_event = pre_event ; - pre_steps_by_column = pre_steps_by_column; - pre_nsteps = nsid; - } - in - error,log_info,blackboard - end - end - else - error,log_info,blackboard) - (error,log_info,blackboard) - l_ag_2) - (error,log_info,blackboard) - (l_ag_1)) - set - (error,log_info,blackboard) - in - let data_structure = - { - data_structure - with - other_links = AgentId2Set.diff data_structure.other_links data_structure.other_links_priority} - in - - let error,log_info,blackboard = - f error log_info blackboard data_structure.other_links_priority + ( error, + log_info, + blackboard, + mixture_agent_id_mutex, + set', + init_step ) + )) + ( error, + log_info, + blackboard, + mixture_agent_id_mutex, + set, + init_step ) + l + in + ( error, + log_info, + blackboard, + rule_agent_id_mutex, + rule_agent_id_subs, + mixture_agent_id_mutex, + fictitious_list, + fictitious_local_list, + set, + init_step )) + data_structure.old_agents_potential_substitution + ( error, + log_info, + blackboard, + AgentIdMap.empty, + AgentIdMap.empty, + AgentIdMap.empty, + blackboard.pre_fictitious_list, + [], + AgentIdSet.empty, + init_step ) + in + let links_mutex = AgentId2Map.empty in + let ( error, + log_info, + blackboard, + links_mutex, + fictitious_list, + fictitious_local_list, + init_step ) = + AgentId2Set.fold + (fun x + ( error, + log_info, + blackboard, + links_mutex, + fictitious_list, + fictitious_local_list, + init_step ) -> + let predicate_info = Mutex (Lock_links (step_id, x)) in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard predicate_info + in + let error, log_info, blackboard, init_step = + init_fictitious_action log_info error predicate_id blackboard + init_step + in + let links_mutex = AgentId2Map.add x predicate_id links_mutex in + let fictitious_local_list = predicate_id :: fictitious_local_list in + let fictitious_list = predicate_id :: fictitious_list in + ( error, + log_info, + blackboard, + links_mutex, + fictitious_list, + fictitious_local_list, + init_step )) + data_structure.other_links + ( error, + log_info, + blackboard, + links_mutex, + fictitious_list, + fictitious_local_list, + init_step ) + in + let data_structure = + { + data_structure with + links_mutex; + rule_agent_id_mutex; + rule_agent_id_subs; + mixture_agent_id_mutex; + } + in + let blackboard = + { blackboard with pre_fictitious_list = fictitious_list } + in + let _ = + if debug_mode then ( + let _ = print_data_structure parameter handler error data_structure in + () + ) + in + let fictitious_list = blackboard.pre_fictitious_list in + let build_map list map = + List.fold_left + (fun map (id, value) -> PredicateidMap.add id value map) + map list + in + let add_state pid (test, action) map = + let test', action' = + PredicateidMap.find_default (Unknown, Unknown) pid map in - let error,log_info,blackboard = - f error log_info blackboard data_structure.other_links + let test = + if strictly_more_refined test test' then + test + else + test' in - - (* deal with rigid elements *) - let side_effect = data_structure.sure_side_effects in - let action_list = - match init_step with - None -> data_structure.create_actions@data_structure.sure_actions - | Some _ -> data_structure.sure_actions + let action = + if strictly_more_refined action action' then + action + else + action' in - let test_list = data_structure.sure_tests in - let fictitious_list = blackboard.pre_fictitious_list in - - let error,log_info,blackboard,fictitious_list,fictitious_local_list,unambiguous_side_effects,_init_step = - List.fold_left - (fun (error,log_info,blackboard,fictitious_list,fictitious_local_list,unambiguous_side_effects,init_step) (site,(binding_state)) -> - begin - let error,log_info,blackboard,potential_target = potential_target parameter handler log_info error blackboard site binding_state in - match - potential_target - with - | [l] -> - begin - let list = - List.fold_left - (fun list t -> t::list) - unambiguous_side_effects - l - in - error, + let map = PredicateidMap.add pid (test, action) map in + map + in + let fadd pid p map = + match p with + | Counter _ | Internal_state_is _ | Undefined | Defined | Present | Bound + | Bound_to_type _ | Unknown -> + () + | Free | Pointer_to_agent _ | Bound_to _ -> + let old = A.get map pid in + A.set map pid (C.add p old) + in + + (* deal with created agents *) + let error, log_info, blackboard, step_id = + match init_step with + | None -> error, log_info, blackboard, step_id + | Some nsid -> + let nsid = nsid in + let nsid_void = nsid + 1 in + let nsid_next = nsid + 1 in + let side_effect = [] in + let action_list = data_structure.create_actions in + let test_list = [] in + let fictitious_list = [] in + + let ( error, + log_info, + blackboard, + fictitious_list, + _fictitious_local_list, + unambiguous_side_effects, + _init_step ) = + List.fold_left + (fun ( error, log_info, blackboard, fictitious_list, fictitious_local_list, - list, - init_step - end - | _ -> - begin - let rule_ag_id = CI.Po.K.agent_id_of_agent (CI.Po.K.agent_of_site site) in - let predicate_info = Mutex (Lock_side_effect (step_id,rule_ag_id,rule_ag_id,CI.Po.K.site_name_of_site site)) in - let error,log_info, blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let error,log_info,blackboard,_step_id = - init_fictitious_action log_info error predicate_id blackboard init_step - in - let error,log_info,blackboard = - List.fold_left - (fun (error,log_info,blackboard) list -> - let blackboard = {blackboard with pre_nsteps = blackboard.pre_nsteps+1} in - let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - list - in - let side_effect = CI.Po.K.side_effect_of_list - side_effect in - let _ = A.set blackboard.pre_side_effect_of_event - blackboard.pre_nsteps - side_effect in - let error,blackboard = - List.fold_left - (fun (error,blackboard) (predicate_id,_,(test,action)) -> - add_fictitious_action error test action predicate_id blackboard) - (error,blackboard) - ((predicate_id,None,(Counter 0,Counter 1))::list) - in - error,log_info,blackboard) - (error,log_info,blackboard) - potential_target - in - error, - log_info, - blackboard, - (predicate_id::fictitious_list), - (predicate_id::fictitious_local_list), unambiguous_side_effects, - init_step - end - end) - (error,log_info,blackboard,fictitious_list,fictitious_local_list,[],init_step) - side_effect - in - let error,log_info,blackboard,test_map = - List.fold_left - (fun (error,log_info,blackboard,map) test -> - let error,log_info,blackboard,test_list = predicates_of_test parameter handler log_info error blackboard test in - error,log_info,blackboard,build_map test_list map) - (error,log_info,blackboard,PredicateidMap.empty) - test_list in - let error,log_info,blackboard,action_map,test_map = - List.fold_left - (fun (error,log_info,blackboard,action_map,test_map) action -> - let error,log_info,blackboard,action_list,test_list = predicates_of_action true parameter handler log_info error blackboard init action in - error,log_info,blackboard,build_map action_list action_map,build_map test_list test_map) - (error,log_info,blackboard,PredicateidMap.empty,test_map) - action_list in - let error,merged_map = - PredicateidMap.monadic_fold2 - parameter error - (fun _ e key test action acc -> - e,PredicateidMap.add key (test,action) acc) - (fun _ e key test acc -> - e,PredicateidMap.add key (test,Unknown) acc) - (fun _ e key action acc -> - e,PredicateidMap.add key (Unknown,action) acc) - test_map - action_map - PredicateidMap.empty in - let merged_map = - List.fold_left - (fun map pid -> PredicateidMap.add pid (Counter 1,Undefined) map) - merged_map - fictitious_local_list - in - let merged_map = - List.fold_left - (fun map (pid,_,(test,action)) -> add_state pid (test,action) map) - merged_map - unambiguous_side_effects - in - let merged_map = - (* If the event is selected, check that the wire end in the state 0*) - (* Undef->Counter 0 : opening event *) - (* Counter 0 -> Counter 1 : potential binding type *) - (* Counter 1 -> Counter 0 : the corresponding substitution is applied *) - (* => Counter 0 -> Undef : closing event, check that if the event has been selected (open and closed), then exactely one binding state has been selected, - according to the corresponding substitution *) - (* If the event is selected & the according substitution taken, then mutual exclusion among the potential binding state*) - List.fold_left - (fun map pid -> add_state pid (Counter 0,Undefined) map) - merged_map - nlist - in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - unambiguous_side_effects - in - if side_effect = [] - && PredicateidMap.is_empty merged_map - then - error,log_info,(blackboard,step_id+1) - else - begin - let nsid = blackboard.pre_nsteps + 1 in - let _ = A.set blackboard.pre_side_effect_of_event nsid (CI.Po.K.side_effect_of_list side_effect) in - let _ = A.set pre_event nsid step in + init_step ) (site, binding_state) -> + let error, log_info, blackboard, potential_target = + potential_target parameter handler log_info error blackboard + site binding_state + in + match potential_target with + | [ l ] -> + let list = + List.fold_left + (fun list t -> t :: list) + unambiguous_side_effects l + in + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + list, + init_step ) + | _ -> + let rule_ag_id = + CI.Po.K.agent_id_of_agent (CI.Po.K.agent_of_site site) + in + let predicate_info = + Mutex + (Lock_side_effect + ( step_id, + rule_ag_id, + rule_ag_id, + CI.Po.K.site_name_of_site site )) + in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + predicate_info + in + let error, log_info, blackboard, _step_id = + init_fictitious_action log_info error predicate_id blackboard + init_step + in + let error, log_info, blackboard = + List.fold_left + (fun (error, log_info, blackboard) list -> + let blackboard = + { + blackboard with + pre_nsteps = blackboard.pre_nsteps + 1; + } + in + let log_info = + StoryProfiling.StoryStats.inc_n_side_events log_info + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] list + in + let side_effect = + CI.Po.K.side_effect_of_list side_effect + in + let _ = + A.set blackboard.pre_side_effect_of_event + blackboard.pre_nsteps side_effect + in + let error, blackboard = + List.fold_left + (fun (error, blackboard) + (predicate_id, _, (test, action)) -> + add_fictitious_action error test action predicate_id + blackboard) + (error, blackboard) + ((predicate_id, None, (Counter 0, Counter 1)) :: list) + in + error, log_info, blackboard) + (error, log_info, blackboard) + potential_target + in + ( error, + log_info, + blackboard, + predicate_id :: fictitious_list, + predicate_id :: fictitious_local_list, + unambiguous_side_effects, + init_step )) + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + [], + init_step ) + side_effect + in + let error, log_info, blackboard, test_map = + List.fold_left + (fun (error, log_info, blackboard, map) test -> + let error, log_info, blackboard, test_list = + predicates_of_test parameter handler log_info error blackboard + test + in + error, log_info, blackboard, build_map test_list map) + (error, log_info, blackboard, PredicateidMap.empty) + test_list + in + let error, log_info, blackboard, action_map, test_map = + List.fold_left + (fun (error, log_info, blackboard, action_map, test_map) action -> + let error, log_info, blackboard, action_list, test_list = + predicates_of_action true parameter handler log_info error + blackboard init action + in + ( error, + log_info, + blackboard, + build_map action_list action_map, + build_map test_list test_map )) + (error, log_info, blackboard, PredicateidMap.empty, test_map) + action_list + in + let error, merged_map = + PredicateidMap.monadic_fold2 parameter error + (fun _ e key test action acc -> + e, PredicateidMap.add key (test, action) acc) + (fun _ e key test acc -> + e, PredicateidMap.add key (test, Unknown) acc) + (fun _ e key action acc -> + e, PredicateidMap.add key (Unknown, action) acc) + test_map action_map PredicateidMap.empty + in + let merged_map = + List.fold_left + (fun map (pid, _, (test, action)) -> + add_state pid (test, action) map) + merged_map unambiguous_side_effects + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] unambiguous_side_effects + in + if side_effect = [] && PredicateidMap.is_empty merged_map then + error, log_info, blackboard, nsid_void + else ( + let _ = + A.set blackboard.pre_side_effect_of_event nsid + (CI.Po.K.side_effect_of_list side_effect) + in let pre_steps_by_column = PredicateidMap.fold - (fun id (test,action) map -> - begin - let value,list = A.get map id in - let value' = value + 1 in - let _ = fadd id action blackboard.history_of_predicate_values_to_predicate_id in - let _ = A.set map id (value',(nsid,value,test,action)::list) - in map - end) - merged_map - blackboard.pre_steps_by_column + (fun id (test, action) map -> + let value, list = A.get map id in + let value' = value + 1 in + let _ = + fadd id action + blackboard.history_of_predicate_values_to_predicate_id + in + let _ = + A.set map id (value', (nsid, value, test, action) :: list) + in + map) + merged_map blackboard.pre_steps_by_column in - let _ = A.set blackboard.pre_kind_of_event nsid (type_of_step step) in let observable_list = - if Trace.step_is_obs step - then - ([nsid],Trace.simulation_info_of_step step)::blackboard.pre_observable_list + if Trace.step_is_obs step then + ([ nsid ], Trace.simulation_info_of_step step) + :: blackboard.pre_observable_list else blackboard.pre_observable_list in let blackboard = { blackboard with - pre_event = pre_event ; - pre_fictitious_list = fictitious_list ; - pre_steps_by_column = pre_steps_by_column; + pre_event; + pre_fictitious_list = fictitious_list; + pre_steps_by_column; pre_nsteps = nsid; pre_observable_list = observable_list; } in - error,log_info,(blackboard,step_id+1) - end - - let add_step parameter handler log_info error step blackboard step_id = - let init = Trace.step_is_init step in - let init_step = None in - let pre_event = blackboard.pre_event in - let test_list = Trace.tests_of_step step in - let (action_list,side_effect) = Trace.actions_of_step step in - let fictitious_local_list = [] in - let fictitious_list = blackboard.pre_fictitious_list in - let build_map list map = - List.fold_left - (fun map (id,value) -> PredicateidMap.add id value map) - map - list + error, log_info, blackboard, nsid_next + ) + in + + (*** deal with substitutable agents ***) + let error, log_info, blackboard, init_step, nlist = + AgentIdMap.fold + (fun rule_ag_id l (error, log_info, blackboard, init_step, nlist) -> + let test_list, action_list, side_effect = + ( AgentIdMap.find_default [] rule_ag_id + data_structure.other_agents_tests, + AgentIdMap.find_default [] rule_ag_id + data_structure.other_agents_actions, + AgentIdMap.find_default [] rule_ag_id + data_structure.other_agents_side_effects ) + in + List.fold_left + (fun (error, log_info, blackboard, init_step, nlist) mixture_ag_id -> + let step = Trace.subs_step rule_ag_id mixture_ag_id in + let test_list = + List_util.smart_map + (Instantiation.subst_agent_in_concrete_test rule_ag_id + mixture_ag_id) + test_list + in + let action_list = + List_util.smart_map + (Instantiation.subst_agent_in_concrete_action rule_ag_id + mixture_ag_id) + action_list + in + let side_effect = + List_util.smart_map + (Instantiation.subst_agent_in_concrete_side_effect rule_ag_id + mixture_ag_id) + side_effect + in + let fictitious_local_list = [] in + let ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + unambiguous_side_effects, + init_step ) = + List.fold_left + (fun ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + unambiguous_side_effects, + init_step ) (site, binding_state) -> + let error, log_info, blackboard, potential_target = + potential_target parameter handler log_info error + blackboard site binding_state + in + match potential_target with + | [ l ] -> + let list = + List.fold_left + (fun list t -> t :: list) + unambiguous_side_effects l + in + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + list, + init_step ) + | _ -> + let predicate_info = + Mutex + (Lock_side_effect + ( step_id, + rule_ag_id, + mixture_ag_id, + CI.Po.K.site_name_of_site site )) + in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + predicate_info + in + let fictitious_list = predicate_id :: fictitious_list in + let error, log_info, blackboard, init_step = + init_fictitious_action log_info error predicate_id + blackboard init_step + in + let error, log_info, blackboard = + List.fold_left + (fun (error, log_info, blackboard) list -> + let blackboard = + { + blackboard with + pre_nsteps = blackboard.pre_nsteps + 1; + } + in + let log_info = + StoryProfiling.StoryStats.inc_n_side_events + log_info + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] list + in + let side_effect = + CI.Po.K.side_effect_of_list side_effect + in + let _ = + A.set blackboard.pre_side_effect_of_event + blackboard.pre_nsteps side_effect + in + let error, blackboard = + List.fold_left + (fun (error, blackboard) + (predicate_id, _, (test, action)) -> + add_fictitious_action error test action + predicate_id blackboard) + (error, blackboard) + ((predicate_id, None, (Counter 0, Counter 1)) + :: list) + in + error, log_info, blackboard) + (error, log_info, blackboard) + potential_target + in + ( error, + log_info, + blackboard, + predicate_id :: fictitious_list, + predicate_id :: fictitious_local_list, + unambiguous_side_effects, + init_step )) + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + [], + init_step ) + side_effect + in + let error, log_info, pid_rule_agent_mutex = + match + AgentIdMap.find_option rule_ag_id + data_structure.rule_agent_id_mutex + with + | Some x -> error, log_info, x + | None -> + warn parameter log_info error __POS__ + (Failure "Unknown agent id") 0 + in + let error, log_info, blackboard, test_map = + List.fold_left + (fun (error, log_info, blackboard, map) test -> + let error, log_info, blackboard, test_list = + predicates_of_test parameter handler log_info error + blackboard test + in + error, log_info, blackboard, build_map test_list map) + (error, log_info, blackboard, PredicateidMap.empty) + test_list + in + let test_map = + PredicateidMap.add pid_rule_agent_mutex (Counter 0) test_map + in + let error, log_info, blackboard, action_map, test_map = + List.fold_left + (fun (error, log_info, blackboard, action_map, test_map) + action -> + let error, log_info, blackboard, action_list, test_list = + predicates_of_action true parameter handler log_info error + blackboard init action + in + ( error, + log_info, + blackboard, + build_map action_list action_map, + build_map test_list test_map )) + (error, log_info, blackboard, PredicateidMap.empty, test_map) + action_list + in + let action_map = + PredicateidMap.add pid_rule_agent_mutex (Counter 1) action_map + in + let test_map, action_map = + match + AgentIdMap.find_option rule_ag_id + data_structure.rule_agent_id_subs + with + | Some m_id -> + ( PredicateidMap.add m_id (Counter 0) test_map, + PredicateidMap.add m_id (Pointer_to_agent mixture_ag_id) + action_map ) + | None -> test_map, action_map + in + (* The following block should be logged and corrected *) + (* let test_map,action_map = + match + AgentIdMap.find_option + mixture_ag_id + data_structure.mixture_agent_id_mutex with + | Some m_id -> + PredicateidMap.add + m_id + (Counter 0) + test_map, + PredicateidMap.add + m_id + (Counter 1) + action_map + | None -> test_map,action_map + in*) + let error, merged_map = + PredicateidMap.monadic_fold2 parameter error + (fun _ e key test action acc -> + e, PredicateidMap.add key (test, action) acc) + (fun _ e key test acc -> + e, PredicateidMap.add key (test, Unknown) acc) + (fun _ e key action acc -> + e, PredicateidMap.add key (Unknown, action) acc) + test_map action_map PredicateidMap.empty + in + let merged_map, nlist = + (* enumeration of potential binding state, according to a substitution *) + (* If the event is selected, check that the wire end in the state 0*) + (* Undef->Counter 0 : opening event *) + (* Counter 0 -> Counter 1 : potential binding type *) + (* => Counter 1 -> Counter 0 : the corresponding substitution is applied *) + (* Counter 0 -> Undef : closing event, check that if the event has been selected (open and closed), then exactely one binding state has been selected, + according to the corresponding substitution *) + (* If the event is selected & the according substitution taken, then mutual exclusion among the potential binding state*) + List.fold_left + (fun (map, nlist) pid -> + ( PredicateidMap.add pid (Counter 1, Counter 0) map, + pid :: nlist )) + (merged_map, nlist) fictitious_local_list + in + let merged_map = + List.fold_left + (fun map (pid, _, (test, action)) -> + add_state pid (test, action) map) + merged_map unambiguous_side_effects + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] unambiguous_side_effects + in + let merged_map = + PredicateidMap.mapi + (fun pid (test, action) -> + if + action = Undefined + && + match A.get blackboard.pre_column_map_inv pid with + | Bound_site (ag_id, site_id) -> + ag_id = mixture_ag_id + && SiteIdSet.mem (rule_ag_id, site_id) + data_structure.removed_sites_in_other_links + | Here _ | Pointer _ | Mutex _ | Link _ | Internal_state _ + | Fictitious -> + false + then + test, Unknown + else + test, action) + merged_map + in + if side_effect = [] && PredicateidMap.is_empty merged_map then + error, log_info, blackboard, init_step, nlist + else ( + let nsid = blackboard.pre_nsteps + 1 in + let _ = + A.set blackboard.pre_side_effect_of_event nsid + (CI.Po.K.side_effect_of_list side_effect) + in + let _ = A.set pre_event nsid step in + let pre_steps_by_column = + PredicateidMap.fold + (fun id (test, action) map -> + let value, list = A.get map id in + let value' = value + 1 in + let _ = + fadd id action + blackboard.history_of_predicate_values_to_predicate_id + in + let _ = + A.set map id + (value', (nsid, value, test, action) :: list) + in + map) + merged_map blackboard.pre_steps_by_column + in + let _ = + A.set blackboard.pre_kind_of_event nsid (type_of_step step) + in + let blackboard = + { + blackboard with + pre_event; + pre_fictitious_list = fictitious_list; + pre_steps_by_column; + pre_nsteps = nsid; + } + in + error, log_info, blackboard, init_step, nlist + )) + (error, log_info, blackboard, init_step, nlist) + l) + data_structure.old_agents_potential_substitution + (error, log_info, blackboard, init_step, []) + in + + (* deal with substitutable agent in links*) + let f error log_info blackboard set = + AgentId2Set.fold + (fun link (error, log_info, blackboard) -> + let link_mutex = + match AgentId2Map.find_option link data_structure.links_mutex with + | Some x -> x + | None -> raise Not_found + in + let rule_ag_id1, rule_ag_id2 = link in + let l_ag_1 = + AgentIdMap.find_default [ rule_ag_id1 ] rule_ag_id1 + data_structure.old_agents_potential_substitution + in + let l_ag_2 = + AgentIdMap.find_default [ rule_ag_id2 ] rule_ag_id2 + data_structure.old_agents_potential_substitution + in + let test_list = + AgentId2Map.find_default [] link data_structure.other_links_tests + in + let action_list = + AgentId2Map.find_default [] link data_structure.other_links_actions + in + List.fold_left + (fun (error, log_info, blackboard) mixture_ag_1 -> + let subs = AgentIdMap.empty in + let subs = + (* if rule_ag_id1 = mixture_ag_1 + then + subs + else*) + AgentIdMap.add rule_ag_id1 mixture_ag_1 subs + in + List.fold_left + (fun (error, log_info, blackboard) mixture_ag_2 -> + if rule_ag_id1 = rule_ag_id2 = (mixture_ag_1 = mixture_ag_2) + then ( + let step = + Trace.dummy_step + ("LINK " ^ string_of_int mixture_ag_1 ^ "/" + ^ string_of_int rule_ag_id1 ^ "," + ^ string_of_int mixture_ag_2 ^ "/" + ^ string_of_int rule_ag_id2 ^ ")") + in + let subs = + (* if rule_ag_id2 = mixture_ag_2 + then + subs + else*) + AgentIdMap.add rule_ag_id2 mixture_ag_2 subs + in + let test_list, action_list = + if subs = AgentIdMap.empty then + test_list, action_list + else ( + let f x = AgentIdMap.find_default x x subs in + ( List_util.smart_map + (Instantiation.subst_map_agent_in_concrete_test f) + test_list, + List_util.smart_map + (Instantiation.subst_map_agent_in_concrete_action f) + action_list ) + ) + in + let error, log_info, blackboard, test_map = + List.fold_left + (fun (error, log_info, blackboard, map) test -> + let error, log_info, blackboard, test_list = + predicates_of_test parameter handler log_info error + blackboard test + in + error, log_info, blackboard, build_map test_list map) + (error, log_info, blackboard, PredicateidMap.empty) + test_list + in + let error, log_info, blackboard, action_map, test_map = + List.fold_left + (fun (error, log_info, blackboard, action_map, test_map) + action -> + let ( error, + log_info, + blackboard, + action_list, + test_list ) = + predicates_of_action true parameter handler log_info + error blackboard init action + in + let action_list = + List.rev_map + (fun (pid, x) -> + match x with + | Free -> + (match + A.get blackboard.pre_column_map_inv pid + with + | Bound_site (ag_id, site_id) -> + if + ag_id = mixture_ag_1 + && SiteIdSet.mem (rule_ag_id1, site_id) + data_structure + .removed_sites_in_other_links + || ag_id = mixture_ag_2 + && SiteIdSet.mem (rule_ag_id2, site_id) + data_structure + .removed_sites_in_other_links + then + pid, Undefined + else + pid, x + | _ -> pid, x) + | _ -> pid, x) + (List.rev action_list) + in + ( error, + log_info, + blackboard, + build_map action_list action_map, + build_map test_list test_map )) + ( error, + log_info, + blackboard, + PredicateidMap.empty, + test_map ) + action_list + in + let error, merged_map = + PredicateidMap.monadic_fold2 parameter error + (fun _ e key test action acc -> + e, PredicateidMap.add key (test, action) acc) + (fun _ e key test acc -> + e, PredicateidMap.add key (test, Unknown) acc) + (fun _ e key action acc -> + e, PredicateidMap.add key (Unknown, action) acc) + test_map action_map PredicateidMap.empty + in + let merged_map = + PredicateidMap.add link_mutex (Counter 0, Counter 1) + merged_map + in + (* Pointer -> *) + let merged_map = + match + AgentIdMap.find_option rule_ag_id1 + data_structure.rule_agent_id_subs + with + | Some m_id -> + PredicateidMap.add m_id + (Pointer_to_agent mixture_ag_1, Unknown) + merged_map + | None -> merged_map + in + let merged_map = + match + AgentIdMap.find_option rule_ag_id2 + data_structure.rule_agent_id_subs + with + | Some m_id -> + PredicateidMap.add m_id + (Pointer_to_agent mixture_ag_2, Unknown) + merged_map + | None -> merged_map + in + if PredicateidMap.is_empty merged_map then + error, log_info, blackboard + else ( + let nsid = blackboard.pre_nsteps + 1 in + let _ = A.set pre_event nsid step in + let pre_steps_by_column = + PredicateidMap.fold + (fun id (test, action) map -> + let value, list = A.get map id in + let value' = value + 1 in + let _ = + fadd id action + blackboard + .history_of_predicate_values_to_predicate_id + in + let _ = + A.set map id + (value', (nsid, value, test, action) :: list) + in + map) + merged_map blackboard.pre_steps_by_column + in + let _ = + A.set blackboard.pre_kind_of_event nsid + (type_of_step step) + in + let blackboard = + { + blackboard with + pre_event; + pre_steps_by_column; + pre_nsteps = nsid; + } + in + error, log_info, blackboard + ) + ) else + error, log_info, blackboard) + (error, log_info, blackboard) + l_ag_2) + (error, log_info, blackboard) + l_ag_1) + set + (error, log_info, blackboard) + in + let data_structure = + { + data_structure with + other_links = + AgentId2Set.diff data_structure.other_links + data_structure.other_links_priority; + } + in + + let error, log_info, blackboard = + f error log_info blackboard data_structure.other_links_priority + in + let error, log_info, blackboard = + f error log_info blackboard data_structure.other_links + in + + (* deal with rigid elements *) + let side_effect = data_structure.sure_side_effects in + let action_list = + match init_step with + | None -> data_structure.create_actions @ data_structure.sure_actions + | Some _ -> data_structure.sure_actions + in + let test_list = data_structure.sure_tests in + let fictitious_list = blackboard.pre_fictitious_list in + + let ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + unambiguous_side_effects, + _init_step ) = + List.fold_left + (fun ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + unambiguous_side_effects, + init_step ) (site, binding_state) -> + let error, log_info, blackboard, potential_target = + potential_target parameter handler log_info error blackboard site + binding_state + in + match potential_target with + | [ l ] -> + let list = + List.fold_left + (fun list t -> t :: list) + unambiguous_side_effects l + in + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + list, + init_step ) + | _ -> + let rule_ag_id = + CI.Po.K.agent_id_of_agent (CI.Po.K.agent_of_site site) + in + let predicate_info = + Mutex + (Lock_side_effect + ( step_id, + rule_ag_id, + rule_ag_id, + CI.Po.K.site_name_of_site site )) + in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + predicate_info + in + let error, log_info, blackboard, _step_id = + init_fictitious_action log_info error predicate_id blackboard + init_step + in + let error, log_info, blackboard = + List.fold_left + (fun (error, log_info, blackboard) list -> + let blackboard = + { blackboard with pre_nsteps = blackboard.pre_nsteps + 1 } + in + let log_info = + StoryProfiling.StoryStats.inc_n_side_events log_info + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] list + in + let side_effect = CI.Po.K.side_effect_of_list side_effect in + let _ = + A.set blackboard.pre_side_effect_of_event + blackboard.pre_nsteps side_effect + in + let error, blackboard = + List.fold_left + (fun (error, blackboard) (predicate_id, _, (test, action)) -> + add_fictitious_action error test action predicate_id + blackboard) + (error, blackboard) + ((predicate_id, None, (Counter 0, Counter 1)) :: list) + in + error, log_info, blackboard) + (error, log_info, blackboard) + potential_target + in + ( error, + log_info, + blackboard, + predicate_id :: fictitious_list, + predicate_id :: fictitious_local_list, + unambiguous_side_effects, + init_step )) + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + [], + init_step ) + side_effect + in + let error, log_info, blackboard, test_map = + List.fold_left + (fun (error, log_info, blackboard, map) test -> + let error, log_info, blackboard, test_list = + predicates_of_test parameter handler log_info error blackboard test + in + error, log_info, blackboard, build_map test_list map) + (error, log_info, blackboard, PredicateidMap.empty) + test_list + in + let error, log_info, blackboard, action_map, test_map = + List.fold_left + (fun (error, log_info, blackboard, action_map, test_map) action -> + let error, log_info, blackboard, action_list, test_list = + predicates_of_action true parameter handler log_info error + blackboard init action + in + ( error, + log_info, + blackboard, + build_map action_list action_map, + build_map test_list test_map )) + (error, log_info, blackboard, PredicateidMap.empty, test_map) + action_list + in + let error, merged_map = + PredicateidMap.monadic_fold2 parameter error + (fun _ e key test action acc -> + e, PredicateidMap.add key (test, action) acc) + (fun _ e key test acc -> e, PredicateidMap.add key (test, Unknown) acc) + (fun _ e key action acc -> + e, PredicateidMap.add key (Unknown, action) acc) + test_map action_map PredicateidMap.empty + in + let merged_map = + List.fold_left + (fun map pid -> PredicateidMap.add pid (Counter 1, Undefined) map) + merged_map fictitious_local_list + in + let merged_map = + List.fold_left + (fun map (pid, _, (test, action)) -> add_state pid (test, action) map) + merged_map unambiguous_side_effects + in + let merged_map = + (* If the event is selected, check that the wire end in the state 0*) + (* Undef->Counter 0 : opening event *) + (* Counter 0 -> Counter 1 : potential binding type *) + (* Counter 1 -> Counter 0 : the corresponding substitution is applied *) + (* => Counter 0 -> Undef : closing event, check that if the event has been selected (open and closed), then exactely one binding state has been selected, + according to the corresponding substitution *) + (* If the event is selected & the according substitution taken, then mutual exclusion among the potential binding state*) + List.fold_left + (fun map pid -> add_state pid (Counter 0, Undefined) map) + merged_map nlist + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] unambiguous_side_effects + in + if side_effect = [] && PredicateidMap.is_empty merged_map then + error, log_info, (blackboard, step_id + 1) + else ( + let nsid = blackboard.pre_nsteps + 1 in + let _ = + A.set blackboard.pre_side_effect_of_event nsid + (CI.Po.K.side_effect_of_list side_effect) in - let add_state pid (test,action) map = - let test',action' = - PredicateidMap.find_default (Unknown,Unknown) pid map in - let test = - if strictly_more_refined test test' - then - test - else - test' - in - let action = - if strictly_more_refined action action' - then - action - else - action' - in - let map = PredicateidMap.add pid (test,action) map in - map + let _ = A.set pre_event nsid step in + let pre_steps_by_column = + PredicateidMap.fold + (fun id (test, action) map -> + let value, list = A.get map id in + let value' = value + 1 in + let _ = + fadd id action + blackboard.history_of_predicate_values_to_predicate_id + in + let _ = + A.set map id (value', (nsid, value, test, action) :: list) + in + map) + merged_map blackboard.pre_steps_by_column in - let fadd pid p map = - match p with - | Counter _ | Internal_state_is _ | Undefined - | Defined | Present | Bound | Bound_to_type _ | Unknown -> - () - | Free | Pointer_to_agent _ | Bound_to _ -> - let old = A.get map pid in - A.set map pid (C.add p old) + let _ = A.set blackboard.pre_kind_of_event nsid (type_of_step step) in + let observable_list = + if Trace.step_is_obs step then + ([ nsid ], Trace.simulation_info_of_step step) + :: blackboard.pre_observable_list + else + blackboard.pre_observable_list in - let error,log_info,blackboard,fictitious_list,fictitious_local_list,unambiguous_side_effects,_init_step = - List.fold_left - (fun (error,log_info,blackboard,fictitious_list,fictitious_local_list,unambiguous_side_effects,init_step) (site,(binding_state)) -> - begin - let error,log_info,blackboard,potential_target = potential_target parameter handler log_info error blackboard site binding_state in - match - potential_target - with - | [l] -> - begin - let list = - List.fold_left - (fun list t -> t::list) - unambiguous_side_effects - l - in - error, - log_info, - blackboard, - fictitious_list, - fictitious_local_list, - list, - init_step - end - | _ -> - begin - let rule_ag_id = CI.Po.K.agent_id_of_agent (CI.Po.K.agent_of_site site) in - let predicate_info = Mutex (Lock_side_effect (step_id,rule_ag_id,rule_ag_id,CI.Po.K.site_name_of_site site)) in - let error,log_info,blackboard,predicate_id = allocate parameter handler log_info error blackboard predicate_info in - let error,log_info,blackboard,init_step = init_fictitious_action log_info error predicate_id blackboard init_step in - let error,log_info,blackboard = - List.fold_left - (fun (error,log_info,blackboard) list -> - let blackboard = {blackboard with pre_nsteps = blackboard.pre_nsteps+1} in - let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - list - in - let side_effect = CI.Po.K.side_effect_of_list side_effect in - let _ = A.set blackboard.pre_side_effect_of_event blackboard.pre_nsteps side_effect in - let error,blackboard = - List.fold_left - (fun (error,blackboard) (predicate_id,_,(test,action)) -> - add_fictitious_action error test action predicate_id blackboard) - (error,blackboard) - ((predicate_id,None,(Counter 0,Counter 1))::list) - in - error,log_info,blackboard) - (error,log_info,blackboard) - potential_target - in - error, - log_info, - blackboard, - (predicate_id::fictitious_list), - (predicate_id::fictitious_local_list), - unambiguous_side_effects, - init_step - end - end) - (error,log_info,blackboard,fictitious_list,fictitious_local_list,[],init_step) - side_effect + let blackboard = + { + blackboard with + pre_event; + pre_fictitious_list = fictitious_list; + pre_steps_by_column; + pre_nsteps = nsid; + pre_observable_list = observable_list; + } in - let error,log_info,blackboard,test_map = - List.fold_left - (fun (error,log_info,blackboard,map) test -> - let error,log_info,blackboard,test_list = predicates_of_test parameter handler log_info error blackboard test in - error,log_info,blackboard,build_map test_list map) - (error,log_info,blackboard,PredicateidMap.empty) - test_list in - let error,log_info,blackboard,action_map,test_map = - List.fold_left - (fun (error,log_info,blackboard,action_map,test_map) action -> - let error,log_info,blackboard,action_list,test_list = predicates_of_action false parameter handler log_info error blackboard init action in - error,log_info,blackboard,build_map action_list action_map,build_map test_list test_map) - (error,log_info,blackboard,PredicateidMap.empty,test_map) - action_list in - let error,merged_map = - PredicateidMap.monadic_fold2 - parameter error - (fun _ e key test action acc -> - e,PredicateidMap.add key (test,action) acc) - (fun _ e key test acc -> - e,PredicateidMap.add key (test,Unknown) acc) - (fun _ e key action acc -> - e,PredicateidMap.add key (Unknown,action) acc) - test_map - action_map - PredicateidMap.empty in - let merged_map = - List.fold_left - (fun map pid -> PredicateidMap.add pid (Counter 1,Undefined) map) - merged_map - fictitious_local_list + error, log_info, (blackboard, step_id + 1) + ) + + let add_step parameter handler log_info error step blackboard step_id = + let init = Trace.step_is_init step in + let init_step = None in + let pre_event = blackboard.pre_event in + let test_list = Trace.tests_of_step step in + let action_list, side_effect = Trace.actions_of_step step in + let fictitious_local_list = [] in + let fictitious_list = blackboard.pre_fictitious_list in + let build_map list map = + List.fold_left + (fun map (id, value) -> PredicateidMap.add id value map) + map list + in + let add_state pid (test, action) map = + let test', action' = + PredicateidMap.find_default (Unknown, Unknown) pid map in - let merged_map = - List.fold_left - (fun map (pid,_,(test,action)) -> add_state pid (test,action) map) - merged_map - unambiguous_side_effects + let test = + if strictly_more_refined test test' then + test + else + test' in - let side_effect = - List.fold_left - (fun list (_,a,_) -> - match a - with - | None -> list - | Some a -> a::list) - [] - unambiguous_side_effects + let action = + if strictly_more_refined action action' then + action + else + action' in - if side_effect = [] - && PredicateidMap.is_empty merged_map - then - error,log_info,(blackboard,step_id+1) - else - begin - let nsid = blackboard.pre_nsteps + 1 in - let _ = A.set blackboard.pre_side_effect_of_event nsid (CI.Po.K.side_effect_of_list side_effect) in - let _ = A.set pre_event nsid step in - let pre_steps_by_column = - PredicateidMap.fold - (fun id (test,action) map -> - begin - let value,list = A.get map id in - let value' = value + 1 in - let _ = fadd id action blackboard.history_of_predicate_values_to_predicate_id in - let _ = A.set map id (value',(nsid,value,test,action)::list) - in map - end) - merged_map - blackboard.pre_steps_by_column + let map = PredicateidMap.add pid (test, action) map in + map + in + let fadd pid p map = + match p with + | Counter _ | Internal_state_is _ | Undefined | Defined | Present | Bound + | Bound_to_type _ | Unknown -> + () + | Free | Pointer_to_agent _ | Bound_to _ -> + let old = A.get map pid in + A.set map pid (C.add p old) + in + let ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + unambiguous_side_effects, + _init_step ) = + List.fold_left + (fun ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + unambiguous_side_effects, + init_step ) (site, binding_state) -> + let error, log_info, blackboard, potential_target = + potential_target parameter handler log_info error blackboard site + binding_state in - let _ = A.set blackboard.pre_kind_of_event nsid (type_of_step step) in - let observable_list = - if Trace.step_is_obs step - then - ([nsid],Trace.simulation_info_of_step step)::blackboard.pre_observable_list - else - blackboard.pre_observable_list + match potential_target with + | [ l ] -> + let list = + List.fold_left + (fun list t -> t :: list) + unambiguous_side_effects l + in + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + list, + init_step ) + | _ -> + let rule_ag_id = + CI.Po.K.agent_id_of_agent (CI.Po.K.agent_of_site site) + in + let predicate_info = + Mutex + (Lock_side_effect + ( step_id, + rule_ag_id, + rule_ag_id, + CI.Po.K.site_name_of_site site )) + in + let error, log_info, blackboard, predicate_id = + allocate parameter handler log_info error blackboard + predicate_info + in + let error, log_info, blackboard, init_step = + init_fictitious_action log_info error predicate_id blackboard + init_step + in + let error, log_info, blackboard = + List.fold_left + (fun (error, log_info, blackboard) list -> + let blackboard = + { blackboard with pre_nsteps = blackboard.pre_nsteps + 1 } + in + let log_info = + StoryProfiling.StoryStats.inc_n_side_events log_info + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] list + in + let side_effect = CI.Po.K.side_effect_of_list side_effect in + let _ = + A.set blackboard.pre_side_effect_of_event + blackboard.pre_nsteps side_effect + in + let error, blackboard = + List.fold_left + (fun (error, blackboard) (predicate_id, _, (test, action)) -> + add_fictitious_action error test action predicate_id + blackboard) + (error, blackboard) + ((predicate_id, None, (Counter 0, Counter 1)) :: list) + in + error, log_info, blackboard) + (error, log_info, blackboard) + potential_target + in + ( error, + log_info, + blackboard, + predicate_id :: fictitious_list, + predicate_id :: fictitious_local_list, + unambiguous_side_effects, + init_step )) + ( error, + log_info, + blackboard, + fictitious_list, + fictitious_local_list, + [], + init_step ) + side_effect + in + let error, log_info, blackboard, test_map = + List.fold_left + (fun (error, log_info, blackboard, map) test -> + let error, log_info, blackboard, test_list = + predicates_of_test parameter handler log_info error blackboard test in - let blackboard = - { - blackboard with - pre_event = pre_event ; - pre_fictitious_list = fictitious_list ; - pre_steps_by_column = pre_steps_by_column; - pre_nsteps = nsid; - pre_observable_list = observable_list; - } + error, log_info, blackboard, build_map test_list map) + (error, log_info, blackboard, PredicateidMap.empty) + test_list + in + let error, log_info, blackboard, action_map, test_map = + List.fold_left + (fun (error, log_info, blackboard, action_map, test_map) action -> + let error, log_info, blackboard, action_list, test_list = + predicates_of_action false parameter handler log_info error + blackboard init action in - error,log_info,(blackboard,step_id+1) - end - - let finalize heuristic parameter handler log_info error blackboard = - let l = blackboard.pre_fictitious_list in - match l - with - | [] -> error,log_info,blackboard - | _ -> - let nsid = blackboard.pre_nsteps + 1 in - let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in - let observable_list = - List.rev_map (fun (x,info) -> (nsid::x,info)) (List.rev blackboard.pre_observable_list) - in - let blackboard = - { - blackboard - with - pre_nsteps = nsid ; - pre_observable_list = observable_list ; - pre_fictitious_observable = Some nsid ; - } - in - let error,blackboard = - List.fold_left - (fun (error,blackboard) predicate_id -> - add_fictitious_action error Undefined Unknown predicate_id blackboard) - (error,blackboard) - l - in - let error,log_info,set = - List.fold_left - (fun set (steps,_) -> - List.fold_left - (fun (error,log_info,set) eid -> - let step = A.get blackboard.pre_event eid in - let error,log_info,agents_in_obs = CI.Po.K.agent_id_in_obs parameter handler log_info error step in - error,log_info,CI.Po.K.AgentIdSet.union set agents_in_obs) - set steps) - (error,log_info,CI.Po.K.AgentIdSet.empty) - observable_list - in - let set x = - CI.Po.K.AgentIdSet.mem x set - in - let _ = - A.iteri - (fun i step -> - let _,_,level = CI.Po.K.level_of_event heuristic parameter handler log_info error step set in - A.set - blackboard.pre_level_of_event - i - level - ) - blackboard.pre_event - in - let _ = - if debug_mode - then - let _ = print_preblackboard parameter handler log_info error blackboard in () - in - error,log_info,blackboard - - let add_step_up_to_iso = add_step_strong - - (** interface *) + ( error, + log_info, + blackboard, + build_map action_list action_map, + build_map test_list test_map )) + (error, log_info, blackboard, PredicateidMap.empty, test_map) + action_list + in + let error, merged_map = + PredicateidMap.monadic_fold2 parameter error + (fun _ e key test action acc -> + e, PredicateidMap.add key (test, action) acc) + (fun _ e key test acc -> e, PredicateidMap.add key (test, Unknown) acc) + (fun _ e key action acc -> + e, PredicateidMap.add key (Unknown, action) acc) + test_map action_map PredicateidMap.empty + in + let merged_map = + List.fold_left + (fun map pid -> PredicateidMap.add pid (Counter 1, Undefined) map) + merged_map fictitious_local_list + in + let merged_map = + List.fold_left + (fun map (pid, _, (test, action)) -> add_state pid (test, action) map) + merged_map unambiguous_side_effects + in + let side_effect = + List.fold_left + (fun list (_, a, _) -> + match a with + | None -> list + | Some a -> a :: list) + [] unambiguous_side_effects + in + if side_effect = [] && PredicateidMap.is_empty merged_map then + error, log_info, (blackboard, step_id + 1) + else ( + let nsid = blackboard.pre_nsteps + 1 in + let _ = + A.set blackboard.pre_side_effect_of_event nsid + (CI.Po.K.side_effect_of_list side_effect) + in + let _ = A.set pre_event nsid step in + let pre_steps_by_column = + PredicateidMap.fold + (fun id (test, action) map -> + let value, list = A.get map id in + let value' = value + 1 in + let _ = + fadd id action + blackboard.history_of_predicate_values_to_predicate_id + in + let _ = + A.set map id (value', (nsid, value, test, action) :: list) + in + map) + merged_map blackboard.pre_steps_by_column + in + let _ = A.set blackboard.pre_kind_of_event nsid (type_of_step step) in + let observable_list = + if Trace.step_is_obs step then + ([ nsid ], Trace.simulation_info_of_step step) + :: blackboard.pre_observable_list + else + blackboard.pre_observable_list + in + let blackboard = + { + blackboard with + pre_event; + pre_fictitious_list = fictitious_list; + pre_steps_by_column; + pre_nsteps = nsid; + pre_observable_list = observable_list; + } + in + error, log_info, (blackboard, step_id + 1) + ) + + let finalize heuristic parameter handler log_info error blackboard = + let l = blackboard.pre_fictitious_list in + match l with + | [] -> error, log_info, blackboard + | _ -> + let nsid = blackboard.pre_nsteps + 1 in + let log_info = StoryProfiling.StoryStats.inc_n_side_events log_info in + let observable_list = + List.rev_map + (fun (x, info) -> nsid :: x, info) + (List.rev blackboard.pre_observable_list) + in + let blackboard = + { + blackboard with + pre_nsteps = nsid; + pre_observable_list = observable_list; + pre_fictitious_observable = Some nsid; + } + in + let error, blackboard = + List.fold_left + (fun (error, blackboard) predicate_id -> + add_fictitious_action error Undefined Unknown predicate_id + blackboard) + (error, blackboard) l + in + let error, log_info, set = + List.fold_left + (fun set (steps, _) -> + List.fold_left + (fun (error, log_info, set) eid -> + let step = A.get blackboard.pre_event eid in + let error, log_info, agents_in_obs = + CI.Po.K.agent_id_in_obs parameter handler log_info error step + in + error, log_info, CI.Po.K.AgentIdSet.union set agents_in_obs) + set steps) + (error, log_info, CI.Po.K.AgentIdSet.empty) + observable_list + in + let set x = CI.Po.K.AgentIdSet.mem x set in + let _ = + A.iteri + (fun i step -> + let _, _, level = + CI.Po.K.level_of_event heuristic parameter handler log_info error + step set + in + A.set blackboard.pre_level_of_event i level) + blackboard.pre_event + in + let _ = + if debug_mode then ( + let _ = + print_preblackboard parameter handler log_info error blackboard + in + () + ) + in + error, log_info, blackboard - let n_predicates _parameter _handler log_info error blackboard = - error,log_info,blackboard.pre_ncolumn+1 + let add_step_up_to_iso = add_step_strong - let event_list_of_predicate parameter _handler log_info error blackboard predicate_id = - try - error,log_info,snd (A.get blackboard.pre_steps_by_column predicate_id) - with - | _ -> - warn - parameter log_info error __POS__ - ~message:"Unknown predicate id" - (Failure "event_list_of_predicate") [] - - let n_events_per_predicate parameter _handler log_info error blackboard predicate_id = - try - error,log_info,fst (A.get blackboard.pre_steps_by_column predicate_id) - with - | _ -> - warn - parameter log_info error __POS__ - ~message:"Unknown predicate id" (Failure "n_events_per_predicate") 0 + (** interface *) - let n_events _parameter _handler log_info error blackboard = - error,log_info,blackboard.pre_nsteps+1 + let n_predicates _parameter _handler log_info error blackboard = + error, log_info, blackboard.pre_ncolumn + 1 - let mandatory_events _parameter _handler log_info error blackboard = - error,log_info,blackboard.pre_observable_list + let event_list_of_predicate parameter _handler log_info error blackboard + predicate_id = + try error, log_info, snd (A.get blackboard.pre_steps_by_column predicate_id) + with _ -> + warn parameter log_info error __POS__ ~message:"Unknown predicate id" + (Failure "event_list_of_predicate") [] - let get_fictitious_observable _parameter _handler log_info error blackboard = - error,log_info,blackboard.pre_fictitious_observable + let n_events_per_predicate parameter _handler log_info error blackboard + predicate_id = + try error, log_info, fst (A.get blackboard.pre_steps_by_column predicate_id) + with _ -> + warn parameter log_info error __POS__ ~message:"Unknown predicate id" + (Failure "n_events_per_predicate") 0 - let get_side_effect _parameter _handler log_info error blackboard = - error,log_info,blackboard.pre_side_effect_of_event + let n_events _parameter _handler log_info error blackboard = + error, log_info, blackboard.pre_nsteps + 1 + let mandatory_events _parameter _handler log_info error blackboard = + error, log_info, blackboard.pre_observable_list + let get_fictitious_observable _parameter _handler log_info error blackboard = + error, log_info, blackboard.pre_fictitious_observable - end:PreBlackboard) + let get_side_effect _parameter _handler log_info error blackboard = + error, log_info, blackboard.pre_side_effect_of_event +end diff --git a/core/cflow/causal.ml b/core/cflow/causal.ml index cb12a1d068..5b125fef04 100644 --- a/core/cflow/causal.ml +++ b/core/cflow/causal.ml @@ -1,8 +1,8 @@ type quark_lists = { - site_tested : (int * int) list; - site_modified : (int * int) list; - internal_state_tested : (int * int) list; - internal_state_modified : (int * int) list; + site_tested: (int * int) list; + site_modified: (int * int) list; + internal_state_tested: (int * int) list; + internal_state_modified: (int * int) list; } type event_kind = OBS of string | EVENT of Trace.event_kind @@ -10,112 +10,124 @@ type event_kind = OBS of string | EVENT of Trace.event_kind let atom_tested = 1 let atom_modified = 2 let atom_testedmodified = 3 -type atom = - { - causal_impact : int ; (*(1) tested (2) modified, (3) tested + modified*) - eid:int ; (*event identifier*) - kind:event_kind ; - (*observation: string list*) - } + +type atom = { + causal_impact: int; (*(1) tested (2) modified, (3) tested + modified*) + eid: int; (*event identifier*) + kind: event_kind; (*observation: string list*) +} type attribute = atom list (*vertical sequence of atoms*) -type grid = - { - flow: (int*int*int,attribute) Hashtbl.t ; - (*(n_i,s_i,q_i) -> att_i with n_i: node_id, s_i: site_id, q_i: - link (1) or internal state (0) *) - pid_to_init: (int*int*int,int) Hashtbl.t ; - obs: int list ; - init_tbl: (int,Mods.IntSet.t) Hashtbl.t;(*decreasing*) - init_to_eidmax: (int,int) Hashtbl.t; - } -type config = - { - events_kind: event_kind Mods.IntMap.t ; - prec_1: Mods.IntSet.t Mods.IntMap.t ; - conflict : Mods.IntSet.t Mods.IntMap.t ; - } -type enriched_grid = - { - config:config; - depth:int; - prec_star: (int list array * Graph_closure.order); (*decreasing*) - depth_of_event: int Mods.IntMap.t ; - size:int; - } -type formatCflow = - | Dot - | Html - | Json + +type grid = { + flow: (int * int * int, attribute) Hashtbl.t; + (*(n_i,s_i,q_i) -> att_i with n_i: node_id, s_i: site_id, q_i: + link (1) or internal state (0) *) + pid_to_init: (int * int * int, int) Hashtbl.t; + obs: int list; + init_tbl: (int, Mods.IntSet.t) Hashtbl.t; (*decreasing*) + init_to_eidmax: (int, int) Hashtbl.t; +} + +type config = { + events_kind: event_kind Mods.IntMap.t; + prec_1: Mods.IntSet.t Mods.IntMap.t; + conflict: Mods.IntSet.t Mods.IntMap.t; +} + +type enriched_grid = { + config: config; + depth: int; + prec_star: int list array * Graph_closure.order; (*decreasing*) + depth_of_event: int Mods.IntMap.t; + size: int; +} + +type formatCflow = Dot | Html | Json let empty_config = - { events_kind = Mods.IntMap.empty; + { + events_kind = Mods.IntMap.empty; conflict = Mods.IntMap.empty; - prec_1 = Mods.IntMap.empty } + prec_1 = Mods.IntMap.empty; + } let print_event_kind ?env f = function | EVENT e -> Trace.print_event_kind ?env f e | OBS i -> - match env with + (match env with | None -> Format.fprintf f "OBS(%s)" i - | Some _ -> Format.pp_print_string f i + | Some _ -> Format.pp_print_string f i) let debug_print_causal f i = - Format.pp_print_string - f (if i = atom_tested then "tested" - else if i = atom_modified then "modified" - else if i = atom_tested lor atom_modified then "tested&modified" - else "CAUSAL IMPACT UNDEFINED") + Format.pp_print_string f + (if i = atom_tested then + "tested" + else if i = atom_modified then + "modified" + else if i = atom_tested lor atom_modified then + "tested&modified" + else + "CAUSAL IMPACT UNDEFINED") let debug_print_atom f a = Format.fprintf f "{#%i: %a %a}" a.eid debug_print_causal a.causal_impact - (print_event_kind ?env:None) a.kind + (print_event_kind ?env:None) + a.kind let debug_print_grid f g = + let () = Format.fprintf f "@[Flow:@," in let () = - Format.fprintf f "@[Flow:@," in - let () = Hashtbl.iter - (fun (node_id,site_id,q) l -> - Format.fprintf - f "@[<2>%i.%i%s:@,%a@]@," node_id site_id - (if q = 0 then "~" else if q = 1 then "" else "UNDEFINED") - (Pp.list Pp.space debug_print_atom) l) - g.flow in + Hashtbl.iter + (fun (node_id, site_id, q) l -> + Format.fprintf f "@[<2>%i.%i%s:@,%a@]@," node_id site_id + (if q = 0 then + "~" + else if q = 1 then + "" + else + "UNDEFINED") + (Pp.list Pp.space debug_print_atom) + l) + g.flow + in Format.fprintf f "@]@." let empty_grid () = { - flow = Hashtbl.create !Parameter.defaultExtArraySize ; - pid_to_init = Hashtbl.create !Parameter.defaultExtArraySize ; - obs = [] ; - init_tbl = Hashtbl.create !Parameter.defaultExtArraySize ; - init_to_eidmax = Hashtbl.create !Parameter.defaultExtArraySize + flow = Hashtbl.create !Parameter.defaultExtArraySize; + pid_to_init = Hashtbl.create !Parameter.defaultExtArraySize; + obs = []; + init_tbl = Hashtbl.create !Parameter.defaultExtArraySize; + init_to_eidmax = Hashtbl.create !Parameter.defaultExtArraySize; } let build_subs l = - snd (List.fold_left - (fun (n,map) a -> (succ n,Mods.IntMap.add a n map)) - (1,Mods.IntMap.empty) l) + snd + (List.fold_left + (fun (n, map) a -> succ n, Mods.IntMap.add a n map) + (1, Mods.IntMap.empty) l) let submap subs l m default = List.fold_left (fun m' a -> - match Mods.IntMap.find_option a subs with - | None -> raise Not_found - | Some new_a -> - Mods.IntMap.add new_a ( - match Mods.IntMap.find_option a m with - | Some x -> x - | None -> - match default with None -> raise Not_found | Some a -> a - ) m') + match Mods.IntMap.find_option a subs with + | None -> raise Not_found + | Some new_a -> + Mods.IntMap.add new_a + (match Mods.IntMap.find_option a m with + | Some x -> x + | None -> + (match default with + | None -> raise Not_found + | Some a -> a)) + m') Mods.IntMap.empty l let add_init_pid eid pid grid = let eid_init = Hashtbl.find grid.pid_to_init pid in let old = - try Hashtbl.find grid.init_tbl eid - with Not_found -> Mods.IntSet.empty + try Hashtbl.find grid.init_tbl eid with Not_found -> Mods.IntSet.empty in let () = Hashtbl.replace grid.init_tbl eid (Mods.IntSet.add eid_init old) in let () = Hashtbl.replace grid.init_to_eidmax eid_init eid in @@ -124,69 +136,71 @@ let add_init_pid eid pid grid = let _subset subs l s = List.fold_left (fun s' a -> - if Mods.IntSet.mem a s - then Mods.IntSet.add - (match Mods.IntMap.find_option a subs with - | Some i -> i - | None -> raise Not_found) - s' - else s') + if Mods.IntSet.mem a s then + Mods.IntSet.add + (match Mods.IntMap.find_option a subs with + | Some i -> i + | None -> raise Not_found) + s' + else + s') Mods.IntSet.empty l let subconfig_with_subs subs config l = { - events_kind = submap subs l config.events_kind None ; + events_kind = submap subs l config.events_kind None; prec_1 = submap subs l config.prec_1 (Some Mods.IntSet.empty); conflict = submap subs l config.conflict (Some Mods.IntSet.empty); } -let subenriched_grid_with_subs subs grid l = - let depth_of_event = submap subs l grid.depth_of_event (Some 0) in + +let subenriched_grid_with_subs subs grid l = + let depth_of_event = submap subs l grid.depth_of_event (Some 0) in let depth = Mods.IntMap.fold (fun _ -> max) depth_of_event 0 in { prec_star = grid.prec_star; - config = subconfig_with_subs subs grid.config l ; - depth_of_event = depth_of_event ; - depth = depth ; - size = List.length l ; + config = subconfig_with_subs subs grid.config l; + depth_of_event; + depth; + size = List.length l; } let _subconfig config l = subconfig_with_subs (build_subs l) config l let _subenriched_grid grid l = subenriched_grid_with_subs (build_subs l) grid l +let add_obs_eid eid grid = { grid with obs = eid :: grid.obs } -let add_obs_eid eid grid = {grid with obs = eid::(grid.obs)} - -let grid_find (node_id,site_id,quark) grid = - Hashtbl.find grid.flow (node_id,site_id,quark) +let grid_find (node_id, site_id, quark) grid = + Hashtbl.find grid.flow (node_id, site_id, quark) -let _is_empty_grid grid = (Hashtbl.length grid.flow = 0) +let _is_empty_grid grid = Hashtbl.length grid.flow = 0 -let grid_add quark eid (attribute:attribute) grid = +let grid_add quark eid (attribute : attribute) grid = let () = - if not (Hashtbl.mem grid.flow quark) - then Hashtbl.add grid.pid_to_init quark eid in - Hashtbl.replace grid.flow quark attribute ; + if not (Hashtbl.mem grid.flow quark) then + Hashtbl.add grid.pid_to_init quark eid + in + Hashtbl.replace grid.flow quark attribute; grid let _last_event attribute = match attribute with | [] -> None - | a::_ -> (Some a.eid) + | a :: _ -> Some a.eid (*adds atom a to attribute att. Collapses last atom if if bears the same id as a --in the case of a non atomic action*) -let push (a:atom) (att:atom list) = +let push (a : atom) (att : atom list) = match att with - | [] -> [a] - | a'::att' -> - if a'.eid = a.eid then + | [] -> [ a ] + | a' :: att' -> + if a'.eid = a.eid then ( let () = assert (a'.kind = a.kind) in - { a' with causal_impact = a.causal_impact lor a'.causal_impact }::att' - else a::att + { a' with causal_impact = a.causal_impact lor a'.causal_impact } :: att' + ) else + a :: att (**side_effect Int2Set.t: pairs (agents,ports) that have been freed as a side effect --via a DEL or a FREE action*) (*NB no internal state modif as side effect*) - (*let impact is_link c = if is_link then if Primitives.Causality.is_link_modif c then @@ -197,194 +211,255 @@ let push (a:atom) (att:atom list) = if Primitives.Causality.is_internal_tested c then atom_testedmodified else atom_modified else atom_tested *) -let add ((node_id,_),site_id) is_link va grid event_number kind = - let q = if is_link then atom_tested else 0 in - let att = - try grid_find (node_id,site_id,q) grid - with Not_found -> [] in +let add ((node_id, _), site_id) is_link va grid event_number kind = + let q = + if is_link then + atom_tested + else + 0 + in + let att = try grid_find (node_id, site_id, q) grid with Not_found -> [] in let att = - push {causal_impact = va ; eid = event_number ; - kind = kind (*; observation = obs*)} att in - let grid = grid_add (node_id,site_id,q) event_number att grid in - add_init_pid event_number (node_id,site_id,q) grid + push + { causal_impact = va; eid = event_number; kind (*; observation = obs*) } + att + in + let grid = grid_add (node_id, site_id, q) event_number att grid in + add_init_pid event_number (node_id, site_id, q) grid let add_actions env grid event_number kind actions = let rec aux grid = function | [] -> grid - | Instantiation.Mod_internal (site,_) :: q -> + | Instantiation.Mod_internal (site, _) :: q -> aux (add site false atom_modified grid event_number kind) q - | Instantiation.Bind (site1,site2) :: q -> + | Instantiation.Bind (site1, site2) :: q -> let grid' = add site2 true atom_modified grid event_number kind in aux (add site1 true atom_modified grid' event_number kind) q - | Instantiation.Bind_to (site1,_) :: q -> + | Instantiation.Bind_to (site1, _) :: q -> aux (add site1 true atom_modified grid event_number kind) q | Instantiation.Free site :: q -> aux (add site true atom_modified grid event_number kind) q - | (Instantiation.Create ((_,na as ag),_) - | Instantiation.Remove (_,na as ag)) :: q -> + | ( Instantiation.Create (((_, na) as ag), _) + | Instantiation.Remove ((_, na) as ag) ) + :: q -> let sigs = Model.signatures env in let ag_intf = Signature.get sigs na in - let grid = add (ag,-1) true atom_modified grid event_number kind in + let grid = add (ag, -1) true atom_modified grid event_number kind in let grid = Signature.fold (fun site _ grid -> - let grid' = - match Signature.default_internal_state na site sigs with - | None -> grid - | Some _ -> add (ag,site) false atom_modified grid event_number kind in - add (ag,site) true atom_modified grid' event_number kind) - grid ag_intf in + let grid' = + match Signature.default_internal_state na site sigs with + | None -> grid + | Some _ -> + add (ag, site) false atom_modified grid event_number kind + in + add (ag, site) true atom_modified grid' event_number kind) + grid ag_intf + in aux grid q - in aux grid actions + in + aux grid actions let add_tests grid event_number kind tests = List.fold_left (List.fold_left (fun grid -> function - | Instantiation.Is_Here ag -> - add (ag,-1) true atom_tested grid event_number kind - | Instantiation.Has_Internal (site,_) -> - add site false atom_tested grid event_number kind - | Instantiation.Is_Free site - | Instantiation.Is_Bound site - | Instantiation.Has_Binding_type (site,_) -> - add site true atom_tested grid event_number kind - | Instantiation.Is_Bound_to (site1,site2) -> - let grid' = add site2 true atom_tested grid event_number kind in - add site1 true atom_tested grid' event_number kind)) + | Instantiation.Is_Here ag -> + add (ag, -1) true atom_tested grid event_number kind + | Instantiation.Has_Internal (site, _) -> + add site false atom_tested grid event_number kind + | Instantiation.Is_Free site + | Instantiation.Is_Bound site + | Instantiation.Has_Binding_type (site, _) -> + add site true atom_tested grid event_number kind + | Instantiation.Is_Bound_to (site1, site2) -> + let grid' = add site2 true atom_tested grid event_number kind in + add site1 true atom_tested grid' event_number kind)) grid tests -let record (kind,event,_) event_number env grid = - let grid = add_tests grid event_number (EVENT kind) event.Instantiation.tests in +let record (kind, event, _) event_number env grid = let grid = - add_tests grid event_number (EVENT kind) [event.Instantiation.connectivity_tests] in + add_tests grid event_number (EVENT kind) event.Instantiation.tests + in + let grid = + add_tests grid event_number (EVENT kind) + [ event.Instantiation.connectivity_tests ] + in let grid = - add_actions env grid event_number (EVENT kind) event.Instantiation.actions in + add_actions env grid event_number (EVENT kind) event.Instantiation.actions + in List.fold_left (fun grid site -> - add (fst site,-1) true atom_tested - (add site true atom_modified grid event_number (EVENT kind)) - event_number (EVENT kind)) + add + (fst site, -1) + true atom_tested + (add site true atom_modified grid event_number (EVENT kind)) + event_number (EVENT kind)) grid event.Instantiation.side_effects_dst -let record_obs (kind,tests,_) side_effects event_number grid = +let record_obs (kind, tests, _) side_effects event_number grid = let grid = add_obs_eid event_number grid in let grid = add_tests grid event_number (OBS kind) tests in List.fold_left (fun grid site -> add site true atom_modified grid event_number (OBS kind)) grid side_effects -let record_init (lbl,actions) event_number env grid = - add_actions env grid event_number (EVENT (Trace.INIT lbl)) actions +let record_init (lbl, actions) event_number env grid = + add_actions env grid event_number (EVENT (Trace.INIT lbl)) actions let add_pred eid atom config = let events_kind = Mods.IntMap.add atom.eid atom.kind config.events_kind in - let pred_set = - Mods.IntMap.find_default Mods.IntSet.empty eid config.prec_1 in + let pred_set = Mods.IntMap.find_default Mods.IntSet.empty eid config.prec_1 in let prec_1 = - Mods.IntMap.add eid (Mods.IntSet.add atom.eid pred_set) config.prec_1 in - {config with prec_1 = prec_1 ; events_kind = events_kind} + Mods.IntMap.add eid (Mods.IntSet.add atom.eid pred_set) config.prec_1 + in + { config with prec_1; events_kind } let add_conflict eid atom config = let events_kind = Mods.IntMap.add atom.eid atom.kind config.events_kind in let cflct_set = - Mods.IntMap.find_default Mods.IntSet.empty eid config.conflict in + Mods.IntMap.find_default Mods.IntSet.empty eid config.conflict + in let cflct = - Mods.IntMap.add eid (Mods.IntSet.add atom.eid cflct_set) config.conflict in - {config with conflict = cflct ; events_kind = events_kind } + Mods.IntMap.add eid (Mods.IntSet.add atom.eid cflct_set) config.conflict + in + { config with conflict = cflct; events_kind } let rec parse_attribute last_modif last_tested attribute config = match attribute with | [] -> config - | atom::att -> + | atom :: att -> let events_kind = Mods.IntMap.add atom.eid atom.kind config.events_kind in let prec_1 = let preds = - Mods.IntMap.find_default Mods.IntSet.empty atom.eid config.prec_1 in - Mods.IntMap.add atom.eid preds config.prec_1 in - let config = {config with events_kind = events_kind ; prec_1 = prec_1} in + Mods.IntMap.find_default Mods.IntSet.empty atom.eid config.prec_1 + in + Mods.IntMap.add atom.eid preds config.prec_1 + in + let config = { config with events_kind; prec_1 } in (*atom has a modification*) - if (atom.causal_impact = atom_modified) || (atom.causal_impact = atom_testedmodified) then + if + atom.causal_impact = atom_modified + || atom.causal_impact = atom_testedmodified + then ( let config = - List.fold_left (fun config pred_id -> add_pred pred_id atom config) - config last_tested in + List.fold_left + (fun config pred_id -> add_pred pred_id atom config) + config last_tested + in let tested = - if (atom.causal_impact = atom_tested) - ||(atom.causal_impact = atom_tested lor atom_modified) - then [atom.eid] else [] in + if + atom.causal_impact = atom_tested + || atom.causal_impact = atom_tested lor atom_modified + then + [ atom.eid ] + else + [] + in parse_attribute (Some atom.eid) tested att config - else + ) else ( (* atom is a pure test*) let config = match last_modif with | None -> config | Some eid -> - add_conflict eid atom config (*adding conflict with last modification*) + add_conflict eid atom + config (*adding conflict with last modification*) in - parse_attribute last_modif (atom.eid::last_tested) att config + parse_attribute last_modif (atom.eid :: last_tested) att config + ) -let cut ?with_reduction:(with_reduction=true) parameter handler log_info error attribute_ids grid = - let error,log_info = StoryProfiling.StoryStats.add_event parameter error StoryProfiling.Build_configuration None log_info in +let cut ?(with_reduction = true) parameter handler log_info error attribute_ids + grid = + let error, log_info = + StoryProfiling.StoryStats.add_event parameter error + StoryProfiling.Build_configuration None log_info + in let rec build_config attribute_ids cfg = match attribute_ids with | [] -> cfg - | (node_i,site_i,type_i)::tl -> + | (node_i, site_i, type_i) :: tl -> let attribute = - try grid_find (node_i,site_i,type_i) grid - with Not_found -> invalid_arg "Causal.cut" in + try grid_find (node_i, site_i, type_i) grid + with Not_found -> invalid_arg "Causal.cut" + in let cfg = match attribute with | [] -> cfg - | atom::att -> - let events_kind = Mods.IntMap.add atom.eid atom.kind cfg.events_kind in + | atom :: att -> + let events_kind = + Mods.IntMap.add atom.eid atom.kind cfg.events_kind + in let prec_1 = let preds = - Mods.IntMap.find_default Mods.IntSet.empty atom.eid cfg.prec_1 in - Mods.IntMap.add atom.eid preds cfg.prec_1 in + Mods.IntMap.find_default Mods.IntSet.empty atom.eid cfg.prec_1 + in + Mods.IntMap.add atom.eid preds cfg.prec_1 + in let tested = - if (atom.causal_impact = atom_tested) || (atom.causal_impact = atom_testedmodified) - then [atom.eid] else [] in + if + atom.causal_impact = atom_tested + || atom.causal_impact = atom_testedmodified + then + [ atom.eid ] + else + [] + in let modif = - if (atom.causal_impact = atom_modified) || (atom.causal_impact = atom_testedmodified) - then Some atom.eid else None in - parse_attribute - modif tested att - {cfg with prec_1 = prec_1 ; events_kind = events_kind} - in build_config tl cfg + if + atom.causal_impact = atom_modified + || atom.causal_impact = atom_testedmodified + then + Some atom.eid + else + None + in + parse_attribute modif tested att { cfg with prec_1; events_kind } + in + build_config tl cfg in let cfg = build_config attribute_ids empty_config in - let error,log_info = StoryProfiling.StoryStats.close_event parameter error StoryProfiling.Build_configuration None log_info in - let error,log_info,reduction = - if with_reduction - then + let error, log_info = + StoryProfiling.StoryStats.close_event parameter error + StoryProfiling.Build_configuration None log_info + in + let error, log_info, reduction = + if with_reduction then Graph_closure.reduction parameter handler log_info error cfg.prec_1 else - error,log_info,cfg.prec_1 + error, log_info, cfg.prec_1 in - error,log_info,{cfg with prec_1 = reduction} + error, log_info, { cfg with prec_1 = reduction } let pp_atom f atom = let imp_str = match atom.causal_impact with - 1 -> "o" | 2 -> "x" | 3 -> "%" - | _ -> invalid_arg "Causal.string_of_atom" in + | 1 -> "o" + | 2 -> "x" + | 3 -> "%" + | _ -> invalid_arg "Causal.string_of_atom" + in Format.fprintf f "%s_%d" imp_str atom.eid let _dump grid fic = - let d_chan = Kappa_files.open_out ((Filename.chop_extension fic)^".txt") in + let d_chan = Kappa_files.open_out (Filename.chop_extension fic ^ ".txt") in let d = Format.formatter_of_out_channel d_chan in let () = Format.pp_open_vbox d 0 in Hashtbl.fold - (fun (n_id,s_id,q) att _ -> - Format.fprintf d "#%i.%i%c:%a@," n_id s_id (if q=0 then '~' else '!') - (Pp.list Pp.empty pp_atom) att - ) grid.flow () ; + (fun (n_id, s_id, q) att _ -> + Format.fprintf d "#%i.%i%c:%a@," n_id s_id + (if q = 0 then + '~' + else + '!') + (Pp.list Pp.empty pp_atom) att) + grid.flow (); let () = Format.fprintf d "@]@." in close_out d_chan -let ids_of_grid grid = Hashtbl.fold (fun key _ l -> key::l) grid.flow [] +let ids_of_grid grid = Hashtbl.fold (fun key _ l -> key :: l) grid.flow [] let config_of_grid = cut - (*let prec_star_of_config_old config = let rec prec_closure config todo already_done closure = if Mods.IntSet.is_empty todo then closure @@ -410,47 +485,68 @@ let prec_star_of_config = Graph_closure.closure let depth_and_size_of_event config = Mods.IntMap.fold - (fun eid prec_eids (emap,_) -> - let d = - Mods.IntSet.fold - (fun eid' d -> - let d' = Mods.IntMap.find_default 0 eid' emap in - max (d'+1) d - ) prec_eids 0 - in - Mods.IntMap.add eid d emap,d - ) config.prec_1 (Mods.IntMap.empty,0) + (fun eid prec_eids (emap, _) -> + let d = + Mods.IntSet.fold + (fun eid' d -> + let d' = Mods.IntMap.find_default 0 eid' emap in + max (d' + 1) d) + prec_eids 0 + in + Mods.IntMap.add eid d emap, d) + config.prec_1 (Mods.IntMap.empty, 0) let enrich_grid parameter handler log_info error config_closure grid = let keep_l = - List.fold_left (fun a b -> Mods.IntSet.add b a) Mods.IntSet.empty grid.obs in + List.fold_left (fun a b -> Mods.IntSet.add b a) Mods.IntSet.empty grid.obs + in let to_keep i = Mods.IntSet.mem i keep_l in - let ids = ids_of_grid grid in - let error,log_info,config = config_of_grid parameter handler log_info error ids grid in - let error,log_info,prec_star = prec_star_of_config parameter handler log_info error (Some StoryProfiling.Transitive_closure) config_closure config.prec_1 to_keep in - let depth_of_event,depth = depth_and_size_of_event config in - error,log_info, - { - config = config ; - prec_star = prec_star ; - depth = depth ; - depth_of_event = depth_of_event ; - size = Mods.IntMap.size config.prec_1 ; - } + let ids = ids_of_grid grid in + let error, log_info, config = + config_of_grid parameter handler log_info error ids grid + in + let error, log_info, prec_star = + prec_star_of_config parameter handler log_info error + (Some StoryProfiling.Transitive_closure) config_closure config.prec_1 + to_keep + in + let depth_of_event, depth = depth_and_size_of_event config in + ( error, + log_info, + { + config; + prec_star; + depth; + depth_of_event; + size = Mods.IntMap.size config.prec_1; + } ) -let fold_over_causal_past_of_obs parameter handler log_info error config_closure grid f a = - let keep_l = List.fold_left (fun a b -> Mods.IntSet.add b a) Mods.IntSet.empty grid.obs in +let fold_over_causal_past_of_obs parameter handler log_info error config_closure + grid f a = + let keep_l = + List.fold_left (fun a b -> Mods.IntSet.add b a) Mods.IntSet.empty grid.obs + in let to_keep i = Mods.IntSet.mem i keep_l in - let ids = ids_of_grid grid in - let error,log_info = StoryProfiling.StoryStats.add_event parameter error StoryProfiling.Build_configuration None log_info in - let error,log_info,config = config_of_grid ~with_reduction:false parameter handler log_info error ids grid in - let error,log_info = StoryProfiling.StoryStats.close_event parameter error StoryProfiling.Build_configuration None log_info in - Graph_closure.closure_bottom_up_with_fold parameter handler log_info error (Some StoryProfiling.Collect_traces) config_closure config.prec_1 to_keep f a + let ids = ids_of_grid grid in + let error, log_info = + StoryProfiling.StoryStats.add_event parameter error + StoryProfiling.Build_configuration None log_info + in + let error, log_info, config = + config_of_grid ~with_reduction:false parameter handler log_info error ids + grid + in + let error, log_info = + StoryProfiling.StoryStats.close_event parameter error + StoryProfiling.Build_configuration None log_info + in + Graph_closure.closure_bottom_up_with_fold parameter handler log_info error + (Some StoryProfiling.Collect_traces) config_closure config.prec_1 to_keep f + a let print_event_kind_dot_annot env f = function | OBS name -> - Format.fprintf - f "[label=\"%s\", style=filled, fillcolor=red]" name + Format.fprintf f "[label=\"%s\", style=filled, fillcolor=red]" name | EVENT e -> Trace.print_event_kind_dot_annot env f e let dot_of_grid profiling env enriched_grid form = @@ -461,338 +557,405 @@ let dot_of_grid profiling env enriched_grid form = let sorted_events = Mods.IntMap.fold (fun eid d dmap -> - let set = Mods.IntMap.find_default Mods.IntSet.empty d dmap in - Mods.IntMap.add d (Mods.IntSet.add eid set) dmap - ) depth_of_event Mods.IntMap.empty in + let set = Mods.IntMap.find_default Mods.IntSet.empty d dmap in + Mods.IntMap.add d (Mods.IntSet.add eid set) dmap) + depth_of_event Mods.IntMap.empty + in Format.fprintf form "@[%t@,digraph G{@, ranksep=.5 ;@," profiling; Mods.IntMap.iter (fun d eids_at_d -> - Format.fprintf form "@[{ rank = same ; \"%d\" [shape=plaintext] ;@," d; - Mods.IntSet.iter - (fun eid -> - match Mods.IntMap.find_option eid config.events_kind with - | None -> raise Not_found - | Some atom_kind -> - if eid <> 0 then - Format.fprintf - form "node_%d %a ;@," eid - (print_event_kind_dot_annot env) atom_kind - (* List.iter (fun obs -> fprintf desc "obs_%d [label =\"%s\", style=filled, fillcolor=red] ;\n node_%d -> obs_%d [arrowhead=vee];\n" eid obs eid eid) atom.observation ;*) - ) eids_at_d ; - Format.fprintf form "}@]@," ; - ) sorted_events ; + Format.fprintf form "@[{ rank = same ; \"%d\" [shape=plaintext] ;@," d; + Mods.IntSet.iter + (fun eid -> + match Mods.IntMap.find_option eid config.events_kind with + | None -> raise Not_found + | Some atom_kind -> + if eid <> 0 then + Format.fprintf form "node_%d %a ;@," eid + (print_event_kind_dot_annot env) + atom_kind + (* List.iter (fun obs -> fprintf desc "obs_%d [label =\"%s\", style=filled, fillcolor=red] ;\n node_%d -> obs_%d [arrowhead=vee];\n" eid obs eid eid) atom.observation ;*)) + eids_at_d; + Format.fprintf form "}@]@,") + sorted_events; let cpt = ref 0 in - while !cpt+1 < (Mods.IntMap.size sorted_events) do - Format.fprintf form "\"%d\" -> \"%d\" [style=\"invis\"];@," !cpt (!cpt+1); + while !cpt + 1 < Mods.IntMap.size sorted_events do + Format.fprintf form "\"%d\" -> \"%d\" [style=\"invis\"];@," !cpt (!cpt + 1); cpt := !cpt + 1 - done ; + done; Mods.IntMap.iter (fun eid pred_set -> - if eid <> 0 then - Mods.IntSet.iter - (fun eid' -> - if eid' = 0 then () - else - Format.fprintf form "node_%d -> node_%d@," eid' eid - ) pred_set - ) config.prec_1 ; + if eid <> 0 then + Mods.IntSet.iter + (fun eid' -> + if eid' = 0 then + () + else + Format.fprintf form "node_%d -> node_%d@," eid' eid) + pred_set) + config.prec_1; Mods.IntMap.iter (fun eid cflct_set -> - if eid <> 0 then - let prec = try (fst prec_star).(eid) with _ -> [] in - let _ = - Mods.IntSet.fold_inv - (fun eid' prec -> - let bool,prec = - let rec aux prec = - match prec with - | [] -> true,prec - | h::t -> - if h=eid' then false,t else - if h>eid' then aux t else true,prec - in aux prec in - let () = - if bool then - Format.fprintf - form "node_%d -> node_%d [style=dotted, arrowhead = tee]@ " - eid eid' + if eid <> 0 then ( + let prec = try (fst prec_star).(eid) with _ -> [] in + let _ = + Mods.IntSet.fold_inv + (fun eid' prec -> + let bool, prec = + let rec aux prec = + match prec with + | [] -> true, prec + | h :: t -> + if h = eid' then + false, t + else if h > eid' then + aux t + else + true, prec in - prec - ) cflct_set prec - in () - ) config.conflict ; - Format.fprintf form "}@," ; + aux prec + in + let () = + if bool then + Format.fprintf form + "node_%d -> node_%d [style=dotted, arrowhead = tee]@ " eid + eid' + in + prec) + cflct_set prec + in + () + )) + config.conflict; + Format.fprintf form "}@,"; Format.fprintf form "/*@, Dot generation time: %f@,*/@]@." (Sys.time () -. t) let js_of_grid env enriched_grid f = let () = Format.fprintf f "// Create a new directed graph@," in let () = - Format.fprintf f "var g = new dagreD3.graphlib.Graph().setGraph({});@," in - - let () = Pp.set - ~trailing:Pp.space Mods.IntMap.bindings Pp.space - (fun f (eid,atom_kind) -> - Format.fprintf - f "g.setNode(%i, { label: \"%a\", style: \"fill: %s\" });" - eid (print_event_kind ~env) atom_kind - (match atom_kind with - | OBS _ -> "#f77" - | EVENT (Trace.INIT _ | Trace.PERT _) -> "#7f7" - | EVENT (Trace.RULE _) -> "#77f")) - f enriched_grid.config.events_kind in + Format.fprintf f "var g = new dagreD3.graphlib.Graph().setGraph({});@," + in + + let () = + Pp.set ~trailing:Pp.space Mods.IntMap.bindings Pp.space + (fun f (eid, atom_kind) -> + Format.fprintf f + "g.setNode(%i, { label: \"%a\", style: \"fill: %s\" });" eid + (print_event_kind ~env) atom_kind + (match atom_kind with + | OBS _ -> "#f77" + | EVENT (Trace.INIT _ | Trace.PERT _) -> "#7f7" + | EVENT (Trace.RULE _) -> "#77f")) + f enriched_grid.config.events_kind + in + let () = + Pp.set Mods.IntMap.bindings Pp.empty + (fun f (eid, set) -> + Pp.set Mods.IntSet.elements ~trailing:Pp.space Pp.space + (fun f eid' -> Format.fprintf f "g.setEdge(%i,%i,{});" eid' eid) + f set) + f enriched_grid.config.prec_1 + in + + let () = + Format.fprintf f "var svg = d3.select(\"svg\"),inner = svg.select(\"g\");@," + in + + let () = Format.fprintf f "// Set up zoom support@," in + let () = + Format.fprintf f "var zoom = d3.behavior.zoom().on(\"zoom\", function() {@," + in + let () = + Format.fprintf f + "inner.attr(\"transform\", \"translate(\" + d3.event.translate + \")\" +@," + in + let () = + Format.fprintf f + "\"scale(\" + d3.event.scale + \")\");@,});@,svg.call(zoom);" + in + let () = + Format.fprintf f + "// Create the renderer@, var render = new dagreD3.render();@," + in let () = - Pp.set - Mods.IntMap.bindings Pp.empty - (fun f (eid,set) -> - Pp.set Mods.IntSet.elements ~trailing:Pp.space Pp.space - (fun f eid' -> Format.fprintf f "g.setEdge(%i,%i,{});" eid' eid) - f set) - f enriched_grid.config.prec_1 in - - let () = Format.fprintf - f "var svg = d3.select(\"svg\"),inner = svg.select(\"g\");@," in - - let () = Format.fprintf - f "// Set up zoom support@," in - let () = Format.fprintf - f "var zoom = d3.behavior.zoom().on(\"zoom\", function() {@," in - let () = Format.fprintf - f "inner.attr(\"transform\", \"translate(\" + d3.event.translate + \")\" +@," in - let () = Format.fprintf - f "\"scale(\" + d3.event.scale + \")\");@,});@,svg.call(zoom);" in - let () = Format.fprintf - f "// Create the renderer@, var render = new dagreD3.render();@," in - let () = Format.fprintf - f "// Run the renderer. This is what draws the final graph.@," in + Format.fprintf f + "// Run the renderer. This is what draws the final graph.@," + in let () = Format.fprintf f "render(inner, g);@," in let () = Format.fprintf f "// Center the graph@,var initialScale = 0.75;@," in let () = Format.fprintf f "zoom@," in - let () = Format.fprintf - f ".translate([(svg.attr(\"width\") - g.graph().width * initialScale) / 2, 20])@," in + let () = + Format.fprintf f + ".translate([(svg.attr(\"width\") - g.graph().width * initialScale) / 2, \ + 20])@," + in let () = Format.fprintf f ".scale(initialScale)@,.event(svg);@," in Format.fprintf f "svg.attr('height', g.graph().height * initialScale + 40);" let html_of_grid profiling compression_type cpt env enriched_grid = - let title f = Format.fprintf - f "%s compressed story number %i" compression_type cpt in - Pp_html.graph_page - title ["http://d3js.org/d3.v3.min.js"; - "http://cpettitt.github.io/project/dagre-d3/latest/dagre-d3.min.js"] + let title f = + Format.fprintf f "%s compressed story number %i" compression_type cpt + in + Pp_html.graph_page title + [ + "http://d3js.org/d3.v3.min.js"; + "http://cpettitt.github.io/project/dagre-d3/latest/dagre-d3.min.js"; + ] (fun f -> - let () = Format.fprintf f "@[") + let () = Format.fprintf f "@[") (fun f -> - let () = Format.fprintf f "@," in - let () = Format.fprintf f "

    @[%t@]

    @," profiling in - Format.fprintf - f "@[" - (js_of_grid env enriched_grid)) - + let () = Format.fprintf f "@," in + let () = Format.fprintf f "

    @[%t@]

    @," profiling in + Format.fprintf f "@[" + (js_of_grid env enriched_grid)) let check_create_quarks aid sites quarks = List.for_all - (fun (site,internal) -> + (fun (site, internal) -> match internal with - | Some _ -> ((List.mem (atom_modified,(aid,site,0)) quarks)&& - (List.mem (atom_modified,(aid,site,1)) quarks)) - | None -> (List.mem (atom_modified,(aid,site,1)) quarks)) sites + | Some _ -> + List.mem (atom_modified, (aid, site, 0)) quarks + && List.mem (atom_modified, (aid, site, 1)) quarks + | None -> List.mem (atom_modified, (aid, site, 1)) quarks) + sites -let check_modified_quarks ((aid,_),site) modif quarks = +let check_modified_quarks ((aid, _), site) modif quarks = List.exists - (fun (c,(n,s,m)) -> - ((c=atom_modified)||(c=atom_testedmodified))&&(n=aid)&&(s=site)&&(m=modif)) quarks + (fun (c, (n, s, m)) -> + (c = atom_modified || c = atom_testedmodified) + && n = aid && s = site && m = modif) + quarks -let check_tested_quarks ((aid,_),site) modif quarks = +let check_tested_quarks ((aid, _), site) modif quarks = List.exists - (fun (c,(n,s,m)) -> - ((c=atom_tested)||(c=atom_testedmodified))&&(n=aid)&&(s=site)&&(m=modif)) quarks + (fun (c, (n, s, m)) -> + (c = atom_tested || c = atom_testedmodified) + && n = aid && s = site && m = modif) + quarks let check_event_quarks actions tests quarks = - (List.for_all + List.for_all (function - | Instantiation.Create ((aid,_),sites) -> + | Instantiation.Create ((aid, _), sites) -> check_create_quarks aid sites quarks - | Instantiation.Free asite -> - check_modified_quarks asite 1 quarks - | Instantiation.Bind_to (asite1,asite2) - | Instantiation.Bind (asite1,asite2) -> - (check_modified_quarks asite1 1 quarks)&& - (check_modified_quarks asite2 1 quarks) - | Instantiation.Mod_internal (asite,_) -> + | Instantiation.Free asite -> check_modified_quarks asite 1 quarks + | Instantiation.Bind_to (asite1, asite2) + | Instantiation.Bind (asite1, asite2) -> + check_modified_quarks asite1 1 quarks + && check_modified_quarks asite2 1 quarks + | Instantiation.Mod_internal (asite, _) -> check_modified_quarks asite 0 quarks - | Instantiation.Remove (aid,_) -> - List.exists - (fun (c,(n,_,_)) -> - ((c=atom_modified)||(c=atom_testedmodified))&&(n=aid)) quarks) - actions)&& - (List.for_all (List.for_all - (function - | Instantiation.Is_Here (aid,_) -> + | Instantiation.Remove (aid, _) -> List.exists - (fun (c,(n,_,_)) -> - ((c=atom_tested)||(c=atom_testedmodified))&&(n=aid)) quarks - | Instantiation.Has_Internal (asite,_) -> - check_tested_quarks asite 0 quarks - | Instantiation.Is_Free asite | Instantiation.Is_Bound asite - | Instantiation.Has_Binding_type (asite,_) -> - check_tested_quarks asite 1 quarks - | Instantiation.Is_Bound_to (asite1,asite2) -> - (check_tested_quarks asite1 1 quarks)&& - (check_tested_quarks asite2 1 quarks))) - tests) - + (fun (c, (n, _, _)) -> + (c = atom_modified || c = atom_testedmodified) && n = aid) + quarks) + actions + && List.for_all + (List.for_all (function + | Instantiation.Is_Here (aid, _) -> + List.exists + (fun (c, (n, _, _)) -> + (c = atom_tested || c = atom_testedmodified) && n = aid) + quarks + | Instantiation.Has_Internal (asite, _) -> + check_tested_quarks asite 0 quarks + | Instantiation.Is_Free asite + | Instantiation.Is_Bound asite + | Instantiation.Has_Binding_type (asite, _) -> + check_tested_quarks asite 1 quarks + | Instantiation.Is_Bound_to (asite1, asite2) -> + check_tested_quarks asite1 1 quarks + && check_tested_quarks asite2 1 quarks)) + tests let log_event id quarks event_kind steps = match event_kind with | EVENT (Trace.INIT _) -> - let stp = - List.find - (function + let stp = + List.find + (function | Trace.Init actions -> - List.for_all - (function - | Instantiation.Create ((aid,_),sites) -> - check_create_quarks aid sites quarks + List.for_all + (function + | Instantiation.Create ((aid, _), sites) -> + check_create_quarks aid sites quarks | Instantiation.Free _ | Instantiation.Bind_to _ - | Instantiation.Bind _ | Instantiation.Mod_internal _ -> true + | Instantiation.Bind _ | Instantiation.Mod_internal _ -> + true | Instantiation.Remove _ -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - "init event has actions not allowed"))) actions - | Trace.Rule _ | Trace.Pert _ | Trace.Obs _ - | Trace.Subs _ | Trace.Dummy _ -> false) steps in - `List [`Int id; Trace.step_to_yojson stp ] + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy + "init event has actions not allowed"))) + actions + | Trace.Rule _ | Trace.Pert _ | Trace.Obs _ | Trace.Subs _ + | Trace.Dummy _ -> + false) + steps + in + `List [ `Int id; Trace.step_to_yojson stp ] | EVENT (Trace.RULE rid) -> - let stp = - List.find - (function - | Trace.Rule (rid',e,_) -> - ((rid=rid')&& - (check_event_quarks - e.Instantiation.actions - (e.Instantiation.connectivity_tests::e.Instantiation.tests) - quarks)) - | Trace.Pert _ | Trace.Obs _ | Trace.Subs _ - | Trace.Dummy _ | Trace.Init _ -> false) steps in - `List [`Int id; Trace.step_to_yojson stp] + let stp = + List.find + (function + | Trace.Rule (rid', e, _) -> + rid = rid' + && check_event_quarks e.Instantiation.actions + (e.Instantiation.connectivity_tests :: e.Instantiation.tests) + quarks + | Trace.Pert _ | Trace.Obs _ | Trace.Subs _ | Trace.Dummy _ + | Trace.Init _ -> + false) + steps + in + `List [ `Int id; Trace.step_to_yojson stp ] | OBS _ -> - let stp = - List.find - (function + let stp = + List.find + (function | Trace.Obs _ -> true - | Trace.Subs _ | Trace.Dummy _ | Trace.Init _ - | Trace.Rule _ | Trace.Pert _ -> false) steps in - `List [`Int id; Trace.step_to_yojson stp] + | Trace.Subs _ | Trace.Dummy _ | Trace.Init _ | Trace.Rule _ + | Trace.Pert _ -> + false) + steps + in + `List [ `Int id; Trace.step_to_yojson stp ] | EVENT (Trace.PERT pert) -> - let stp = - List.find - (function - | Trace.Pert (pert',e,_) -> - ((pert=pert')&& - (check_event_quarks - e.Instantiation.actions - (e.Instantiation.connectivity_tests::e.Instantiation.tests) - quarks)) - | Trace.Rule _ | Trace.Obs _ | Trace.Subs _ - | Trace.Dummy _ | Trace.Init _ -> false) steps in - `List [`Int id; Trace.step_to_yojson stp] + let stp = + List.find + (function + | Trace.Pert (pert', e, _) -> + pert = pert' + && check_event_quarks e.Instantiation.actions + (e.Instantiation.connectivity_tests :: e.Instantiation.tests) + quarks + | Trace.Rule _ | Trace.Obs _ | Trace.Subs _ | Trace.Dummy _ + | Trace.Init _ -> + false) + steps + in + `List [ `Int id; Trace.step_to_yojson stp ] let json_of_grid enriched_grid grid_story steps = let config = enriched_grid.config in let prec_star = enriched_grid.prec_star in let depth_of_event = enriched_grid.depth_of_event in let tbl = Hashtbl.create !Parameter.defaultExtArraySize in - let () = Hashtbl.iter - ( fun quark att_ls -> - List.iter - ( fun atom -> - Hashtbl.add tbl (atom.eid) (atom.causal_impact,quark)) att_ls - ) grid_story.flow in + let () = + Hashtbl.iter + (fun quark att_ls -> + List.iter + (fun atom -> Hashtbl.add tbl atom.eid (atom.causal_impact, quark)) + att_ls) + grid_story.flow + in let sorted_events = Mods.IntMap.fold (fun eid d dmap -> - let set = Mods.IntMap.find_default Mods.IntSet.empty d dmap in - Mods.IntMap.add d (Mods.IntSet.add eid set) dmap - ) depth_of_event Mods.IntMap.empty in + let set = Mods.IntMap.find_default Mods.IntSet.empty d dmap in + Mods.IntMap.add d (Mods.IntSet.add eid set) dmap) + depth_of_event Mods.IntMap.empty + in let node_to_json eid = match Mods.IntMap.find_option eid config.events_kind with | None -> raise Not_found | Some atom_kind -> - if eid <> 0 then - let quarks = Hashtbl.find_all tbl eid in - log_event eid quarks atom_kind steps - else `Null in + if eid <> 0 then ( + let quarks = Hashtbl.find_all tbl eid in + log_event eid quarks atom_kind steps + ) else + `Null + in let nodes_to_list = Mods.IntMap.fold (fun _ eids_at_d ls -> - let ls'' = Mods.IntSet.fold - (fun eid ls' -> - eid::ls') eids_at_d [] in - ls''@ls - ) sorted_events [] in + let ls'' = Mods.IntSet.fold (fun eid ls' -> eid :: ls') eids_at_d [] in + ls'' @ ls) + sorted_events [] + in let nodes_to_json = JsonUtil.of_list node_to_json nodes_to_list in - let edge_to_json (eid, eid') = - ( `Assoc [ - "from", `Int eid'; - "to", `Int eid; - ]) in + let edge_to_json (eid, eid') = `Assoc [ "from", `Int eid'; "to", `Int eid ] in let prec_edges = Mods.IntMap.fold (fun eid pred_set ls -> - if eid <> 0 then - let ls'' = Mods.IntSet.fold - (fun eid' ls' -> - if eid' = 0 then ls' - else (eid, eid')::ls' - ) pred_set [] in - ls''@ls - else ls) config.prec_1 [] in + if eid <> 0 then ( + let ls'' = + Mods.IntSet.fold + (fun eid' ls' -> + if eid' = 0 then + ls' + else + (eid, eid') :: ls') + pred_set [] + in + ls'' @ ls + ) else + ls) + config.prec_1 [] + in let prec_edges_to_json = JsonUtil.of_list edge_to_json prec_edges in let confl_edges = Mods.IntMap.fold (fun eid cflct_set ls -> - if eid <> 0 then + if eid <> 0 then ( let prec = try (fst prec_star).(eid) with _ -> [] in - let (_, ls') = + let _, ls' = Mods.IntSet.fold_inv - (fun eid' (prec,ls') -> - let bool,prec = + (fun eid' (prec, ls') -> + let bool, prec = let rec aux prec = match prec with - | [] -> true,prec - | h::t -> - if h=eid' then false,t else - if h>eid' then aux t else true,prec - in aux prec in + | [] -> true, prec + | h :: t -> + if h = eid' then + false, t + else if h > eid' then + aux t + else + true, prec + in + aux prec + in let ls'' = if bool then - (eid, eid')::ls' - else ls' in - (prec,ls'') - ) cflct_set (prec,ls) - in ls' - else ls - ) config.conflict [] in + (eid, eid') :: ls' + else + ls' + in + prec, ls'') + cflct_set (prec, ls) + in + ls' + ) else + ls) + config.conflict [] + in let confl_edges_to_json = JsonUtil.of_list edge_to_json confl_edges in - (`Assoc [ - "nodes", nodes_to_json; - "cause", prec_edges_to_json; - "inhibit", confl_edges_to_json - ]: Yojson.Basic.t) + (`Assoc + [ + "nodes", nodes_to_json; + "cause", prec_edges_to_json; + "inhibit", confl_edges_to_json; + ] + : Yojson.Basic.t) (*story_list:[(key_i,list_i)] et list_i:[(grid,_,sim_info option)...] et sim_info:{with story_id:int story_time: float ; story_event: int}*) -let pretty_print - ~dotFormat parameter handler log_info error env config_closure +let pretty_print ~dotFormat parameter handler log_info error env config_closure compression_type label grid_list = match Loggers.formatter_of_logger (Remanent_parameters.get_logger parameter) @@ -802,131 +965,170 @@ let pretty_print let n = List.length grid_list in let () = if compression_type = "" then - Format.fprintf err_fmt "+ Pretty printing %d flow%s@." - n (if n>1 then "s" else "") + Format.fprintf err_fmt "+ Pretty printing %d flow%s@." n + (if n > 1 then + "s" + else + "") else - Format.fprintf err_fmt "+ Pretty printing %d %scompressed flow%s@." - n label (if n>1 then "s" else "") + Format.fprintf err_fmt "+ Pretty printing %d %scompressed flow%s@." n + label + (if n > 1 then + "s" + else + "") in let compression_type = - if compression_type = "" then "none" else compression_type in - let error,log_info,story_list = + if compression_type = "" then + "none" + else + compression_type + in + let error, log_info, story_list = List.fold_left - (fun (error,log_info,list) (z,x,y) -> - let error,log_info,x = enrich_grid parameter handler log_info error config_closure x in - error,log_info,(z,x,y)::list) - (error,log_info,[]) grid_list + (fun (error, log_info, list) (z, x, y) -> + let error, log_info, x = + enrich_grid parameter handler log_info error config_closure x + in + error, log_info, (z, x, y) :: list) + (error, log_info, []) grid_list in let story_list = List.rev story_list in let _ = List.fold_left - (fun cpt (steps,enriched_config,stories) -> - let av_t,ids,n = - List.fold_left - (fun (av_t,ids,n) info -> - (av_t +. info.Trace.Simulation_info.story_time, - info.Trace.Simulation_info.story_id::ids,n+1) - ) - (0.,[],0) (List.rev stories) - in - let () = (*dump grid fic state env ; *) - let () = - if (dotFormat = Json) then - (let (_,grid_story,_) = List.nth grid_list cpt in - Kappa_files.with_cflow_file - [compression_type;(string_of_int cpt)] ".json" - (fun f -> Format.fprintf f "%s@." - (Yojson.Basic.to_string - (json_of_grid enriched_config grid_story steps)))) in - match dotFormat with - | Dot | Json -> - let profiling desc = - Format.fprintf - desc "/* @[Compression of %d causal flows" n; - Format.fprintf - desc "@ obtained in average at %E t.u@] */@," - (av_t/.(float_of_int n)) ; - Format.fprintf - desc "@[/* Compressed causal flows were:@ [%a] */@]" - (Pp.list (fun f -> Format.fprintf f ";@,") - Format.pp_print_int) ids - in - Kappa_files.with_cflow_file - [compression_type;string_of_int cpt] ".dot" - (dot_of_grid profiling env enriched_config) - | Html -> - let profiling desc = - Format.fprintf - desc - "@[
    @,
    Compression of
    %d causal flows
    "n; - Format.fprintf - desc "@,
    obtained in average at
    %E t.u
    @," - (av_t/.(float_of_int n)) ; - Format.fprintf desc "
    Compressed causal flows were:
    "; - Format.fprintf - desc "@
    [@[%a@]]
    @]@,
    " - (Pp.list (fun f -> Format.fprintf f ";@,") - Format.pp_print_int) ids; - in + (fun cpt (steps, enriched_config, stories) -> + let av_t, ids, n = + List.fold_left + (fun (av_t, ids, n) info -> + ( av_t +. info.Trace.Simulation_info.story_time, + info.Trace.Simulation_info.story_id :: ids, + n + 1 )) + (0., [], 0) (List.rev stories) + in + let () = + (*dump grid fic state env ; *) + let () = + if dotFormat = Json then ( + let _, grid_story, _ = List.nth grid_list cpt in Kappa_files.with_cflow_file - [compression_type;string_of_int cpt] ".html" - (html_of_grid - profiling compression_type cpt env enriched_config) in - cpt+1 - ) 0 story_list + [ compression_type; string_of_int cpt ] + ".json" + (fun f -> + Format.fprintf f "%s@." + (Yojson.Basic.to_string + (json_of_grid enriched_config grid_story steps))) + ) + in + match dotFormat with + | Dot | Json -> + let profiling desc = + Format.fprintf desc "/* @[Compression of %d causal flows" n; + Format.fprintf desc "@ obtained in average at %E t.u@] */@," + (av_t /. float_of_int n); + Format.fprintf desc + "@[/* Compressed causal flows were:@ [%a] */@]" + (Pp.list + (fun f -> Format.fprintf f ";@,") + Format.pp_print_int) + ids + in + Kappa_files.with_cflow_file + [ compression_type; string_of_int cpt ] + ".dot" + (dot_of_grid profiling env enriched_config) + | Html -> + let profiling desc = + Format.fprintf desc + "@[
    @,
    Compression of
    %d causal flows
    " + n; + Format.fprintf desc + "@,
    obtained in average at
    %E t.u
    @," + (av_t /. float_of_int n); + Format.fprintf desc "
    Compressed causal flows were:
    "; + Format.fprintf desc "@
    [@[%a@]]
    @]@,
    " + (Pp.list + (fun f -> Format.fprintf f ";@,") + Format.pp_print_int) + ids + in + Kappa_files.with_cflow_file + [ compression_type; string_of_int cpt ] + ".html" + (html_of_grid profiling compression_type cpt env enriched_config) + in + cpt + 1) + 0 story_list in - let () = match dotFormat with + let () = + match dotFormat with | Json -> - Kappa_files.with_cflow_file [compression_type;"env"] ".json" - (fun f -> Format.fprintf f "%s@." + Kappa_files.with_cflow_file [ compression_type; "env" ] ".json" + (fun f -> + Format.fprintf f "%s@." (Yojson.Basic.to_string (Model.to_yojson env))) - | Dot | Html -> () in + | Dot | Html -> () + in let _ = - Kappa_files.with_cflow_file - [compression_type;"Summary"] ".dat" + Kappa_files.with_cflow_file [ compression_type; "Summary" ] ".dat" (fun form -> - let () = Format.fprintf form "@[#id\tE\tT\t\tdepth\tsize\t@," in - let () = - Pp.listi Pp.empty - (fun cpt f (_,enriched_config,story) -> - let depth = enriched_config.depth in - let size = enriched_config.size in - List.iter - (fun info -> - let time = info.Trace.Simulation_info.story_time in - let event = info.Trace.Simulation_info.story_event in - Format.fprintf f "%i\t%i\t%E\t%i\t%i\t@," - cpt event time depth size - ) story) form story_list in - Format.fprintf form "@]@?") + let () = Format.fprintf form "@[#id\tE\tT\t\tdepth\tsize\t@," in + let () = + Pp.listi Pp.empty + (fun cpt f (_, enriched_config, story) -> + let depth = enriched_config.depth in + let size = enriched_config.size in + List.iter + (fun info -> + let time = info.Trace.Simulation_info.story_time in + let event = info.Trace.Simulation_info.story_event in + Format.fprintf f "%i\t%i\t%E\t%i\t%i\t@," cpt event time + depth size) + story) + form story_list + in + Format.fprintf form "@]@?") in - error,log_info + error, log_info let print_stat f _parameter _handler enriched_grid = let count_obs = - match - snd enriched_grid.prec_star - with - Graph_closure.Increasing_with_last_event -> (fun x -> x) + match snd enriched_grid.prec_star with + | Graph_closure.Increasing_with_last_event -> fun x -> x | Graph_closure.Decreasing_without_last_event -> succ in let size = Array.length (fst enriched_grid.prec_star) in let rec aux k n_step longest_story n_nonempty length_sum length_square_sum = - if k>=size - then (n_step,longest_story,n_nonempty,length_sum,length_square_sum) - else + if k >= size then + n_step, longest_story, n_nonempty, length_sum, length_square_sum + else ( let cc = List.length (Array.get (fst enriched_grid.prec_star) k) in - let cc' = if cc>0 then count_obs cc else cc in - aux (k+1) (n_step+1) (max longest_story cc') - (if cc>0 then n_nonempty+1 else n_nonempty) - (length_sum+cc') (length_square_sum+cc'*cc') in - let n_step,longest_story,n_nonempty,length_sum,length_square_sum = - aux 0 0 0 0 0 0 in - let () = Format.fprintf f "@[Stats:@," in + let cc' = + if cc > 0 then + count_obs cc + else + cc + in + aux (k + 1) (n_step + 1) (max longest_story cc') + (if cc > 0 then + n_nonempty + 1 + else + n_nonempty) + (length_sum + cc') + (length_square_sum + (cc' * cc')) + ) + in + let n_step, longest_story, n_nonempty, length_sum, length_square_sum = + aux 0 0 0 0 0 0 + in + let () = Format.fprintf f "@[Stats:@," in let () = Format.fprintf f " number of step : %i@," n_step in let () = Format.fprintf f " longest story : %i@," longest_story in - let () = Format.fprintf f " average length : %.4g@," - (float length_sum /. float n_nonempty) in - let () = Format.fprintf f " geometric mean : %.4g@," - (sqrt (float length_square_sum /. float n_nonempty)) in + let () = + Format.fprintf f " average length : %.4g@," + (float length_sum /. float n_nonempty) + in + let () = + Format.fprintf f " geometric mean : %.4g@," + (sqrt (float length_square_sum /. float n_nonempty)) + in Format.fprintf f "@]@." diff --git a/core/cflow/causal.mli b/core/cflow/causal.mli index 1ee3727a40..0f635b0e98 100644 --- a/core/cflow/causal.mli +++ b/core/cflow/causal.mli @@ -1,74 +1,82 @@ type quark_lists = { - site_tested : (int * int) list; - site_modified : (int * int) list; - internal_state_tested : (int * int) list; - internal_state_modified : (int * int) list; + site_tested: (int * int) list; + site_modified: (int * int) list; + internal_state_tested: (int * int) list; + internal_state_modified: (int * int) list; } type event_kind = OBS of string | EVENT of Trace.event_kind -type atom = - { - causal_impact : int ; (*(1) tested (2) modified, (3) tested + modified*) - eid:int ; (*event identifier*) - kind:event_kind ; - (* observation: string list*) - } +type atom = { + causal_impact: int; (*(1) tested (2) modified, (3) tested + modified*) + eid: int; (*event identifier*) + kind: event_kind; (* observation: string list*) +} type attribute = atom list (*vertical sequence of atoms*) -type grid = - { - flow: (int*int*int,attribute) Hashtbl.t ; - (*(n_i,s_i,q_i) -> att_i with n_i: node_id, s_i: site_id, q_i: - link (1) or internal state (0) *) - pid_to_init: (int*int*int,int) Hashtbl.t ; - obs: int list ; - init_tbl: (int,Mods.IntSet.t) Hashtbl.t;(*decreasing*) - init_to_eidmax: (int,int) Hashtbl.t; - } -type config = - { - events_kind: event_kind Mods.IntMap.t ; - prec_1: Mods.IntSet.t Mods.IntMap.t ; - conflict : Mods.IntSet.t Mods.IntMap.t ; - } -type enriched_grid = - { - config:config; - depth:int; - prec_star: (int list array * Graph_closure.order) ; - depth_of_event: int Mods.IntMap.t ; - size:int; - } -type formatCflow = - | Dot - | Html - | Json + +type grid = { + flow: (int * int * int, attribute) Hashtbl.t; + (*(n_i,s_i,q_i) -> att_i with n_i: node_id, s_i: site_id, q_i: + link (1) or internal state (0) *) + pid_to_init: (int * int * int, int) Hashtbl.t; + obs: int list; + init_tbl: (int, Mods.IntSet.t) Hashtbl.t; (*decreasing*) + init_to_eidmax: (int, int) Hashtbl.t; +} + +type config = { + events_kind: event_kind Mods.IntMap.t; + prec_1: Mods.IntSet.t Mods.IntMap.t; + conflict: Mods.IntSet.t Mods.IntMap.t; +} + +type enriched_grid = { + config: config; + depth: int; + prec_star: int list array * Graph_closure.order; + depth_of_event: int Mods.IntMap.t; + size: int; +} + +type formatCflow = Dot | Html | Json val empty_grid : unit -> grid val record : - (Trace.event_kind * - Instantiation.concrete Instantiation.event * unit Trace.Simulation_info.t) -> - int -> Model.t -> grid -> grid + Trace.event_kind + * Instantiation.concrete Instantiation.event + * unit Trace.Simulation_info.t -> + int -> + Model.t -> + grid -> + grid + val record_obs : - (string * - Instantiation.concrete Instantiation.test list list - * unit Trace.Simulation_info.t) -> - Instantiation.concrete Instantiation.site list -> int -> grid -> grid + string + * Instantiation.concrete Instantiation.test list list + * unit Trace.Simulation_info.t -> + Instantiation.concrete Instantiation.site list -> + int -> + grid -> + grid + val record_init : int list * Instantiation.concrete Instantiation.action list -> - int -> Model.t -> grid -> grid + int -> + Model.t -> + grid -> + grid -val cut : ?with_reduction:bool -> +val cut : + ?with_reduction:bool -> Remanent_parameters_sig.parameters -> 'a -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> (int * int * int) list -> grid -> - Exception.method_handler * StoryProfiling.StoryStats.log_info * - config + Exception.method_handler * StoryProfiling.StoryStats.log_info * config val enrich_grid : Remanent_parameters_sig.parameters -> @@ -77,8 +85,7 @@ val enrich_grid : Exception.method_handler -> Graph_closure.config -> grid -> - Exception.method_handler * StoryProfiling.StoryStats.log_info * - enriched_grid + Exception.method_handler * StoryProfiling.StoryStats.log_info * enriched_grid val fold_over_causal_past_of_obs : Remanent_parameters_sig.parameters -> @@ -88,20 +95,19 @@ val fold_over_causal_past_of_obs : Graph_closure.config -> grid -> (Remanent_parameters_sig.parameters -> - 'a -> - StoryProfiling.StoryStats.log_info -> - Exception.method_handler -> - Graph_closure.M.elt -> - int list -> - 'b -> - Exception.method_handler * StoryProfiling.StoryStats.log_info * - ('b, 'c) Stop.stop) -> + 'a -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + Graph_closure.M.elt -> + int list -> 'b -> - (Exception.method_handler * StoryProfiling.StoryStats.log_info * - 'b, - Exception.method_handler * StoryProfiling.StoryStats.log_info * - 'c) - Stop.stop + Exception.method_handler + * StoryProfiling.StoryStats.log_info + * ('b, 'c) Stop.stop) -> + 'b -> + ( Exception.method_handler * StoryProfiling.StoryStats.log_info * 'b, + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'c ) + Stop.stop val debug_print_grid : Format.formatter -> grid -> unit @@ -114,10 +120,10 @@ val pretty_print : Model.t -> Graph_closure.config -> string -> - string -> (Trace.t * grid * 'b Trace.Simulation_info.t list) list -> - Exception.method_handler*StoryProfiling.StoryStats.log_info + string -> + (Trace.t * grid * 'b Trace.Simulation_info.t list) list -> + Exception.method_handler * StoryProfiling.StoryStats.log_info (** [pretty_print err_fmt env config_closure compression_type label story_list state env] *) -val print_stat : - Format.formatter -> 'a -> 'b -> enriched_grid -> unit +val print_stat : Format.formatter -> 'a -> 'b -> enriched_grid -> unit diff --git a/core/cflow/cflow_handler.ml b/core/cflow/cflow_handler.ml index bcd0ea8e2e..aff1c73384 100644 --- a/core/cflow/cflow_handler.ml +++ b/core/cflow/cflow_handler.ml @@ -19,9 +19,7 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - -module type Cflow_handler = -sig +module type Cflow_handler = sig type sort_algo_for_stories type compression_mode @@ -30,381 +28,524 @@ sig val get_weak_compression : compression_mode -> bool val get_strong_compression : compression_mode -> bool - - + type parameter = { + cache_size: int option; + current_compression_mode: Story_json.current_compression_mode option; + compression_mode: compression_mode; + priorities_weak: Priority.priorities; + priorities_strong: Priority.priorities; + priorities_causal: Priority.priorities; + compute_all_stories: bool; + sort_algo_for_stories: sort_algo_for_stories; + logger_err: Loggers.t; + logger_profiling: Loggers.t; + logger_out: Loggers.t; + logger_server: Loggers.t; + json_buffer: + StoryProfiling.StoryStats.log_info Story_json.message Fifo.t ref option; + log_step: bool; + debug_mode: bool; + logger_step: Loggers.t; + kasa: Remanent_parameters_sig.parameters; + always_disambiguate_initial_states: bool; + bound_on_itteration_number: int option; + time_independent: bool; + blacklist_events: bool; + server: bool; + is_server_channel_on: bool; + dump: string -> unit; + } (** a struct which contains parameterizable options *) - type parameter = - { - cache_size : int option ; - current_compression_mode: Story_json.current_compression_mode option; - compression_mode : compression_mode ; - priorities_weak: Priority.priorities ; - priorities_strong : Priority.priorities ; - priorities_causal : Priority.priorities ; - compute_all_stories : bool ; - sort_algo_for_stories: sort_algo_for_stories; - logger_err : Loggers.t ; - logger_profiling : Loggers.t ; - logger_out : Loggers.t ; - logger_server: Loggers.t ; - json_buffer: - StoryProfiling.StoryStats.log_info Story_json.message Fifo.t ref option ; - log_step : bool ; - debug_mode : bool ; - logger_step: Loggers.t ; - kasa: Remanent_parameters_sig.parameters ; - always_disambiguate_initial_states : bool ; - bound_on_itteration_number: int option ; - time_independent: bool ; - blacklist_events: bool ; - server: bool; - is_server_channel_on: bool; - dump: string -> unit; - } - - val get_current_compression_mode : parameter -> Story_json.current_compression_mode option - - type handler = (*handler to interpret abstract values*) - { - env: Model.t ; - rule_name_cache: string array; - agent_name_cache: string array; - steps_by_column: (int * Predicate_maps.predicate_value * bool) list Predicate_maps.QPredicateMap.t ; - } - type 'a zeroary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'a - type ('a,'b) unary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'b - type ('a,'b,'c) binary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'c - type ('a,'b,'c,'d) ternary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> 'c -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'd - type ('a,'b,'c,'d,'e) quaternary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> 'c -> 'd -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'e - val do_not_bound_itterations: parameter -> parameter - val set_itteration_bound: parameter -> int -> parameter - val get_bound_on_itteration_number: parameter -> int option - val set_first_story_per_obs: parameter -> parameter - val set_all_stories_per_obs: parameter -> parameter - val build_parameter: called_from:Remanent_parameters_sig.called_from -> - ?send_message:(string -> unit) -> none:bool -> weak:bool -> strong:bool -> - unit -> parameter - val string_of_exn: exn -> string option - val is_server_mode: parameter -> bool - val set_compression_weak: parameter -> parameter - val set_compression_strong: parameter -> parameter - val set_compression_none: parameter -> parameter - val get_priorities: parameter -> Priority.priorities option - val get_all_stories_per_obs: parameter -> bool - val set_log_step: parameter -> bool -> parameter - val get_log_step: parameter -> bool - val set_debugging_mode: parameter -> bool -> parameter - val get_debugging_mode: parameter -> bool - val get_profiling_logger: parameter -> Loggers.t - val get_server_channel: parameter -> Loggers.t - val shut_down_server_channel: parameter -> parameter - val is_server_channel_on: parameter -> bool - - val get_logger: parameter -> Loggers.t - val set_logger: parameter -> Loggers.t -> parameter - val get_out_channel: parameter -> Loggers.t - val set_out_channel: parameter -> Loggers.t -> parameter - val get_debugging_channel: parameter -> Loggers.t - val set_debugging_channel: parameter -> Loggers.t-> parameter - val get_kasa_parameters: parameter -> Remanent_parameters_sig.parameters - val set_kasa_parameters: Remanent_parameters_sig.parameters -> parameter -> parameter - val do_we_use_bucket_sort: parameter -> bool - val use_bucket_sort: parameter -> parameter - val use_fusion_sort: parameter -> parameter - val always_disambiguate: parameter -> bool - val set_always_disambiguate: parameter -> bool -> parameter - val init_handler: Model.t -> handler - val string_of_rule_id: handler -> int -> string - val string_of_agent_id: handler -> int -> string - val get_predicate_map: handler -> (int * Predicate_maps.predicate_value * bool) list Predicate_maps.QPredicateMap.t - val get_is_time_independent: parameter -> bool - val get_blacklist_events: parameter -> bool - val save_current_phase_title: parameter -> string -> unit - val reset_current_phase_title: parameter -> unit - val save_progress_bar: parameter -> bool * int * int * int -> unit - val reset_progress_bar: parameter -> unit - val set_save_current_phase_title: parameter -> (string -> unit) -> parameter - val set_reset_current_phase_title: parameter -> (unit -> unit) -> parameter - val set_save_progress_bar: parameter -> (bool * int * int * int -> unit) -> parameter - val set_reset_progress_bar: parameter -> (unit -> unit) -> parameter - val save_error_log: parameter -> Exception_without_parameter.method_handler -> unit - val set_save_error_log: parameter -> (Exception_without_parameter.method_handler -> unit) -> parameter - val push_json: + val get_current_compression_mode : + parameter -> Story_json.current_compression_mode option + + type handler = { + (*handler to interpret abstract values*) + env: Model.t; + rule_name_cache: string array; + agent_name_cache: string array; + steps_by_column: + (int * Predicate_maps.predicate_value * bool) list + Predicate_maps.QPredicateMap.t; + } + + type 'a zeroary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'a + + type ('a, 'b) unary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'b + + type ('a, 'b, 'c) binary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'c + + type ('a, 'b, 'c, 'd) ternary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'd + + type ('a, 'b, 'c, 'd, 'e) quaternary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + 'd -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'e + + val do_not_bound_itterations : parameter -> parameter + val set_itteration_bound : parameter -> int -> parameter + val get_bound_on_itteration_number : parameter -> int option + val set_first_story_per_obs : parameter -> parameter + val set_all_stories_per_obs : parameter -> parameter + + val build_parameter : + called_from:Remanent_parameters_sig.called_from -> + ?send_message:(string -> unit) -> + none:bool -> + weak:bool -> + strong:bool -> + unit -> + parameter + + val string_of_exn : exn -> string option + val is_server_mode : parameter -> bool + val set_compression_weak : parameter -> parameter + val set_compression_strong : parameter -> parameter + val set_compression_none : parameter -> parameter + val get_priorities : parameter -> Priority.priorities option + val get_all_stories_per_obs : parameter -> bool + val set_log_step : parameter -> bool -> parameter + val get_log_step : parameter -> bool + val set_debugging_mode : parameter -> bool -> parameter + val get_debugging_mode : parameter -> bool + val get_profiling_logger : parameter -> Loggers.t + val get_server_channel : parameter -> Loggers.t + val shut_down_server_channel : parameter -> parameter + val is_server_channel_on : parameter -> bool + val get_logger : parameter -> Loggers.t + val set_logger : parameter -> Loggers.t -> parameter + val get_out_channel : parameter -> Loggers.t + val set_out_channel : parameter -> Loggers.t -> parameter + val get_debugging_channel : parameter -> Loggers.t + val set_debugging_channel : parameter -> Loggers.t -> parameter + val get_kasa_parameters : parameter -> Remanent_parameters_sig.parameters + + val set_kasa_parameters : + Remanent_parameters_sig.parameters -> parameter -> parameter + + val do_we_use_bucket_sort : parameter -> bool + val use_bucket_sort : parameter -> parameter + val use_fusion_sort : parameter -> parameter + val always_disambiguate : parameter -> bool + val set_always_disambiguate : parameter -> bool -> parameter + val init_handler : Model.t -> handler + val string_of_rule_id : handler -> int -> string + val string_of_agent_id : handler -> int -> string + + val get_predicate_map : + handler -> + (int * Predicate_maps.predicate_value * bool) list + Predicate_maps.QPredicateMap.t + + val get_is_time_independent : parameter -> bool + val get_blacklist_events : parameter -> bool + val save_current_phase_title : parameter -> string -> unit + val reset_current_phase_title : parameter -> unit + val save_progress_bar : parameter -> bool * int * int * int -> unit + val reset_progress_bar : parameter -> unit + val set_save_current_phase_title : parameter -> (string -> unit) -> parameter + val set_reset_current_phase_title : parameter -> (unit -> unit) -> parameter + + val set_save_progress_bar : + parameter -> (bool * int * int * int -> unit) -> parameter + + val set_reset_progress_bar : parameter -> (unit -> unit) -> parameter + + val save_error_log : + parameter -> Exception_without_parameter.method_handler -> unit + + val set_save_error_log : + parameter -> + (Exception_without_parameter.method_handler -> unit) -> + parameter + + val push_json : parameter -> StoryProfiling.StoryStats.log_info Story_json.message -> unit - val pop_json: + + val pop_json : parameter -> StoryProfiling.StoryStats.log_info Story_json.message option end -module Cflow_handler = - (struct - type sort_algo_for_stories = Bucket | Fusion - - type compression_mode = - { - causal_trace:bool; - weak_compression:bool; - strong_compression:bool - } - - let get_causal_trace x = x.causal_trace - let get_causal_trace_only x = not (x.weak_compression || x.strong_compression) - let get_weak_compression x = x.weak_compression - let get_strong_compression x = x.strong_compression - - type parameter = - { - cache_size : int option ; - current_compression_mode: Story_json.current_compression_mode option; - compression_mode : compression_mode ; - priorities_weak: Priority.priorities ; - priorities_strong : Priority.priorities ; - priorities_causal: Priority.priorities ; - compute_all_stories : bool ; - sort_algo_for_stories: sort_algo_for_stories; - logger_err : Loggers.t; - logger_profiling: Loggers.t; - logger_out : Loggers.t; - logger_server : Loggers.t ; - json_buffer: - StoryProfiling.StoryStats.log_info Story_json.message Fifo.t ref option ; - log_step : bool ; - debug_mode: bool ; - logger_step : Loggers.t ; - kasa : Remanent_parameters_sig.parameters ; - always_disambiguate_initial_states : bool ; - bound_on_itteration_number: int option ; - time_independent: bool ; - blacklist_events: bool ; - server: bool ; - is_server_channel_on: bool; - dump: string -> unit ; - } - - let get_current_compression_mode parameter = parameter.current_compression_mode - - let build_parameter ~called_from - ?(send_message=fun x -> - Loggers.fprintf Loggers.dummy_txt_logger "%s" x; - Loggers.print_newline Loggers.dummy_txt_logger) - ~none ~weak ~strong () = - let server,out_server,out_channel,out_channel_err,out_channel_profiling,log_step_channel = - match - called_from - with - | Remanent_parameters_sig.Server -> - true, +module Cflow_handler : Cflow_handler = struct + type sort_algo_for_stories = Bucket | Fusion + + type compression_mode = { + causal_trace: bool; + weak_compression: bool; + strong_compression: bool; + } + + let get_causal_trace x = x.causal_trace + let get_causal_trace_only x = not (x.weak_compression || x.strong_compression) + let get_weak_compression x = x.weak_compression + let get_strong_compression x = x.strong_compression + + type parameter = { + cache_size: int option; + current_compression_mode: Story_json.current_compression_mode option; + compression_mode: compression_mode; + priorities_weak: Priority.priorities; + priorities_strong: Priority.priorities; + priorities_causal: Priority.priorities; + compute_all_stories: bool; + sort_algo_for_stories: sort_algo_for_stories; + logger_err: Loggers.t; + logger_profiling: Loggers.t; + logger_out: Loggers.t; + logger_server: Loggers.t; + json_buffer: + StoryProfiling.StoryStats.log_info Story_json.message Fifo.t ref option; + log_step: bool; + debug_mode: bool; + logger_step: Loggers.t; + kasa: Remanent_parameters_sig.parameters; + always_disambiguate_initial_states: bool; + bound_on_itteration_number: int option; + time_independent: bool; + blacklist_events: bool; + server: bool; + is_server_channel_on: bool; + dump: string -> unit; + } + + let get_current_compression_mode parameter = + parameter.current_compression_mode + + let build_parameter ~called_from + ?(send_message = + fun x -> + Loggers.fprintf Loggers.dummy_txt_logger "%s" x; + Loggers.print_newline Loggers.dummy_txt_logger) ~none ~weak ~strong () + = + let ( server, + out_server, + out_channel, + out_channel_err, + out_channel_profiling, + log_step_channel ) = + match called_from with + | Remanent_parameters_sig.Server -> + ( true, Loggers.open_logger_from_channel ~mode:Loggers.Json stdout, Loggers.open_infinite_buffer ~mode:Loggers.HTML (), Loggers.open_infinite_buffer ~mode:Loggers.HTML (), Loggers.open_circular_buffer ~mode:Loggers.HTML (), - Loggers.open_circular_buffer ~mode:Loggers.HTML_Tabular () - | Remanent_parameters_sig.KaSa - | Remanent_parameters_sig.KaSim - | Remanent_parameters_sig.Internalised -> - let channel = Kappa_files.open_branch_and_cut_engine_profiling () in - false, + Loggers.open_circular_buffer ~mode:Loggers.HTML_Tabular () ) + | Remanent_parameters_sig.KaSa | Remanent_parameters_sig.KaSim + | Remanent_parameters_sig.Internalised -> + let channel = Kappa_files.open_branch_and_cut_engine_profiling () in + ( false, Loggers.dummy_txt_logger, Loggers.open_logger_from_formatter Format.err_formatter, Loggers.open_logger_from_formatter Format.err_formatter, - Loggers.open_logger_from_formatter (Format.formatter_of_out_channel channel), - Loggers.open_logger_from_formatter Format.std_formatter - in - { - server = server ; - is_server_channel_on = server ; - current_compression_mode = None ; - priorities_weak = Priority.weak ; - priorities_strong = Priority.strong ; - priorities_causal = Priority.causal ; - compute_all_stories = false ; - sort_algo_for_stories = Bucket; - logger_server = out_server ; - logger_out = out_channel ; - logger_err = out_channel_err ; - logger_profiling = out_channel_profiling ; - json_buffer = None ; - compression_mode = { + Loggers.open_logger_from_formatter + (Format.formatter_of_out_channel channel), + Loggers.open_logger_from_formatter Format.std_formatter ) + in + { + server; + is_server_channel_on = server; + current_compression_mode = None; + priorities_weak = Priority.weak; + priorities_strong = Priority.strong; + priorities_causal = Priority.causal; + compute_all_stories = false; + sort_algo_for_stories = Bucket; + logger_server = out_server; + logger_out = out_channel; + logger_err = out_channel_err; + logger_profiling = out_channel_profiling; + json_buffer = None; + compression_mode = + { causal_trace = none; weak_compression = weak; strong_compression = strong; }; - cache_size = Parameter.get_cache_size () ; - debug_mode = false ; - log_step = true ; - logger_step = log_step_channel ; - kasa = Remanent_parameters.get_parameters ~called_from () ; - always_disambiguate_initial_states = true ; - bound_on_itteration_number = None ; - time_independent = !Parameter.time_independent ; - blacklist_events = !Parameter.blacklist_events ; - dump = send_message ; - } - - let set_compression_weak p = - {p with current_compression_mode = Some Story_json.Weak} - let set_compression_strong p = - {p with current_compression_mode = Some Story_json.Strong} - let set_compression_none p = - {p with current_compression_mode = Some Story_json.Causal} - - - - type handler = - { - env: Model.t ; - rule_name_cache: string array; - agent_name_cache: string array; - steps_by_column: (int * Predicate_maps.predicate_value * bool) list Predicate_maps.QPredicateMap.t ; - } - - type 'a zeroary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'a - type ('a,'b) unary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'b - type ('a,'b,'c) binary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'c - type ('a,'b,'c,'d) ternary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> 'c -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'd - type ('a,'b,'c,'d,'e) quaternary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> 'c -> 'd -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'e - - let init_handler env = - let n_rules = Model.nb_rules env in - let rule_name_cache = Array.make n_rules "" in - let () = - Model.fold_rules - (fun x () r -> - rule_name_cache.(x) <- - Format.asprintf "%a" - (Model.print_ast_rule ~noCounters:false ~env:env) - r.Primitives.syntactic_rule) () env in - let n_agents = Signature.size (Model.signatures env) in - let agent_name_cache = Array.init n_agents - (fun x -> Format.asprintf "%a" (Model.print_agent ~env:env) x) in - let steps_by_column = Predicate_maps.QPredicateMap.empty 0 in - {env = env; - rule_name_cache=rule_name_cache; - agent_name_cache=agent_name_cache; - steps_by_column=steps_by_column - } - - let string_of_exn _x = Some "" - - let get_priorities parameter = - match parameter.current_compression_mode with - | None -> None - | Some Story_json.Weak -> Some parameter.priorities_weak - | Some Story_json.Strong -> Some parameter.priorities_strong - | Some Story_json.Causal -> Some parameter.priorities_causal - - let set_first_story_per_obs parameter = - { - parameter - with compute_all_stories = false } - - let set_all_stories_per_obs parameter = - { parameter with compute_all_stories = true } - - let get_all_stories_per_obs parameter = parameter.compute_all_stories - - let get_debugging_mode parameter = parameter.debug_mode - let set_debugging_mode parameter bool= {parameter with debug_mode = bool } - - let get_log_step parameter = parameter.log_step - let set_log_step parameter bool = {parameter with log_step = bool} - - let get_logger parameter = parameter.logger_step - let set_logger parameter fmt = {parameter with logger_step = fmt} - let get_out_channel parameter = parameter.logger_out - let set_out_channel parameter fmt = {parameter with logger_out = fmt} - let get_debugging_channel parameter = parameter.logger_err - let set_debugging_channel parameter fmt = {parameter with logger_err = fmt } - - let get_kasa_parameters parameter = parameter.kasa - let set_kasa_parameters parameter parameter' = {parameter' with kasa = parameter} - - let do_we_use_bucket_sort parameter = parameter.sort_algo_for_stories = Bucket - let use_bucket_sort parameter = {parameter with sort_algo_for_stories = Bucket} - let use_fusion_sort parameter = {parameter with sort_algo_for_stories = Fusion} - - let always_disambiguate parameter = parameter.always_disambiguate_initial_states - let set_always_disambiguate parameter bool = { parameter with always_disambiguate_initial_states = bool} - let do_not_bound_itterations parameter = {parameter with bound_on_itteration_number = None} - let set_itteration_bound parameter int = {parameter with bound_on_itteration_number = Some int} - let get_bound_on_itteration_number parameter = parameter.bound_on_itteration_number - let get_profiling_logger parameter = parameter.logger_profiling - let string_of_rule_id handler i = handler.rule_name_cache.(i) - let string_of_agent_id handler i = handler.agent_name_cache.(i) - - let get_predicate_map handler = handler.steps_by_column - let get_is_time_independent parameter = parameter.time_independent - let get_blacklist_events parameter = parameter.blacklist_events - - let is_server_mode parameter = parameter.server - let get_server_channel parameter = parameter.logger_server - let shut_down_server_channel parameter = - {parameter with - logger_server= Loggers.dummy_txt_logger; - is_server_channel_on = false} - let is_server_channel_on parameter = parameter.is_server_channel_on - let save_current_phase_title parameter x = - parameter.kasa.Remanent_parameters_sig.save_current_phase_title x - - let dump_json parameter message = - if - is_server_mode parameter - then - parameter.dump - (Yojson.Basic.to_string (Story_json.message_to_json message)) - - let save_progress_bar parameter x = - let (b,i,_j,n_stories) = x in - let () = - dump_json parameter - (Story_json.Progress - { Story_json.bool = (if b then "true" else "false"); - Story_json.current = i; - Story_json.total = n_stories }) - in - parameter.kasa.Remanent_parameters_sig.save_progress_bar x - let reset_progress_bar parameter = parameter.kasa.Remanent_parameters_sig.reset_progress_bar () - let reset_current_phase_title parameter = parameter.kasa.Remanent_parameters_sig.reset_current_phase_title () - let set_save_current_phase_title parameter f = - {parameter - with kasa = - {parameter.kasa - with Remanent_parameters_sig.save_current_phase_title = f}} - let set_reset_current_phase_title parameter f = - {parameter - with kasa = - {parameter.kasa - with Remanent_parameters_sig.reset_current_phase_title = f}} - let set_save_progress_bar parameter f = - {parameter - with kasa = {parameter.kasa - with Remanent_parameters_sig.save_progress_bar = f}} - let set_reset_progress_bar parameter f = - {parameter - with kasa = {parameter.kasa - with Remanent_parameters_sig.reset_progress_bar = f}} - let save_error_log parameter x = parameter.kasa.Remanent_parameters_sig.save_error_list x - let set_save_error_log parameter f = - {parameter - with kasa = - {parameter.kasa - with Remanent_parameters_sig.save_error_list = f}} - - let push_json parameter json = - match - parameter.json_buffer - with - | None -> dump_json parameter json - | Some ref -> ref := Fifo.push json !ref - - let pop_json parameter = - match - parameter.json_buffer - with - | None -> None - | Some ref -> - let fifo, elt_opt = Fifo.pop !ref in - let () = ref := fifo in - elt_opt - - end:Cflow_handler) + cache_size = Parameter.get_cache_size (); + debug_mode = false; + log_step = true; + logger_step = log_step_channel; + kasa = Remanent_parameters.get_parameters ~called_from (); + always_disambiguate_initial_states = true; + bound_on_itteration_number = None; + time_independent = !Parameter.time_independent; + blacklist_events = !Parameter.blacklist_events; + dump = send_message; + } + + let set_compression_weak p = + { p with current_compression_mode = Some Story_json.Weak } + + let set_compression_strong p = + { p with current_compression_mode = Some Story_json.Strong } + + let set_compression_none p = + { p with current_compression_mode = Some Story_json.Causal } + + type handler = { + env: Model.t; + rule_name_cache: string array; + agent_name_cache: string array; + steps_by_column: + (int * Predicate_maps.predicate_value * bool) list + Predicate_maps.QPredicateMap.t; + } + + type 'a zeroary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'a + + type ('a, 'b) unary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'b + + type ('a, 'b, 'c) binary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'c + + type ('a, 'b, 'c, 'd) ternary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'd + + type ('a, 'b, 'c, 'd, 'e) quaternary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + 'd -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'e + + let init_handler env = + let n_rules = Model.nb_rules env in + let rule_name_cache = Array.make n_rules "" in + let () = + Model.fold_rules + (fun x () r -> + rule_name_cache.(x) <- + Format.asprintf "%a" + (Model.print_ast_rule ~noCounters:false ~env) + r.Primitives.syntactic_rule) + () env + in + let n_agents = Signature.size (Model.signatures env) in + let agent_name_cache = + Array.init n_agents (fun x -> + Format.asprintf "%a" (Model.print_agent ~env) x) + in + let steps_by_column = Predicate_maps.QPredicateMap.empty 0 in + { env; rule_name_cache; agent_name_cache; steps_by_column } + + let string_of_exn _x = Some "" + + let get_priorities parameter = + match parameter.current_compression_mode with + | None -> None + | Some Story_json.Weak -> Some parameter.priorities_weak + | Some Story_json.Strong -> Some parameter.priorities_strong + | Some Story_json.Causal -> Some parameter.priorities_causal + + let set_first_story_per_obs parameter = + { parameter with compute_all_stories = false } + + let set_all_stories_per_obs parameter = + { parameter with compute_all_stories = true } + + let get_all_stories_per_obs parameter = parameter.compute_all_stories + let get_debugging_mode parameter = parameter.debug_mode + let set_debugging_mode parameter bool = { parameter with debug_mode = bool } + let get_log_step parameter = parameter.log_step + let set_log_step parameter bool = { parameter with log_step = bool } + let get_logger parameter = parameter.logger_step + let set_logger parameter fmt = { parameter with logger_step = fmt } + let get_out_channel parameter = parameter.logger_out + let set_out_channel parameter fmt = { parameter with logger_out = fmt } + let get_debugging_channel parameter = parameter.logger_err + let set_debugging_channel parameter fmt = { parameter with logger_err = fmt } + let get_kasa_parameters parameter = parameter.kasa + + let set_kasa_parameters parameter parameter' = + { parameter' with kasa = parameter } + + let do_we_use_bucket_sort parameter = parameter.sort_algo_for_stories = Bucket + + let use_bucket_sort parameter = + { parameter with sort_algo_for_stories = Bucket } + + let use_fusion_sort parameter = + { parameter with sort_algo_for_stories = Fusion } + + let always_disambiguate parameter = + parameter.always_disambiguate_initial_states + + let set_always_disambiguate parameter bool = + { parameter with always_disambiguate_initial_states = bool } + + let do_not_bound_itterations parameter = + { parameter with bound_on_itteration_number = None } + + let set_itteration_bound parameter int = + { parameter with bound_on_itteration_number = Some int } + + let get_bound_on_itteration_number parameter = + parameter.bound_on_itteration_number + + let get_profiling_logger parameter = parameter.logger_profiling + let string_of_rule_id handler i = handler.rule_name_cache.(i) + let string_of_agent_id handler i = handler.agent_name_cache.(i) + let get_predicate_map handler = handler.steps_by_column + let get_is_time_independent parameter = parameter.time_independent + let get_blacklist_events parameter = parameter.blacklist_events + let is_server_mode parameter = parameter.server + let get_server_channel parameter = parameter.logger_server + + let shut_down_server_channel parameter = + { + parameter with + logger_server = Loggers.dummy_txt_logger; + is_server_channel_on = false; + } + + let is_server_channel_on parameter = parameter.is_server_channel_on + + let save_current_phase_title parameter x = + parameter.kasa.Remanent_parameters_sig.save_current_phase_title x + + let dump_json parameter message = + if is_server_mode parameter then + parameter.dump + (Yojson.Basic.to_string (Story_json.message_to_json message)) + + let save_progress_bar parameter x = + let b, i, _j, n_stories = x in + let () = + dump_json parameter + (Story_json.Progress + { + Story_json.bool = + (if b then + "true" + else + "false"); + Story_json.current = i; + Story_json.total = n_stories; + }) + in + parameter.kasa.Remanent_parameters_sig.save_progress_bar x + + let reset_progress_bar parameter = + parameter.kasa.Remanent_parameters_sig.reset_progress_bar () + + let reset_current_phase_title parameter = + parameter.kasa.Remanent_parameters_sig.reset_current_phase_title () + + let set_save_current_phase_title parameter f = + { + parameter with + kasa = + { + parameter.kasa with + Remanent_parameters_sig.save_current_phase_title = f; + }; + } + + let set_reset_current_phase_title parameter f = + { + parameter with + kasa = + { + parameter.kasa with + Remanent_parameters_sig.reset_current_phase_title = f; + }; + } + + let set_save_progress_bar parameter f = + { + parameter with + kasa = + { parameter.kasa with Remanent_parameters_sig.save_progress_bar = f }; + } + + let set_reset_progress_bar parameter f = + { + parameter with + kasa = + { parameter.kasa with Remanent_parameters_sig.reset_progress_bar = f }; + } + + let save_error_log parameter x = + parameter.kasa.Remanent_parameters_sig.save_error_list x + + let set_save_error_log parameter f = + { + parameter with + kasa = { parameter.kasa with Remanent_parameters_sig.save_error_list = f }; + } + + let push_json parameter json = + match parameter.json_buffer with + | None -> dump_json parameter json + | Some ref -> ref := Fifo.push json !ref + + let pop_json parameter = + match parameter.json_buffer with + | None -> None + | Some ref -> + let fifo, elt_opt = Fifo.pop !ref in + let () = ref := fifo in + elt_opt +end diff --git a/core/cflow/cflow_handler.mli b/core/cflow/cflow_handler.mli index a1cc7e9af5..5869d29215 100644 --- a/core/cflow/cflow_handler.mli +++ b/core/cflow/cflow_handler.mli @@ -1,118 +1,182 @@ -module type Cflow_handler = - sig - type sort_algo_for_stories - type compression_mode - - val get_causal_trace : compression_mode -> bool - val get_causal_trace_only : compression_mode -> bool - val get_weak_compression : compression_mode -> bool - val get_strong_compression : compression_mode -> bool - - (** a struct which contains parameterizable options *) - type parameter = - { - cache_size : int option ; - current_compression_mode: Story_json.current_compression_mode option; - compression_mode : compression_mode ; - priorities_weak: Priority.priorities ; - priorities_strong : Priority.priorities ; - priorities_causal : Priority.priorities ; - compute_all_stories : bool ; - sort_algo_for_stories: sort_algo_for_stories; - logger_err : Loggers.t ; - logger_profiling : Loggers.t ; - logger_out : Loggers.t ; - logger_server : Loggers.t ; - json_buffer: - StoryProfiling.StoryStats.log_info Story_json.message Fifo.t ref option ; - log_step : bool ; - debug_mode : bool ; - logger_step: Loggers.t ; - kasa: Remanent_parameters_sig.parameters ; - always_disambiguate_initial_states : bool ; - bound_on_itteration_number: int option ; - time_independent: bool ; - blacklist_events: bool ; - server: bool ; - is_server_channel_on: bool ; - dump: string -> unit; - } - - val get_current_compression_mode : parameter -> Story_json.current_compression_mode option - - type handler = (*handler to interpret abstract values*) - { - env: Model.t ; - rule_name_cache: string array; - agent_name_cache: string array; - steps_by_column: (int * Predicate_maps.predicate_value * bool) list Predicate_maps.QPredicateMap.t ; - } - - type 'a zeroary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'a - type ('a,'b) unary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'b - type ('a,'b,'c) binary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'c - type ('a,'b,'c,'d) ternary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> 'c -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'd - type ('a,'b,'c,'d,'e) quaternary = parameter -> handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> 'a -> 'b -> 'c -> 'd -> Exception.method_handler * StoryProfiling.StoryStats.log_info * 'e - val do_not_bound_itterations: parameter -> parameter - val set_itteration_bound: parameter -> int -> parameter - val get_bound_on_itteration_number: parameter -> int option - val set_first_story_per_obs: parameter -> parameter - val set_all_stories_per_obs: parameter -> parameter - val build_parameter: called_from:Remanent_parameters_sig.called_from -> - ?send_message:(string -> unit) -> none:bool -> weak:bool -> strong:bool -> - unit -> parameter - val string_of_exn: exn -> string option - val is_server_mode: parameter -> bool - val set_compression_weak: parameter -> parameter - val set_compression_strong: parameter -> parameter - val set_compression_none: parameter -> parameter - val get_priorities: parameter -> Priority.priorities option - val get_all_stories_per_obs: parameter -> bool - val set_log_step: parameter -> bool -> parameter - val get_log_step: parameter -> bool - val set_debugging_mode: parameter -> bool -> parameter - val get_debugging_mode: parameter -> bool - val get_profiling_logger: parameter -> Loggers.t - val get_server_channel: parameter -> Loggers.t - val shut_down_server_channel: parameter -> parameter - val is_server_channel_on: parameter -> bool - - val get_logger: parameter -> Loggers.t - val set_logger: parameter -> Loggers.t -> parameter - val get_out_channel: parameter -> Loggers.t - val set_out_channel: parameter -> Loggers.t -> parameter - val get_debugging_channel: parameter -> Loggers.t - val set_debugging_channel: parameter -> Loggers.t-> parameter - val get_kasa_parameters: parameter -> Remanent_parameters_sig.parameters - val set_kasa_parameters: Remanent_parameters_sig.parameters -> parameter -> parameter - val do_we_use_bucket_sort: parameter -> bool - val use_bucket_sort: parameter -> parameter - val use_fusion_sort: parameter -> parameter - val always_disambiguate: parameter -> bool - val set_always_disambiguate: parameter -> bool -> parameter - val init_handler: Model.t -> handler - val string_of_rule_id: handler -> int -> string - val string_of_agent_id: handler -> int -> string - val get_predicate_map: handler -> (int * Predicate_maps.predicate_value * bool) list Predicate_maps.QPredicateMap.t - val get_is_time_independent: parameter -> bool - val get_blacklist_events: parameter -> bool - val save_current_phase_title: parameter -> string -> unit - val reset_current_phase_title: parameter -> unit - val save_progress_bar: parameter -> bool * int * int * int -> unit - val reset_progress_bar: parameter -> unit - val set_save_current_phase_title: parameter -> (string -> unit) -> parameter - val set_reset_current_phase_title: parameter -> (unit -> unit) -> parameter - val set_save_progress_bar: parameter -> (bool * int * int * int -> unit) -> parameter - val set_reset_progress_bar: parameter -> (unit -> unit) -> parameter - val save_error_log: parameter -> Exception_without_parameter.method_handler -> unit - val set_save_error_log: parameter -> (Exception_without_parameter.method_handler -> unit) -> parameter - (* val dump_json: parameter -> Yojson.Basic.t -> unit*) - - val push_json: - parameter -> StoryProfiling.StoryStats.log_info Story_json.message -> unit - val pop_json: - parameter -> StoryProfiling.StoryStats.log_info Story_json.message option - - end - -module Cflow_handler:Cflow_handler +module type Cflow_handler = sig + type sort_algo_for_stories + type compression_mode + + val get_causal_trace : compression_mode -> bool + val get_causal_trace_only : compression_mode -> bool + val get_weak_compression : compression_mode -> bool + val get_strong_compression : compression_mode -> bool + + type parameter = { + cache_size: int option; + current_compression_mode: Story_json.current_compression_mode option; + compression_mode: compression_mode; + priorities_weak: Priority.priorities; + priorities_strong: Priority.priorities; + priorities_causal: Priority.priorities; + compute_all_stories: bool; + sort_algo_for_stories: sort_algo_for_stories; + logger_err: Loggers.t; + logger_profiling: Loggers.t; + logger_out: Loggers.t; + logger_server: Loggers.t; + json_buffer: + StoryProfiling.StoryStats.log_info Story_json.message Fifo.t ref option; + log_step: bool; + debug_mode: bool; + logger_step: Loggers.t; + kasa: Remanent_parameters_sig.parameters; + always_disambiguate_initial_states: bool; + bound_on_itteration_number: int option; + time_independent: bool; + blacklist_events: bool; + server: bool; + is_server_channel_on: bool; + dump: string -> unit; + } + (** a struct which contains parameterizable options *) + + val get_current_compression_mode : + parameter -> Story_json.current_compression_mode option + + type handler = { + (*handler to interpret abstract values*) + env: Model.t; + rule_name_cache: string array; + agent_name_cache: string array; + steps_by_column: + (int * Predicate_maps.predicate_value * bool) list + Predicate_maps.QPredicateMap.t; + } + + type 'a zeroary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'a + + type ('a, 'b) unary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'b + + type ('a, 'b, 'c) binary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'c + + type ('a, 'b, 'c, 'd) ternary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'd + + type ('a, 'b, 'c, 'd, 'e) quaternary = + parameter -> + handler -> + StoryProfiling.StoryStats.log_info -> + Exception.method_handler -> + 'a -> + 'b -> + 'c -> + 'd -> + Exception.method_handler * StoryProfiling.StoryStats.log_info * 'e + + val do_not_bound_itterations : parameter -> parameter + val set_itteration_bound : parameter -> int -> parameter + val get_bound_on_itteration_number : parameter -> int option + val set_first_story_per_obs : parameter -> parameter + val set_all_stories_per_obs : parameter -> parameter + + val build_parameter : + called_from:Remanent_parameters_sig.called_from -> + ?send_message:(string -> unit) -> + none:bool -> + weak:bool -> + strong:bool -> + unit -> + parameter + + val string_of_exn : exn -> string option + val is_server_mode : parameter -> bool + val set_compression_weak : parameter -> parameter + val set_compression_strong : parameter -> parameter + val set_compression_none : parameter -> parameter + val get_priorities : parameter -> Priority.priorities option + val get_all_stories_per_obs : parameter -> bool + val set_log_step : parameter -> bool -> parameter + val get_log_step : parameter -> bool + val set_debugging_mode : parameter -> bool -> parameter + val get_debugging_mode : parameter -> bool + val get_profiling_logger : parameter -> Loggers.t + val get_server_channel : parameter -> Loggers.t + val shut_down_server_channel : parameter -> parameter + val is_server_channel_on : parameter -> bool + val get_logger : parameter -> Loggers.t + val set_logger : parameter -> Loggers.t -> parameter + val get_out_channel : parameter -> Loggers.t + val set_out_channel : parameter -> Loggers.t -> parameter + val get_debugging_channel : parameter -> Loggers.t + val set_debugging_channel : parameter -> Loggers.t -> parameter + val get_kasa_parameters : parameter -> Remanent_parameters_sig.parameters + + val set_kasa_parameters : + Remanent_parameters_sig.parameters -> parameter -> parameter + + val do_we_use_bucket_sort : parameter -> bool + val use_bucket_sort : parameter -> parameter + val use_fusion_sort : parameter -> parameter + val always_disambiguate : parameter -> bool + val set_always_disambiguate : parameter -> bool -> parameter + val init_handler : Model.t -> handler + val string_of_rule_id : handler -> int -> string + val string_of_agent_id : handler -> int -> string + + val get_predicate_map : + handler -> + (int * Predicate_maps.predicate_value * bool) list + Predicate_maps.QPredicateMap.t + + val get_is_time_independent : parameter -> bool + val get_blacklist_events : parameter -> bool + val save_current_phase_title : parameter -> string -> unit + val reset_current_phase_title : parameter -> unit + val save_progress_bar : parameter -> bool * int * int * int -> unit + val reset_progress_bar : parameter -> unit + val set_save_current_phase_title : parameter -> (string -> unit) -> parameter + val set_reset_current_phase_title : parameter -> (unit -> unit) -> parameter + + val set_save_progress_bar : + parameter -> (bool * int * int * int -> unit) -> parameter + + val set_reset_progress_bar : parameter -> (unit -> unit) -> parameter + + val save_error_log : + parameter -> Exception_without_parameter.method_handler -> unit + + val set_save_error_log : + parameter -> + (Exception_without_parameter.method_handler -> unit) -> + parameter + (* val dump_json: parameter -> Yojson.Basic.t -> unit*) + + val push_json : + parameter -> StoryProfiling.StoryStats.log_info Story_json.message -> unit + + val pop_json : + parameter -> StoryProfiling.StoryStats.log_info Story_json.message option +end + +module Cflow_handler : Cflow_handler diff --git a/core/cflow/cflow_js_interface.ml b/core/cflow/cflow_js_interface.ml index 5aa247bf6d..4245dcf1d2 100644 --- a/core/cflow/cflow_js_interface.ml +++ b/core/cflow/cflow_js_interface.ml @@ -18,42 +18,41 @@ * Informatique et en Automatique. All rights reserved. This file is * distributed under the terms of the GNU Library General Public License *) -type cflow_state = - { - std_logger: Loggers.t option; - err_logger: Loggers.t option; - profiling_logger: Loggers.t option; - status_logger: Loggers.t option; - current_phase: string option; - progress_bar: (bool*int*int*int) option; - causal_flows: Utilities.story_table option; - trivial_compression: Utilities.story_table option; - weak_compression: Utilities.story_table option; - strong_compression: Utilities.story_table option; - error_list: Utilities.error_log option; - } +type cflow_state = { + std_logger: Loggers.t option; + err_logger: Loggers.t option; + profiling_logger: Loggers.t option; + status_logger: Loggers.t option; + current_phase: string option; + progress_bar: (bool * int * int * int) option; + causal_flows: Utilities.story_table option; + trivial_compression: Utilities.story_table option; + weak_compression: Utilities.story_table option; + strong_compression: Utilities.story_table option; + error_list: Utilities.error_log option; +} let init () = - ref { - std_logger = None ; - err_logger = None ; - profiling_logger = None; - status_logger = None ; - current_phase = None; - progress_bar = None; - causal_flows = None; - trivial_compression = None; - weak_compression = None; - strong_compression = None; - error_list = None; - } - + ref + { + std_logger = None; + err_logger = None; + profiling_logger = None; + status_logger = None; + current_phase = None; + progress_bar = None; + causal_flows = None; + trivial_compression = None; + weak_compression = None; + strong_compression = None; + error_list = None; + } let get_std_buffer cflow_state = cflow_state.std_logger let get_err_buffer cflow_state = cflow_state.err_logger let get_profiling_buffer cflow_state = cflow_state.profiling_logger let get_branch_and_cut_status cflow_state = cflow_state.status_logger -let get_progress_bar cflow_state = cflow_state.progress_bar +let get_progress_bar cflow_state = cflow_state.progress_bar let get_current_phase_title cflow_state = cflow_state.current_phase let get_causal_flow_table cflow_state = cflow_state.causal_flows let get_trivial_compression_table cflow_state = cflow_state.trivial_compression @@ -62,38 +61,51 @@ let get_strong_compression_table cflow_state = cflow_state.strong_compression let get_error_list cflow_state = cflow_state.error_list let save_current_phase_title_aux cflow_state_ptr string = - {(!cflow_state_ptr) with current_phase = Some string} + { !cflow_state_ptr with current_phase = Some string } + let reset_current_phase_title_aux cflow_state_ptr = - {(!cflow_state_ptr) with current_phase = None } + { !cflow_state_ptr with current_phase = None } + let save_progress_bar_aux cflow_state_ptr bar = - {(!cflow_state_ptr) with progress_bar = Some bar } + { !cflow_state_ptr with progress_bar = Some bar } + let reset_progress_bar_aux cflow_state_ptr = - {(!cflow_state_ptr) with progress_bar = None } + { !cflow_state_ptr with progress_bar = None } + let save_causal_flow_table_aux cflow_state_ptr table = - {(!cflow_state_ptr) with causal_flows = Some table} + { !cflow_state_ptr with causal_flows = Some table } + let save_trivial_compression_table_aux cflow_state_ptr table = - {(!cflow_state_ptr) with trivial_compression = Some table} + { !cflow_state_ptr with trivial_compression = Some table } + let save_weak_compression_table_aux cflow_state_ptr table = - {(!cflow_state_ptr) with weak_compression = Some table} + { !cflow_state_ptr with weak_compression = Some table } + let save_strong_compression_table_aux cflow_state_ptr table = - {(!cflow_state_ptr) with strong_compression = Some table} + { !cflow_state_ptr with strong_compression = Some table } + let save_error_log_aux cflow_state_ptr error = - {(!cflow_state_ptr) with error_list = Some error} + { !cflow_state_ptr with error_list = Some error } + let redirect_std_buffer_aux cflow_state_ptr loggers = - {(!cflow_state_ptr) with std_logger = loggers} + { !cflow_state_ptr with std_logger = loggers } + let redirect_err_buffer_aux cflow_state_ptr loggers = - {(!cflow_state_ptr) with err_logger = loggers} + { !cflow_state_ptr with err_logger = loggers } + let redirect_profiling_buffer_aux cflow_state_ptr loggers = - {(!cflow_state_ptr) with profiling_logger = loggers} + { !cflow_state_ptr with profiling_logger = loggers } + let redirect_branch_and_cut_buffer_aux cflow_state_ptr loggers = - {(!cflow_state_ptr) with status_logger = loggers} + { !cflow_state_ptr with status_logger = loggers } let lift f cflow_state_ptr_opt data = match cflow_state_ptr_opt with | None -> () | Some cflow_state_ptr -> cflow_state_ptr := f cflow_state_ptr data -let lift_reset f cflow_state_ptr_opt = lift (fun x () -> f x) cflow_state_ptr_opt () +let lift_reset f cflow_state_ptr_opt = + lift (fun x () -> f x) cflow_state_ptr_opt () let save_current_phase_title = lift save_current_phase_title_aux let reset_current_phase_title = lift_reset reset_current_phase_title_aux diff --git a/core/cflow/cflow_js_interface.mli b/core/cflow/cflow_js_interface.mli index c8eb8e51ac..75a6a25ad4 100644 --- a/core/cflow/cflow_js_interface.mli +++ b/core/cflow/cflow_js_interface.mli @@ -20,31 +20,41 @@ type cflow_state -val init: unit -> cflow_state ref - -val get_std_buffer: cflow_state -> Loggers.t option -val get_err_buffer: cflow_state -> Loggers.t option -val get_profiling_buffer: cflow_state -> Loggers.t option -val get_branch_and_cut_status: cflow_state -> Loggers.t option -val get_progress_bar: cflow_state -> (bool*int*int*int) option -val get_current_phase_title: cflow_state -> string option -val get_causal_flow_table: cflow_state -> Utilities.story_table option -val get_trivial_compression_table: cflow_state -> Utilities.story_table option -val get_weak_compression_table: cflow_state -> Utilities.story_table option -val get_strong_compression_table: cflow_state -> Utilities.story_table option -val get_error_list: cflow_state -> Utilities.error_log option - -val save_current_phase_title: cflow_state ref option -> string -> unit -val reset_current_phase_title: cflow_state ref option -> unit -val save_progress_bar: cflow_state ref option -> bool * int * int * int -> unit -val reset_progress_bar: cflow_state ref option -> unit -val save_causal_flow_table: cflow_state ref option -> Utilities.story_table -> unit -val save_trivial_compression_table: cflow_state ref option -> Utilities.story_table -> unit -val save_weak_compression_table: cflow_state ref option -> Utilities.story_table -> unit -val save_strong_compression_table: cflow_state ref option -> Utilities.story_table -> unit -val save_error_list: cflow_state ref option -> Utilities.error_log -> unit - -val redirect_std_buffer: cflow_state ref option -> Loggers.t option -> unit -val redirect_err_buffer: cflow_state ref option -> Loggers.t option -> unit -val redirect_profiling_buffer: cflow_state ref option -> Loggers.t option -> unit -val redirect_branch_and_cut_buffer: cflow_state ref option -> Loggers.t option -> unit +val init : unit -> cflow_state ref +val get_std_buffer : cflow_state -> Loggers.t option +val get_err_buffer : cflow_state -> Loggers.t option +val get_profiling_buffer : cflow_state -> Loggers.t option +val get_branch_and_cut_status : cflow_state -> Loggers.t option +val get_progress_bar : cflow_state -> (bool * int * int * int) option +val get_current_phase_title : cflow_state -> string option +val get_causal_flow_table : cflow_state -> Utilities.story_table option +val get_trivial_compression_table : cflow_state -> Utilities.story_table option +val get_weak_compression_table : cflow_state -> Utilities.story_table option +val get_strong_compression_table : cflow_state -> Utilities.story_table option +val get_error_list : cflow_state -> Utilities.error_log option +val save_current_phase_title : cflow_state ref option -> string -> unit +val reset_current_phase_title : cflow_state ref option -> unit +val save_progress_bar : cflow_state ref option -> bool * int * int * int -> unit +val reset_progress_bar : cflow_state ref option -> unit + +val save_causal_flow_table : + cflow_state ref option -> Utilities.story_table -> unit + +val save_trivial_compression_table : + cflow_state ref option -> Utilities.story_table -> unit + +val save_weak_compression_table : + cflow_state ref option -> Utilities.story_table -> unit + +val save_strong_compression_table : + cflow_state ref option -> Utilities.story_table -> unit + +val save_error_list : cflow_state ref option -> Utilities.error_log -> unit +val redirect_std_buffer : cflow_state ref option -> Loggers.t option -> unit +val redirect_err_buffer : cflow_state ref option -> Loggers.t option -> unit + +val redirect_profiling_buffer : + cflow_state ref option -> Loggers.t option -> unit + +val redirect_branch_and_cut_buffer : + cflow_state ref option -> Loggers.t option -> unit diff --git a/core/cflow/compression_main.ml b/core/cflow/compression_main.ml index b086815ec4..1a031f252c 100644 --- a/core/cflow/compression_main.ml +++ b/core/cflow/compression_main.ml @@ -22,48 +22,45 @@ module U = Utilities module S = U.S type secret_log_info = StoryProfiling.StoryStats.log_info + let init_secret_log_info = StoryProfiling.StoryStats.init_log_info type secret_parameter = S.PH.B.PB.CI.Po.K.H.parameter let build_parameter = S.PH.B.PB.CI.Po.K.H.build_parameter let get_logger = S.PH.B.PB.CI.Po.K.H.get_logger - let log_step = true let debug_mode = false let dump_profiling_info = true - let _ = dump_profiling_info - let bucket_sort = true -let get_all_stories = false (** false -> only the first story per observable hit; true -> all stories per obs hit *) -let max_number_of_itterations = None +(** false -> only the first story per observable hit; true -> all stories per obs hit *) +let get_all_stories = false -let we_shall_not = (fun _ -> false) -let we_shall = (fun _ -> true) -let do_not_log parameter = (S.PH.B.PB.CI.Po.K.H.set_log_step parameter false) +let max_number_of_itterations = None +let we_shall_not _ = false +let we_shall _ = true +let do_not_log parameter = S.PH.B.PB.CI.Po.K.H.set_log_step parameter false -let compress_and_print - parameter ~dotFormat ?js_interface env log_info step_list = +let compress_and_print parameter ~dotFormat ?js_interface env log_info step_list + = (*let called_from = Remanent_parameters_sig.Server in*) let parameter = S.PH.B.PB.CI.Po.K.H.set_log_step parameter log_step in let parameter = S.PH.B.PB.CI.Po.K.H.set_debugging_mode parameter debug_mode in let parameter = - match - max_number_of_itterations - with + match max_number_of_itterations with | None -> S.PH.B.PB.CI.Po.K.H.do_not_bound_itterations parameter | Some i -> S.PH.B.PB.CI.Po.K.H.set_itteration_bound parameter i in let parameter = - if get_all_stories - then S.PH.B.PB.CI.Po.K.H.set_all_stories_per_obs parameter - else parameter + if get_all_stories then + S.PH.B.PB.CI.Po.K.H.set_all_stories_per_obs parameter + else + parameter in let parameter = - if bucket_sort - then + if bucket_sort then S.PH.B.PB.CI.Po.K.H.use_bucket_sort parameter else S.PH.B.PB.CI.Po.K.H.use_fusion_sort parameter @@ -76,575 +73,685 @@ let compress_and_print let handler = S.PH.B.PB.CI.Po.K.H.init_handler env in let () = S.PH.B.PB.CI.Po.K.H.push_json parameter - (Story_json.Phase (Story_json.Start,"Starting Compression")) in - let error,log_info,table1 = U.create_story_table parameter handler log_info error in - let error,log_info,table2 = U.create_story_table parameter handler log_info error in - let error,log_info,table3 = U.create_story_table parameter handler log_info error in - let error,log_info,table4 = U.create_story_table parameter handler log_info error in + (Story_json.Phase (Story_json.Start, "Starting Compression")) + in + let error, log_info, table1 = + U.create_story_table parameter handler log_info error + in + let error, log_info, table2 = + U.create_story_table parameter handler log_info error + in + let error, log_info, table3 = + U.create_story_table parameter handler log_info error + in + let error, log_info, table4 = + U.create_story_table parameter handler log_info error + in let () = Cflow_js_interface.save_causal_flow_table js_interface table1 in - let () = Cflow_js_interface.save_trivial_compression_table js_interface table2 in + let () = + Cflow_js_interface.save_trivial_compression_table js_interface table2 + in let () = Cflow_js_interface.save_weak_compression_table js_interface table3 in - let () = Cflow_js_interface.save_strong_compression_table js_interface table4 in - let () = Cflow_js_interface.redirect_std_buffer js_interface (Some (S.PH.B.PB.CI.Po.K.H.get_logger parameter)) in - let () = Cflow_js_interface.redirect_err_buffer js_interface (Some (S.PH.B.PB.CI.Po.K.H.get_debugging_channel parameter)) in - let () = Cflow_js_interface.redirect_profiling_buffer js_interface (Some (S.PH.B.PB.CI.Po.K.H.get_profiling_logger parameter)) in - let () = Cflow_js_interface.redirect_branch_and_cut_buffer js_interface (Some (Remanent_parameters.get_compression_status_logger (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter))) in + let () = + Cflow_js_interface.save_strong_compression_table js_interface table4 + in + let () = + Cflow_js_interface.redirect_std_buffer js_interface + (Some (S.PH.B.PB.CI.Po.K.H.get_logger parameter)) + in + let () = + Cflow_js_interface.redirect_err_buffer js_interface + (Some (S.PH.B.PB.CI.Po.K.H.get_debugging_channel parameter)) + in + let () = + Cflow_js_interface.redirect_profiling_buffer js_interface + (Some (S.PH.B.PB.CI.Po.K.H.get_profiling_logger parameter)) + in + let () = + Cflow_js_interface.redirect_branch_and_cut_buffer js_interface + (Some + (Remanent_parameters.get_compression_status_logger + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter))) + in let parameter = - match - js_interface - with + match js_interface with | None -> parameter | Some _js_interface_ptr -> - begin - let parameter = S.PH.B.PB.CI.Po.K.H.set_save_current_phase_title parameter (fun s -> Cflow_js_interface.save_current_phase_title js_interface s) in - let parameter = S.PH.B.PB.CI.Po.K.H.set_reset_current_phase_title parameter (fun () -> Cflow_js_interface.reset_current_phase_title js_interface) in - let parameter = S.PH.B.PB.CI.Po.K.H.set_save_progress_bar parameter (Cflow_js_interface.save_progress_bar js_interface) in - let parameter = S.PH.B.PB.CI.Po.K.H.set_reset_progress_bar parameter (fun () -> Cflow_js_interface.reset_progress_bar js_interface) in - let parameter = S.PH.B.PB.CI.Po.K.H.set_save_error_log parameter (fun error -> Cflow_js_interface.save_error_list js_interface error) in - parameter - end + let parameter = + S.PH.B.PB.CI.Po.K.H.set_save_current_phase_title parameter (fun s -> + Cflow_js_interface.save_current_phase_title js_interface s) + in + let parameter = + S.PH.B.PB.CI.Po.K.H.set_reset_current_phase_title parameter (fun () -> + Cflow_js_interface.reset_current_phase_title js_interface) + in + let parameter = + S.PH.B.PB.CI.Po.K.H.set_save_progress_bar parameter + (Cflow_js_interface.save_progress_bar js_interface) + in + let parameter = + S.PH.B.PB.CI.Po.K.H.set_reset_progress_bar parameter (fun () -> + Cflow_js_interface.reset_progress_bar js_interface) + in + let parameter = + S.PH.B.PB.CI.Po.K.H.set_save_error_log parameter (fun error -> + Cflow_js_interface.save_error_list js_interface error) + in + parameter in let parameter = S.PH.B.PB.CI.Po.K.H.set_compression_none parameter in let parameter_causal = - if causal_trace_on - then parameter + if causal_trace_on then + parameter else S.PH.B.PB.CI.Po.K.H.shut_down_server_channel parameter in let parameter_weak = - if weak_compression_on - then parameter + if weak_compression_on then + parameter else S.PH.B.PB.CI.Po.K.H.shut_down_server_channel parameter in let parameter_strong = - if strong_compression_on - then parameter + if strong_compression_on then + parameter else S.PH.B.PB.CI.Po.K.H.shut_down_server_channel parameter in - let empty_compression = error, log_info, table1,table2,table3,table4 in + let empty_compression = error, log_info, table1, table2, table3, table4 in let step_list = U.trace_of_pretrace step_list in - let error, log_info, causal,_trivial,weak,strong = - if (not causal_trace_on) - && (not weak_compression_on) - && (not strong_compression_on) - then empty_compression - else - begin - let error,log_info,step_list = U.remove_events_after_last_obs parameter handler log_info error step_list in - if not (U.has_obs step_list) - then - let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "+ No causal flow found@." - in - empty_compression - else - let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - (if (weak_compression_on || strong_compression_on) - then "+ Producing causal compressions@." - else "+ Producing causal traces@.") - in - let last_eid = U.last_eid_in_pretrace step_list in - let error,log_info,step_list = U.split_init parameter handler log_info error step_list in - (* causal compression without any simplification (just partial order compression)*) - (* this is very costly, and mainly for teaching purpose *) - let error,log_info,causal_table = - if causal_trace_on - then - let parameter = parameter_causal in - let () = - if log_step then - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t - blackboard generation@." - in - let error,log_info,step_list = U.make_unambiguous parameter handler log_info error step_list in - let error,log_info,blackboard = U.convert_trace_into_musical_notation parameter handler log_info error step_list in + let error, log_info, causal, _trivial, weak, strong = + if + (not causal_trace_on) && (not weak_compression_on) + && not strong_compression_on + then + empty_compression + else ( + let error, log_info, step_list = + U.remove_events_after_last_obs parameter handler log_info error + step_list + in + if not (U.has_obs step_list) then ( + let () = + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "+ No causal flow found@." + in + empty_compression + ) else ( + let () = + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + (if weak_compression_on || strong_compression_on then + "+ Producing causal compressions@." + else + "+ Producing causal traces@.") + in + let last_eid = U.last_eid_in_pretrace step_list in + let error, log_info, step_list = + U.split_init parameter handler log_info error step_list + in + (* causal compression without any simplification (just partial order compression)*) + (* this is very costly, and mainly for teaching purpose *) + let error, log_info, causal_table = + if causal_trace_on then ( + let parameter = parameter_causal in + let () = + if log_step then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "\t - blackboard generation@." + in + let error, log_info, step_list = + U.make_unambiguous parameter handler log_info error step_list + in + let error, log_info, blackboard = + U.convert_trace_into_musical_notation parameter handler log_info + error step_list + in + let () = + if debug_mode && log_step then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "\t - pretty printing the grid@." + in + let log_info, error = + if debug_mode then ( + let error, log_info, () = + U.export_musical_grid_to_xls parameter handler log_info error + "a" 0 0 blackboard + in + let error, log_info, () = + U.print_musical_grid parameter handler log_info error + blackboard + in + log_info, error + ) else + log_info, error + in + let error, log_info, list = + U.extract_observable_hits_from_musical_notation parameter handler + log_info error blackboard + in + let n_stories = List.length list in + let () = + if log_step then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "\t - computing causal past of each observed events (%i)@." + n_stories + in + let error, log_info, causal_story_list = let () = - if debug_mode && log_step - then - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t - pretty printing the grid@." + if debug_mode then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "\t\t * causal compression @." in - let log_info,error = - if debug_mode - then - let error,log_info,() = - U.export_musical_grid_to_xls parameter handler log_info error "a" 0 0 blackboard - in - let error,log_info,() = U.print_musical_grid parameter handler log_info error blackboard in - log_info,error - else - log_info,error + (* let log_info = U.S.PH.B.PB.CI.Po.K.P.set_start_compression log_info in *) + (* We use the grid to get the causal precedence (pred* ) of each observable *) + let grid = U.convert_trace_into_grid step_list handler in + let error, log_info, enriched_grid = + U + .enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar + parameter handler log_info error grid in - let error,log_info,list = - U.extract_observable_hits_from_musical_notation parameter handler log_info error blackboard + let () = + if Parameter.log_number_of_causal_flows then ( + match + Loggers.formatter_of_logger + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + with + | None -> () + | Some logger -> + Causal.print_stat logger parameter handler enriched_grid + ) in - let n_stories = List.length list in let () = if log_step then Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t - computing causal past of each observed events (%i)@." n_stories + "\t - causal flow compression (%i)@." n_stories in - let error,log_info,causal_story_list = - let () = - if debug_mode then - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t\t * causal compression @." - in - (* let log_info = U.S.PH.B.PB.CI.Po.K.P.set_start_compression log_info in *) - (* We use the grid to get the causal precedence (pred* ) of each observable *) - let grid = U.convert_trace_into_grid step_list handler in - let error,log_info,enriched_grid = - U.enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar parameter handler log_info error grid - in - let () = - if Parameter.log_number_of_causal_flows - then - match - Loggers.formatter_of_logger + (* we fold the list of obervable hit, and for each one collect the causal past *) + U.fold_left_with_progress_bar parameter handler log_info error + ~event:StoryProfiling.Collect_traces + (fun parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ + handler log_info error story_list observable_id -> + let () = + if debug_mode then + Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - with - | None -> () - | Some logger -> - Causal.print_stat logger parameter handler enriched_grid - in - let () = - if log_step then - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t - causal flow compression (%i)@." n_stories - in - (* we fold the list of obervable hit, and for each one collect the causal past *) - U.fold_left_with_progress_bar - parameter - handler - log_info - error - ~event:StoryProfiling.Collect_traces - (fun - parameter - ?shall_we_compute:_ - ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error story_list observable_id -> - let () = - if debug_mode then - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t\t * causal compression @." - in - let () = - if S.PH.B.PB.CI.Po.K.H.is_server_mode parameter && - S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter + "\t\t * causal compression @." + in + let () = + if + S.PH.B.PB.CI.Po.K.H.is_server_mode parameter + && S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter then - S.PH.B.PB.CI.Po.K.H.push_json parameter - (Story_json.Phase (Story_json.Inprogress, - "Start one causal compression" - )) - in - let error,log_info,trace_before_compression = - U.causal_prefix_of_an_observable_hit - parameter handler log_info error - "compression_main, line 2014" - blackboard enriched_grid observable_id - in - let info = - match U.get_runtime_info_from_observable_hit observable_id - with - | None -> [] - | Some info -> - let info = - {info with Trace.Simulation_info.story_id = - U.get_counter story_list} in - let info = Trace.Simulation_info.update_profiling_info - log_info info in - [info] - in - let error,log_info,causal_story_array = - U.store_trace parameter handler log_info error trace_before_compression info story_list - in - error,log_info,causal_story_array - ) - table1 - (List.rev list) - in - let error,log_info,causal_story_list = - U.flatten_story_table parameter handler log_info error causal_story_list - in - error,log_info,causal_story_list + (Story_json.Phase + ( Story_json.Inprogress, + "Start one causal compression" )) + in + let error, log_info, trace_before_compression = + U.causal_prefix_of_an_observable_hit parameter handler + log_info error "compression_main, line 2014" blackboard + enriched_grid observable_id + in + let info = + match + U.get_runtime_info_from_observable_hit observable_id + with + | None -> [] + | Some info -> + let info = + { + info with + Trace.Simulation_info.story_id = + U.get_counter story_list; + } + in + let info = + Trace.Simulation_info.update_profiling_info log_info + info + in + [ info ] + in + let error, log_info, causal_story_array = + U.store_trace parameter handler log_info error + trace_before_compression info story_list + in + error, log_info, causal_story_array) + table1 (List.rev list) + in + let error, log_info, causal_story_list = + U.flatten_story_table parameter handler log_info error + causal_story_list + in + error, log_info, causal_story_list + ) else + error, log_info, table1 + in + (* Now causal compression, with detection of siphons & detection of pseudo inverse events *) + let parameter_deeper = + S.PH.B.PB.CI.Po.K.H.set_kasa_parameters + (Remanent_parameters.update_prefix + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + "\t\t\t") + parameter_causal + in + let one_iteration_of_compression (log_info, error, event_list) = + let error, log_info, event_list = + if Graph_closure.ignore_flow_from_outgoing_siphon then + U.fill_siphon parameter_deeper ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error event_list else - error,log_info,table1 + error, log_info, event_list + in + let () = + if debug_mode then U.print_trace parameter handler event_list in - (* Now causal compression, with detection of siphons & detection of pseudo inverse events *) - let parameter_deeper = - S.PH.B.PB.CI.Po.K.H.set_kasa_parameters - (Remanent_parameters.update_prefix - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - "\t\t\t") - parameter_causal + let error, log_info, event_list = + if Parameter.do_global_cut then + U.cut parameter_deeper ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error event_list + else + error, log_info, event_list in - let one_iteration_of_compression (log_info,error,event_list) = - let error,log_info,event_list = - if Graph_closure.ignore_flow_from_outgoing_siphon - then - U.fill_siphon parameter_deeper - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error event_list - else - error,log_info,event_list + if Parameter.cut_pseudo_inverse_event then + U.remove_pseudo_inverse_events parameter_deeper + ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler log_info + error event_list + else + error, log_info, event_list + in + (* This fonction iter the causal compression until a fixpoint is reached *) + let rec aux k (error, log_info, event_list) = + let size = Utilities.size_of_pretrace event_list in + match + S.PH.B.PB.CI.Po.K.H.get_bound_on_itteration_number parameter + with + | Some k' when k >= k' -> + let () = + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "%s\t- max number of iterations reached, %i events remaining @." + (Remanent_parameters.get_prefix + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) + size in + error, log_info, event_list + | Some _ | None -> let () = - if debug_mode then - U.print_trace parameter handler event_list + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "%s\t\t- start iteration %i, %i events remaining @." + (Remanent_parameters.get_prefix + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) + (k + 1) size in - let error,log_info,event_list = - if Parameter.do_global_cut - then - U.cut parameter_deeper - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error event_list - else - error,log_info,event_list + let output_opt = + try + Some + (one_iteration_of_compression (log_info, error, event_list)) + with Sys.Break -> None in - if Parameter.cut_pseudo_inverse_event - then - U.remove_pseudo_inverse_events - parameter_deeper - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error event_list - else - error,log_info,event_list - in - (* This fonction iter the causal compression until a fixpoint is reached *) - let rec aux k (error,log_info,event_list) = - let size = Utilities.size_of_pretrace event_list in - match - S.PH.B.PB.CI.Po.K.H.get_bound_on_itteration_number parameter - with - | Some k' when k>=k' -> + (match output_opt with + | None -> let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "%s\t- max number of iterations reached, %i events remaining @." + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "%s\t- iterations stopped by the end-user, %i events \ + remaining @." (Remanent_parameters.get_prefix (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) size in - error,log_info,event_list - | Some _ | None -> - let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "%s\t\t- start iteration %i, %i events remaining @." - (Remanent_parameters.get_prefix - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - (k+1) - size - in - let output_opt = - try - Some - (one_iteration_of_compression (log_info,error,event_list)) - with Sys.Break -> None - in - match - output_opt - with - | None -> - let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "%s\t- iterations stopped by the end-user, %i events remaining @." - (Remanent_parameters.get_prefix - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - size - in - error,log_info,event_list - | Some (error,log_info,event_list') -> - if U.size_of_pretrace event_list' < U.size_of_pretrace event_list - then - aux (k+1) (error,log_info,event_list') - else + error, log_info, event_list + | Some (error, log_info, event_list') -> + if U.size_of_pretrace event_list' < U.size_of_pretrace event_list + then + aux (k + 1) (error, log_info, event_list') + else ( let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) "%s\t- a fixpoint has been reached, %i events remaining @." (Remanent_parameters.get_prefix (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) size in - error,log_info,event_list' - in - let aux k (error,log_info,event_list) = - let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "%s\t- simplify the trace, %i events @." - (Remanent_parameters.get_prefix - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - (Utilities.size_of_pretrace event_list) - in - aux k (error,log_info,event_list) - in - let error,log_info,causal_story_table,weakly_story_table = - if weak_compression_on || strong_compression_on - then - if - S.PH.B.PB.CI.Po.K.H.get_blacklist_events parameter - then - begin - let parameter = parameter_weak in - let blacklist = U.create_black_list (last_eid+1) in - let error,log_info,(_bl,causal_story_table,weak_story_table) = - Utilities_expert.fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking_the_trace - parameter - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error - we_shall we_shall_not Utilities_expert.parameters - aux - (fun parameter handler log_info error trace -> - (* we remove pseudo inverse events *) - let () = - if S.PH.B.PB.CI.Po.K.H.is_server_mode parameter && - S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter - then - S.PH.B.PB.CI.Po.K.H.push_json parameter - (Story_json.Phase(Story_json.Inprogress, - "Start collecting one new trace" - )) - in - let error,log_info,trace = - U.remove_pseudo_inverse_events (do_not_log parameter) - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error trace - in - (* we compute causal compression *) - U.cut (do_not_log parameter) - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error trace - ) - (fun parameter - ?shall_we_compute:_ - ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error trace info (blacklist,table2,table3) -> - let error,log_info,table2 = U.store_trace parameter handler log_info error trace info table2 in - let error,log_info,trace = U.remove_blacklisted_event parameter handler log_info error blacklist trace in - let error,log_info,list = U.weakly_compress parameter handler log_info error trace in - let error,log_info,blacklist,table3 = - List.fold_left - (fun (error,log_info,blacklist,table3) trace -> - let error,log_info,table3 = - U.store_trace parameter handler log_info error trace info table3 - in - let error,log_info,blacklist = - U.black_list parameter handler log_info error trace blacklist - in - error,log_info,blacklist,table3) - (error,log_info,blacklist,table3) - list - in - let () = Cflow_js_interface.save_trivial_compression_table js_interface table2 in - let () = Cflow_js_interface.save_weak_compression_table js_interface table3 in - error,log_info,(blacklist,table2,table3)) - step_list - (blacklist,table2,table3) - in - let error,log_info,causal_story_table = - U.flatten_story_table parameter handler log_info error causal_story_table - in - let error,log_info,weak_story_table = - U.flatten_story_table parameter handler log_info error weak_story_table - in - let () = Cflow_js_interface.save_trivial_compression_table js_interface causal_story_table in - let () = Cflow_js_interface.save_weak_compression_table js_interface weak_story_table in - error,log_info,causal_story_table,weak_story_table - end - else - begin - let error,log_info,causal_story_table = - let parameter = parameter_causal in - Utilities_expert.fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking_the_trace - parameter - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error - we_shall we_shall_not Utilities_expert.parameters - aux - (fun parameter handler log_info error trace -> - (* we remove pseudo inverse events *) - let () = - if S.PH.B.PB.CI.Po.K.H.is_server_mode parameter && - S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter - then - S.PH.B.PB.CI.Po.K.H.push_json parameter - (Story_json.Phase(Story_json.Inprogress, - "Start collecting one new trace" - )) - in - let error,log_info,trace = - U.remove_pseudo_inverse_events - (do_not_log parameter) - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error trace - in - (* we compute causal compression *) - U.cut - (do_not_log parameter) - ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error trace - ) - (fun parameter - ?shall_we_compute:_ - ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error info trace table -> - let error, info, table = U.store_trace parameter handler log_info error info trace table in - let () = Cflow_js_interface.save_trivial_compression_table js_interface table in - error, info, table) - step_list - table2 - in - let error,log_info,causal_story_table = - U.flatten_story_table parameter handler log_info error causal_story_table - in - let () = Cflow_js_interface.save_trivial_compression_table js_interface causal_story_table in - let () = - Loggers.print_newline - (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - in - let () = - Loggers.print_newline - (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - in - let n_causal_stories = U.count_stories causal_story_table in - let error,log_info,weakly_story_table = - begin - let parameter = parameter_weak in - let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t - weak flow compression (%i)@." - n_causal_stories - in - let blacklist = U.create_black_list (last_eid+1) in - let parameter = S.PH.B.PB.CI.Po.K.H.set_compression_weak parameter in - let error,log_info,(_blacklist,weakly_story_table) = - U.fold_story_table_with_progress_bar parameter handler log_info error "weak compression" - (fun - parameter - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error trace list_info (blacklist,story_list) -> - let error,log_info,list = U.weakly_compress parameter handler log_info error trace in - let error,log_info,blacklist,story_list = - List.fold_left - (fun (error,log_info,blacklist,story_list) trace -> - let error,log_info,story_list = U.store_trace parameter handler log_info error trace list_info story_list in - let () = Cflow_js_interface.save_weak_compression_table js_interface story_list in - error,log_info,blacklist,story_list) - (error,log_info,blacklist,story_list) - list - in error,log_info,(blacklist,story_list)) - causal_story_table - (blacklist,table3) - in - U.flatten_story_table parameter handler log_info error weakly_story_table - end - in - let () = Cflow_js_interface.save_weak_compression_table js_interface weakly_story_table in - error,log_info,causal_story_table,weakly_story_table - end - else - error,log_info,table2,table3 + error, log_info, event_list' + )) + in + let aux k (error, log_info, event_list) = + let () = + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "%s\t- simplify the trace, %i events @." + (Remanent_parameters.get_prefix + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) + (Utilities.size_of_pretrace event_list) in - let n_weak_stories = U.count_stories weakly_story_table in - let error,log_info,strongly_story_table = - if strong_compression_on - then - begin - let parameter = parameter_strong in - let parameter = S.PH.B.PB.CI.Po.K.H.set_compression_strong parameter in + aux k (error, log_info, event_list) + in + let error, log_info, causal_story_table, weakly_story_table = + if weak_compression_on || strong_compression_on then + if S.PH.B.PB.CI.Po.K.H.get_blacklist_events parameter then ( + let parameter = parameter_weak in + let blacklist = U.create_black_list (last_eid + 1) in + let error, log_info, (_bl, causal_story_table, weak_story_table) = + Utilities_expert + .fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking_the_trace + parameter ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error we_shall we_shall_not + Utilities_expert.parameters aux + (fun parameter handler log_info error trace -> + (* we remove pseudo inverse events *) + let () = + if + S.PH.B.PB.CI.Po.K.H.is_server_mode parameter + && S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter + then + S.PH.B.PB.CI.Po.K.H.push_json parameter + (Story_json.Phase + ( Story_json.Inprogress, + "Start collecting one new trace" )) + in + let error, log_info, trace = + U.remove_pseudo_inverse_events (do_not_log parameter) + ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error trace + in + (* we compute causal compression *) + U.cut (do_not_log parameter) ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error trace) + (fun parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ + ?print_if_zero:_ handler log_info error trace info + (blacklist, table2, table3) -> + let error, log_info, table2 = + U.store_trace parameter handler log_info error trace info + table2 + in + let error, log_info, trace = + U.remove_blacklisted_event parameter handler log_info + error blacklist trace + in + let error, log_info, list = + U.weakly_compress parameter handler log_info error trace + in + let error, log_info, blacklist, table3 = + List.fold_left + (fun (error, log_info, blacklist, table3) trace -> + let error, log_info, table3 = + U.store_trace parameter handler log_info error trace + info table3 + in + let error, log_info, blacklist = + U.black_list parameter handler log_info error trace + blacklist + in + error, log_info, blacklist, table3) + (error, log_info, blacklist, table3) + list + in + let () = + Cflow_js_interface.save_trivial_compression_table + js_interface table2 + in + let () = + Cflow_js_interface.save_weak_compression_table + js_interface table3 + in + error, log_info, (blacklist, table2, table3)) + step_list + (blacklist, table2, table3) + in + let error, log_info, causal_story_table = + U.flatten_story_table parameter handler log_info error + causal_story_table + in + let error, log_info, weak_story_table = + U.flatten_story_table parameter handler log_info error + weak_story_table + in + let () = + Cflow_js_interface.save_trivial_compression_table js_interface + causal_story_table + in + let () = + Cflow_js_interface.save_weak_compression_table js_interface + weak_story_table + in + error, log_info, causal_story_table, weak_story_table + ) else ( + let error, log_info, causal_story_table = + let parameter = parameter_causal in + Utilities_expert + .fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking_the_trace + parameter ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error we_shall we_shall_not + Utilities_expert.parameters aux + (fun parameter handler log_info error trace -> + (* we remove pseudo inverse events *) + let () = + if + S.PH.B.PB.CI.Po.K.H.is_server_mode parameter + && S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter + then + S.PH.B.PB.CI.Po.K.H.push_json parameter + (Story_json.Phase + ( Story_json.Inprogress, + "Start collecting one new trace" )) + in + let error, log_info, trace = + U.remove_pseudo_inverse_events (do_not_log parameter) + ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error trace + in + (* we compute causal compression *) + U.cut (do_not_log parameter) ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler + log_info error trace) + (fun parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ + ?print_if_zero:_ handler log_info error info trace table -> + let error, info, table = + U.store_trace parameter handler log_info error info trace + table + in + let () = + Cflow_js_interface.save_trivial_compression_table + js_interface table + in + error, info, table) + step_list table2 + in + let error, log_info, causal_story_table = + U.flatten_story_table parameter handler log_info error + causal_story_table + in + let () = + Cflow_js_interface.save_trivial_compression_table js_interface + causal_story_table + in + let () = + Loggers.print_newline (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + in + let () = + Loggers.print_newline (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + in + let n_causal_stories = U.count_stories causal_story_table in + let error, log_info, weakly_story_table = + let parameter = parameter_weak in let () = - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "\t - strong flow compression (%i)@." - n_weak_stories + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "\t - weak flow compression (%i)@." n_causal_stories + in + let blacklist = U.create_black_list (last_eid + 1) in + let parameter = + S.PH.B.PB.CI.Po.K.H.set_compression_weak parameter in - let error,log_info,strongly_story_table = - U.fold_story_table_with_progress_bar - parameter handler log_info error - "strong_compression" - (fun - parameter - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error refined_event_list list_info strongly_story_table -> - let error,log_info,list = U.compress parameter handler log_info error refined_event_list in - let error,log_info,strongly_story_table = - match + let error, log_info, (_blacklist, weakly_story_table) = + U.fold_story_table_with_progress_bar parameter handler + log_info error "weak compression" + (fun parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ + ?print_if_zero:_ handler log_info error trace list_info + (blacklist, story_list) -> + let error, log_info, list = + U.weakly_compress parameter handler log_info error trace + in + let error, log_info, blacklist, story_list = + List.fold_left + (fun (error, log_info, blacklist, story_list) trace -> + let error, log_info, story_list = + U.store_trace parameter handler log_info error + trace list_info story_list + in + let () = + Cflow_js_interface.save_weak_compression_table + js_interface story_list + in + error, log_info, blacklist, story_list) + (error, log_info, blacklist, story_list) list - with - | [] -> - error,log_info,strongly_story_table - | _ -> - List.fold_left - (fun (error,log_info,strongly_story_table) list -> - U.store_trace parameter handler log_info error list list_info strongly_story_table) - (error,log_info,strongly_story_table) - list in - error,log_info,strongly_story_table) - weakly_story_table - table4 + error, log_info, (blacklist, story_list)) + causal_story_table (blacklist, table3) in - U.flatten_story_table parameter handler log_info error strongly_story_table - end - else - error,log_info,table4 - in - error, log_info, + U.flatten_story_table parameter handler log_info error + weakly_story_table + in + let () = + Cflow_js_interface.save_weak_compression_table js_interface + weakly_story_table + in + error, log_info, causal_story_table, weakly_story_table + ) + else + error, log_info, table2, table3 + in + let n_weak_stories = U.count_stories weakly_story_table in + let error, log_info, strongly_story_table = + if strong_compression_on then ( + let parameter = parameter_strong in + let parameter = + S.PH.B.PB.CI.Po.K.H.set_compression_strong parameter + in + let () = + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "\t - strong flow compression (%i)@." n_weak_stories + in + let error, log_info, strongly_story_table = + U.fold_story_table_with_progress_bar parameter handler log_info + error "strong_compression" + (fun parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ + handler log_info error refined_event_list list_info + strongly_story_table -> + let error, log_info, list = + U.compress parameter handler log_info error + refined_event_list + in + let error, log_info, strongly_story_table = + match list with + | [] -> error, log_info, strongly_story_table + | _ -> + List.fold_left + (fun (error, log_info, strongly_story_table) list -> + U.store_trace parameter handler log_info error list + list_info strongly_story_table) + (error, log_info, strongly_story_table) + list + in + error, log_info, strongly_story_table) + weakly_story_table table4 + in + U.flatten_story_table parameter handler log_info error + strongly_story_table + ) else + error, log_info, table4 + in + ( error, + log_info, causal_table, causal_story_table, weakly_story_table, - strongly_story_table - end + strongly_story_table ) + ) + ) in - let error,log_info = - if causal_trace_on then - let error,log_info,export = U.export_story_table parameter handler log_info error causal in - let error,log_info = - Causal.pretty_print - ~dotFormat (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) handler - log_info error env Graph_closure.config_small_graph "" "" export + let error, log_info = + if causal_trace_on then ( + let error, log_info, export = + U.export_story_table parameter handler log_info error causal in - error,log_info - else error,log_info + let error, log_info = + Causal.pretty_print ~dotFormat + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + handler log_info error env Graph_closure.config_small_graph "" "" + export + in + error, log_info + ) else + error, log_info in - let error,log_info = - if weak_compression_on then - let error,log_info,export = U.export_story_table parameter handler log_info error weak in - let error,log_info = - Causal.pretty_print - ~dotFormat (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) handler - log_info error env Graph_closure.config_small_graph "Weakly" "weakly " export + let error, log_info = + if weak_compression_on then ( + let error, log_info, export = + U.export_story_table parameter handler log_info error weak + in + let error, log_info = + Causal.pretty_print ~dotFormat + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + handler log_info error env Graph_closure.config_small_graph "Weakly" + "weakly " export in - error,log_info - else error,log_info + error, log_info + ) else + error, log_info in - let error,_log_info = - if strong_compression_on then - let error,log_info,export = U.export_story_table parameter handler log_info error strong in - let error,log_info = - Causal.pretty_print - ~dotFormat (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) handler - log_info error env Graph_closure.config_small_graph "Strongly" "strongly " export + let error, _log_info = + if strong_compression_on then ( + let error, log_info, export = + U.export_story_table parameter handler log_info error strong in - error,log_info - else - error,log_info + let error, log_info = + Causal.pretty_print ~dotFormat + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + handler log_info error env Graph_closure.config_small_graph "Strongly" + "strongly " export + in + error, log_info + ) else + error, log_info in let () = S.PH.B.PB.CI.Po.K.H.push_json parameter - (Story_json.Phase (Story_json.Success,"Compression completed")) in - let _ = StoryProfiling.StoryStats.close_logger (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) in + (Story_json.Phase (Story_json.Success, "Compression completed")) + in + let _ = + StoryProfiling.StoryStats.close_logger + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + in let _ = - Exception.print_for_KaSim (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error + Exception.print_for_KaSim + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error in () diff --git a/core/cflow/compression_main.mli b/core/cflow/compression_main.mli index 685ddda9fb..afcc9b155e 100644 --- a/core/cflow/compression_main.mli +++ b/core/cflow/compression_main.mli @@ -6,16 +6,24 @@ type secret_parameter (** {6 Build} *) val init_secret_log_info : unit -> secret_log_info + val build_parameter : called_from:Remanent_parameters_sig.called_from -> ?send_message:(string -> unit) -> - none:bool -> weak:bool -> strong:bool -> unit -> + none:bool -> + weak:bool -> + strong:bool -> + unit -> secret_parameter -(** {6 Use} *) val get_logger : secret_parameter -> Loggers.t +(** {6 Use} *) val compress_and_print : - secret_parameter -> dotFormat:Causal.formatCflow -> + secret_parameter -> + dotFormat:Causal.formatCflow -> ?js_interface:Cflow_js_interface.cflow_state ref -> - Model.t -> secret_log_info -> Trace.t -> unit + Model.t -> + secret_log_info -> + Trace.t -> + unit diff --git a/core/cflow/dag.ml b/core/cflow/dag.ml index 93ae108aee..bad0ef9a63 100644 --- a/core/cflow/dag.ml +++ b/core/cflow/dag.ml @@ -21,56 +21,73 @@ module S = Generic_branch_and_cut_solver.Solver -let warn parameter error pos ?message:(message="") exn default = +let warn parameter error pos ?(message = "") exn default = Exception.warn - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error pos - ~message exn default + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error pos ~message exn default -module type StoryTable = -sig +module type StoryTable = sig type table - val fold_table: - ((Trace.t,StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list,'a,'a) S.PH.B.PB.CI.Po.K.H.ternary, table, 'a, 'a) S.PH.B.PB.CI.Po.K.H.ternary - val init_table: table S.PH.B.PB.CI.Po.K.H.zeroary - val count_stories: table -> int - val add_story: (Causal.grid,Trace.t,StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list,table,table) S.PH.B.PB.CI.Po.K.H.quaternary - val hash_list: (table, table) S.PH.B.PB.CI.Po.K.H.unary - - val sort_list: (table, (Trace.t * Causal.grid * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) list) S.PH.B.PB.CI.Po.K.H.unary + val fold_table : + ( ( Trace.t, + StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list, + 'a, + 'a ) + S.PH.B.PB.CI.Po.K.H.ternary, + table, + 'a, + 'a ) + S.PH.B.PB.CI.Po.K.H.ternary + + val init_table : table S.PH.B.PB.CI.Po.K.H.zeroary + val count_stories : table -> int + + val add_story : + ( Causal.grid, + Trace.t, + StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list, + table, + table ) + S.PH.B.PB.CI.Po.K.H.quaternary + + val hash_list : (table, table) S.PH.B.PB.CI.Po.K.H.unary + + val sort_list : + ( table, + (Trace.t + * Causal.grid + * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) + list ) + S.PH.B.PB.CI.Po.K.H.unary end -module H=S.PH.B.PB.CI.Po.K.H -module A=Mods.DynArray +module H = S.PH.B.PB.CI.Po.K.H +module A = Mods.DynArray type label = string type node_kind = OBS | PERT | RULE | INIT | FICTITIOUS type node = node_kind * label -type graph = - { - root: int; - labels: node A.t ; - pred: int list A.t ; - conflict_pred: int list A.t; - } +type graph = { + root: int; + labels: node A.t; + pred: int list A.t; + conflict_pred: int list A.t; +} let dummy_graph = { - root = 0 ; - labels = A.make 1 (FICTITIOUS,"") ; - pred = A.make 1 [] ; - conflict_pred = A.make 1 [] ; + root = 0; + labels = A.make 1 (FICTITIOUS, ""); + pred = A.make 1 []; + conflict_pred = A.make 1 []; } type position = int -type key = - | Fresh of node - | Former of position - | Stop - +type key = Fresh of node | Former of position | Stop type canonical_form = key list -type prehash = (node*int) list +type prehash = (node * int) list let _dummy_cannonical_form = [] let _dummy_prehash = [] @@ -93,14 +110,11 @@ let _print_story_info logger _parameter json = *) let channel_opt = Loggers.channel_of_logger logger in let () = - begin - match channel_opt - with - | None -> () - | Some channel -> - let () = Yojson.Basic.to_channel channel json in - () - end + match channel_opt with + | None -> () + | Some channel -> + let () = Yojson.Basic.to_channel channel json in + () in let () = Loggers.print_newline logger in () @@ -111,105 +125,103 @@ let print_graph logger parameter _handler error id story_info graph = let () = Graph_loggers.print_graph_preamble logger "story" in let () = A.iteri - (fun i (node_kind,j) -> - if i=0 && j = "" - then - () - else - let directives = - match node_kind - with - OBS -> [Graph_loggers_sig.Color Graph_loggers_sig.Red] - | PERT -> [Graph_loggers_sig.Color Graph_loggers_sig.Green; - Graph_loggers_sig.Shape Graph_loggers_sig.Invhouse] - | RULE -> [Graph_loggers_sig.Color Graph_loggers_sig.LightSkyBlue ;Graph_loggers_sig.Shape Graph_loggers_sig.Invhouse] - | INIT -> [Graph_loggers_sig.Color Graph_loggers_sig.Green; - Graph_loggers_sig.Shape Graph_loggers_sig.House] - | FICTITIOUS -> [Graph_loggers_sig.Shape Graph_loggers_sig.Invisible] - in - Graph_loggers.print_node - logger - ~directives:(Graph_loggers_sig.Label j::directives) - (string_of_int i) - ) + (fun i (node_kind, j) -> + if i = 0 && j = "" then + () + else ( + let directives = + match node_kind with + | OBS -> [ Graph_loggers_sig.Color Graph_loggers_sig.Red ] + | PERT -> + [ + Graph_loggers_sig.Color Graph_loggers_sig.Green; + Graph_loggers_sig.Shape Graph_loggers_sig.Invhouse; + ] + | RULE -> + [ + Graph_loggers_sig.Color Graph_loggers_sig.LightSkyBlue; + Graph_loggers_sig.Shape Graph_loggers_sig.Invhouse; + ] + | INIT -> + [ + Graph_loggers_sig.Color Graph_loggers_sig.Green; + Graph_loggers_sig.Shape Graph_loggers_sig.House; + ] + | FICTITIOUS -> + [ Graph_loggers_sig.Shape Graph_loggers_sig.Invisible ] + in + Graph_loggers.print_node logger + ~directives:(Graph_loggers_sig.Label j :: directives) + (string_of_int i) + )) graph.labels in let () = A.iteri - (fun i l -> - List.iter - (fun j -> - Graph_loggers.print_edge logger (string_of_int j) (string_of_int i) - ) l - ) + (fun i l -> + List.iter + (fun j -> + Graph_loggers.print_edge logger (string_of_int j) (string_of_int i)) + l) graph.pred in let () = A.iteri - (fun i l -> - List.iter - (fun j -> - Graph_loggers.print_edge - logger - ~directives:[ - Graph_loggers_sig.LineStyle Graph_loggers_sig.Dotted ; - Graph_loggers_sig.ArrowHead Graph_loggers_sig.Tee + (fun i l -> + List.iter + (fun j -> + Graph_loggers.print_edge logger + ~directives: + [ + Graph_loggers_sig.LineStyle Graph_loggers_sig.Dotted; + Graph_loggers_sig.ArrowHead Graph_loggers_sig.Tee; ] - (string_of_int i) - (string_of_int j) - ) - l - ) + (string_of_int i) (string_of_int j)) + l) graph.conflict_pred in let current_compression_mode parameter = - match H.get_current_compression_mode parameter - with - | None -> Story_json.Causal - | Some x -> x + match H.get_current_compression_mode parameter with + | None -> Story_json.Causal + | Some x -> x in - let - result = + let result = { - Story_json.log_info = story_info ; - Story_json.story_mode = current_compression_mode parameter ; + Story_json.log_info = story_info; + Story_json.story_mode = current_compression_mode parameter; Story_json.story = Story_json.New { - Story_json.graph = Graph_loggers_sig.graph_of_logger logger ; - Story_json.id = id - }} + Story_json.graph = Graph_loggers_sig.graph_of_logger logger; + Story_json.id; + }; + } in let () = H.push_json parameter (Story_json.Story result) in error let print_elt log elt = - match - elt - with + match elt with | Stop -> let () = Loggers.fprintf log "STOP" in Loggers.print_newline log | Former i -> let () = Loggers.fprintf log "Pointer %i" i in Loggers.print_newline log - | Fresh (_,s) -> + | Fresh (_, s) -> let () = Loggers.fprintf log "Event %s" s in Loggers.print_newline log let _print_canonical_form parameter _handler error dag = - let _ = - List.iter - (print_elt (H.get_debugging_channel parameter)) - dag - in + let _ = List.iter (print_elt (H.get_debugging_channel parameter)) dag in let _ = Loggers.print_newline (H.get_debugging_channel parameter) in error let _print_prehash parameter _handler error representation = let _ = List.iter - (fun ((_,b),i) -> Loggers.fprintf (H.get_debugging_channel parameter) "%s:%i," b i) + (fun ((_, b), i) -> + Loggers.fprintf (H.get_debugging_channel parameter) "%s:%i," b i) representation in let _ = Loggers.print_newline (H.get_debugging_channel parameter) in @@ -217,804 +229,841 @@ let _print_prehash parameter _handler error representation = let label handler = function | Causal.EVENT (Trace.RULE i) -> H.string_of_rule_id handler i - | Causal.EVENT (Trace.INIT [i]) -> H.string_of_agent_id handler i - | Causal.EVENT (Trace.INIT _ | Trace.PERT _ as x) -> + | Causal.EVENT (Trace.INIT [ i ]) -> H.string_of_agent_id handler i + | Causal.EVENT ((Trace.INIT _ | Trace.PERT _) as x) -> Format.asprintf "%a" (Trace.print_event_kind ~env:handler.H.env) x | Causal.OBS name -> name + let kind node = - match node - with + match node with | Causal.EVENT (Trace.INIT _) -> INIT | Causal.EVENT (Trace.RULE _) -> RULE | Causal.EVENT (Trace.PERT _) -> PERT | Causal.OBS _ -> OBS let compare_elt x y = - match x,y with - | Stop,Stop -> 0 - | Stop,_ -> -1 - | _,Stop -> +1 + match x, y with + | Stop, Stop -> 0 + | Stop, _ -> -1 + | _, Stop -> 1 | Former i, Former j -> compare i j - | Former _,_ -> -1 - | _,Former _ -> +1 - | Fresh s,Fresh s' -> compare s s' + | Former _, _ -> -1 + | _, Former _ -> 1 + | Fresh s, Fresh s' -> compare s s' let quick_compare g t1 t2 = compare_elt (g t1) (g t2) let rec aux compare_elt l1 l2 = - match l1,l2 - with - | [],[] -> 0 + match l1, l2 with + | [], [] -> 0 | [], _ -> -1 - | _ ,[] -> +1 - | t::q,t'::q' -> + | _, [] -> 1 + | t :: q, t' :: q' -> let cmp = compare_elt t t' in - if cmp = 0 - then aux compare_elt q q' - else cmp + if cmp = 0 then + aux compare_elt q q' + else + cmp let compare_canonic = aux compare_elt + let compare_canonic_opt x y = - match x,y - with - | None,None -> 0 - | None,_ -> -1 - | _,None -> +1 - |Some x,Some y -> compare_canonic x y + match x, y with + | None, None -> 0 + | None, _ -> -1 + | _, None -> 1 + | Some x, Some y -> compare_canonic x y let compare_prehash = aux compare let graph_of_grid parameter handler log_info error grid = - let error,log_info = StoryProfiling.StoryStats.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Graph_conversion None log_info in - let ids = Hashtbl.fold (fun key _ l -> key::l) grid.Causal.flow [] in + let error, log_info = + StoryProfiling.StoryStats.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Graph_conversion None log_info + in + let ids = Hashtbl.fold (fun key _ l -> key :: l) grid.Causal.flow [] in let label = label handler in - let error,log_info,config = Causal.cut (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) handler log_info error ids grid in - match Mods.IntMap.max_key config.Causal.prec_1 - with None -> error,log_info,dummy_graph - | Some size -> - let succ_size = succ size in - let labels = A.make succ_size (FICTITIOUS,"") in - let pred = A.make succ_size [] in - let conflict_pred = A.make succ_size [] in - let () = - Mods.IntMap.iter - (fun i atom_kind -> - A.set labels i (kind atom_kind,label atom_kind) - ) - config.Causal.events_kind - in - let () = - Mods.IntMap.iter - (fun i s -> - if Mods.IntSet.is_empty s - then () - else - A.set pred i (Mods.IntSet.elements s)) - config.Causal.prec_1 - in - let () = - Mods.IntMap.iter - (fun i s -> - if Mods.IntSet.is_empty s - then () - else - A.set conflict_pred i (Mods.IntSet.elements s)) - config.Causal.conflict - in - let root = size in - let error,log_info = StoryProfiling.StoryStats.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Graph_conversion None log_info in - error, - log_info, - { - root = root; - labels = labels ; - pred = pred ; - conflict_pred = conflict_pred - } + let error, log_info, config = + Causal.cut + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + handler log_info error ids grid + in + match Mods.IntMap.max_key config.Causal.prec_1 with + | None -> error, log_info, dummy_graph + | Some size -> + let succ_size = succ size in + let labels = A.make succ_size (FICTITIOUS, "") in + let pred = A.make succ_size [] in + let conflict_pred = A.make succ_size [] in + let () = + Mods.IntMap.iter + (fun i atom_kind -> A.set labels i (kind atom_kind, label atom_kind)) + config.Causal.events_kind + in + let () = + Mods.IntMap.iter + (fun i s -> + if Mods.IntSet.is_empty s then + () + else + A.set pred i (Mods.IntSet.elements s)) + config.Causal.prec_1 + in + let () = + Mods.IntMap.iter + (fun i s -> + if Mods.IntSet.is_empty s then + () + else + A.set conflict_pred i (Mods.IntSet.elements s)) + config.Causal.conflict + in + let root = size in + let error, log_info = + StoryProfiling.StoryStats.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Graph_conversion None log_info + in + error, log_info, { root; labels; pred; conflict_pred } let concat list1 list2 = let rec aux list1 list2 = - match list2 - with + match list2 with | [] -> list1 - | t::q -> aux (t::list1) q + | t :: q -> aux (t :: list1) q in aux list2 (List.rev list1) -let compare_node (a,_) (b,_) = compare a b +let compare_node (a, _) (b, _) = compare a b let smash l = let rec aux l former weight output = - match l - with - | [] -> List.rev ((former,weight)::output) - | (t,wt)::q when t = former -> aux q former (wt+weight) output - | (t,wt)::q -> aux q t wt ((former,weight)::output) + match l with + | [] -> List.rev ((former, weight) :: output) + | (t, wt) :: q when t = former -> aux q former (wt + weight) output + | (t, wt) :: q -> aux q t wt ((former, weight) :: output) in - match l - with + match l with | [] -> [] - | (t,wt)::q -> aux q t wt [] + | (t, wt) :: q -> aux q t wt [] let prehash _parameter _handler error graph = - error, - smash - (List.sort - compare_node - (let l=ref [] in - let _ = - A.iter - (function - | FICTITIOUS,_ -> () - | (OBS|PERT|RULE|INIT),_ as a -> l:=(a,1)::(!l)) - graph.labels - in - !l)) + ( error, + smash + (List.sort compare_node + (let l = ref [] in + let _ = + A.iter + (function + | FICTITIOUS, _ -> () + | ((OBS | PERT | RULE | INIT), _) as a -> l := (a, 1) :: !l) + graph.labels + in + !l)) ) let canonicalize parameter _handler log_info error graph = let asso = Mods.IntMap.empty in - let label i = - try - A.get graph.labels i - with - | _ -> FICTITIOUS,"" - in - let rec pop (candidate:key list) (to_beat:key list option) = - match - candidate,to_beat - with - | [],_ | _,None -> Some to_beat (* candidate is a prefix of to_beat, we output the suffix *) - | _::_, Some [] -> None (* the candidate is worse *) - | t::q,Some (tr::qr) -> + let label i = try A.get graph.labels i with _ -> FICTITIOUS, "" in + let rec pop (candidate : key list) (to_beat : key list option) = + match candidate, to_beat with + | [], _ | _, None -> + Some to_beat (* candidate is a prefix of to_beat, we output the suffix *) + | _ :: _, Some [] -> None (* the candidate is worse *) + | t :: q, Some (tr :: qr) -> let cmp = compare_elt t tr in - if cmp < 0 - then + if cmp < 0 then Some None (* the candidate is better *) else if cmp = 0 then - pop q (Some qr) (* we do not know, we look further *) + pop q (Some qr) + (* we do not know, we look further *) else - None (* the candidate is worse *) + None + (* the candidate is worse *) in - let rec visit (i:int) (map:int Mods.IntMap.t) (fresh_pos:int) (to_beat:key list option) = - match - Mods.IntMap.find_option i map - with - | Some i -> (* the node has already been seen, we put a pointer *) - begin (*0*) - match - pop [Former i] to_beat - with - | None -> (* to beat is better, we cut the construction *) - None - | Some to_beat -> (* to beat may be improved, we go on *) - Some ([Former i],map,fresh_pos,to_beat) - end (*0*) - | None -> (* the node is seen for the first time *) + let rec visit (i : int) (map : int Mods.IntMap.t) (fresh_pos : int) + (to_beat : key list option) = + match Mods.IntMap.find_option i map with + | Some i -> + (* the node has already been seen, we put a pointer *) + (*0*) + (match pop [ Former i ] to_beat with + | None -> + (* to beat is better, we cut the construction *) + None + | Some to_beat -> + (* to beat may be improved, we go on *) + Some ([ Former i ], map, fresh_pos, to_beat)) + (*0*) + | None -> + (* the node is seen for the first time *) let map = Mods.IntMap.add i fresh_pos map in let fresh_pos = fresh_pos + 1 in - begin (*0*) - match - pop [Fresh (label i)] to_beat - with + (*0*) + (match pop [ Fresh (label i) ] to_beat with + | None -> None + | Some (to_beat : key list option) -> + (*1*) + let sibbling1 = try A.get graph.pred i with Not_found -> [] in + let sibbling2 = + try A.get graph.conflict_pred i with Not_found -> [] + in + let rec best_sibbling (m : int Mods.IntMap.t) (f : int) + (candidates : int list) (not_best : int list) + (to_beat : key list option) + (record : + (int * (key list * int Mods.IntMap.t * int * key list option)) + option) = + match candidates with + | [] -> + (*2*) + (match record with + | None -> None + | Some record -> Some (not_best, record)) + (*2*) + | t :: q -> + let rep = visit t m f to_beat in + (*2*) + (match rep with + | None -> best_sibbling m f q (t :: not_best) to_beat record + | Some ((encoding : key list), map, fresh, residue) -> + (*3*) + let (to_beat_after : key list option) = + match residue with + | None -> Some encoding + | _ -> to_beat + in + let (not_best : int list) = + match record with + | None -> not_best + | Some (best, _) -> best :: not_best + in + best_sibbling m f q not_best to_beat_after + (Some (t, (encoding, map, fresh, residue)))) + (*3*) + (*2*) + in + let rec aux m f l sol to_beat = + match l with + | [] -> Some (m, f, sol, to_beat) + | _ -> + (*2*) + (match best_sibbling m f l [] to_beat None with + | None -> None + | Some (not_best, record) -> + let _, (best, map, fresh_pos, to_beat_after) = record in + aux map fresh_pos not_best (concat sol best) to_beat_after) + (*2*) + in + let list = [ Fresh (label i) ] in + (*2*) + let g x = + match Mods.IntMap.find_option x map with + | Some x -> Former x + | None -> Fresh (label x) + in + let sibbling1 = List.sort (quick_compare g) sibbling1 in + (match aux map fresh_pos sibbling1 list to_beat with | None -> None - | Some (to_beat:key list option) -> - begin (*1*) - let sibbling1 = - try - A.get graph.pred i - with - | Not_found -> [] + | Some (map, fresh_pos, list, to_beat) -> + (*3*) + (match pop [ Stop ] to_beat with + | None -> None + | Some to_beat -> + (*4*) + let list = concat list [ Stop ] in + (*5*) + let g x = + match Mods.IntMap.find_option x map with + | Some x -> Former x + | None -> Fresh (label x) in - let sibbling2 = - try - A.get graph.conflict_pred i - with - | Not_found -> [] - in - let rec best_sibbling (m:int Mods.IntMap.t) (f:int) (candidates:int list) (not_best:int list) (to_beat:key list option) (record: (int * (key list * int Mods.IntMap.t * int * key list option)) option) = - match candidates - with - | [] -> - begin (*2*) - match - record - with - | None -> None - | Some record -> Some (not_best,record) - end (*2*) - | t::q -> - let rep = visit t m f to_beat in - begin (*2*) - match - rep - with - | None -> best_sibbling m f q (t::not_best) to_beat record - | Some ((encoding:key list),map,fresh,residue) -> - begin (*3*) - let (to_beat_after:key list option) = - match - residue - with - | None -> - Some encoding - | _ -> - to_beat - in - let (not_best:int list) = - match - record - with - | None -> not_best - | Some (best,_) -> best::not_best - in - best_sibbling - m - f - q - not_best - to_beat_after - (Some (t,(encoding,map,fresh,residue))) - end (*3*) - end (*2*) - in - let rec aux m f l sol to_beat = - match - l - with - | [] -> Some (m,f,sol,to_beat) - | _ -> - begin (*2*) - match - best_sibbling m f l [] to_beat None - with - | None -> None - | Some (not_best,record) -> - let (_,(best,map,fresh_pos,to_beat_after)) = record in - aux map fresh_pos not_best (concat sol best) to_beat_after - end (*2*) - in - let list = [Fresh (label i)] in - begin (*2*) - let g x = - match Mods.IntMap.find_option x map with - | Some x -> Former x - | None -> Fresh (label x) - in - let sibbling1 = List.sort (quick_compare g) sibbling1 in - match - aux map fresh_pos sibbling1 list to_beat - with + let sibbling2 = List.sort (quick_compare g) sibbling2 in + (match aux map fresh_pos sibbling2 list to_beat with + | None -> None + | Some (map, fresh_pos, list, to_beat) -> + (*6*) + (match pop [ Stop ] to_beat with | None -> None - | Some (map,fresh_pos,list,to_beat) -> - begin (*3*) - match - pop [Stop] to_beat - with - | None -> None - | Some to_beat -> - begin (*4*) - let list = concat list [Stop] in - begin (*5*) - let g x = - match Mods.IntMap.find_option x map with - | Some x -> Former x - | None -> Fresh (label x) - in - let sibbling2 = List.sort (quick_compare g) sibbling2 in - match - aux map fresh_pos sibbling2 list to_beat - with - | None -> None - | Some (map,fresh_pos,list,to_beat) -> - begin (*6*) - match - pop [Stop] to_beat - with - | None -> None - | Some to_beat -> - let list = concat list [Stop] in - Some (list,map,fresh_pos,to_beat) - end (*6*) - end (*5*) - end (*4*) - end (*3*) - end (*2*) - end (*1*) - end (*0*) + | Some to_beat -> + let list = concat list [ Stop ] in + Some (list, map, fresh_pos, to_beat))) + (*6*) + (*5*)) + (*4*)) + (*3*) + (*2*)) + (*1*) + (*0*) + in + let error, log_info = + StoryProfiling.StoryStats.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Cannonic_form_computation None log_info in - let error, log_info = StoryProfiling.StoryStats.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Cannonic_form_computation None log_info in let error, output = - match - visit graph.root asso 0 None - with - | Some (rep,_,_,_) -> error,rep - | None -> error,[] + match visit graph.root asso 0 None with + | Some (rep, _, _, _) -> error, rep + | None -> error, [] in - let error, log_info = StoryProfiling.StoryStats.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Cannonic_form_computation None log_info in - error,log_info,output + let error, log_info = + StoryProfiling.StoryStats.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Cannonic_form_computation None log_info + in + error, log_info, output + +module ListTable : StoryTable = struct + type table = + (prehash + * (Causal.grid + * graph + * canonical_form option + * Trace.t + * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) + list) + list + + let init_table _parameter _handler log_info error = error, log_info, [] + + let add_story parameter handler log_info error grid pretrace info table = + let error, log_info, graph = + graph_of_grid parameter handler log_info error grid + in + let error, prehash = prehash parameter handler error graph in + error, log_info, (prehash, [ grid, graph, None, pretrace, info ]) :: table + + let sort_outer = + let compare (a, _) (b, _) = compare_prehash a b in + List.sort compare + + let sort_inner = + let compare (_, _, a, _, _) (_, _, b, _, _) = compare_canonic_opt a b in + List.sort compare + + let hash_inner _parameter _handler error cmp list = + let list = sort_inner list in + let rec visit elements_to_store stored_elements last_element + last_element_occurrences = + match elements_to_store, last_element with + | (_, _, t, _, list) :: q, Some (_, _, old, _) when compare t old = 0 -> + visit q stored_elements last_element + (List.fold_left + (fun list a -> a :: list) + list last_element_occurrences) + | (grid, graph, t, event, list) :: q, Some (grid', graph', a, event') -> + visit q + ((grid', graph', a, event', List.sort cmp last_element_occurrences) + :: stored_elements) + (Some (grid, graph, t, event)) + (*List.rev*) list + | (grid, graph, t, event, list) :: q, None -> + visit q stored_elements (Some (grid, graph, t, event)) (List.rev list) + | [], None -> [] + | [], Some (grid, graph, a, event) -> + List.rev + ((grid, graph, a, event, List.sort cmp last_element_occurrences) + :: stored_elements) + in + let list = visit list [] None [] in + error, list + + let hash_list parameter handler log_info error list = + let list = sort_outer (List.rev list) in + let rec visit elements_to_store stored_elements last_element + last_element_occurrences = + match elements_to_store, last_element with + | ((t : prehash), list) :: q, Some old when compare t old = 0 -> + visit q stored_elements last_element + (List.fold_left + (fun list a -> a :: list) + list last_element_occurrences) + | (t, list) :: q, Some a -> + visit q ((a, last_element_occurrences) :: stored_elements) (Some t) list + | (t, list) :: q, None -> visit q stored_elements (Some t) (List.rev list) + | [], None -> [] + | [], Some a -> List.rev ((a, last_element_occurrences) :: stored_elements) + in + let list = visit list [] None [] in + let rec visit2 l log_info error acc = + match l with + | [] -> error, log_info, acc + | (t, list) :: q -> + if List.length list = 1 then + visit2 q log_info error ((t, list) :: acc) + else ( + let error, log_info, list' = + List.fold_left + (fun (error, log_info, list') (grid, graph, dag, b, c) -> + let error, log_info, dag' = + match dag with + | None -> canonicalize parameter handler log_info error graph + | Some dag -> error, log_info, dag + in + error, log_info, (grid, graph, Some dag', b, c) :: list') + (error, log_info, []) list + in + let error, list' = + hash_inner parameter handler error + Trace.Simulation_info.compare_by_story_id list' + in + visit2 q log_info error ((t, list') :: acc) + ) + in + let error, log_info, list = visit2 list log_info error [] in + error, log_info, list + + let project_tuple (grid, _, _, trace, list) = List.hd list, trace, grid, list + let sort_list _parameter _handler log_info error list = + let flat_list = + List.fold_left + (fun list_out (_prehash, list) -> + List.fold_left + (fun list_out tuple -> project_tuple tuple :: list_out) + list_out list) + [] list + in + let compare_pair (a, _, _, _) (c, _, _, _) = + Trace.Simulation_info.compare_by_story_id a c + in + let flat_list = List.sort compare_pair flat_list in + ( error, + log_info, + List.rev_map (fun (_a, b, c, d) -> b, c, d) (List.rev flat_list) ) + + let count_stories list = + List.fold_left (fun n l -> n + List.length (snd l)) 0 list + + let fold_table parameter handler log_info (error : Exception.method_handler) g + list a = + List.fold_left + (fun a (_, l) -> + List.fold_left + (fun (error, log_info, a) (_, _, _, x, y) -> + g parameter handler log_info error x y a) + a l) + (error, log_info, a) (List.rev list) +end -module ListTable = - ( - struct - type table = (prehash * (Causal.grid * graph * canonical_form option * Trace.t * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) list) list +module BucketTable : StoryTable = struct + type story_id = int - let init_table _parameter _handler log_info error = - error,log_info,[] + let succ_story_id = succ - let add_story parameter handler log_info error grid pretrace info table = - let error,log_info,graph = graph_of_grid parameter handler log_info error grid in - let error,prehash = prehash parameter handler error graph in - error,log_info,(prehash,[grid,graph,None,pretrace,info])::table + type prehash_elt = node * int + module KeyS = SetMap.Make (struct + type t = key - let sort_outer = - let compare (a,_) (b,_) = compare_prehash a b in - List.sort compare + let compare = compare + let print _ _ = () + end) - let sort_inner = - let compare (_,_,a,_,_) (_,_,b,_,_) = compare_canonic_opt a b in - List.sort compare + module PreHashS = SetMap.Make (struct + type t = prehash_elt - let hash_inner _parameter _handler error cmp list = - let list = sort_inner list in - let rec visit elements_to_store stored_elements last_element last_element_occurrences = - match elements_to_store,last_element - with - | (_,_,t,_,list)::q,Some (_,_,old,_) when compare t old = 0 -> - visit - q - stored_elements - last_element - (List.fold_left - (fun list a -> a::list) - list - last_element_occurrences) - | (grid,graph,t,event,list)::q,Some (grid',graph',a,event') -> - - visit q ((grid',graph',a,event',List.sort cmp last_element_occurrences)::stored_elements) (Some (grid,graph,t,event)) ((*List.rev*) list) - | (grid,graph,t,event,list)::q,None -> - visit q stored_elements (Some (grid,graph,t,event)) (List.rev list) - | [],None -> [] - | [],Some (grid,graph,a,event) -> - List.rev ((grid,graph,a,event,List.sort cmp last_element_occurrences)::stored_elements) - in - let list = visit list [] None [] in - error,list + let compare = compare + let print _ _ = () + end) - let hash_list parameter handler log_info error list = - let list = sort_outer (List.rev list) in - let rec visit elements_to_store stored_elements last_element last_element_occurrences = - match elements_to_store,last_element - with - | ((t:prehash),list)::q,Some old when compare t old = 0 -> - visit q stored_elements last_element - (List.fold_left - (fun list a -> a::list) list last_element_occurrences) - | (t,list)::q,Some a -> - visit q ((a,last_element_occurrences)::stored_elements) (Some t) list - | (t,list)::q,None -> - visit q stored_elements (Some t) (List.rev list) - | [],None -> [] - | [],Some a -> - List.rev ((a,last_element_occurrences)::stored_elements) - in - let list = visit list [] None [] in - let rec visit2 l log_info error acc = - match l - with - | [] -> error,log_info,acc - | (t,list)::q -> - if List.length list = 1 - then visit2 q log_info error ((t,list)::acc) - else - let error,log_info,list' = - List.fold_left - (fun (error,log_info,list') (grid,graph,dag,b,c) -> - let error,log_info,dag' = - match dag - with - | None -> canonicalize parameter handler log_info error graph - | Some dag -> error,log_info,dag - in - (error,log_info,(grid,graph,Some dag',b,c)::list') - ) - (error,log_info,[]) list - in - let error,list' = - hash_inner parameter handler error - Trace.Simulation_info.compare_by_story_id - list' - in - visit2 q log_info error ((t,list')::acc) - in - let error,log_info,list = visit2 list log_info error [] in - error,log_info,list + module KeyMap = KeyS.Map + module PreHashMap = PreHashS.Map - let project_tuple (grid,_,_,trace,list) = - List.hd list,trace,grid,list + type inner_tree = + | Inner_node of (inner_tree KeyMap.t * story_id option) + | Inner_leave of (key list * story_id) - let sort_list _parameter _handler log_info error list = - let flat_list = - List.fold_left - (fun list_out (_prehash,list) -> - List.fold_left - (fun list_out tuple -> - (project_tuple tuple)::list_out - ) - list_out list) - [] list - in - let compare_pair (a,_,_,_) (c,_,_,_) = - Trace.Simulation_info.compare_by_story_id a c in - let flat_list = List.sort compare_pair flat_list in - error, log_info, List.rev_map (fun (_a,b,c,d) -> b,c,d) (List.rev flat_list) + type outer_tree = + | Empty + | Outer_node of (outer_tree PreHashMap.t * story_id option) + | Outer_leave of (prehash_elt list * story_id) + | To_inner of (outer_tree PreHashMap.t * inner_tree) - let count_stories list = - List.fold_left - (fun n l -> n + List.length (snd l)) - 0 - list + type table = { + tree: outer_tree; + array: + (Causal.grid + * graph + * canonical_form option + * Trace.t + * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) + Int_storage.Nearly_inf_Imperatif.t; + fresh_id: story_id; + } - let fold_table parameter handler log_info (error:Exception.method_handler) g list a = - List.fold_left - (fun a (_,l) -> - List.fold_left - (fun (error,log_info,a) (_,_,_,x,y) -> g parameter handler log_info error x y a) - a - l) - (error,log_info,a) - (List.rev list) - - end:StoryTable) - -module BucketTable = - (struct - type story_id = int - let succ_story_id = succ - type prehash_elt = node * int - - module KeyS = (SetMap.Make (struct type t = key - let compare = compare - let print _ _ = () end)) - module PreHashS = (SetMap.Make (struct type t = prehash_elt - let compare = compare - let print _ _ = () end)) - module KeyMap = KeyS.Map - module PreHashMap = PreHashS.Map - - type inner_tree = - | Inner_node of (inner_tree KeyMap.t * story_id option) - | Inner_leave of (key list * story_id) - - - type outer_tree = - | Empty - | Outer_node of (outer_tree PreHashMap.t * story_id option) - | Outer_leave of (prehash_elt list * story_id) - | To_inner of (outer_tree PreHashMap.t * inner_tree) - - type table = - { - tree: outer_tree; - array: (Causal.grid * graph * canonical_form option * Trace.t * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) Int_storage.Nearly_inf_Imperatif.t; - fresh_id: story_id - } - - - let init_table parameters _handler log_info error= - let error,array = Int_storage.Nearly_inf_Imperatif.create (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters) error 0 in - error,log_info,{ - tree= Empty; - array= array; - fresh_id= 0 } - - let get_cannonical_form parameter handler log_info error id table = - let error,assoc = - Int_storage.Nearly_inf_Imperatif.get + let init_table parameters _handler log_info error = + let error, array = + Int_storage.Nearly_inf_Imperatif.create + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters) + error 0 + in + error, log_info, { tree = Empty; array; fresh_id = 0 } + + let get_cannonical_form parameter handler log_info error id table = + let error, assoc = + Int_storage.Nearly_inf_Imperatif.get + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error id table.array + in + match assoc with + | None -> + let error, a = + warn parameter error __POS__ ~message:"unknown story id" + (Failure "Inconsistent story id") (table, []) + in + error, log_info, a + | Some (_, _, Some cannonic, _, _) -> error, log_info, (table, cannonic) + | Some (grid, graph, None, trace, info) -> + let error, log_info, cannonic = + canonicalize parameter handler log_info error graph + in + let error, array' = + Int_storage.Nearly_inf_Imperatif.set (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error - id + error id + (grid, graph, Some cannonic, trace, info) table.array in - match assoc - with - None -> - let error,a = - warn - parameter error __POS__ - ~message:"unknown story id" - (Failure "Inconsistent story id") - (table,[]) + let table = { table with array = array' } in + error, log_info, (table, cannonic) + + let add_story parameter handler log_info error grid pretrace story_info table + = + let error, log_info, graph = + graph_of_grid parameter handler log_info error grid + in + let error, prehash = prehash parameter handler error graph in + let assoc = grid, graph, None, pretrace, story_info in + let add_story error x table = + let error, array = + Int_storage.Nearly_inf_Imperatif.set + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error table.fresh_id x table.array + in + let error = + if + S.PH.B.PB.CI.Po.K.H.is_server_mode parameter + && S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter + then ( + let error = + print_graph + (S.PH.B.PB.CI.Po.K.H.get_server_channel parameter) + parameter handler error table.fresh_id story_info graph + in + error + ) else + error + in + ( error, + log_info, + table.fresh_id, + { table with array; fresh_id = succ_story_id table.fresh_id } ) + in + let add_story_info error story_info id table = + let error, asso_opt = + Int_storage.Nearly_inf_Imperatif.get + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error id table.array + in + match asso_opt with + | None -> + warn parameter error __POS__ ~message:"Unknown story id" + (Failure "Unknown story id") table + | Some (grid, graph, canonic, trace, info) -> + let current_compression_mode parameter = + match H.get_current_compression_mode parameter with + | None -> Story_json.Causal + | Some x -> x in - error,log_info,a - | Some (_,_,Some cannonic,_,_) -> - error,log_info,(table,cannonic) - | Some (grid,graph,None,trace,info) -> - let error,log_info,cannonic = canonicalize parameter handler log_info error graph in - let error,array' = Int_storage.Nearly_inf_Imperatif.set - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error id (grid,graph,Some cannonic,trace,info) table.array in - let table = {table with array = array'} in - error,log_info,(table,cannonic) - - let add_story parameter handler log_info error grid pretrace story_info table = - let error,log_info,graph = graph_of_grid parameter handler log_info error grid in - let error,prehash = prehash parameter handler error graph in - let assoc = (grid,graph,None,pretrace,story_info) in - let add_story error x table = - let error,array = + let result = + { + Story_json.story_mode = current_compression_mode parameter; + Story_json.log_info = story_info; + Story_json.story = Story_json.Same_as id; + } + in + let () = + if + S.PH.B.PB.CI.Po.K.H.is_server_mode parameter + && S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter + then + S.PH.B.PB.CI.Po.K.H.push_json parameter (Story_json.Story result) + in + let error, array = Int_storage.Nearly_inf_Imperatif.set (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error table.fresh_id x table.array in - let error = - if S.PH.B.PB.CI.Po.K.H.is_server_mode parameter && - S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter - then - let error = - print_graph - (S.PH.B.PB.CI.Po.K.H.get_server_channel parameter) - parameter - handler - error - table.fresh_id - story_info - graph - in error - else - error + error id + (grid, graph, canonic, trace, story_info @ info) + table.array in - error,log_info,table.fresh_id, - {table - with - array = array ; - fresh_id = succ_story_id table.fresh_id} - in - let add_story_info error story_info id table = - let error,asso_opt = Int_storage.Nearly_inf_Imperatif.get (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error id table.array in - match - asso_opt - with - | None -> - warn - parameter error __POS__ - ~message:"Unknown story id" - (Failure "Unknown story id") - table - | Some (grid,graph,canonic,trace,info) -> - let current_compression_mode parameter = - match H.get_current_compression_mode parameter - with - | None -> Story_json.Causal - | Some x -> x + error, { table with array } + in + let update_assoc error canonic_form assoc = + match assoc with + | grid, graph, None, trace, info -> + error, (grid, graph, Some canonic_form, trace, info) + | _, _, Some _, _, _ -> + warn parameter error __POS__ + ~message: + "the canonical form of this story should not have been computed yet" + (Failure + "the canonical form of stories should not have been computed yet") + assoc + in + let rec aux_inner2 log_info error canonic_form canonic_form' id' assoc table + = + match canonic_form, canonic_form' with + | [], [] -> + let error, table = add_story_info error story_info id' table in + error, log_info, table, Inner_leave ([], id') + | t :: q, [] -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Inner_node (KeyMap.add t (Inner_leave (q, id)) KeyMap.empty, Some id') + ) + | [], t' :: q' -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Inner_node + (KeyMap.add t' (Inner_leave (q', id')) KeyMap.empty, Some id) ) + | t :: q, t' :: q' when t = t' -> + let error, log_info, table, tree = + aux_inner2 log_info error q q' id' assoc table + in + error, log_info, table, Inner_node (KeyMap.add t tree KeyMap.empty, None) + | t :: q, t' :: q' -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Inner_node + ( KeyMap.add t + (Inner_leave (q, id)) + (KeyMap.add t' (Inner_leave (q', id')) KeyMap.empty), + None ) ) + in + let rec aux_outer2 log_info error prehash prehash' id' table = + match prehash, prehash' with + | [], [] -> + let error, log_info, cannonic_form = + canonicalize parameter handler log_info error graph + in + let error, assoc = update_assoc error cannonic_form assoc in + let error, log_info, (table, cannonic_form') = + get_cannonical_form parameter handler log_info error id' table + in + let error, log_info, table, inner = + aux_inner2 log_info error cannonic_form cannonic_form' id' assoc table + in + error, log_info, table, To_inner (PreHashMap.empty, inner) + | t :: q, [] -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Outer_node + (PreHashMap.add t (Outer_leave (q, id)) PreHashMap.empty, Some id') + ) + | [], t' :: q' -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Outer_node + (PreHashMap.add t' (Outer_leave (q', id')) PreHashMap.empty, Some id) + ) + | t :: q, t' :: q' when t = t' -> + let error, log_info, table, tree = + aux_outer2 log_info error q q' id' table + in + ( error, + log_info, + table, + Outer_node (PreHashMap.add t tree PreHashMap.empty, None) ) + | t :: q, t' :: q' -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Outer_node + ( PreHashMap.add t + (Outer_leave (q, id)) + (PreHashMap.add t' (Outer_leave (q', id')) PreHashMap.empty), + None ) ) + in + let rec aux_inner log_info error assoc story_info suffix inner_tree table = + match suffix with + | [] -> + (match inner_tree with + | Inner_node (map, None) -> + let error, log_info, id, table = add_story error assoc table in + error, log_info, table, Inner_node (map, Some id) + | Inner_node (_, Some id') | Inner_leave ([], id') -> + let error, table = add_story_info error story_info id' table in + error, log_info, table, inner_tree + | Inner_leave (t' :: q', id') -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Inner_node + (KeyMap.add t' (Inner_leave (q', id')) KeyMap.empty, Some id) )) + | t :: q -> + (match inner_tree with + | Inner_node (map, assoc') -> + (match KeyMap.find_option t map with + | None -> + let error, log_info, id, table = add_story error assoc table in + let inner_tree = + Inner_node (KeyMap.add t (Inner_leave (q, id)) map, assoc') + in + error, log_info, table, inner_tree + | Some inner_tree' -> + let error, log_info, table', inner_tree'' = + aux_inner log_info error assoc story_info q inner_tree' table + in + if inner_tree'' == inner_tree' then + error, log_info, table', inner_tree + else + ( error, + log_info, + table', + Inner_node (KeyMap.add t inner_tree'' map, assoc') )) + | Inner_leave (l', id') -> + aux_inner2 log_info error suffix l' id' assoc table) + in + let rec aux_outer log_info error assoc story_info suffix outer_tree table = + match suffix with + | [] -> + (match outer_tree with + | Empty -> + let error, log_info, id, table = add_story error assoc table in + error, log_info, table, Outer_leave (suffix, id) + | Outer_node (map, None) -> + let error, log_info, id, table = add_story error assoc table in + error, log_info, table, Outer_node (map, Some id) + | Outer_node (map, Some id') -> + let error, graph = + match assoc with + | _, graph, None, _, _ -> error, graph + | _, graph, Some _, _, _ -> + warn parameter error __POS__ + ~message: + "the canonical form of stories in the outer tree should not \ + have been computed yet" + (Failure + "the canonical form of stories in the outer tree should not \ + have been compute yet") + graph in - let result = - { - Story_json.story_mode = current_compression_mode parameter; - Story_json.log_info = story_info ; - Story_json.story = Story_json.Same_as id - } + let error, log_info, cannonic_form = + canonicalize parameter handler log_info error graph in - let () = - if S.PH.B.PB.CI.Po.K.H.is_server_mode parameter && - S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter - then - S.PH.B.PB.CI.Po.K.H.push_json parameter (Story_json.Story result) + let error, assoc = update_assoc error cannonic_form assoc in + let error, log_info, (table, cannonic_form') = + get_cannonical_form parameter handler log_info error id' table in - let error,array = Int_storage.Nearly_inf_Imperatif.set - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error id - (grid,graph,canonic,trace,story_info@info) table.array + let error, log_info, table, inner = + aux_inner2 log_info error cannonic_form cannonic_form' id' assoc + table in - error,{table with array = array} - in - let update_assoc error canonic_form assoc = - match - assoc - with - | (grid,graph,None,trace,info) -> error,(grid,graph,Some canonic_form,trace,info) - | (_,_,Some _,_,_) -> - warn - parameter error __POS__ - ~message:"the canonical form of this story should not have been computed yet" - (Failure "the canonical form of stories should not have been computed yet") - assoc - in - let rec aux_inner2 log_info error canonic_form canonic_form' id' assoc table = - match canonic_form,canonic_form' - with - | [],[] -> - let error,table = add_story_info error story_info id' table in - error,log_info,table,Inner_leave ([],id') - | t::q,[] -> - let error,log_info,id,table = add_story error assoc table in - error, log_info, table, Inner_node (KeyMap.add t (Inner_leave(q,id)) KeyMap.empty,Some id') - | [],t'::q' -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, Inner_node (KeyMap.add t' (Inner_leave(q',id')) KeyMap.empty,Some id) - | t::q,t'::q' when t=t' -> - let error,log_info,table,tree = aux_inner2 log_info error q q' id' assoc table in - error,log_info,table, Inner_node (KeyMap.add t tree KeyMap.empty,None) - | t::q,t'::q' -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, Inner_node (KeyMap.add t (Inner_leave(q,id)) (KeyMap.add t' (Inner_leave(q',id')) KeyMap.empty),None) - in - let rec aux_outer2 log_info error prehash prehash' id' table = - match - prehash,prehash' - with - | [],[] -> - let error,log_info,cannonic_form = canonicalize parameter handler log_info error graph in - let error,assoc = update_assoc error cannonic_form assoc in - let error,log_info,(table,cannonic_form') = get_cannonical_form parameter handler log_info error id' table in - let error,log_info,table,inner = aux_inner2 log_info error cannonic_form cannonic_form' id' assoc table in - error,log_info,table,To_inner (PreHashMap.empty, inner) - | t::q,[] -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, Outer_node (PreHashMap.add t (Outer_leave(q,id)) PreHashMap.empty,Some id') - | [],t'::q' -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, Outer_node (PreHashMap.add t' (Outer_leave(q',id')) PreHashMap.empty,Some id) - | t::q,t'::q' when t=t' -> - let error,log_info,table,tree = aux_outer2 log_info error q q' id' table in - error,log_info,table, Outer_node (PreHashMap.add t tree PreHashMap.empty,None) - | t::q,t'::q' -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, Outer_node (PreHashMap.add t (Outer_leave(q,id)) (PreHashMap.add t' (Outer_leave(q',id')) PreHashMap.empty),None) - in - let rec aux_inner log_info error assoc story_info suffix inner_tree table = - match - suffix - with - | [] -> - begin - match - inner_tree - with - | Inner_node (map,None) -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, - Inner_node (map , (Some id)) - | Inner_node (_,Some id') - | Inner_leave ([],id') -> - let error,table = add_story_info error story_info id' table in - error,log_info,table,inner_tree - | Inner_leave (t'::q',id') -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table,Inner_node (KeyMap.add t' (Inner_leave (q',id')) KeyMap.empty,Some id) - end - | t::q -> - begin - match - inner_tree - with - | Inner_node (map,assoc') -> - begin - match - KeyMap.find_option t map - with - | None -> - let error,log_info,id,table = add_story error assoc table in - let inner_tree = - Inner_node (KeyMap.add t (Inner_leave (q,id)) map,assoc') - in - error,log_info,table,inner_tree - | Some (inner_tree') -> - let error,log_info,table',inner_tree'' = aux_inner log_info error assoc story_info q inner_tree' table in - if inner_tree'' == inner_tree' - then error,log_info,table',inner_tree - else - error,log_info,table',Inner_node(KeyMap.add t inner_tree'' map,assoc') - end - | Inner_leave (l',id') -> - aux_inner2 log_info error suffix l' id' assoc table - end - in - let rec aux_outer log_info error assoc story_info suffix outer_tree table = - match - suffix - with - | [] -> - begin - match - outer_tree - with - | Empty -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table,Outer_leave(suffix,id) - | Outer_node (map,None) -> - let error,log_info, id,table = add_story error assoc table in - error,log_info,table,Outer_node (map , Some id) - | Outer_node (map,Some id') -> - let error,graph = - match - assoc - with - | (_,graph,None,_,_) -> error,graph - | (_,graph,Some _,_,_) -> - warn - parameter error __POS__ - ~message:"the canonical form of stories in the outer tree should not have been computed yet" - (Failure - "the canonical form of stories in the outer tree should not have been compute yet") graph - in - let error,log_info,cannonic_form = canonicalize parameter handler log_info error graph in - let error,assoc = update_assoc error cannonic_form assoc in - let error,log_info,(table,cannonic_form') = get_cannonical_form parameter handler log_info error id' table in - let error,log_info,table,inner = aux_inner2 log_info error cannonic_form cannonic_form' id' assoc table in - error,log_info,table,To_inner (map, inner) - | Outer_leave (_q,id') -> - let error,table = add_story_info error story_info id' table in - error,log_info,table,outer_tree - | To_inner (map,inner) -> - let error,log_info,suffix = canonicalize parameter handler log_info error graph in - let error,assoc = update_assoc error suffix assoc in - let error,log_info,table,inner = aux_inner log_info error assoc story_info suffix inner table in - error,log_info,table,To_inner(map,inner) - end - | t::q -> - begin - match - outer_tree - with - | Empty -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table,Outer_leave(suffix,id) - | Outer_node (map,assoc') -> - begin - match - PreHashMap.find_option t map - with - | None -> - let error,log_info,id,table = add_story error assoc table in - let inner_tree = - Outer_node (PreHashMap.add t (Outer_leave (q,id)) map,assoc') - in - error,log_info,table,inner_tree - | Some (outer_tree') -> - let error,log_info,table',outer_tree'' = aux_outer log_info error assoc story_info q outer_tree' table in - if outer_tree'' == outer_tree' - then error,log_info,table',outer_tree - else - error,log_info,table',Outer_node(PreHashMap.add t outer_tree'' map,assoc') - end - | Outer_leave (t'::q',id') when not (t = t') -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, Outer_node (PreHashMap.add t (Outer_leave (q,id)) (PreHashMap.add t' (Outer_leave (q',id')) PreHashMap.empty),None) - | Outer_leave (l',id') -> - aux_outer2 log_info error suffix l' id' table - | To_inner (_map,inner) -> - let error,log_info,id,table = add_story error assoc table in - error,log_info,table, To_inner (PreHashMap.add t (Outer_leave (q,id)) (PreHashMap.add t (Outer_leave (q,id)) PreHashMap.empty),inner) - end - in - let error,log_info,table,tree = aux_outer log_info error (grid,graph,None,pretrace,story_info) story_info prehash table.tree table in - error,log_info,{table with tree = tree} - - (* let rec print_inner_tree parameter handler error prefix inner_tree = - match - inner_tree - with - | Inner_node (map,assoc') -> - let () = - match - assoc' - with - | None -> - Format.fprintf parameter.H.out_channel "%sUnfilled Node\n" prefix - | Some (id) -> - Format.fprintf parameter.H.out_channel "%sFilled Node: %i\n" prefix id + error, log_info, table, To_inner (map, inner) + | Outer_leave (_q, id') -> + let error, table = add_story_info error story_info id' table in + error, log_info, table, outer_tree + | To_inner (map, inner) -> + let error, log_info, suffix = + canonicalize parameter handler log_info error graph + in + let error, assoc = update_assoc error suffix assoc in + let error, log_info, table, inner = + aux_inner log_info error assoc story_info suffix inner table in - let prefix' = prefix^" " in - KeyMap.iter - (fun elt map -> - print_elt parameter.H.out_channel elt; - print_inner_tree parameter handler error prefix' map) - map - | Inner_leave (l,id) -> - let () = Format.fprintf parameter.H.out_channel "%sLEAVE:\n" prefix in - let _ = print_canonical_form parameter handler error l in - ()*) - - (* + error, log_info, table, To_inner (map, inner)) + | t :: q -> + (match outer_tree with + | Empty -> + let error, log_info, id, table = add_story error assoc table in + error, log_info, table, Outer_leave (suffix, id) + | Outer_node (map, assoc') -> + (match PreHashMap.find_option t map with + | None -> + let error, log_info, id, table = add_story error assoc table in + let inner_tree = + Outer_node (PreHashMap.add t (Outer_leave (q, id)) map, assoc') + in + error, log_info, table, inner_tree + | Some outer_tree' -> + let error, log_info, table', outer_tree'' = + aux_outer log_info error assoc story_info q outer_tree' table + in + if outer_tree'' == outer_tree' then + error, log_info, table', outer_tree + else + ( error, + log_info, + table', + Outer_node (PreHashMap.add t outer_tree'' map, assoc') )) + | Outer_leave (t' :: q', id') when not (t = t') -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + Outer_node + ( PreHashMap.add t + (Outer_leave (q, id)) + (PreHashMap.add t' (Outer_leave (q', id')) PreHashMap.empty), + None ) ) + | Outer_leave (l', id') -> aux_outer2 log_info error suffix l' id' table + | To_inner (_map, inner) -> + let error, log_info, id, table = add_story error assoc table in + ( error, + log_info, + table, + To_inner + ( PreHashMap.add t + (Outer_leave (q, id)) + (PreHashMap.add t (Outer_leave (q, id)) PreHashMap.empty), + inner ) )) + in + let error, log_info, table, tree = + aux_outer log_info error + (grid, graph, None, pretrace, story_info) + story_info prehash table.tree table + in + error, log_info, { table with tree } + + (* let rec print_inner_tree parameter handler error prefix inner_tree = + match + inner_tree + with + | Inner_node (map,assoc') -> + let () = + match + assoc' + with + | None -> + Format.fprintf parameter.H.out_channel "%sUnfilled Node\n" prefix + | Some (id) -> + Format.fprintf parameter.H.out_channel "%sFilled Node: %i\n" prefix id + in + let prefix' = prefix^" " in + KeyMap.iter + (fun elt map -> + print_elt parameter.H.out_channel elt; + print_inner_tree parameter handler error prefix' map) + map + | Inner_leave (l,id) -> + let () = Format.fprintf parameter.H.out_channel "%sLEAVE:\n" prefix in + let _ = print_canonical_form parameter handler error l in + ()*) + + (* let rec print_outer_tree parameter handler error prefix outer_tree = match outer_tree @@ -1052,115 +1101,117 @@ let rec print_outer_tree parameter handler error prefix outer_tree = in print_inner_tree parameter handler error prefix' inner *) - let hash_list parameter _ log_info error table = - let error,array = - Int_storage.Nearly_inf_Imperatif.fold - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error - (fun parameter' error i (a,b,c,d,e) array -> - Int_storage.Nearly_inf_Imperatif.set - parameter' error - i - (a,b,c,d,List.sort Trace.Simulation_info.compare_by_story_id e) - array) - table.array - table.array - in - error,log_info,{table with array = array} - - let sort_list parameter _ log_info error table = - let error,l = - Int_storage.Nearly_inf_Imperatif.fold - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error - (fun _parameter error _ (a,_b,_c,d,e) l -> error,(d,a,e)::l) - table.array - [] - in error,log_info,l - - let count_stories table = table.fresh_id - - let fold_table parameter handler log_info error f table a = - let a,(b,c) = - Int_storage.Nearly_inf_Imperatif.fold_with_interruption - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error - (fun parameter' error _ (_,_,_,d,e) (log_info,a) -> - let a,b,c = f (S.PH.B.PB.CI.Po.K.H.set_kasa_parameters parameter' parameter) handler log_info error d e a in - a,(b,c)) - table.array - (log_info,a) - in a,b,c - - end:StoryTable) - -module type Selector = -sig - val choose_fst: H.parameter -> bool + let hash_list parameter _ log_info error table = + let error, array = + Int_storage.Nearly_inf_Imperatif.fold + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error + (fun parameter' error i (a, b, c, d, e) array -> + Int_storage.Nearly_inf_Imperatif.set parameter' error i + (a, b, c, d, List.sort Trace.Simulation_info.compare_by_story_id e) + array) + table.array table.array + in + error, log_info, { table with array } + + let sort_list parameter _ log_info error table = + let error, l = + Int_storage.Nearly_inf_Imperatif.fold + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error + (fun _parameter error _ (a, _b, _c, d, e) l -> error, (d, a, e) :: l) + table.array [] + in + error, log_info, l + + let count_stories table = table.fresh_id + + let fold_table parameter handler log_info error f table a = + let a, (b, c) = + Int_storage.Nearly_inf_Imperatif.fold_with_interruption + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error + (fun parameter' error _ (_, _, _, d, e) (log_info, a) -> + let a, b, c = + f + (S.PH.B.PB.CI.Po.K.H.set_kasa_parameters parameter' parameter) + handler log_info error d e a + in + a, (b, c)) + table.array (log_info, a) + in + a, b, c end +module type Selector = sig + val choose_fst : H.parameter -> bool +end -module Choice(S:Selector)(A:StoryTable)(B:StoryTable) = - (struct - type table = - | A of A.table - | B of B.table - - let init_table parameter handler log_info error = - if S.choose_fst parameter - then - let error,log_info,table = A.init_table parameter handler log_info error in - error,log_info,A(table) - else - let error,log_info,table = B.init_table parameter handler log_info error in - error,log_info,B(table) - - let add_story parameter handler log_info error grid pretrace info table = - match - table - with - | A(table) -> - let error,log_info,table = A.add_story parameter handler log_info error grid pretrace info table in - error,log_info,A(table) - | B(table) -> - let error,log_info,table = B.add_story parameter handler log_info error grid pretrace info table in - error,log_info,B(table) - - let hash_list parameter handler log_info error table = - match - table - with - | A(table) -> - let error,log_info,table = A.hash_list parameter handler log_info error table in - error,log_info,A(table) - | B(table) -> - let error,log_info,table = B.hash_list parameter handler log_info error table in - error,log_info,B(table) - - let sort_list parameter handler log_info error table = - match - table - with - | A(table) -> A.sort_list parameter handler log_info error table - | B(table) -> B.sort_list parameter handler log_info error table - - let count_stories table = - match - table - with - | A(table) -> A.count_stories table - | B(table) -> B.count_stories table +module Choice (S : Selector) (A : StoryTable) (B : StoryTable) : StoryTable = +struct + type table = A of A.table | B of B.table - let fold_table parameter handler log_info error g table a = - match - table - with - | A(table) -> A.fold_table parameter handler log_info error g table a - | B(table) -> B.fold_table parameter handler log_info error g table a + let init_table parameter handler log_info error = + if S.choose_fst parameter then ( + let error, log_info, table = + A.init_table parameter handler log_info error + in + error, log_info, A table + ) else ( + let error, log_info, table = + B.init_table parameter handler log_info error + in + error, log_info, B table + ) + let add_story parameter handler log_info error grid pretrace info table = + match table with + | A table -> + let error, log_info, table = + A.add_story parameter handler log_info error grid pretrace info table + in + error, log_info, A table + | B table -> + let error, log_info, table = + B.add_story parameter handler log_info error grid pretrace info table + in + error, log_info, B table - end:StoryTable) + let hash_list parameter handler log_info error table = + match table with + | A table -> + let error, log_info, table = + A.hash_list parameter handler log_info error table + in + error, log_info, A table + | B table -> + let error, log_info, table = + B.hash_list parameter handler log_info error table + in + error, log_info, B table + + let sort_list parameter handler log_info error table = + match table with + | A table -> A.sort_list parameter handler log_info error table + | B table -> B.sort_list parameter handler log_info error table + + let count_stories table = + match table with + | A table -> A.count_stories table + | B table -> B.count_stories table + + let fold_table parameter handler log_info error g table a = + match table with + | A table -> A.fold_table parameter handler log_info error g table a + | B table -> B.fold_table parameter handler log_info error g table a +end (* module StoryTable = ListTable*) (* module StoryTable = BucketTable*) -module StoryTable = Choice(struct let choose_fst = S.PH.B.PB.CI.Po.K.H.do_we_use_bucket_sort end)(BucketTable)(ListTable) +module StoryTable = + Choice + (struct + let choose_fst = S.PH.B.PB.CI.Po.K.H.do_we_use_bucket_sort + end) + (BucketTable) + (ListTable) diff --git a/core/cflow/dag.mli b/core/cflow/dag.mli index b1f4294aae..4fd9582e8e 100644 --- a/core/cflow/dag.mli +++ b/core/cflow/dag.mli @@ -19,26 +19,58 @@ * et en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type canonical_form type graph -val compare_canonic: canonical_form -> canonical_form -> int -val graph_of_grid: - (Causal.grid,graph) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary -val canonicalize: (graph,canonical_form) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary - -module type StoryTable = - sig - type table - - val fold_table: - ((Trace.t,StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list,'a,'a) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.ternary, table, 'a, 'a) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.ternary - val init_table: table Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.zeroary - val count_stories: table -> int - val add_story: (Causal.grid,Trace.t,StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list,table,table) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.quaternary - val hash_list: (table, table) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary - - val sort_list: (table, (Trace.t * Causal.grid * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) list) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary - end - -module StoryTable:StoryTable + +val compare_canonic : canonical_form -> canonical_form -> int + +val graph_of_grid : + ( Causal.grid, + graph ) + Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary + +val canonicalize : + ( graph, + canonical_form ) + Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary + +module type StoryTable = sig + type table + + val fold_table : + ( ( Trace.t, + StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list, + 'a, + 'a ) + Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.ternary, + table, + 'a, + 'a ) + Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.ternary + + val init_table : + table Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.zeroary + + val count_stories : table -> int + + val add_story : + ( Causal.grid, + Trace.t, + StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list, + table, + table ) + Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.quaternary + + val hash_list : + (table, table) Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary + + val sort_list : + ( table, + (Trace.t + * Causal.grid + * StoryProfiling.StoryStats.log_info Trace.Simulation_info.t list) + list ) + Generic_branch_and_cut_solver.Solver.PH.B.PB.CI.Po.K.H.unary +end + +module StoryTable : StoryTable diff --git a/core/cflow/dag2.ml b/core/cflow/dag2.ml index dc725baa4b..56a4f3019a 100644 --- a/core/cflow/dag2.ml +++ b/core/cflow/dag2.ml @@ -1,135 +1,109 @@ -type 'a superlist = - Elt of 'a -| Super_list of 'a superlist list list +type 'a superlist = Elt of 'a | Super_list of 'a superlist list list -let rec fold f a list = - match list - with - | Elt elt -> f a elt - | Super_list l -> - List.fold_left - (List.fold_left - (fold f)) - a l +let rec fold f a list = + match list with + | Elt elt -> f a elt + | Super_list l -> List.fold_left (List.fold_left (fold f)) a l -let rec compare_list compare l1 l2 = - match - l1 - with - | [] -> - begin - match l2 - with - | [] -> 0 - | _ -> -1 - end - | h1::t1 -> - begin - match l2 - with - | [] -> 1 - | h2::t2 -> - let cmp = compare h1 h2 in - match cmp - with - | 0 -> compare_list compare t1 t2 - | _ -> cmp - end +let rec compare_list compare l1 l2 = + match l1 with + | [] -> + (match l2 with + | [] -> 0 + | _ -> -1) + | h1 :: t1 -> + (match l2 with + | [] -> 1 + | h2 :: t2 -> + let cmp = compare h1 h2 in + (match cmp with + | 0 -> compare_list compare t1 t2 + | _ -> cmp)) let rec compare_superlist compare a b = - match a,b with - | Elt a,Elt b -> compare a b - | Super_list a,Super_list b -> - compare_list (compare_list (compare_superlist compare)) a b + match a, b with + | Elt a, Elt b -> compare a b + | Super_list a, Super_list b -> + compare_list (compare_list (compare_superlist compare)) a b | Elt _, Super_list _ -> -1 | Super_list _, Elt _ -> 1 -let rec sort compare superlist = - match - superlist - with - | Elt a -> Elt a - | Super_list a -> - Super_list - (List.rev_map - (fun l -> - let l' = List.rev_map (sort compare) l in - let l' = List.sort (compare_superlist compare) l' in - l' - ) +let rec sort compare superlist = + match superlist with + | Elt a -> Elt a + | Super_list a -> + Super_list + (List.rev_map + (fun l -> + let l' = List.rev_map (sort compare) l in + let l' = List.sort (compare_superlist compare) l' in + l') (List.rev a)) let dump_super_list f s l = let rec aux depth f l = match l with - | Elt a -> - Format.fprintf f "%s%a@," depth s a + | Elt a -> Format.fprintf f "%s%a@," depth s a | Super_list l -> - Pp.list - Pp.cut - (fun f l -> - Format.fprintf f "%s@,%a" depth - (Pp.list - Pp.cut (fun f l -> - Format.fprintf - f "(%s@,%a" depth (aux ("--"^depth)) l) - ) l - ) f l - in Format.fprintf f "@[%a@]@." (aux "->") l + Pp.list Pp.cut + (fun f l -> + Format.fprintf f "%s@,%a" depth + (Pp.list Pp.cut (fun f l -> + Format.fprintf f "(%s@,%a" depth (aux ("--" ^ depth)) l)) + l) + f l + in + Format.fprintf f "@[%a@]@." (aux "->") l -type 'a info = - { - pred_1: int list ; - conflict_1: int list ; - label: 'a ; - depth: int - } +type 'a info = { pred_1: int list; conflict_1: int list; label: 'a; depth: int } -let compare_fst_triple (a,_,_) (b,_,_) = compare a b +let compare_fst_triple (a, _, _) (b, _, _) = compare a b let smash compare l = let rec aux to_do old current accu = match to_do with - | [] -> current::accu - | h::t -> - if compare h old = 0 - then aux t old (h::current) accu - else aux t h [h] (current::accu) + | [] -> current :: accu + | h :: t -> + if compare h old = 0 then + aux t old (h :: current) accu + else + aux t h [ h ] (current :: accu) in match l with | Elt a -> Elt a | Super_list l -> - Super_list - (List.rev (List.fold_left - (fun accu l -> - match l with - | [] -> accu - | h::t -> aux t h [h] accu) - [] l)) + Super_list + (List.rev + (List.fold_left + (fun accu l -> + match l with + | [] -> accu + | h :: t -> aux t h [ h ] accu) + [] l)) -(*let l = - Super_list - [ +(*let l = + Super_list [ - Super_list - [ - [Elt (2,0,0);Elt (3,0,0);Elt (4,0,0)]; - [Elt (1,1,1);Elt (2,1,1);Elt (3,1,1)]; - [Elt (2,2,2);Elt (4,2,2);Elt (5,3,3)]; - [Elt (1,4,4);Elt (2,4,4);Elt (3,4,4)]]; - Super_list - [[Elt (1,5,5);Elt (2,5,5)]]; - Super_list - [[Elt (1,6,6);Elt (2,6,6)]]]];; + [ + Super_list + [ + [Elt (2,0,0);Elt (3,0,0);Elt (4,0,0)]; + [Elt (1,1,1);Elt (2,1,1);Elt (3,1,1)]; + [Elt (2,2,2);Elt (4,2,2);Elt (5,3,3)]; + [Elt (1,4,4);Elt (2,4,4);Elt (3,4,4)]]; + Super_list + [[Elt (1,5,5);Elt (2,5,5)]]; + Super_list + [[Elt (1,6,6);Elt (2,6,6)]]]];; -let dump_triple (a,b,c) = ("("^(string_of_int a)^","^(string_of_int b)^","^(string_of_int c)^")") + let dump_triple (a,b,c) = ("("^(string_of_int a)^","^(string_of_int b)^","^(string_of_int c)^")") -let _ = dump_super_list dump_triple l -let l1 = sort compare_fst_triple l -let _ = dump_super_list dump_triple l1 -let l2 = smash (compare_superlist compare_fst_triple) l1 -let _ = dump_super_list dump_triple l2 *) - (* + let _ = dump_super_list dump_triple l + let l1 = sort compare_fst_triple l + let _ = dump_super_list dump_triple l1 + let l2 = smash (compare_superlist compare_fst_triple) l1 + let _ = dump_super_list dump_triple l2 *) +(* let normal_form root compare f = let deal_with_elt elt = let info = f x in diff --git a/core/cflow/dune b/core/cflow/dune index 03c683a973..d5e83955fe 100644 --- a/core/cflow/dune +++ b/core/cflow/dune @@ -1,16 +1,32 @@ (library - (name kappa_cflow) - (libraries yojson result - kappa_profiling kappa_kasa_kastor_toolset kappa_classical_graphs) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms - -open Kappa_runtime - -open Kappa_cli - -open Kappa_logging - -open Kappa_profiling - -open Kappa_errors - -open Kappa_kasa_kastor_toolset - -open Kappa_parameters - -open Kappa_classical_graphs))) + (name kappa_cflow) + (libraries + yojson + result + kappa_profiling + kappa_kasa_kastor_toolset + kappa_classical_graphs) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms + -open + Kappa_runtime + -open + Kappa_cli + -open + Kappa_logging + -open + Kappa_profiling + -open + Kappa_errors + -open + Kappa_kasa_kastor_toolset + -open + Kappa_parameters + -open + Kappa_classical_graphs))) diff --git a/core/cflow/generic_branch_and_cut_solver.ml b/core/cflow/generic_branch_and_cut_solver.ml index 450b8690f8..f28cef0534 100644 --- a/core/cflow/generic_branch_and_cut_solver.ml +++ b/core/cflow/generic_branch_and_cut_solver.ml @@ -20,344 +20,408 @@ let log_steps = false -module type Solver = - (sig - module PH:Propagation_heuristics.Blackboard_with_heuristic - - val compress: (PH.B.blackboard,PH.update_order list,PH.B.blackboard * PH.B.assign_result * PH.B.result list) PH.B.PB.CI.Po.K.H.binary - val detect_independent_events: (PH.B.blackboard,PH.B.PB.step_id list,PH.B.PB.step_id list) PH.B.PB.CI.Po.K.H.binary - val filter: (PH.B.blackboard,PH.B.PB.step_id list,PH.B.blackboard) PH.B.PB.CI.Po.K.H.binary - - val sub: (Trace.t,PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary - - val clean: (PH.B.blackboard,PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary - - val translate: (PH.B.blackboard,PH.B.PB.step_id list,Trace.t*PH.B.result) PH.B.PB.CI.Po.K.H.binary - val translate_result: PH.B.result -> Trace.t - - end) - +module type Solver = sig + module PH : Propagation_heuristics.Blackboard_with_heuristic + + val compress : + ( PH.B.blackboard, + PH.update_order list, + PH.B.blackboard * PH.B.assign_result * PH.B.result list ) + PH.B.PB.CI.Po.K.H.binary + + val detect_independent_events : + ( PH.B.blackboard, + PH.B.PB.step_id list, + PH.B.PB.step_id list ) + PH.B.PB.CI.Po.K.H.binary + + val filter : + ( PH.B.blackboard, + PH.B.PB.step_id list, + PH.B.blackboard ) + PH.B.PB.CI.Po.K.H.binary + + val sub : (Trace.t, PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary + val clean : (PH.B.blackboard, PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary + + val translate : + ( PH.B.blackboard, + PH.B.PB.step_id list, + Trace.t * PH.B.result ) + PH.B.PB.CI.Po.K.H.binary + + val translate_result : PH.B.result -> Trace.t +end -module Solver = -struct - module PH= Propagation_heuristics.Propagation_heuristic -(*Blackboard_with_heuristic*) +module Solver = struct + module PH = Propagation_heuristics.Propagation_heuristic + (*Blackboard_with_heuristic*) - let warn parameter error pos ?message:(message="") exn default = + let warn parameter error pos ?(message = "") exn default = Exception.warn - (PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error pos - ~message exn default + (PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error pos ~message exn default let _combine_output o1 o2 = - if PH.B.is_ignored o2 then o1 else o2 + if PH.B.is_ignored o2 then + o1 + else + o2 - let rec propagate parameter handler log_info error instruction_list propagate_list blackboard = - let bool,log_info = PH.B.tick log_info in + let rec propagate parameter handler log_info error instruction_list + propagate_list blackboard = + let bool, log_info = PH.B.tick log_info in let _ = if bool then StoryProfiling.StoryStats.dump_complete_log - (PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) log_info + (PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + log_info in - match instruction_list - with - | t::q -> - begin - let error,log_info,(blackboard,instruction_list,propagate_list,assign_result) = PH.apply_instruction parameter handler log_info error blackboard t q propagate_list in - if PH.B.is_failed assign_result - then - error,log_info,(blackboard,assign_result) - else - propagate parameter handler log_info error instruction_list propagate_list blackboard - end - | [] -> - begin - match propagate_list - with - | t::q -> - let error,log_info,(blackboard,instruction_list,propagate_list,assign_result) = PH.propagate parameter handler log_info error blackboard t instruction_list q in - if PH.B.is_failed assign_result - then - error,log_info,(blackboard,assign_result) - else - propagate parameter handler log_info error instruction_list propagate_list blackboard - | [] -> error,log_info,(blackboard,PH.B.success) - end + match instruction_list with + | t :: q -> + let ( error, + log_info, + (blackboard, instruction_list, propagate_list, assign_result) ) = + PH.apply_instruction parameter handler log_info error blackboard t q + propagate_list + in + if PH.B.is_failed assign_result then + error, log_info, (blackboard, assign_result) + else + propagate parameter handler log_info error instruction_list + propagate_list blackboard + | [] -> + (match propagate_list with + | t :: q -> + let ( error, + log_info, + (blackboard, instruction_list, propagate_list, assign_result) ) = + PH.propagate parameter handler log_info error blackboard t + instruction_list q + in + if PH.B.is_failed assign_result then + error, log_info, (blackboard, assign_result) + else + propagate parameter handler log_info error instruction_list + propagate_list blackboard + | [] -> error, log_info, (blackboard, PH.B.success)) - type choices = - {current:PH.update_order list ; - stack:PH.update_order list list } + type choices = { + current: PH.update_order list; + stack: PH.update_order list list; + } + + let branch_choice_list choice_list = + { current = []; stack = choice_list.current :: choice_list.stack } + + let update_current choice_list list = { choice_list with current = list } - let branch_choice_list choice_list = {current = [] ; stack = choice_list.current::choice_list.stack} - let update_current choice_list list = {choice_list with current = list} let pop_next_choice parameter _handler error stack = - match stack.current - with - | t::q -> error,(t,{stack with current=q}) - | [] -> - warn - parameter error __POS__ - ~message:"Empty choice stack" - (Failure "Empty choice list in pop_next_choice") (PH.dummy_update_order,stack) + match stack.current with + | t :: q -> error, (t, { stack with current = q }) + | [] -> + warn parameter error __POS__ ~message:"Empty choice stack" + (Failure "Empty choice list in pop_next_choice") + (PH.dummy_update_order, stack) let no_more_choice stack = - match stack.current - with - | [] -> true - | _ -> false + match stack.current with + | [] -> true + | _ -> false let backtrack parameter handler log_info error blackboard choice_list = let rec backtrack_aux log_info error blackboard choice_list = - match choice_list.current - with - | [] -> - begin - match choice_list.stack - with - | [] -> error,log_info,(blackboard,None) - | t::q -> - let choice_list = {current = t ; stack = q } in - let error,log_info,blackboard = PH.B.reset_last_branching parameter handler log_info error blackboard in - backtrack_aux log_info error blackboard choice_list - end - | _ -> error,log_info,(blackboard,Some choice_list) + match choice_list.current with + | [] -> + (match choice_list.stack with + | [] -> error, log_info, (blackboard, None) + | t :: q -> + let choice_list = { current = t; stack = q } in + let error, log_info, blackboard = + PH.B.reset_last_branching parameter handler log_info error + blackboard + in + backtrack_aux log_info error blackboard choice_list) + | _ -> error, log_info, (blackboard, Some choice_list) + in + let error, log_info, blackboard = + PH.B.reset_last_branching parameter handler log_info error blackboard in - let error,log_info,blackboard = PH.B.reset_last_branching parameter handler log_info error blackboard in backtrack_aux log_info error blackboard choice_list - - let empty_choice_list = - {stack=[];current=[]} + let empty_choice_list = { stack = []; current = [] } let rec sublist l l' = - match l,l' - with - | [],_ -> true - | _,[] -> false - | h::t,h'::t' when h=h' -> sublist t t' - | _,_h'::t' -> sublist l t' + match l, l' with + | [], _ -> true + | _, [] -> false + | h :: t, h' :: t' when h = h' -> sublist t t' + | _, _h' :: t' -> sublist l t' let sort_stories_according_to_length l = - List.rev_map fst (List.sort (fun (_,a) (_,b) -> compare b a) (List.rev_map (fun a -> (a,List.length a)) l)) + List.rev_map fst + (List.sort + (fun (_, a) (_, b) -> compare b a) + (List.rev_map (fun a -> a, List.length a) l)) let filter_out_non_minimal_story l = let rec aux to_visit goodones = - match - to_visit - with + match to_visit with | [] -> List.rev goodones - | h::t -> - aux (List.filter (fun story -> not (sublist h story)) t) - (h::(List.filter (fun story -> not (sublist h story)) goodones)) - in aux (sort_stories_according_to_length l) [] + | h :: t -> + aux + (List.filter (fun story -> not (sublist h story)) t) + (h :: List.filter (fun story -> not (sublist h story)) goodones) + in + aux (sort_stories_according_to_length l) [] - let rec iter parameter handler log_info error blackboard choice_list story_list = - let error,log_info,bool = PH.B.is_maximal_solution parameter handler log_info error blackboard in - if bool - then + let rec iter parameter handler log_info error blackboard choice_list + story_list = + let error, log_info, bool = + PH.B.is_maximal_solution parameter handler log_info error blackboard + in + if bool then ( (* SUCCESS *) - let error,log_info,list = - PH.B.translate_blackboard parameter handler log_info error blackboard + let error, log_info, list = + PH.B.translate_blackboard parameter handler log_info error blackboard in - if PH.B.PB.CI.Po.K.H.get_all_stories_per_obs parameter - then - begin - let story_list = list::story_list in - let error,() = - if choice_list.current <> [] - then - warn - parameter error __POS__ - ~message:"In case of success, the current list of choices should be empty" - (Failure "In case of success, the current list of choices should be empty") () - else - error,() - in - let choice_list = - match choice_list.stack - with [] -> choice_list - | t::q -> { current=t;stack=q} - in - let error,log_info,(blackboard,choice_list) = backtrack parameter handler log_info error blackboard choice_list in - begin - match choice_list - with - | Some choice_list -> iter parameter handler log_info error blackboard choice_list story_list (*(update_first_story first_story list)*) - | None -> - let _ = - PH.B.export_blackboard_to_xls - parameter handler log_info error "FAIL" - (!Priority.n_story) (!Priority.n_branch) - blackboard - in - error,log_info,(blackboard,story_list) - end - end - else - error,log_info,(blackboard,[list]) - else - let error,choice_list = - if no_more_choice choice_list - then - let error,_log_info,list = - PH.next_choice parameter handler log_info error blackboard in - error,update_current choice_list list - else - error,choice_list + if PH.B.PB.CI.Po.K.H.get_all_stories_per_obs parameter then ( + let story_list = list :: story_list in + let error, () = + if choice_list.current <> [] then + warn parameter error __POS__ + ~message: + "In case of success, the current list of choices should be \ + empty" + (Failure + "In case of success, the current list of choices should be \ + empty") () + else + error, () + in + let choice_list = + match choice_list.stack with + | [] -> choice_list + | t :: q -> { current = t; stack = q } + in + let error, log_info, (blackboard, choice_list) = + backtrack parameter handler log_info error blackboard choice_list + in + match choice_list with + | Some choice_list -> + iter parameter handler log_info error blackboard choice_list + story_list (*(update_first_story first_story list)*) + | None -> + let _ = + PH.B.export_blackboard_to_xls parameter handler log_info error + "FAIL" !Priority.n_story !Priority.n_branch blackboard + in + error, log_info, (blackboard, story_list) + ) else + error, log_info, (blackboard, [ list ]) + ) else ( + let error, choice_list = + if no_more_choice choice_list then ( + let error, _log_info, list = + PH.next_choice parameter handler log_info error blackboard + in + error, update_current choice_list list + ) else + error, choice_list in - let error,log_info,blackboard = PH.B.branch parameter handler log_info error blackboard in - let error,(choice,choice_list) = pop_next_choice parameter handler error choice_list in - let error,log_info,(blackboard,output) = propagate parameter handler log_info error [choice] [] blackboard in - if PH.B.is_failed output - then - let error,log_info,(blackboard,choice_list) = backtrack parameter handler log_info error blackboard choice_list in - begin - match choice_list - with - | Some choice_list -> iter parameter handler log_info error blackboard choice_list story_list - | None -> error,log_info,(blackboard,story_list) - end - else - iter parameter handler log_info error blackboard (branch_choice_list choice_list) story_list + let error, log_info, blackboard = + PH.B.branch parameter handler log_info error blackboard + in + let error, (choice, choice_list) = + pop_next_choice parameter handler error choice_list + in + let error, log_info, (blackboard, output) = + propagate parameter handler log_info error [ choice ] [] blackboard + in + if PH.B.is_failed output then ( + let error, log_info, (blackboard, choice_list) = + backtrack parameter handler log_info error blackboard choice_list + in + match choice_list with + | Some choice_list -> + iter parameter handler log_info error blackboard choice_list + story_list + | None -> error, log_info, (blackboard, story_list) + ) else + iter parameter handler log_info error blackboard + (branch_choice_list choice_list) + story_list + ) - let detect_independent_events parameter handler log_info error blackboard list_eid = - let error,log_info,(_blackboard,events_to_keep) = - PH.B.cut parameter handler log_info error blackboard list_eid in - error,log_info,events_to_keep + let detect_independent_events parameter handler log_info error blackboard + list_eid = + let error, log_info, (_blackboard, events_to_keep) = + PH.B.cut parameter handler log_info error blackboard list_eid + in + error, log_info, events_to_keep let translate _parameter _handler log_info error blackboard list = let list' = List.rev_map (fun k -> - PH.B.get_event blackboard - (PH.B.PB.dec_step_id k), - PH.B.side_effect_of_event blackboard - (PH.B.PB.dec_step_id k)) (List.rev list) in + ( PH.B.get_event blackboard (PH.B.PB.dec_step_id k), + PH.B.side_effect_of_event blackboard (PH.B.PB.dec_step_id k) )) + (List.rev list) + in let list = List.rev_map fst (List.rev list') in - error,log_info,(list,list') + error, log_info, (list, list') - let translate_result result = - List.rev_map fst @@ List.rev result + let translate_result result = List.rev_map fst @@ List.rev result let clean parameter handler error log_info blackboard = PH.B.reset_init parameter handler error log_info blackboard let filter parameter handler log_info error blackboard events_to_keep = let log_info = StoryProfiling.StoryStats.set_step_time log_info in - let error,log_info,blackboard = PH.B.branch parameter handler log_info error blackboard in + let error, log_info, blackboard = + PH.B.branch parameter handler log_info error blackboard + in let events_to_remove = let n_events = PH.B.get_n_eid blackboard in let rec aux k list sol = - if k=n_events - then + if k = n_events then List.rev sol - else - match - list - with - | t::q -> - if (PH.B.PB.int_of_step_id t)=k - then aux (k+1) q sol - else aux (k+1) list ((PH.B.PB.step_id_of_int k)::sol) - | [] -> - aux (k+1) list ((PH.B.PB.step_id_of_int k)::sol) + else ( + match list with + | t :: q -> + if PH.B.PB.int_of_step_id t = k then + aux (k + 1) q sol + else + aux (k + 1) list (PH.B.PB.step_id_of_int k :: sol) + | [] -> aux (k + 1) list (PH.B.PB.step_id_of_int k :: sol) + ) in aux 0 events_to_keep [] in - let error,log_info,forbidden_events = - PH.forbidden_events parameter handler log_info error events_to_remove in + let error, log_info, forbidden_events = + PH.forbidden_events parameter handler log_info error events_to_remove + in let () = - if log_steps then - let () = Loggers.fprintf (PH.B.PB.CI.Po.K.H.get_logger parameter) "Start cutting" in - let () = Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) in + if log_steps then ( + let () = + Loggers.fprintf + (PH.B.PB.CI.Po.K.H.get_logger parameter) + "Start cutting" + in + let () = + Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) + in () + ) in - let error,log_info,(blackboard,_output) = + let error, log_info, (blackboard, _output) = propagate parameter handler log_info error forbidden_events [] blackboard in - let log_info = StoryProfiling.StoryStats.set_concurrent_event_deletion_time log_info in + let log_info = + StoryProfiling.StoryStats.set_concurrent_event_deletion_time log_info + in let log_info = StoryProfiling.StoryStats.set_step_time log_info in - error,log_info,blackboard + error, log_info, blackboard let sub parameter handler log_info error to_keep = let log_info = StoryProfiling.StoryStats.set_step_time log_info in - let error,log_info,blackboard = PH.B.import parameter handler log_info error to_keep in - let log_info = StoryProfiling.StoryStats.set_concurrent_event_deletion_time log_info in + let error, log_info, blackboard = + PH.B.import parameter handler log_info error to_keep + in + let log_info = + StoryProfiling.StoryStats.set_concurrent_event_deletion_time log_info + in let log_info = StoryProfiling.StoryStats.set_step_time log_info in - error,log_info,blackboard + error, log_info, blackboard let compress parameter handler log_info error blackboard list_order = - let error,log_info,blackboard = PH.B.branch parameter handler log_info error blackboard in - let log_info = StoryProfiling.StoryStats.set_concurrent_event_deletion_time log_info in + let error, log_info, blackboard = + PH.B.branch parameter handler log_info error blackboard + in + let log_info = + StoryProfiling.StoryStats.set_concurrent_event_deletion_time log_info + in let log_info = StoryProfiling.StoryStats.set_step_time log_info in let () = - if log_steps then + if log_steps then ( + let () = + Loggers.fprintf + (PH.B.PB.CI.Po.K.H.get_logger parameter) + "After Causal Cut %i" + (PH.B.get_n_unresolved_events blackboard) + in let () = - Loggers.fprintf (PH.B.PB.CI.Po.K.H.get_logger parameter) - "After Causal Cut %i" (PH.B.get_n_unresolved_events blackboard) + Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) in - let () = Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) in () + ) in - let error,log_info,(blackboard,output) = + let error, log_info, (blackboard, output) = propagate parameter handler log_info error list_order [] blackboard in - if PH.B.is_failed output - then + if PH.B.is_failed output then ( let () = - if log_steps then - let () = - Loggers.fprintf (PH.B.PB.CI.Po.K.H.get_logger parameter) - - "After observable propagation FAIL %i @." (PH.B.get_n_unresolved_events blackboard) - in - let () = Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) - in - () + if log_steps then ( + let () = + Loggers.fprintf + (PH.B.PB.CI.Po.K.H.get_logger parameter) + "After observable propagation FAIL %i @." + (PH.B.get_n_unresolved_events blackboard) + in + let () = + Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) + in + () + ) in - error,log_info,(blackboard,output,[]) - else + error, log_info, (blackboard, output, []) + ) else ( let () = - if log_steps then + if log_steps then ( let () = - Loggers.fprintf (PH.B.PB.CI.Po.K.H.get_logger parameter) - "After observable propagation %i @." (PH.B.get_n_unresolved_events blackboard) + Loggers.fprintf + (PH.B.PB.CI.Po.K.H.get_logger parameter) + "After observable propagation %i @." + (PH.B.get_n_unresolved_events blackboard) in - let () = Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) + let () = + Loggers.print_newline (PH.B.PB.CI.Po.K.H.get_logger parameter) in () + ) in - let bool,string= - begin - match - parameter.PH.B.PB.CI.Po.K.H.current_compression_mode - with - | None | Some Story_json.Causal-> false,"" - | Some Story_json.Weak -> - Parameter.dump_grid_after_branching_during_weak_compression,Parameter.xlsweakFileName - | Some Story_json.Strong -> - Parameter.dump_grid_after_branching_during_strong_compression,Parameter.xlsstrongFileName - end + let bool, string = + match parameter.PH.B.PB.CI.Po.K.H.current_compression_mode with + | None | Some Story_json.Causal -> false, "" + | Some Story_json.Weak -> + ( Parameter.dump_grid_after_branching_during_weak_compression, + Parameter.xlsweakFileName ) + | Some Story_json.Strong -> + ( Parameter.dump_grid_after_branching_during_strong_compression, + Parameter.xlsstrongFileName ) in - let () = Priority.n_branch:= 1+((!Priority.n_branch)+1) in - let error, log_info = - if bool then + let () = Priority.n_branch := 1 + (!Priority.n_branch + 1) in + let error, log_info = + if bool then ( let error, log_info, () = - PH.B.export_blackboard_to_xls - parameter handler log_info error string - (!Priority.n_story) (!Priority.n_branch) blackboard - in error, log_info - else error, log_info + PH.B.export_blackboard_to_xls parameter handler log_info error + string !Priority.n_story !Priority.n_branch blackboard + in + error, log_info + ) else + error, log_info in - let error,log_info,(blackboard,story_list) = iter parameter handler log_info error blackboard empty_choice_list [] + let error, log_info, (blackboard, story_list) = + iter parameter handler log_info error blackboard empty_choice_list [] in let output = - match - story_list - with - [] -> PH.B.fail + match story_list with + | [] -> PH.B.fail | _ -> PH.B.success in - error,log_info,(blackboard,output,filter_out_non_minimal_story (List.rev story_list)) - - + ( error, + log_info, + (blackboard, output, filter_out_non_minimal_story (List.rev story_list)) + ) + ) end diff --git a/core/cflow/generic_branch_and_cut_solver.mli b/core/cflow/generic_branch_and_cut_solver.mli index c20ed0c8b1..51f6e27f53 100644 --- a/core/cflow/generic_branch_and_cut_solver.mli +++ b/core/cflow/generic_branch_and_cut_solver.mli @@ -1,19 +1,34 @@ -module type Solver = - (sig - module PH:Propagation_heuristics.Blackboard_with_heuristic +module type Solver = sig + module PH : Propagation_heuristics.Blackboard_with_heuristic - val compress: (PH.B.blackboard,PH.update_order list,PH.B.blackboard * PH.B.assign_result * PH.B.result list) PH.B.PB.CI.Po.K.H.binary - val detect_independent_events: (PH.B.blackboard,PH.B.PB.step_id list,PH.B.PB.step_id list) PH.B.PB.CI.Po.K.H.binary - val filter: (PH.B.blackboard,PH.B.PB.step_id list,PH.B.blackboard) PH.B.PB.CI.Po.K.H.binary + val compress : + ( PH.B.blackboard, + PH.update_order list, + PH.B.blackboard * PH.B.assign_result * PH.B.result list ) + PH.B.PB.CI.Po.K.H.binary - val sub: (Trace.step list,PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary + val detect_independent_events : + ( PH.B.blackboard, + PH.B.PB.step_id list, + PH.B.PB.step_id list ) + PH.B.PB.CI.Po.K.H.binary - val clean: (PH.B.blackboard,PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary + val filter : + ( PH.B.blackboard, + PH.B.PB.step_id list, + PH.B.blackboard ) + PH.B.PB.CI.Po.K.H.binary - val translate: (PH.B.blackboard,PH.B.PB.step_id list,Trace.step list * PH.B.result) PH.B.PB.CI.Po.K.H.binary - val translate_result: PH.B.result -> Trace.step list + val sub : (Trace.step list, PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary + val clean : (PH.B.blackboard, PH.B.blackboard) PH.B.PB.CI.Po.K.H.unary - end) + val translate : + ( PH.B.blackboard, + PH.B.PB.step_id list, + Trace.step list * PH.B.result ) + PH.B.PB.CI.Po.K.H.binary -module Solver:Solver + val translate_result : PH.B.result -> Trace.step list +end +module Solver : Solver diff --git a/core/cflow/graph_closure.ml b/core/cflow/graph_closure.ml index 368c8755e9..a4f3c2e268 100644 --- a/core/cflow/graph_closure.ml +++ b/core/cflow/graph_closure.ml @@ -16,7 +16,6 @@ * et en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - module A = Array module S = Mods.IntSet module M = Mods.IntMap @@ -27,410 +26,427 @@ let check_mode = false type algo_type = Top_down | Bottom_up | Check type order = Increasing_with_last_event | Decreasing_without_last_event -type config = - { - do_tick: bool ; - keep_all_nodes: bool ; - cut_transitive_path: bool ; - stat_trans_closure_for_big_graphs: bool; - max_index:int; - algo: algo_type - } +type config = { + do_tick: bool; + keep_all_nodes: bool; + cut_transitive_path: bool; + stat_trans_closure_for_big_graphs: bool; + max_index: int; + algo: algo_type; +} let config_big_graph_with_progress_bar = { do_tick = true; - keep_all_nodes=false; - cut_transitive_path=true ; - stat_trans_closure_for_big_graphs=true; - max_index=300; - algo= Bottom_up (*if check_mode then Check else Top_down*) ; + keep_all_nodes = false; + cut_transitive_path = true; + stat_trans_closure_for_big_graphs = true; + max_index = 300; + algo = Bottom_up (*if check_mode then Check else Top_down*); } let config_big_graph_without_progress_bar = - { config_big_graph_with_progress_bar with do_tick = false} + { config_big_graph_with_progress_bar with do_tick = false } let config_small_graph = { do_tick = false; - keep_all_nodes = true ; - cut_transitive_path = false ; - stat_trans_closure_for_big_graphs=true; - algo= Bottom_up ; + keep_all_nodes = true; + cut_transitive_path = false; + stat_trans_closure_for_big_graphs = true; + algo = Bottom_up; max_index = 300; } - let swap f a b = f b a -let ignore_fst f = (fun _ -> f) +let ignore_fst f _ = f let rec compare_succ p l = match l with - | [] | [_] -> true - | a::q -> - begin - match q with - | b::_ when p a b -> compare_succ p q - | _ -> false - end - - -let strictly_increasing = compare_succ (fun (a:int) b -> a < b) -let strictly_decreasing = compare_succ (fun (a:int) b -> a > b) + | [] | [ _ ] -> true + | a :: q -> + (match q with + | b :: _ when p a b -> compare_succ p q + | _ -> false) +let strictly_increasing = compare_succ (fun (a : int) b -> a < b) +let strictly_decreasing = compare_succ (fun (a : int) b -> a > b) let concat a = List.rev_append (List.rev a) let print_list f l = Format.fprintf f "@[%a@]@." (Pp.list Pp.comma Format.pp_print_string) l let check form p f string a b = - match p a,p b with - | false,false -> let () = print_list form a in + match p a, p b with + | false, false -> + let () = print_list form a in + let () = print_list form b in + failwith (string ^ "_arg1_2") + | true, false -> let () = print_list form b in - failwith (string^"_arg1_2") - | true,false -> let () = print_list form b in failwith (string^"_arg2") - | false,true -> let () = print_list form a in failwith (string^"_arg1") - | true,true -> + failwith (string ^ "_arg2") + | false, true -> + let () = print_list form a in + failwith (string ^ "_arg1") + | true, true -> let rep = f a b in let () = print_list form rep in - if p rep then rep - else - (print_list form a;print_list form b;print_list form rep; - failwith (string^"_output")) + if p rep then + rep + else ( + print_list form a; + print_list form b; + print_list form rep; + failwith (string ^ "_output") + ) let is_strict_sublist p a b = let rec aux a b = - match a,b with - | _,[] -> false - | [],_::_ -> true - | h::t,h'::t' when h=h' -> aux t t' - | h::_,h'::_ when p h h' -> false - | _,_::t' -> aux a t' - in aux a b + match a, b with + | _, [] -> false + | [], _ :: _ -> true + | h :: t, h' :: t' when h = h' -> aux t t' + | h :: _, h' :: _ when p h h' -> false + | _, _ :: t' -> aux a t' + in + aux a b -let insert_elt p e = List_util.merge_uniq p [e] +let insert_elt p e = List_util.merge_uniq p [ e ] let diff_list p a b = let rec aux a b accu = - match a,b - with - | b,[] -> List.rev (List.rev_append b accu) - | [],_::_ -> List.rev accu - | h::t,h'::t' when h=h' -> aux t t' accu - | h::t,h'::_ when p h h' -> aux t b (h::accu) - | _,_::t' -> aux a t' accu - in aux a b [] + match a, b with + | b, [] -> List.rev (List.rev_append b accu) + | [], _ :: _ -> List.rev accu + | h :: t, h' :: t' when h = h' -> aux t t' accu + | h :: t, h' :: _ when p h h' -> aux t b (h :: accu) + | _, _ :: t' -> aux a t' accu + in + aux a b [] let compare_bool a b = compare a b < 0 -let diff_list_decreasing = diff_list (swap compare_bool) -let merge_list_decreasing = - List_util.merge_uniq (fun x y -> Stdlib.compare y x) - +let diff_list_decreasing = diff_list (swap compare_bool) +let merge_list_decreasing = List_util.merge_uniq (fun x y -> Stdlib.compare y x) -let closure_bottom_up_with_fold parameter handler log_info error event config prec is_obs f a = +let closure_bottom_up_with_fold parameter handler log_info error event config + prec is_obs f a = let err_logger = Remanent_parameters.get_logger parameter in - let is_obs = if config.keep_all_nodes then (fun _ -> true) else is_obs in + let is_obs = + if config.keep_all_nodes then + fun _ -> + true + else + is_obs + in let max_index = M.fold (fun i _ -> max i) prec 0 in let () = - if config.stat_trans_closure_for_big_graphs && config.max_index > 300 - then - let n_edges = - M.fold (ignore_fst (S.fold (ignore_fst succ))) prec 0 in + if config.stat_trans_closure_for_big_graphs && config.max_index > 300 then ( + let n_edges = M.fold (ignore_fst (S.fold (ignore_fst succ))) prec 0 in let () = Loggers.print_newline err_logger in - let () = Loggers.fprintf err_logger "\t\tTransitive closure (%i nodes, %i edges)" max_index n_edges in + let () = + Loggers.fprintf err_logger "\t\tTransitive closure (%i nodes, %i edges)" + max_index n_edges + in let () = Loggers.print_newline err_logger in () + ) in - let do_tick,tick,close_tick = - if max_index > 300 && config.do_tick - then - begin - let tick = Tick_stories.tick_stories err_logger Configuration.empty - (Remanent_parameters.save_progress_bar parameter) - (false,0,0,max_index) in - let f = Tick_stories.tick_stories - err_logger Configuration.empty - (Remanent_parameters.save_progress_bar parameter) in - let close () = Loggers.print_newline err_logger in - f, - tick, - close - end - else - (fun x -> x), - (false,0,0,0), - (fun () -> ()) - in - let s_pred_star = A.make (max_index+1) [] in - let clean,_max_succ = - begin - let max_succ = A.init (max_index+1) (fun i -> i) in - let _ = - M.iter - (fun succ -> - S.iter - (fun pred -> - A.set max_succ pred (max succ (A.get max_succ pred)))) - prec - in - let is_last_succ_of = A.make (max_index+1) [] in - let add node max_succ = - let old_l = A.get is_last_succ_of max_succ in - let l' = node::old_l in - A.set is_last_succ_of max_succ l' - in - let _ = - A.iteri - add - max_succ + let do_tick, tick, close_tick = + if max_index > 300 && config.do_tick then ( + let tick = + Tick_stories.tick_stories err_logger Configuration.empty + (Remanent_parameters.save_progress_bar parameter) + (false, 0, 0, max_index) in - let _ = A.set is_last_succ_of 0 [] in - let gc_when_visit node = - List.iter - (fun k -> A.set s_pred_star k []) - (A.get is_last_succ_of node) + let f = + Tick_stories.tick_stories err_logger Configuration.empty + (Remanent_parameters.save_progress_bar parameter) in - gc_when_visit, - (fun i -> A.get max_succ i) - end + let close () = Loggers.print_newline err_logger in + f, tick, close + ) else + (fun x -> x), (false, 0, 0, 0), fun () -> () + in + let s_pred_star = A.make (max_index + 1) [] in + let clean, _max_succ = + let max_succ = A.init (max_index + 1) (fun i -> i) in + let _ = + M.iter + (fun succ -> + S.iter (fun pred -> + A.set max_succ pred (max succ (A.get max_succ pred)))) + prec + in + let is_last_succ_of = A.make (max_index + 1) [] in + let add node max_succ = + let old_l = A.get is_last_succ_of max_succ in + let l' = node :: old_l in + A.set is_last_succ_of max_succ l' + in + let _ = A.iteri add max_succ in + let _ = A.set is_last_succ_of 0 [] in + let gc_when_visit node = + List.iter (fun k -> A.set s_pred_star k []) (A.get is_last_succ_of node) + in + gc_when_visit, fun i -> A.get max_succ i in - let error,log_info = - match - event - with - | None -> error,log_info - | Some e -> StoryProfiling.StoryStats.add_event parameter error e None log_info + let error, log_info = + match event with + | None -> error, log_info + | Some e -> + StoryProfiling.StoryStats.add_event parameter error e None log_info in let output = M.fold_with_interruption - (fun succ s_pred (tick,error,log_info,counter,a) -> - begin - let rec aux (l:int list) (accu:int list) = - match l with - | [] -> accu - | pred::t -> - begin - let new_l = A.get s_pred_star pred in - let diff = - if config.cut_transitive_path - then - diff_list_decreasing t new_l - else - t - in - aux - diff - (merge_list_decreasing (pred::new_l) accu) - end - in - let pred_star = - let l_pred = S.fold (fun i j -> i::j) s_pred [] in - let s = A.get s_pred_star succ in - aux l_pred s - in - let _ = - A.set s_pred_star succ pred_star - in - let _ = clean succ in - let tick = do_tick tick in - if is_obs succ - then - let error,log_info,a = f parameter handler log_info error succ pred_star a in - Stop.success_or_stop - (fun a -> Stop.success (tick,error,log_info,counter+1,a)) - (fun b -> Stop.stop (error,log_info,b)) - a - else - Stop.success (tick,error,log_info,counter,a) - - end) - prec (tick,error,log_info,1,a) + (fun succ s_pred (tick, error, log_info, counter, a) -> + let rec aux (l : int list) (accu : int list) = + match l with + | [] -> accu + | pred :: t -> + let new_l = A.get s_pred_star pred in + let diff = + if config.cut_transitive_path then + diff_list_decreasing t new_l + else + t + in + aux diff (merge_list_decreasing (pred :: new_l) accu) + in + let pred_star = + let l_pred = S.fold (fun i j -> i :: j) s_pred [] in + let s = A.get s_pred_star succ in + aux l_pred s + in + let _ = A.set s_pred_star succ pred_star in + let _ = clean succ in + let tick = do_tick tick in + if is_obs succ then ( + let error, log_info, a = + f parameter handler log_info error succ pred_star a + in + Stop.success_or_stop + (fun a -> Stop.success (tick, error, log_info, counter + 1, a)) + (fun b -> Stop.stop (error, log_info, b)) + a + ) else + Stop.success (tick, error, log_info, counter, a)) + prec + (tick, error, log_info, 1, a) in let _ = close_tick () in Stop.success_or_stop - (fun (_,error,log_info,_,a) -> - let error,log_info = - match event - with - None -> error,log_info - | Some e -> - StoryProfiling.StoryStats.close_event parameter error e None log_info - in - Stop.success (error,log_info,a)) - (fun (error,log_info,b) -> - let error,log_info = - match event - with - None -> error,log_info - | Some e -> - StoryProfiling.StoryStats.close_event parameter error e None log_info - in - Stop.stop (error,log_info,b)) + (fun (_, error, log_info, _, a) -> + let error, log_info = + match event with + | None -> error, log_info + | Some e -> + StoryProfiling.StoryStats.close_event parameter error e None log_info + in + Stop.success (error, log_info, a)) + (fun (error, log_info, b) -> + let error, log_info = + match event with + | None -> error, log_info + | Some e -> + StoryProfiling.StoryStats.close_event parameter error e None log_info + in + Stop.stop (error, log_info, b)) output -let closure_bottom_up parameter handler log_info error event_opt config prec is_obs = +let closure_bottom_up parameter handler log_info error event_opt config prec + is_obs = let max_index = M.fold (fun i _ -> max i) prec 0 in - let s_pred_star = A.make (max_index+1) [] in + let s_pred_star = A.make (max_index + 1) [] in let f _p _h c e i s a = - let _ = A.set a i s in (e,c,Stop.success a) + let _ = A.set a i s in + e, c, Stop.success a + in + let output = + closure_bottom_up_with_fold parameter handler log_info error event_opt + config prec is_obs f s_pred_star in - let output = closure_bottom_up_with_fold parameter handler log_info error event_opt config prec is_obs - f s_pred_star in Stop.success_or_stop - (fun (error,log_info,graph) -> - error,log_info,(graph,Decreasing_without_last_event)) - (fun (error,log_info,_) -> error,log_info,(s_pred_star,Decreasing_without_last_event)) + (fun (error, log_info, graph) -> + error, log_info, (graph, Decreasing_without_last_event)) + (fun (error, log_info, _) -> + error, log_info, (s_pred_star, Decreasing_without_last_event)) output -let closure_top_down parameter _handler log_info error _event_opt config prec is_obs delta = +let closure_top_down parameter _handler log_info error _event_opt config prec + is_obs delta = let err_logger = Remanent_parameters.get_logger parameter in - let is_obs = if config.keep_all_nodes then (fun _ -> true) else is_obs in - let max_index = M.fold (fun i _ -> max i) prec 0 in - let prec = - M.fold (fun i s_pred l -> (i,s_pred)::l) prec [] + let is_obs = + if config.keep_all_nodes then + fun _ -> + true + else + is_obs in + let max_index = M.fold (fun i _ -> max i) prec 0 in + let prec = M.fold (fun i s_pred l -> (i, s_pred) :: l) prec [] in let create_taints i = let rec aux delta output = - if delta = 0 then output - else aux (delta - 1) (S.empty::output) + if delta = 0 then + output + else + aux (delta - 1) (S.empty :: output) in - aux delta [S.singleton i] + aux delta [ S.singleton i ] in let shift_taints l = - match l with t::t'::q -> (S.union t t')::q - | _ -> l + match l with + | t :: t' :: q -> S.union t t' :: q + | _ -> l in let rec merge_taints l1 l2 = - match - l1,l2 - with - | _,[] -> l1 - | [],_ -> l2 - | t::q,t'::q' -> - (S.union t t')::(merge_taints q q') + match l1, l2 with + | _, [] -> l1 + | [], _ -> l2 + | t :: q, t' :: q' -> S.union t t' :: merge_taints q q' in - let s_pred_star = A.make (max_index+1) [] in + let s_pred_star = A.make (max_index + 1) [] in let taint i taints = - match - taints - with [] -> () - | t::_q -> - S.iter - (fun taint -> A.set s_pred_star taint (i::(A.get s_pred_star taint))) - t + match taints with + | [] -> () + | t :: _q -> + S.iter + (fun taint -> A.set s_pred_star taint (i :: A.get s_pred_star taint)) + t in - let do_tick,tick,close_tick = - if max_index > 300 && config.do_tick - then + let do_tick, tick, close_tick = + if max_index > 300 && config.do_tick then ( let tick = Tick_stories.tick_stories err_logger Configuration.empty (Remanent_parameters.save_progress_bar parameter) - (false,0,0,max_index) in + (false, 0, 0, max_index) + in let f = Tick_stories.tick_stories err_logger Configuration.empty (Remanent_parameters.save_progress_bar parameter) in let close () = Loggers.print_newline err_logger in - f,tick,close - else - (fun x -> x),(false,0,0,0),(fun () -> ()) + f, tick, close + ) else + (fun x -> x), (false, 0, 0, 0), fun () -> () in - let tainting = A.make (max_index+1) [] in + let tainting = A.make (max_index + 1) [] in let _ = List.fold_left - (fun tick (i,s_pred) -> - let new_taint = - if is_obs i - then - create_taints i - else - [] - in - let taints = merge_taints new_taint (A.get tainting i) in - let () = taint i taints in - let shifted_taints = shift_taints taints in - let taint x = A.set tainting x (merge_taints shifted_taints (A.get tainting x)) in - let () = S.iter taint s_pred in - let () = A.set tainting i [] in - do_tick tick) + (fun tick (i, s_pred) -> + let new_taint = + if is_obs i then + create_taints i + else + [] + in + let taints = merge_taints new_taint (A.get tainting i) in + let () = taint i taints in + let shifted_taints = shift_taints taints in + let taint x = + A.set tainting x (merge_taints shifted_taints (A.get tainting x)) + in + let () = S.iter taint s_pred in + let () = A.set tainting i [] in + do_tick tick) tick prec in let () = close_tick () in - error,log_info,(s_pred_star,Increasing_with_last_event) + error, log_info, (s_pred_star, Increasing_with_last_event) -let get_list_in_increasing_order_with_last_event i (m,mode) = - match - mode - with +let get_list_in_increasing_order_with_last_event i (m, mode) = + match mode with | Increasing_with_last_event -> m.(i) | Decreasing_without_last_event -> - begin - match - m.(i) - with - [] -> [] - | l -> List.rev (i::l) - end + (match m.(i) with + | [] -> [] + | l -> List.rev (i :: l)) -let closure_check parameter handler log_info error event_opt config prec is_obs = +let closure_check parameter handler log_info error event_opt config prec is_obs + = let t = Sys.time () in - let error,log_info,(a,a') = closure_top_down parameter handler log_info error event_opt config prec is_obs 0 in + let error, log_info, (a, a') = + closure_top_down parameter handler log_info error event_opt config prec + is_obs 0 + in let t' = Sys.time () in - let error,log_info,(b,b') = closure_bottom_up parameter handler log_info error event_opt {config with do_tick = false} prec is_obs in + let error, log_info, (b, b') = + closure_bottom_up parameter handler log_info error event_opt + { config with do_tick = false } + prec is_obs + in let t'' = Sys.time () in - let _ = Printf.fprintf stderr "NEW: %f OLD: %f \n" (t'-.t) (t''-.t') in + let _ = Printf.fprintf stderr "NEW: %f OLD: %f \n" (t' -. t) (t'' -. t') in let _ = A.iteri (fun i _s -> - let s = get_list_in_increasing_order_with_last_event i (a,a') in - let s' = get_list_in_increasing_order_with_last_event i (b,b') in - if s = s' then () - else - let _ = Printf.fprintf stderr "DIFFER %i\n" i in - let _ = List.iter (Printf.fprintf stderr "%i, ") s in - let _ = Printf.fprintf stderr "\n" in - let _ = List.iter (Printf.fprintf stderr "%i, ") s' in - let _ = Printf.fprintf stderr "\n" in - ()) + let s = get_list_in_increasing_order_with_last_event i (a, a') in + let s' = get_list_in_increasing_order_with_last_event i (b, b') in + if s = s' then + () + else ( + let _ = Printf.fprintf stderr "DIFFER %i\n" i in + let _ = List.iter (Printf.fprintf stderr "%i, ") s in + let _ = Printf.fprintf stderr "\n" in + let _ = List.iter (Printf.fprintf stderr "%i, ") s' in + let _ = Printf.fprintf stderr "\n" in + () + )) a - in error,log_info,(a,a') + in + error, log_info, (a, a') let closure parameter handler log_info error event_opt config prec is_obs = - match - config.algo - with - | Check -> closure_check parameter handler log_info error event_opt config prec is_obs - | Bottom_up -> closure_bottom_up parameter handler log_info error event_opt config prec is_obs - | Top_down -> closure_top_down parameter handler log_info error event_opt config prec is_obs 0 - + match config.algo with + | Check -> + closure_check parameter handler log_info error event_opt config prec is_obs + | Bottom_up -> + closure_bottom_up parameter handler log_info error event_opt config prec + is_obs + | Top_down -> + closure_top_down parameter handler log_info error event_opt config prec + is_obs 0 let reduction_top_down parameter handler log_info error prec = - let error,log_info = StoryProfiling.StoryStats.add_event parameter error StoryProfiling.Graph_reduction None log_info in - let error,log_info,(prec_star,_) = closure_top_down parameter handler log_info error StoryProfiling.Transitive_closure config_big_graph_without_progress_bar prec (fun _ -> true) 2 in + let error, log_info = + StoryProfiling.StoryStats.add_event parameter error + StoryProfiling.Graph_reduction None log_info + in + let error, log_info, (prec_star, _) = + closure_top_down parameter handler log_info error + StoryProfiling.Transitive_closure config_big_graph_without_progress_bar + prec + (fun _ -> true) + 2 + in let output = M.fold (fun eid neigh out -> - let to_remove = A.get prec_star eid in - let s = - S.fold (fun i l -> i::l) neigh [] - in - let s = List.rev s in - let rec aux l1 l2 output = - match l1,l2 with - _,[] -> List.fold_left (fun set i -> S.add i set) output l1 (* This is quite annoying, why prec is not described with ordered list *) - | [],_ -> output - | h::q,h'::q' -> - let cmp = compare h h' in - if cmp < 0 then aux q l2 (S.add h output) - else if cmp = 0 then aux q q' output - else aux (h::q) q' output - in - let s = aux s to_remove S.empty in - M.add eid s out - ) + let to_remove = A.get prec_star eid in + let s = S.fold (fun i l -> i :: l) neigh [] in + let s = List.rev s in + let rec aux l1 l2 output = + match l1, l2 with + | _, [] -> + List.fold_left (fun set i -> S.add i set) output l1 + (* This is quite annoying, why prec is not described with ordered list *) + | [], _ -> output + | h :: q, h' :: q' -> + let cmp = compare h h' in + if cmp < 0 then + aux q l2 (S.add h output) + else if cmp = 0 then + aux q q' output + else + aux (h :: q) q' output + in + let s = aux s to_remove S.empty in + M.add eid s out) prec prec in - let error,log_info = StoryProfiling.StoryStats.close_event parameter error StoryProfiling.Graph_reduction None log_info in - error,log_info,output + let error, log_info = + StoryProfiling.StoryStats.close_event parameter error + StoryProfiling.Graph_reduction None log_info + in + error, log_info, output let reduction = reduction_top_down diff --git a/core/cflow/kappa_instantiation.ml b/core/cflow/kappa_instantiation.ml index d4202a77c2..58458736d6 100644 --- a/core/cflow/kappa_instantiation.ml +++ b/core/cflow/kappa_instantiation.ml @@ -19,543 +19,558 @@ * under the terms of the GNU Library General Public License *) let debug_mode = false + let compose_with_handler f g parameter handler error x = - let error,y = g parameter handler error x in + let error, y = g parameter handler error x in f parameter handler error y module P = StoryProfiling.StoryStats - -module type Cflow_signature = -sig - module H:Cflow_handler.Cflow_handler +module type Cflow_signature = sig + module H : Cflow_handler.Cflow_handler type agent_id = int - module AgentIdSet:SetMap.Set with type elt = agent_id - type internal_state = int + module AgentIdSet : SetMap.Set with type elt = agent_id + type internal_state = int type side_effect = Instantiation.concrete Instantiation.site list - val empty_side_effect: side_effect - val agent_name_of_binding_type: Instantiation.binding_type -> Instantiation.agent_name - val site_name_of_binding_type: Instantiation.binding_type -> Instantiation.site_name - val agent_id_of_agent: - Instantiation.concrete -> int - val agent_name_of_agent: Instantiation.concrete -> Instantiation.agent_name - val agent_of_site: Instantiation.concrete Instantiation.site -> Instantiation.concrete - val agent_id_of_site: Instantiation.concrete Instantiation.site -> int - val agent_name_of_site: Instantiation.concrete Instantiation.site -> Instantiation.agent_name - val site_name_of_site: Instantiation.concrete Instantiation.site -> Instantiation.site_name - - val build_grid: - (Trace.step * Instantiation.concrete Instantiation.site list) list -> bool -> - H.handler -> Causal.grid - val print_side_effect: Loggers.t -> side_effect -> unit - val side_effect_of_list: Instantiation.concrete Instantiation.site list -> side_effect - - val get_id_of_refined_step: Trace.step -> int option - val get_time_of_refined_step: Trace.step -> float option - - val level_of_event: Priority.priorities option -> (Trace.step,(agent_id -> bool),Priority.level) H.binary - val disambiguate: Trace.t -> Trace.t - val clean_events: Trace.t -> Trace.t - - val fill_siphon: Trace.t -> Trace.t - val split_init: Trace.t -> Trace.t - val agent_id_in_obs: (Trace.step, AgentIdSet.t) H.unary -end + val empty_side_effect : side_effect + + val agent_name_of_binding_type : + Instantiation.binding_type -> Instantiation.agent_name -module Cflow_linker = - (struct - module H = Cflow_handler.Cflow_handler - module PI = Instantiation + val site_name_of_binding_type : + Instantiation.binding_type -> Instantiation.site_name - type agent_id = int + val agent_id_of_agent : Instantiation.concrete -> int + val agent_name_of_agent : Instantiation.concrete -> Instantiation.agent_name - type side_effect = PI.concrete PI.site list + val agent_of_site : + Instantiation.concrete Instantiation.site -> Instantiation.concrete - module AgentIdMap = Mods.IntMap - module AgentIdSet = Mods.IntSet - module SiteMap = Mods.IntMap - module SiteSet = Mods.IntSet - type internal_state = int + val agent_id_of_site : Instantiation.concrete Instantiation.site -> int - let empty_side_effect = [] + val agent_name_of_site : + Instantiation.concrete Instantiation.site -> Instantiation.agent_name - let site_name_of_binding_type = snd - let agent_name_of_binding_type = fst - let agent_id_of_agent = fst + val site_name_of_site : + Instantiation.concrete Instantiation.site -> Instantiation.site_name - let agent_name_of_agent = snd + val build_grid : + (Trace.step * Instantiation.concrete Instantiation.site list) list -> + bool -> + H.handler -> + Causal.grid - let agent_of_site = fst + val print_side_effect : Loggers.t -> side_effect -> unit - let agent_id_of_site x = agent_id_of_agent @@ agent_of_site x + val side_effect_of_list : + Instantiation.concrete Instantiation.site list -> side_effect - let agent_name_of_site x = agent_name_of_agent @@ agent_of_site x + val get_id_of_refined_step : Trace.step -> int option + val get_time_of_refined_step : Trace.step -> float option - let site_name_of_site = snd + val level_of_event : + Priority.priorities option -> + (Trace.step, agent_id -> bool, Priority.level) H.binary - let get_gen_of_refined_step f x = - match - Trace.simulation_info_of_step x - with - | None -> None - | Some a -> Some (f a) + val disambiguate : Trace.t -> Trace.t + val clean_events : Trace.t -> Trace.t + val fill_siphon : Trace.t -> Trace.t + val split_init : Trace.t -> Trace.t + val agent_id_in_obs : (Trace.step, AgentIdSet.t) H.unary +end - let get_time_of_refined_step x = - get_gen_of_refined_step (fun x -> x.Trace.Simulation_info.story_time) x - let get_id_of_refined_step x = - get_gen_of_refined_step (fun x -> x.Trace.Simulation_info.story_event) x +module Cflow_linker : Cflow_signature = struct + module H = Cflow_handler.Cflow_handler + module PI = Instantiation - let build_grid list bool handler = - let env = handler.H.env in - let empty_set = [] in - let grid = Causal.empty_grid () in - let grid,_,_,_ = - List.fold_left - (fun (grid,side_effect,counter,subs) (k,side) -> - let maybe_side_effect = - if bool then fun se -> se - else fun _ -> List.rev_append side_effect side in - let translate y = Mods.IntMap.find_default y y subs in - match k with - | Trace.Rule (id,event,info) -> - let event' = - PI.subst_map_agent_in_concrete_event translate event in - let side_effects_dst = - maybe_side_effect event'.Instantiation.side_effects_dst in - Causal.record - (Trace.RULE id,{ - Instantiation.tests = event'.Instantiation.tests; - Instantiation.actions = event'.Instantiation.actions; - Instantiation.side_effects_src = - event'.Instantiation.side_effects_src; - Instantiation.side_effects_dst; - Instantiation.connectivity_tests = - event'.Instantiation.connectivity_tests; - },info) - counter env grid, - empty_set,counter+1,Mods.IntMap.empty - | Trace.Pert (id,event,info) -> - let event' = - PI.subst_map_agent_in_concrete_event translate event in - let side_effects_dst = - maybe_side_effect event'.Instantiation.side_effects_dst in - Causal.record - (Trace.PERT id,{ - Instantiation.tests = event'.Instantiation.tests; - Instantiation.actions = event'.Instantiation.actions; - Instantiation.side_effects_src = - event'.Instantiation.side_effects_src; - Instantiation.side_effects_dst; - Instantiation.connectivity_tests = - event'.Instantiation.connectivity_tests; - },info) - counter env grid, - empty_set,counter+1,Mods.IntMap.empty - | Trace.Obs (id,tests,info) -> - let tests' = - List_util.smart_map - (List_util.smart_map - (PI.subst_map_agent_in_concrete_test translate)) tests in - Causal.record_obs - (id,tests',info) side_effect counter grid, - maybe_side_effect empty_set,counter+1,Mods.IntMap.empty - | Trace.Subs (a,b) -> - grid, side_effect, counter, Mods.IntMap.add a b subs - | Trace.Init actions -> - let actions' = - List_util.smart_map - (PI.subst_map_agent_in_concrete_action translate) actions in - Causal.record_init (Trace.creation_of_actions snd actions',actions') - counter env grid, - side_effect,counter+1,Mods.IntMap.empty - | Trace.Dummy _ -> - grid, maybe_side_effect empty_set, counter, subs - ) - (grid,empty_set,1,Mods.IntMap.empty) list - in grid - - let clean_events = - List.filter - (function Trace.Rule _ | Trace.Pert _ | Trace.Obs _ | Trace.Init _ -> true - | Trace.Dummy _ | Trace.Subs _ -> false) - - let print_side_effect log = - List.iter - (fun ((a,_),b) -> Loggers.fprintf log "(%i,%i)," a b) - let side_effect_of_list l = l - - let level_of_event priority_opt parameter _handler log_info error e set = - match priority_opt,H.get_priorities parameter with - | None,None -> error,log_info,Priority.highest - | Some priorities,_ | None,Some priorities -> - match e with - | Trace.Obs _ -> error,log_info,priorities.Priority.other_events - | Trace.Rule _ | Trace.Pert _ -> - begin - let actions = Trace.actions_of_step e in - let priority = - List.fold_left - (fun priority -> - function - | PI.Create (ag,_) -> - let ag_id = agent_id_of_agent ag in - if set ag_id then priority - else - Priority.min_level priority priorities.Priority.creation - | PI.Remove _ -> - Priority.min_level priority priorities.Priority.removal - | PI.Mod_internal _ -> priority - | PI.Free _ -> - Priority.min_level priority priorities.Priority.unbinding - | PI.Bind(_,_) | PI.Bind_to(_,_) -> priority - ) - priorities.Priority.other_events - (fst (actions)) + type agent_id = int + type side_effect = PI.concrete PI.site list + + module AgentIdMap = Mods.IntMap + module AgentIdSet = Mods.IntSet + module SiteMap = Mods.IntMap + module SiteSet = Mods.IntSet + + type internal_state = int + + let empty_side_effect = [] + let site_name_of_binding_type = snd + let agent_name_of_binding_type = fst + let agent_id_of_agent = fst + let agent_name_of_agent = snd + let agent_of_site = fst + let agent_id_of_site x = agent_id_of_agent @@ agent_of_site x + let agent_name_of_site x = agent_name_of_agent @@ agent_of_site x + let site_name_of_site = snd + + let get_gen_of_refined_step f x = + match Trace.simulation_info_of_step x with + | None -> None + | Some a -> Some (f a) + + let get_time_of_refined_step x = + get_gen_of_refined_step (fun x -> x.Trace.Simulation_info.story_time) x + + let get_id_of_refined_step x = + get_gen_of_refined_step (fun x -> x.Trace.Simulation_info.story_event) x + + let build_grid list bool handler = + let env = handler.H.env in + let empty_set = [] in + let grid = Causal.empty_grid () in + let grid, _, _, _ = + List.fold_left + (fun (grid, side_effect, counter, subs) (k, side) -> + let maybe_side_effect = + if bool then + fun se -> + se + else + fun _ -> + List.rev_append side_effect side + in + let translate y = Mods.IntMap.find_default y y subs in + match k with + | Trace.Rule (id, event, info) -> + let event' = PI.subst_map_agent_in_concrete_event translate event in + let side_effects_dst = + maybe_side_effect event'.Instantiation.side_effects_dst in - error,log_info,priority - end - | (Trace.Dummy _ | Trace.Subs _ | Trace.Init _) -> - error,log_info,priorities.Priority.substitution - - let subs_agent_in_event mapping mapping' = function - | Trace.Rule (a,event,info) -> - Trace.Rule - (a, - PI.subst_map2_agent_in_concrete_event - (fun x -> AgentIdMap.find_default x x mapping) - (fun x -> AgentIdMap.find_default x x mapping') - event, - info) - | Trace.Pert (a,event,info) -> - Trace.Pert - (a, - PI.subst_map2_agent_in_concrete_event - (fun x -> AgentIdMap.find_default x x mapping) - (fun x -> AgentIdMap.find_default x x mapping') - event, - info) - | Trace.Obs (a,b,c) -> - Trace.Obs(a, - List_util.smart_map - (List_util.smart_map - (PI.subst_map_agent_in_concrete_test - (fun x -> AgentIdMap.find_default x x mapping))) b, - c) - | Trace.Init b -> - Trace.Init - (List_util.smart_map - (PI.subst_map_agent_in_concrete_action - (fun x -> AgentIdMap.find_default x x mapping')) b) - | Trace.Dummy _ | Trace.Subs _ as event -> event - - let disambiguate event_list = - let _,_,_,event_list_rev = - List.fold_left - (fun (max_id,used,mapping,event_list) event -> - let max_id,used,mapping' = - List.fold_left - (fun (max_id,used,mapping) x -> - if AgentIdSet.mem x used - then - (max_id+1,AgentIdSet.add (max_id+1) used, - AgentIdMap.add x (max_id+1) mapping) - else (max x max_id,AgentIdSet.add x used,mapping)) - (max_id,used,mapping) (Trace.creation_of_step event) in - let list = (subs_agent_in_event mapping mapping' event)::event_list in - max_id,used,mapping',list) - (0,AgentIdSet.empty,AgentIdMap.empty,[]) - event_list - in List.rev event_list_rev - - type agent_info = - { - initial_step: Trace.step ; - internal_states: internal_state SiteMap.t ; - bound_sites: SiteSet.t ; - sites_with_wrong_internal_state: SiteSet.t - } - - let convert_init remanent step_list action_list = - let extract_agent id soup = - List.partition - (function - | (PI.Create ((id',_),_) | PI.Mod_internal (((id',_),_),_) | - PI.Free ((id',_),_) | PI.Bind_to (((id',_),_),_)) -> id = id' - | (PI.Bind _ | PI.Remove _) -> failwith "Problematic initial event") - soup in - let rec aux recur acc soup = function - | [] -> (if soup <> [] then Trace.Init soup::acc else acc),recur - | PI.Free _ :: t -> aux recur acc soup t - | (PI.Bind _ | PI.Remove _ | PI.Bind_to _ | PI.Mod_internal _) :: t -> - aux recur acc soup t - | PI.Create ((id,_),site_list) :: t -> - let this,soup' = extract_agent id soup in - let standalone = - List.for_all - (function - | (PI.Create _ | PI.Free _ | PI.Mod_internal _) -> true - | (PI.Bind_to _ | PI.Bind _ | PI.Remove _) -> false) - this in - let this = Trace.Init this in - if standalone then - let map = - List.fold_left - (fun map -> function - | s, Some u -> SiteMap.add s u map - | _, None -> map) - SiteMap.empty site_list in - let agent_info = - { - initial_step=this; - internal_states=map; - bound_sites=SiteSet.empty; - sites_with_wrong_internal_state=SiteSet.empty - } - in aux (AgentIdMap.add id agent_info recur) (this::acc) soup' t - else aux recur (this::acc) soup' t - in aux remanent step_list action_list action_list - - let as_init restriction_map agid agent_info = - let restriction = - AgentIdMap.find_default - SiteSet.empty - agid - restriction_map - in - SiteSet.is_empty - (SiteSet.inter agent_info.bound_sites restriction) - && - SiteSet.is_empty - (SiteSet.inter agent_info.sites_with_wrong_internal_state restriction) - - let mod_site restriction_map site state (remanent,set) = - let agid = agent_id_of_site site in - let s_name = site_name_of_site site in - match AgentIdMap.find_option agid remanent with - | None -> remanent,set - | Some ag_info -> - match SiteMap.find_option s_name ag_info.internal_states with - | None -> remanent,set - | Some state_ref -> - if state_ref = state (* Back to the original internal state*) - then - begin - if SiteSet.mem s_name ag_info.sites_with_wrong_internal_state - then - let ag_info = + ( Causal.record + ( Trace.RULE id, { - ag_info with - sites_with_wrong_internal_state = - SiteSet.remove s_name ag_info.sites_with_wrong_internal_state} - in - let remanent = AgentIdMap.add agid ag_info remanent in - begin - if as_init restriction_map agid ag_info - then - remanent, - AgentIdSet.add agid set - else - remanent, - set - end - else remanent,set - end - else (* No longer the default state *) - begin - if SiteSet.mem s_name ag_info.sites_with_wrong_internal_state - then - remanent,set - else - let ag_info = + Instantiation.tests = event'.Instantiation.tests; + Instantiation.actions = event'.Instantiation.actions; + Instantiation.side_effects_src = + event'.Instantiation.side_effects_src; + Instantiation.side_effects_dst; + Instantiation.connectivity_tests = + event'.Instantiation.connectivity_tests; + }, + info ) + counter env grid, + empty_set, + counter + 1, + Mods.IntMap.empty ) + | Trace.Pert (id, event, info) -> + let event' = PI.subst_map_agent_in_concrete_event translate event in + let side_effects_dst = + maybe_side_effect event'.Instantiation.side_effects_dst + in + ( Causal.record + ( Trace.PERT id, { - ag_info with - sites_with_wrong_internal_state = - SiteSet.add s_name ag_info.sites_with_wrong_internal_state} - in - let remanent = AgentIdMap.add agid ag_info remanent in - begin - if as_init restriction_map agid ag_info - then - remanent,set - else - remanent, - AgentIdSet.remove agid set - end - end - - let unbind_side restriction_map (agid,s_name) (remanent,set) = - match AgentIdMap.find_option agid remanent with - | None -> remanent,set - | Some ag_info -> - if SiteSet.mem s_name ag_info.bound_sites - then - let ag_info = + Instantiation.tests = event'.Instantiation.tests; + Instantiation.actions = event'.Instantiation.actions; + Instantiation.side_effects_src = + event'.Instantiation.side_effects_src; + Instantiation.side_effects_dst; + Instantiation.connectivity_tests = + event'.Instantiation.connectivity_tests; + }, + info ) + counter env grid, + empty_set, + counter + 1, + Mods.IntMap.empty ) + | Trace.Obs (id, tests, info) -> + let tests' = + List_util.smart_map + (List_util.smart_map + (PI.subst_map_agent_in_concrete_test translate)) + tests + in + ( Causal.record_obs (id, tests', info) side_effect counter grid, + maybe_side_effect empty_set, + counter + 1, + Mods.IntMap.empty ) + | Trace.Subs (a, b) -> + grid, side_effect, counter, Mods.IntMap.add a b subs + | Trace.Init actions -> + let actions' = + List_util.smart_map + (PI.subst_map_agent_in_concrete_action translate) + actions + in + ( Causal.record_init + (Trace.creation_of_actions snd actions', actions') + counter env grid, + side_effect, + counter + 1, + Mods.IntMap.empty ) + | Trace.Dummy _ -> grid, maybe_side_effect empty_set, counter, subs) + (grid, empty_set, 1, Mods.IntMap.empty) + list + in + grid + + let clean_events = + List.filter (function + | Trace.Rule _ | Trace.Pert _ | Trace.Obs _ | Trace.Init _ -> true + | Trace.Dummy _ | Trace.Subs _ -> false) + + let print_side_effect log = + List.iter (fun ((a, _), b) -> Loggers.fprintf log "(%i,%i)," a b) + + let side_effect_of_list l = l + + let level_of_event priority_opt parameter _handler log_info error e set = + match priority_opt, H.get_priorities parameter with + | None, None -> error, log_info, Priority.highest + | Some priorities, _ | None, Some priorities -> + (match e with + | Trace.Obs _ -> error, log_info, priorities.Priority.other_events + | Trace.Rule _ | Trace.Pert _ -> + let actions = Trace.actions_of_step e in + let priority = + List.fold_left + (fun priority -> function + | PI.Create (ag, _) -> + let ag_id = agent_id_of_agent ag in + if set ag_id then + priority + else + Priority.min_level priority priorities.Priority.creation + | PI.Remove _ -> + Priority.min_level priority priorities.Priority.removal + | PI.Mod_internal _ -> priority + | PI.Free _ -> + Priority.min_level priority priorities.Priority.unbinding + | PI.Bind (_, _) | PI.Bind_to (_, _) -> priority) + priorities.Priority.other_events (fst actions) + in + error, log_info, priority + | Trace.Dummy _ | Trace.Subs _ | Trace.Init _ -> + error, log_info, priorities.Priority.substitution) + + let subs_agent_in_event mapping mapping' = function + (* mapping -> before the event, including agents to be removed *) + (* mapping' -> after the event, including agents to be created *) + (* This is useful when one agent is removed, and one is created with the same id in a single event *) + | Trace.Rule (a, event, info) -> + Trace.Rule + ( a, + PI.subst_map2_agent_in_concrete_event + (fun x -> AgentIdMap.find_default x x mapping) + (fun x -> AgentIdMap.find_default x x mapping') + event, + info ) + | Trace.Pert (a, event, info) -> + Trace.Pert + ( a, + PI.subst_map2_agent_in_concrete_event + (fun x -> AgentIdMap.find_default x x mapping) + (fun x -> AgentIdMap.find_default x x mapping') + event, + info ) + | Trace.Obs (a, b, c) -> + Trace.Obs + ( a, + List_util.smart_map + (List_util.smart_map + (PI.subst_map_agent_in_concrete_test (fun x -> + AgentIdMap.find_default x x mapping))) + b, + c ) + | Trace.Init b -> + Trace.Init + (List_util.smart_map + (PI.subst_map_agent_in_concrete_action (fun x -> + AgentIdMap.find_default x x mapping')) + b) + | (Trace.Dummy _ | Trace.Subs _) as event -> event + + let disambiguate event_list = + let _, _, _, event_list_rev = + List.fold_left + (fun (max_id, used, mapping, event_list) event -> + let max_id, used, mapping' = + List.fold_left + (fun (max_id, used, mapping) x -> + if AgentIdSet.mem x used then + ( max_id + 1, + AgentIdSet.add (max_id + 1) used, + AgentIdMap.add x (max_id + 1) mapping ) + else + max x max_id, AgentIdSet.add x used, mapping) + (max_id, used, mapping) + (Trace.creation_of_step event) + in + (* mapping can be safely applied to all agents except the newly created ones *) + (* mapping' can be safely applied to all agents except the ones that have been just removes *) + let list = subs_agent_in_event mapping mapping' event :: event_list in + max_id, used, mapping', list) + (0, AgentIdSet.empty, AgentIdMap.empty, []) + event_list + in + List.rev event_list_rev + + type agent_info = { + initial_step: Trace.step; + internal_states: internal_state SiteMap.t; + bound_sites: SiteSet.t; + sites_with_wrong_internal_state: SiteSet.t; + } + + let convert_init remanent step_list action_list = + let extract_agent id soup = + List.partition + (function + | PI.Create ((id', _), _) + | PI.Mod_internal (((id', _), _), _) + | PI.Free ((id', _), _) + | PI.Bind_to (((id', _), _), _) -> + id = id' + | PI.Bind _ | PI.Remove _ -> failwith "Problematic initial event") + soup + in + let rec aux recur acc soup = function + | [] -> + ( (if soup <> [] then + Trace.Init soup :: acc + else + acc), + recur ) + | PI.Free _ :: t -> aux recur acc soup t + | (PI.Bind _ | PI.Remove _ | PI.Bind_to _ | PI.Mod_internal _) :: t -> + aux recur acc soup t + | PI.Create ((id, _), site_list) :: t -> + let this, soup' = extract_agent id soup in + let standalone = + List.for_all + (function + | PI.Create _ | PI.Free _ | PI.Mod_internal _ -> true + | PI.Bind_to _ | PI.Bind _ | PI.Remove _ -> false) + this + in + let this = Trace.Init this in + if standalone then ( + let map = + List.fold_left + (fun map -> function + | s, Some u -> SiteMap.add s u map + | _, None -> map) + SiteMap.empty site_list + in + let agent_info = { - ag_info with - bound_sites = - SiteSet.remove s_name ag_info.bound_sites} + initial_step = this; + internal_states = map; + bound_sites = SiteSet.empty; + sites_with_wrong_internal_state = SiteSet.empty; + } in - let remanent = AgentIdMap.add agid ag_info remanent in - begin - if as_init restriction_map agid ag_info - then - remanent, - AgentIdSet.add agid set + aux (AgentIdMap.add id agent_info recur) (this :: acc) soup' t + ) else + aux recur (this :: acc) soup' t + in + aux remanent step_list action_list action_list + + let as_init restriction_map agid agent_info = + let restriction = + AgentIdMap.find_default SiteSet.empty agid restriction_map + in + SiteSet.is_empty (SiteSet.inter agent_info.bound_sites restriction) + && SiteSet.is_empty + (SiteSet.inter agent_info.sites_with_wrong_internal_state restriction) + + let mod_site restriction_map site state (remanent, set) = + let agid = agent_id_of_site site in + let s_name = site_name_of_site site in + match AgentIdMap.find_option agid remanent with + | None -> remanent, set + | Some ag_info -> + (match SiteMap.find_option s_name ag_info.internal_states with + | None -> remanent, set + | Some state_ref -> + if state_ref = state (* Back to the original internal state*) then + if SiteSet.mem s_name ag_info.sites_with_wrong_internal_state then ( + let ag_info = + { + ag_info with + sites_with_wrong_internal_state = + SiteSet.remove s_name ag_info.sites_with_wrong_internal_state; + } + in + let remanent = AgentIdMap.add agid ag_info remanent in + if as_init restriction_map agid ag_info then + remanent, AgentIdSet.add agid set else - remanent, - set - end - else remanent,set - - - let unbind restriction_map site rem = - let agid = agent_id_of_site site in - let s_name = site_name_of_site site in - unbind_side restriction_map (agid,s_name) rem - - let bind restriction_map site (remanent,set) = - let agid = agent_id_of_site site in - let s_name = site_name_of_site site in - match AgentIdMap.find_option agid remanent with - | None -> remanent,set - | Some ag_info -> - if SiteSet.mem s_name ag_info.bound_sites + remanent, set + ) else + remanent, set + else if + (* No longer the default state *) + SiteSet.mem s_name ag_info.sites_with_wrong_internal_state then - remanent,set - else + remanent, set + else ( let ag_info = { ag_info with - bound_sites = - SiteSet.add s_name ag_info.bound_sites} + sites_with_wrong_internal_state = + SiteSet.add s_name ag_info.sites_with_wrong_internal_state; + } in let remanent = AgentIdMap.add agid ag_info remanent in - begin - if as_init restriction_map agid ag_info - then - remanent,set - else - remanent, - AgentIdSet.remove agid set - end - - let split_init refined_step_list = - let remanent = AgentIdMap.empty in - fst (List.fold_left - (fun (step_list,remanent) refined_step -> - match refined_step - with - | Trace.Init init -> convert_init remanent step_list init - | Trace.Subs _ | Trace.Obs _ | Trace.Dummy _ - | Trace.Rule _ | Trace.Pert _ -> - (refined_step::step_list,remanent)) - ([],remanent) - (List.rev refined_step_list)) - - let add_in_scope site scope = - let agid = agent_id_of_site site in - let s_name = site_name_of_site site in - let old_set = - AgentIdMap.find_default - SiteSet.empty - agid - scope - in - let new_set = - SiteSet.add s_name old_set - in - if old_set == new_set - then scope - else - AgentIdMap.add agid new_set scope - - let deal_with_tests tests scope = + if as_init restriction_map agid ag_info then + remanent, set + else + remanent, AgentIdSet.remove agid set + )) + + let unbind_side restriction_map (agid, s_name) (remanent, set) = + match AgentIdMap.find_option agid remanent with + | None -> remanent, set + | Some ag_info -> + if SiteSet.mem s_name ag_info.bound_sites then ( + let ag_info = + { + ag_info with + bound_sites = SiteSet.remove s_name ag_info.bound_sites; + } + in + let remanent = AgentIdMap.add agid ag_info remanent in + if as_init restriction_map agid ag_info then + remanent, AgentIdSet.add agid set + else + remanent, set + ) else + remanent, set + + let unbind restriction_map site rem = + let agid = agent_id_of_site site in + let s_name = site_name_of_site site in + unbind_side restriction_map (agid, s_name) rem + + let bind restriction_map site (remanent, set) = + let agid = agent_id_of_site site in + let s_name = site_name_of_site site in + match AgentIdMap.find_option agid remanent with + | None -> remanent, set + | Some ag_info -> + if SiteSet.mem s_name ag_info.bound_sites then + remanent, set + else ( + let ag_info = + { ag_info with bound_sites = SiteSet.add s_name ag_info.bound_sites } + in + let remanent = AgentIdMap.add agid ag_info remanent in + if as_init restriction_map agid ag_info then + remanent, set + else + remanent, AgentIdSet.remove agid set + ) + + let split_init refined_step_list = + let remanent = AgentIdMap.empty in + fst + (List.fold_left + (fun (step_list, remanent) refined_step -> + match refined_step with + | Trace.Init init -> convert_init remanent step_list init + | Trace.Subs _ | Trace.Obs _ | Trace.Dummy _ | Trace.Rule _ + | Trace.Pert _ -> + refined_step :: step_list, remanent) + ([], remanent) + (List.rev refined_step_list)) + + let add_in_scope site scope = + let agid = agent_id_of_site site in + let s_name = site_name_of_site site in + let old_set = AgentIdMap.find_default SiteSet.empty agid scope in + let new_set = SiteSet.add s_name old_set in + if old_set == new_set then + scope + else + AgentIdMap.add agid new_set scope + + let deal_with_tests tests scope = + List.fold_left + (List.fold_left (fun scope x -> + match x with + | PI.Is_Here _ -> scope + | PI.Is_Bound site + | PI.Is_Free site + | PI.Has_Binding_type (site, _) + | PI.Has_Internal (site, _) -> + add_in_scope site scope + | PI.Is_Bound_to (site1, site2) -> + add_in_scope site1 (add_in_scope site2 scope))) + scope tests + + let fill_siphon refined_step_list = + let rev_trace = List.rev refined_step_list in + let scope = AgentIdMap.empty in + let refined_step_with_scope_list, _ = List.fold_left - (List.fold_left - (fun scope x -> - match x with - | PI.Is_Here _ -> scope - | PI.Is_Bound site - | PI.Is_Free site | PI.Has_Binding_type (site,_) - | PI.Has_Internal (site,_) -> - add_in_scope site scope - | PI.Is_Bound_to (site1,site2) -> add_in_scope site1 (add_in_scope site2 scope))) - scope - tests - - let fill_siphon refined_step_list = - let rev_trace = List.rev refined_step_list in - let scope = AgentIdMap.empty in - let refined_step_with_scope_list,_ = - List.fold_left - (fun (step_list, scope) refined_step -> - match refined_step with - | Trace.Init _ -> (refined_step,scope)::step_list, scope - | Trace.Rule (_,event,_) | Trace.Pert (_,event,_) -> - let scope' = deal_with_tests event.Instantiation.tests scope in - (refined_step,scope)::step_list, scope' - | Trace.Obs (_,tests,_) -> - let scope' = deal_with_tests tests scope in - (refined_step,scope)::step_list, scope' - | (Trace.Subs _ | Trace.Dummy _) -> - assert false - ) ([],scope) rev_trace - in - let remanent = AgentIdMap.empty in - let a,_ = - List.fold_left - (fun (step_list,remanent) refined_step -> - match refined_step with - | (Trace.Init init,_) -> convert_init remanent step_list init - | (Trace.Rule (_,event,_),scope) - | (Trace.Pert (_,event,_),scope) -> - let remanent,set = - List.fold_left - (fun recur -> - function - | PI.Create _ -> recur - | PI.Mod_internal (site,state) -> - mod_site scope site state recur - | (PI.Bind (site1,site2) | PI.Bind_to (site1,site2)) -> - bind scope site1 (bind scope site2 recur) - | PI.Free site -> unbind scope site recur - | PI.Remove _ -> recur ) - (remanent,AgentIdSet.empty) event.Instantiation.actions in - let remanent,set = - List.fold_right (unbind scope) - event.Instantiation.side_effects_dst (remanent,set) - in - ((AgentIdSet.fold - (fun id list -> - match AgentIdMap.find_option id remanent with - | Some x -> x.initial_step::list - | None -> list) - set - (fst refined_step::step_list)),remanent) - | Trace.Obs _,_ -> - (fst refined_step::step_list,remanent) - | Trace.Subs _,_ | Trace.Dummy _,_ -> assert false) - ([],remanent) - refined_step_with_scope_list in - List.rev a - - let agent_id_in_obs _parameter _handler info error = function - | (Trace.Subs _ | Trace.Rule _ | Trace.Pert _ - | Trace.Init _ | Trace.Dummy _) -> error,info,AgentIdSet.empty - | Trace.Obs (_,tests,_) -> - error, info, + (fun (step_list, scope) refined_step -> + match refined_step with + | Trace.Init _ -> (refined_step, scope) :: step_list, scope + | Trace.Rule (_, event, _) | Trace.Pert (_, event, _) -> + let scope' = deal_with_tests event.Instantiation.tests scope in + (refined_step, scope) :: step_list, scope' + | Trace.Obs (_, tests, _) -> + let scope' = deal_with_tests tests scope in + (refined_step, scope) :: step_list, scope' + | Trace.Subs _ | Trace.Dummy _ -> assert false) + ([], scope) rev_trace + in + let remanent = AgentIdMap.empty in + let a, _ = + List.fold_left + (fun (step_list, remanent) refined_step -> + match refined_step with + | Trace.Init init, _ -> convert_init remanent step_list init + | Trace.Rule (_, event, _), scope | Trace.Pert (_, event, _), scope -> + let remanent, set = + List.fold_left + (fun recur -> function + | PI.Create _ -> recur + | PI.Mod_internal (site, state) -> + mod_site scope site state recur + | PI.Bind (site1, site2) | PI.Bind_to (site1, site2) -> + bind scope site1 (bind scope site2 recur) + | PI.Free site -> unbind scope site recur + | PI.Remove _ -> recur) + (remanent, AgentIdSet.empty) + event.Instantiation.actions + in + let remanent, set = + List.fold_right (unbind scope) + event.Instantiation.side_effects_dst (remanent, set) + in + ( AgentIdSet.fold + (fun id list -> + match AgentIdMap.find_option id remanent with + | Some x -> x.initial_step :: list + | None -> list) + set + (fst refined_step :: step_list), + remanent ) + | Trace.Obs _, _ -> fst refined_step :: step_list, remanent + | Trace.Subs _, _ | Trace.Dummy _, _ -> assert false) + ([], remanent) refined_step_with_scope_list + in + List.rev a + + let agent_id_in_obs _parameter _handler info error = function + | Trace.Subs _ | Trace.Rule _ | Trace.Pert _ | Trace.Init _ | Trace.Dummy _ + -> + error, info, AgentIdSet.empty + | Trace.Obs (_, tests, _) -> + ( error, + info, List.fold_left - (List.fold_left - (fun l x -> - match x with - | PI.Is_Here x -> - AgentIdSet.add (agent_id_of_agent x) l - | PI.Is_Bound _ | PI.Is_Free _ | PI.Has_Binding_type _ - | PI.Is_Bound_to _ | PI.Has_Internal _ -> l)) - AgentIdSet.empty - tests - end:Cflow_signature) + (List.fold_left (fun l x -> + match x with + | PI.Is_Here x -> AgentIdSet.add (agent_id_of_agent x) l + | PI.Is_Bound _ | PI.Is_Free _ | PI.Has_Binding_type _ + | PI.Is_Bound_to _ | PI.Has_Internal _ -> + l)) + AgentIdSet.empty tests ) +end diff --git a/core/cflow/kastor_mpi.ml b/core/cflow/kastor_mpi.ml index b81b40c1b1..0bd789ccf6 100644 --- a/core/cflow/kastor_mpi.ml +++ b/core/cflow/kastor_mpi.ml @@ -7,45 +7,67 @@ (******************************************************************************) let on_message ~none ~weak ~strong ~send_message = - let parameter = ref + let parameter = + ref (Compression_main.build_parameter - ~called_from:Remanent_parameters_sig.Server - ~send_message ~none ~weak ~strong ()) in - fun text -> try - JsonUtil.read_variant - Yojson.Basic.read_string + ~called_from:Remanent_parameters_sig.Server ~send_message ~none ~weak + ~strong ()) + in + fun text -> + try + JsonUtil.read_variant Yojson.Basic.read_string (fun st b -> function - | "CONFIG" -> - let conf = - JsonUtil.read_next_item Yojson.Basic.read_json st b in - let none = match Yojson.Basic.Util.to_bool_option - (Yojson.Basic.Util.member "none" conf) - with None -> none | Some b -> b in - let weak = match Yojson.Basic.Util.to_bool_option - (Yojson.Basic.Util.member "weak" conf) - with None -> weak | Some b -> b in - let strong = match Yojson.Basic.Util.to_bool_option - (Yojson.Basic.Util.member "strong" conf) - with None -> strong | Some b -> b in - let () = parameter := - Compression_main.build_parameter - ~called_from:Remanent_parameters_sig.Server - ~send_message - ~none ~weak ~strong () in - () - | "RUN" -> - let env, steps = - JsonUtil.read_next_item - (Trace.fold_trace - (fun _env steps step -> step::steps) (fun _ -> [])) st b in - let () = Compression_main.compress_and_print - !parameter ~dotFormat:Causal.Html - env (Compression_main.init_secret_log_info ()) - (List.rev steps) in - () - | x -> - raise (Yojson.json_error ("Invalid KaStor message: "^x))) - (Yojson.Safe.init_lexer ()) (Lexing.from_string text) + | "CONFIG" -> + let conf = JsonUtil.read_next_item Yojson.Basic.read_json st b in + let none = + match + Yojson.Basic.Util.to_bool_option + (Yojson.Basic.Util.member "none" conf) + with + | None -> none + | Some b -> b + in + let weak = + match + Yojson.Basic.Util.to_bool_option + (Yojson.Basic.Util.member "weak" conf) + with + | None -> weak + | Some b -> b + in + let strong = + match + Yojson.Basic.Util.to_bool_option + (Yojson.Basic.Util.member "strong" conf) + with + | None -> strong + | Some b -> b + in + let () = + parameter := + Compression_main.build_parameter + ~called_from:Remanent_parameters_sig.Server ~send_message + ~none ~weak ~strong () + in + () + | "RUN" -> + let env, steps = + JsonUtil.read_next_item + (Trace.fold_trace + (fun _env steps step -> step :: steps) + (fun _ -> [])) + st b + in + let () = + Compression_main.compress_and_print !parameter + ~dotFormat:Causal.Html env + (Compression_main.init_secret_log_info ()) + (List.rev steps) + in + () + | x -> raise (Yojson.json_error ("Invalid KaStor message: " ^ x))) + (Yojson.Safe.init_lexer ()) + (Lexing.from_string text) with e -> let () = Format.eprintf "%s@." (Printexc.to_string e) in () (*TODO*) diff --git a/core/cflow/kastor_mpi.mli b/core/cflow/kastor_mpi.mli index fba2e3a7e8..0ec0b9688e 100644 --- a/core/cflow/kastor_mpi.mli +++ b/core/cflow/kastor_mpi.mli @@ -7,5 +7,9 @@ (******************************************************************************) val on_message : - none:bool -> weak:bool -> strong:bool -> - send_message:(string -> unit) -> string -> unit + none:bool -> + weak:bool -> + strong:bool -> + send_message:(string -> unit) -> + string -> + unit diff --git a/core/cflow/po_cut.ml b/core/cflow/po_cut.ml index 205f679e4a..d048f72be3 100644 --- a/core/cflow/po_cut.ml +++ b/core/cflow/po_cut.ml @@ -18,179 +18,166 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Po_cut = -sig - module K:Kappa_instantiation.Cflow_signature +module type Po_cut = sig + module K : Kappa_instantiation.Cflow_signature - val cut: (Trace.t,(Trace.t * int )) K.H.unary + val cut : (Trace.t, Trace.t * int) K.H.unary type on_the_fly_state + val init_cut : on_the_fly_state - val cut_step : - on_the_fly_state -> Trace.step -> on_the_fly_state + val cut_step : on_the_fly_state -> Trace.step -> on_the_fly_state val finalize_cut : on_the_fly_state -> Trace.step list * int - val cut_rev_trace: - Trace.step list (*reverse order*) -> Trace.step list (* correct order *) * int - - + val cut_rev_trace : + Trace.step list (*reverse order*) -> + Trace.step list (* correct order *) * int end -module Po_cut = - (struct - - module K=Kappa_instantiation.Cflow_linker - - type predicate_info = - | Here of K.agent_id - | Bound_site of K.agent_id * Instantiation.site_name - | Internal_state of K.agent_id * Instantiation.site_name - - module PSM = SetMap.Make (struct type t = predicate_info - let compare = compare - let print _ _ = () end) - module PS = PSM.Set - - let created_predicates_of_action action = - match action with - | Instantiation.Create (ag,interface) -> - let ag_id = K.agent_id_of_agent ag in - List.fold_left - (fun list (s_id,opt) -> - let list = Bound_site(ag_id,s_id) :: list in - match opt - with - | None -> list - | Some _ -> (Internal_state (ag_id,s_id))::list - ) - [Here ag_id] - interface - | Instantiation.Bind _ | Instantiation.Bind_to _ | Instantiation.Remove _ | Instantiation.Free _ | Instantiation.Mod_internal _ -> [] - - let predicates_of_action action = - match action with - | Instantiation.Create (ag,interface) -> - let ag_id = K.agent_id_of_agent ag in - List.fold_left - (fun list (s_id,opt) -> - let list = (Bound_site(ag_id,s_id))::list in - match opt - with - | None -> list - | Some _ -> (Internal_state (ag_id,s_id))::list - ) - [Here ag_id] - interface - | Instantiation.Mod_internal (site,_) -> - [Internal_state (K.agent_id_of_site site,K.site_name_of_site site)] - | Instantiation.Bind_to (s1,s2) | Instantiation.Bind (s1,s2) -> - [Bound_site (K.agent_id_of_site s1,K.site_name_of_site s1);Bound_site (K.agent_id_of_site s2,K.site_name_of_site s2)] - | Instantiation.Free s -> - [Bound_site (K.agent_id_of_site s,K.site_name_of_site s)] - | Instantiation.Remove _ -> [] - - let predicates_of_test test = - match test - with - | Instantiation.Is_Here (agent) -> - [Here (K.agent_id_of_agent agent)] - | Instantiation.Has_Internal(site,_) -> - [Internal_state (K.agent_id_of_site site,K.site_name_of_site site)] - | Instantiation.Is_Free s | Instantiation.Is_Bound s | Instantiation.Has_Binding_type (s,_) -> - [Bound_site (K.agent_id_of_site s,K.site_name_of_site s)] - | Instantiation.Is_Bound_to (s1,s2) -> - [Bound_site (K.agent_id_of_site s1,K.site_name_of_site s1);Bound_site (K.agent_id_of_site s2,K.site_name_of_site s2)] - - let predicates_of_side_effects sides = - List.map (fun ((ag_id,_),s_id) -> Bound_site(ag_id,s_id)) sides - - type on_the_fly_state = PS.t * Trace.step list * int - let init_cut = (PS.empty, [], 0) - let finalize_cut (_a,b,c) = b,c - - let cut_step (seen,kept,n_cut) event = - let rec keep l = - match l - with - | [] -> false - | t0::q0 -> - let rec aux1 l = - match l - with - | [] -> keep q0 - | t1::q1 -> - if PS.mem t1 seen - then true - else aux1 q1 - in - aux1 (predicates_of_action t0) - in - let rec keep2 l = - match l - with - | [] -> false - | t::q -> - if PS.mem t seen - then - true - else - keep2 q +module Po_cut : Po_cut = struct + module K = Kappa_instantiation.Cflow_linker + + type predicate_info = + | Here of K.agent_id + | Bound_site of K.agent_id * Instantiation.site_name + | Internal_state of K.agent_id * Instantiation.site_name + + module PSM = SetMap.Make (struct + type t = predicate_info + + let compare = compare + let print _ _ = () + end) + + module PS = PSM.Set + + let created_predicates_of_action action = + match action with + | Instantiation.Create (ag, interface) -> + let ag_id = K.agent_id_of_agent ag in + List.fold_left + (fun list (s_id, opt) -> + let list = Bound_site (ag_id, s_id) :: list in + match opt with + | None -> list + | Some _ -> Internal_state (ag_id, s_id) :: list) + [ Here ag_id ] interface + | Instantiation.Bind _ | Instantiation.Bind_to _ | Instantiation.Remove _ + | Instantiation.Free _ | Instantiation.Mod_internal _ -> + [] + + let predicates_of_action action = + match action with + | Instantiation.Create (ag, interface) -> + let ag_id = K.agent_id_of_agent ag in + List.fold_left + (fun list (s_id, opt) -> + let list = Bound_site (ag_id, s_id) :: list in + match opt with + | None -> list + | Some _ -> Internal_state (ag_id, s_id) :: list) + [ Here ag_id ] interface + | Instantiation.Mod_internal (site, _) -> + [ Internal_state (K.agent_id_of_site site, K.site_name_of_site site) ] + | Instantiation.Bind_to (s1, s2) | Instantiation.Bind (s1, s2) -> + [ + Bound_site (K.agent_id_of_site s1, K.site_name_of_site s1); + Bound_site (K.agent_id_of_site s2, K.site_name_of_site s2); + ] + | Instantiation.Free s -> + [ Bound_site (K.agent_id_of_site s, K.site_name_of_site s) ] + | Instantiation.Remove _ -> [] + + let predicates_of_test test = + match test with + | Instantiation.Is_Here agent -> [ Here (K.agent_id_of_agent agent) ] + | Instantiation.Has_Internal (site, _) -> + [ Internal_state (K.agent_id_of_site site, K.site_name_of_site site) ] + | Instantiation.Is_Free s + | Instantiation.Is_Bound s + | Instantiation.Has_Binding_type (s, _) -> + [ Bound_site (K.agent_id_of_site s, K.site_name_of_site s) ] + | Instantiation.Is_Bound_to (s1, s2) -> + [ + Bound_site (K.agent_id_of_site s1, K.site_name_of_site s1); + Bound_site (K.agent_id_of_site s2, K.site_name_of_site s2); + ] + + let predicates_of_side_effects sides = + List.map (fun ((ag_id, _), s_id) -> Bound_site (ag_id, s_id)) sides + + type on_the_fly_state = PS.t * Trace.step list * int + + let init_cut = PS.empty, [], 0 + let finalize_cut (_a, b, c) = b, c + + let cut_step (seen, kept, n_cut) event = + let rec keep l = + match l with + | [] -> false + | t0 :: q0 -> + let rec aux1 l = + match l with + | [] -> keep q0 + | t1 :: q1 -> + if PS.mem t1 seen then + true + else + aux1 q1 + in + aux1 (predicates_of_action t0) + in + let rec keep2 l = + match l with + | [] -> false + | t :: q -> + if PS.mem t seen then + true + else + keep2 q + in + let action_list, _ = Trace.actions_of_step event in + let seen = + List.fold_left + (fun seen action -> + List.fold_left + (fun seen elt -> PS.remove elt seen) + seen + (created_predicates_of_action action)) + seen action_list + in + let actions, _ = Trace.actions_of_step event in + if + Trace.step_is_obs event || keep actions + || keep2 (predicates_of_side_effects (Trace.side_effects_of_step event)) + then ( + let kept = event :: kept in + let tests = Trace.tests_of_step event in + let tests' = + predicates_of_side_effects (Trace.side_effects_of_step event) in - let (action_list,_) = Trace.actions_of_step event in let seen = List.fold_left - (fun seen action -> - List.fold_left - (fun seen elt -> PS.remove elt seen) - seen - (created_predicates_of_action action) - ) - seen action_list - in - let (actions,_) = Trace.actions_of_step event in - if (Trace.step_is_obs event) - || (keep actions) - || (keep2 (predicates_of_side_effects (Trace.side_effects_of_step event))) - then - begin - let kept = event::kept in - let tests = Trace.tests_of_step event in - let tests' = - predicates_of_side_effects (Trace.side_effects_of_step event) in - let seen = - List.fold_left - (fun seen test -> - List.fold_left - (fun seen predicate_info -> PS.add predicate_info seen) - seen - (predicates_of_test test) - ) - seen - tests - in - let seen = + (fun seen test -> List.fold_left (fun seen predicate_info -> PS.add predicate_info seen) - seen - tests' - in - (seen,kept,n_cut) - end - else - (seen,kept,n_cut+1) - - let cut_rev_trace rev_event_list = - let _,event_list,n = + seen (predicates_of_test test)) + seen tests + in + let seen = List.fold_left - cut_step - init_cut - rev_event_list + (fun seen predicate_info -> PS.add predicate_info seen) + seen tests' in - (event_list,n) + seen, kept, n_cut + ) else + seen, kept, n_cut + 1 - let cut _parameter _handler info error event_list = - let trace = cut_rev_trace (List.rev event_list) in - error, info, trace + let cut_rev_trace rev_event_list = + let _, event_list, n = List.fold_left cut_step init_cut rev_event_list in + event_list, n - - end:Po_cut) + let cut _parameter _handler info error event_list = + let trace = cut_rev_trace (List.rev event_list) in + error, info, trace +end diff --git a/core/cflow/predicate_maps.ml b/core/cflow/predicate_maps.ml index 83c9a48884..cd6527c899 100644 --- a/core/cflow/predicate_maps.ml +++ b/core/cflow/predicate_maps.ml @@ -1,58 +1,49 @@ type predicate_value = - | Internal_state_is of int - | Undefined (** the wire does not exist yet *) - | Present (** for agent presence *) - | Free (** for binding sites *) - | Bound_to of int * Instantiation.agent_name * Instantiation.site_name (** for binding sites *) - + | Internal_state_is of int + | Undefined (** the wire does not exist yet *) + | Present (** for agent presence *) + | Free (** for binding sites *) + | Bound_to of int * Instantiation.agent_name * Instantiation.site_name + (** for binding sites *) module A = Mods.DynArray + type predicate_info = -| Here of int -| Bound_site of int * Instantiation.site_name -| Internal_state of int * Instantiation.site_name + | Here of int + | Bound_site of int * Instantiation.site_name + | Internal_state of int * Instantiation.site_name let string_of_predicate_info pi = - match - pi - with - | Here ag -> "Here "^(string_of_int ag) - | Bound_site (ag,s) -> "Bound_state "^(string_of_int ag)^" "^(string_of_int s) - | Internal_state (ag,s) -> "Internal_state "^(string_of_int ag)^" "^(string_of_int s) + match pi with + | Here ag -> "Here " ^ string_of_int ag + | Bound_site (ag, s) -> + "Bound_state " ^ string_of_int ag ^ " " ^ string_of_int s + | Internal_state (ag, s) -> + "Internal_state " ^ string_of_int ag ^ " " ^ string_of_int s + +module PredicateSetMap = SetMap.Make (struct + type t = predicate_info -module PredicateSetMap = - SetMap.Make (struct type t = predicate_info - let compare = compare - let print f x = Format.pp_print_string - f (string_of_predicate_info x) end) + let compare = compare + let print f x = Format.pp_print_string f (string_of_predicate_info x) +end) module PredicateMap = PredicateSetMap.Map -module QPredicateMap = -struct +module QPredicateMap = struct type 'a t = 'a PredicateMap.t A.t let empty n = A.make n PredicateMap.empty - - let iter f t = - A.iter - (PredicateMap.iter f) - t + let iter f t = A.iter (PredicateMap.iter f) t let hash predicate = - match - predicate - with - | Here ag - | Bound_site (ag,_) - | Internal_state (ag,_) -> ag - - let lift f predicate_id tab = - f predicate_id (A.get tab (hash predicate_id)) + match predicate with + | Here ag | Bound_site (ag, _) | Internal_state (ag, _) -> ag + let lift f predicate_id tab = f predicate_id (A.get tab (hash predicate_id)) let find_default def p t = lift (PredicateMap.find_default def) p t - let find_option p t = lift (PredicateMap.find_option) p t - let mem p t = lift (PredicateMap.mem) p t + let find_option p t = lift PredicateMap.find_option p t + let mem p t = lift PredicateMap.mem p t let add predicate_id x tab = let hash = hash predicate_id in @@ -60,25 +51,19 @@ struct let _ = A.set tab hash (PredicateMap.add predicate_id x old) in tab - let recycle tab i = - A.set tab i PredicateMap.empty - + let recycle tab i = A.set tab i PredicateMap.empty end - module MPredicateMap = - struct - type 'a t = 'a PredicateMap.t - - let predicate_max _parameter _handler info error _list = error,info,0 - let empty _n = PredicateMap.empty - - let iter = PredicateMap.iter - let find_default = PredicateMap.find_default - let find_option = PredicateMap.find_option - let mem = PredicateMap.mem - let add = PredicateMap.add - end +module MPredicateMap = struct + type 'a t = 'a PredicateMap.t + let predicate_max _parameter _handler info error _list = error, info, 0 + let empty _n = PredicateMap.empty + let iter = PredicateMap.iter + let find_default = PredicateMap.find_default + let find_option = PredicateMap.find_option + let mem = PredicateMap.mem + let add = PredicateMap.add +end - module CPredicateMap = MPredicateMap - +module CPredicateMap = MPredicateMap diff --git a/core/cflow/priority.ml b/core/cflow/priority.ml index 82b764a1a3..6801ba8b75 100644 --- a/core/cflow/priority.ml +++ b/core/cflow/priority.ml @@ -19,15 +19,24 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -type selection_strategy = All_remaining_events | Wire_with_the_least_number_of_events | Wire_with_the_most_number_of_events +type selection_strategy = + | All_remaining_events + | Wire_with_the_least_number_of_events + | Wire_with_the_most_number_of_events + type try_to_remove_first = Late_events | Early_events -type level = Highest | High | Above_average | Average | Bellow_average | Low | Lowest +type level = + | Highest + | High + | Above_average + | Average + | Bellow_average + | Low + | Lowest let weight x = - match - x - with + match x with | Highest -> 0 | High -> 1 | Above_average -> 2 @@ -37,8 +46,18 @@ let weight x = | Lowest -> 6 let _compare_level lvl1 lvl2 = compare (weight lvl1) (weight lvl2) -let min_level a b = if compare a b <= 0 then a else b -let _max_level a b = if compare a b <= 0 then b else a + +let min_level a b = + if compare a b <= 0 then + a + else + b + +let _max_level a b = + if compare a b <= 0 then + b + else + a let highest = Highest let high = High @@ -49,11 +68,9 @@ let low = Low let lowest = Lowest let string_of_level level = - match - level - with + match level with | Highest -> "highest" - | High -> "high" + | High -> "high" | Above_average -> "above average" | Average -> "average" | Bellow_average -> "bellow average" @@ -61,11 +78,9 @@ let string_of_level level = | Lowest -> "lowest" let lower level = - match - level - with + match level with | Highest -> Some High - | High -> Some Above_average + | High -> Some Above_average | Above_average -> Some Average | Average -> Some Bellow_average | Bellow_average -> Some Low @@ -73,71 +88,70 @@ let lower level = | Lowest -> None let higher level = - match - level - with + match level with | Highest -> None - | High -> Some Highest + | High -> Some Highest | Above_average -> Some High | Average -> Some Above_average | Bellow_average -> Some Average | Low -> Some Bellow_average | Lowest -> Some Low +module LevelSetMap = SetMap.Make (struct + type t = level + + let compare = compare + let print f x = Format.pp_print_string f (string_of_level x) +end) -module LevelSetMap = SetMap.Make (struct type t = level - let compare = compare - let print f x = Format.pp_print_string - f (string_of_level x) end) module LevelMap = LevelSetMap.Map -type priorities = - { - creation: level ; - unbinding: level ; - removal: level ; - other_events: level ; - substitution: level ; - side_effects: level ; - candidate_set_of_events: selection_strategy; - try_to_remove_first: try_to_remove_first; - } +type priorities = { + creation: level; + unbinding: level; + removal: level; + other_events: level; + substitution: level; + side_effects: level; + candidate_set_of_events: selection_strategy; + try_to_remove_first: try_to_remove_first; +} (** each event is associated with a level corresponding of its actions (if multiple action, then, the least corresponding level is selected Events with the least level of priority are removed first Among them, the choice is driven by the fields 'candidate_set_of_events' and 'try_to_remove_first' *) let causal = { - creation = Highest ; - unbinding = Highest ; - removal = Highest ; - other_events = Highest ; - substitution = Highest ; - side_effects = Highest ; + creation = Highest; + unbinding = Highest; + removal = Highest; + other_events = Highest; + substitution = Highest; + side_effects = Highest; candidate_set_of_events = Wire_with_the_least_number_of_events; try_to_remove_first = Late_events; } let weak = { - creation = Highest ; - unbinding = Highest ; - removal = Highest ; - other_events = Highest ; - substitution = High ; - side_effects = High ; + creation = Highest; + unbinding = Highest; + removal = Highest; + other_events = Highest; + substitution = High; + side_effects = High; candidate_set_of_events = Wire_with_the_least_number_of_events; try_to_remove_first = Late_events; } let strong = { - creation = Highest ; - unbinding = High ; - removal = Above_average ; - other_events = Average ; - substitution = Bellow_average ; - side_effects = Low ; + creation = Highest; + unbinding = High; + removal = Above_average; + other_events = Average; + substitution = Bellow_average; + side_effects = Low; candidate_set_of_events = Wire_with_the_least_number_of_events; try_to_remove_first = Late_events; } diff --git a/core/cflow/priority.mli b/core/cflow/priority.mli index 5c6d934889..422727bf5f 100644 --- a/core/cflow/priority.mli +++ b/core/cflow/priority.mli @@ -24,50 +24,49 @@ (** parameters to tune which event is discarded next *) -type selection_strategy = All_remaining_events | Wire_with_the_least_number_of_events | Wire_with_the_most_number_of_events -type try_to_remove_first = Late_events | Early_events +type selection_strategy = + | All_remaining_events + | Wire_with_the_least_number_of_events + | Wire_with_the_most_number_of_events +type try_to_remove_first = Late_events | Early_events type level -val string_of_level: level -> string +val string_of_level : level -> string (*val strictly_higher_level: level -> level -> bool*) -val min_level: level -> level -> level - -val highest: level -val high: level -val above_average:level -val average:level -val bellow_average:level -val low: level -val lowest: level +val min_level : level -> level -> level +val highest : level +val high : level +val above_average : level +val average : level +val bellow_average : level +val low : level +val lowest : level +val lower : level -> level option +val higher : level -> level option -val lower: level -> level option -val higher: level -> level option +module LevelMap : SetMap.Map with type elt = level -module LevelMap: (SetMap.Map with type elt = level) - -type priorities = - { - creation: level ; - unbinding: level ; - removal: level ; - other_events: level ; - substitution: level ; - side_effects: level ; - candidate_set_of_events: selection_strategy; - try_to_remove_first: try_to_remove_first; - } +type priorities = { + creation: level; + unbinding: level; + removal: level; + other_events: level; + substitution: level; + side_effects: level; + candidate_set_of_events: selection_strategy; + try_to_remove_first: try_to_remove_first; +} (** each event is associated with a level corresponding of its actions (if multiple action, then, the least corresponding level is selected *) -(** Events with the least level of priority are removed first *) -(** Among them, the choice is driven by the fields 'candidate_set_of_events' and 'try_to_remove_first' *) - -val causal: priorities -val weak: priorities -val strong: priorities -val n_story: int ref -val n_branch: int ref +(** Events with the least level of priority are removed first *) +(** Among them, the choice is driven by the fields 'candidate_set_of_events' and 'try_to_remove_first' *) +val causal : priorities +val weak : priorities +val strong : priorities +val n_story : int ref +val n_branch : int ref diff --git a/core/cflow/propagation_heuristics.ml b/core/cflow/propagation_heuristics.ml index 0833124e81..058bc96aba 100644 --- a/core/cflow/propagation_heuristics.ml +++ b/core/cflow/propagation_heuristics.ml @@ -19,2005 +19,4180 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - let debug_mode = false let look_up_for_better_cut = Parameter.look_up_for_better_cut let look_down_for_better_cut = Parameter.look_down_for_better_cut -module type Blackboard_with_heuristic = - sig - module B:Blackboard.Blackboard - - type update_order - type propagation_check - - val dummy_update_order: update_order - val forced_events: (B.blackboard,(update_order list * B.PB.step_id list * unit Trace.Simulation_info.t option) list) B.PB.CI.Po.K.H.unary - val forbidden_events: (B.PB.step_id list,update_order list) B.PB.CI.Po.K.H.unary - val next_choice: (B.blackboard,update_order list) B.PB.CI.Po.K.H.unary - val apply_instruction: (B.blackboard,update_order,update_order list,propagation_check list,B.blackboard * update_order list * propagation_check list * B.assign_result) B.PB.CI.Po.K.H.quaternary - val propagate: (B.blackboard,propagation_check,update_order list,propagation_check list,B.blackboard * update_order list * propagation_check list * B.assign_result) B.PB.CI.Po.K.H.quaternary - end - -module Propagation_heuristic = - (struct +module type Blackboard_with_heuristic = sig + module B : Blackboard.Blackboard - module B=(Blackboard.Blackboard:Blackboard.Blackboard) + type update_order + type propagation_check - let warn parameter error pos ?message:(message="") exn default = - Exception.warn - (B.PB.CI.Po.K.H.get_kasa_parameters parameter) error - pos ~message exn default + val dummy_update_order : update_order - type update_order = - | Keep_event of B.PB.step_id - | Discard_event of B.PB.step_id - | Cut_event of B.PB.step_id - | Refine_value_after of B.event_case_address * B.PB.predicate_value - | Refine_value_before of B.event_case_address * B.PB.predicate_value - | Skip + val forced_events : + ( B.blackboard, + (update_order list + * B.PB.step_id list + * unit Trace.Simulation_info.t option) + list ) + B.PB.CI.Po.K.H.unary - let dummy_update_order = Skip + val forbidden_events : + (B.PB.step_id list, update_order list) B.PB.CI.Po.K.H.unary - type propagation_check = - | Propagate_up of B.event_case_address - | Propagate_down of B.event_case_address + val next_choice : (B.blackboard, update_order list) B.PB.CI.Po.K.H.unary - let _print_output log x = - if B.is_failed x - then Loggers.fprintf log "FAILED" - else if B.is_ignored x - then Loggers.fprintf log "IGNORED" - else Loggers.fprintf log "SUCCESS" + val apply_instruction : + ( B.blackboard, + update_order, + update_order list, + propagation_check list, + B.blackboard + * update_order list + * propagation_check list + * B.assign_result ) + B.PB.CI.Po.K.H.quaternary - let forced_events _parameter _handler log_info error blackboard = - let list = B.forced_events blackboard in - error,log_info, - List.rev_map - (fun (l,info)-> - List.rev_map - (fun x -> Keep_event x) - (List.rev l),l,info) - (List.rev list) + val propagate : + ( B.blackboard, + propagation_check, + update_order list, + propagation_check list, + B.blackboard + * update_order list + * propagation_check list + * B.assign_result ) + B.PB.CI.Po.K.H.quaternary +end - let forbidden_events _paramter _handler log_info error list = - error,log_info,List.rev_map (fun x -> Cut_event x) (List.rev list) +module Propagation_heuristic : Blackboard_with_heuristic = struct + module B : Blackboard.Blackboard = Blackboard.Blackboard - let get_gen_unresolved_event_on_pid first last succ stop parameter handler log_info error blackboard p_id level = - let k_init = first blackboard p_id in - let k_end = last blackboard p_id in - match k_init,k_end - with - | None,_|_,None-> error,log_info,None - | Some i,Some j -> - begin - let rec aux i log_info error = - if stop i j - then error,log_info,None - else - let event_case_address = B.build_event_case_address p_id (B.build_pointer i) in - let error,log_info,exist = B.exist_case parameter handler log_info error blackboard event_case_address in - match exist - with - | None -> - let error,log_info,(_seid,eid,_test,_action) = - B.get_static parameter handler log_info error blackboard event_case_address in - let error,log_info,level_of_event = B.level_of_event parameter handler log_info error blackboard eid in - if level_of_event = level - then - error,log_info,Some eid - else - aux (succ i) log_info error - | Some true | Some false -> - aux (succ i) log_info error - in - aux i log_info error - end + let warn parameter error pos ?(message = "") exn default = + Exception.warn + (B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error pos ~message exn default - let get_last_unresolved_event_on_pid parameter handler log_info error blackboard p_id level = - get_gen_unresolved_event_on_pid - B.get_last_linked_event - B.get_first_linked_event - B.PB.dec_step_short_id (fun i j -> i i>j) parameter handler log_info error - blackboard p_id level + let dummy_update_order = Skip - let get_gen_unresolved_event first last succ stop parameter handler log_info error blackboard level = - begin - let rec aux i log_info error = - if stop i last - then error,log_info,None - else - let error, log_info, exist = B.is_selected_event parameter handler log_info error i blackboard in - match exist - with - | None -> - let error,log_info,level_of_event = B.level_of_event parameter handler log_info error blackboard i in - if level_of_event = level - then - error,log_info,Some i - else - aux (succ i) log_info error - | Some true | Some false -> aux (succ i) log_info error - in - aux first log_info error - end + type propagation_check = + | Propagate_up of B.event_case_address + | Propagate_down of B.event_case_address - let get_last_unresolved_event parameter handler log_info error blackboard level = - get_gen_unresolved_event - (B.PB.step_id_of_int (B.get_n_eid blackboard)) - (B.PB.zero_step_id) - (B.PB.dec_step_id) (fun i j -> i i>j) parameter handler log_info error - blackboard level + let forced_events _parameter _handler log_info error blackboard = + let list = B.forced_events blackboard in + ( error, + log_info, + List.rev_map + (fun (l, info) -> + List.rev_map (fun x -> Keep_event x) (List.rev l), l, info) + (List.rev list) ) - let next_choice parameter handler log_info error blackboard = - let bool,string= - begin - match - parameter.B.PB.CI.Po.K.H.current_compression_mode - with - | None | Some Story_json.Causal-> false,"" - | Some Story_json.Weak -> - Parameter.dump_grid_after_branching_during_weak_compression,Parameter.xlsweakFileName - | Some Story_json.Strong -> - Parameter.dump_grid_after_branching_during_strong_compression,Parameter.xlsstrongFileName - end - in - let () = Priority.n_branch:= (!Priority.n_branch)+1 in - let error,log_info = - if bool - then - let error,log_info,() = B.export_blackboard_to_xls parameter handler log_info error string - (!Priority.n_story) (!Priority.n_branch) blackboard in - error,log_info - else - error,log_info - in - let error, priority = - match - B.PB.CI.Po.K.H.get_priorities parameter - with - | Some x -> error,x - | None -> - warn - parameter error __POS__ - ~message:"Compression mode has to been selected" - (Failure "Compression mode has not been selected") - Priority.causal - in - let n_p_id = B.get_npredicate_id blackboard in - let error,() = - match - priority.Priority.candidate_set_of_events - with - | Priority.All_remaining_events -> - warn - parameter error __POS__ - ~message:"All_remaining_events strategy is not implemented yet" (Failure "All remaining events strategy is not implemented yet") - () - | Priority.Wire_with_the_least_number_of_events -> error,() - | Priority.Wire_with_the_most_number_of_events -> error,() - in - let best_pair x a b = - match - x.Priority.candidate_set_of_events - with - | Priority.All_remaining_events - | Priority.Wire_with_the_most_number_of_events -> Tools.max_pos_int_not_zero a b - | Priority.Wire_with_the_least_number_of_events -> Tools.min_pos_int_not_zero a b - in - let get_unresolved_event x parameter handler log_info error blackboard p_id level = - match - x.Priority.try_to_remove_first - with - | Priority.Late_events -> - begin - match - x.Priority.candidate_set_of_events - with - | Priority.All_remaining_events -> get_last_unresolved_event - parameter handler log_info error blackboard level - | Priority.Wire_with_the_most_number_of_events - | Priority.Wire_with_the_least_number_of_events -> - get_last_unresolved_event_on_pid parameter handler log_info error blackboard p_id level - end - | Priority.Early_events -> - begin - match - x.Priority.candidate_set_of_events - with - | Priority.All_remaining_events -> get_first_unresolved_event parameter handler log_info error blackboard level - | Priority.Wire_with_the_most_number_of_events - | Priority.Wire_with_the_least_number_of_events -> - get_first_unresolved_event_on_pid parameter handler log_info error blackboard p_id level - end - in - let error,list = - if n_p_id = 0 - then - error,[] - else - let rec try_level level_opt error = - match level_opt - with - | None -> - error,[] - | Some level -> - let rec aux level n_p_id step best = - if step=n_p_id - then - best - else - let grade = B.get_n_unresolved_events_of_pid_by_level blackboard step level in - aux level n_p_id (step+1) (best_pair priority best (grade,step)) - in - let n,p_id = - aux level n_p_id 1 (B.get_n_unresolved_events_of_pid_by_level blackboard 0 level,0) - in - if n = 0 - then - try_level (Priority.lower level) error - else - let error,_log_info,event_id = - get_unresolved_event priority parameter handler log_info error blackboard p_id level - in - match event_id - with - | None -> - let log = B.PB.CI.Po.K.H.get_debugging_channel parameter in + let forbidden_events _paramter _handler log_info error list = + error, log_info, List.rev_map (fun x -> Cut_event x) (List.rev list) - let error,() = - warn - parameter error __POS__ - ~message:("An empty wire has been selected"^(string_of_int n)) - (Failure "An empty wire has been selected") () - in - let () = - Loggers.fprintf log "ERROR 249: %s\n" (Priority.string_of_level level) - in - try_level (Priority.lower level) error - | Some event_id -> - error,[Discard_event event_id;Keep_event event_id] + let get_gen_unresolved_event_on_pid first last succ stop parameter handler + log_info error blackboard p_id level = + let k_init = first blackboard p_id in + let k_end = last blackboard p_id in + match k_init, k_end with + | None, _ | _, None -> error, log_info, None + | Some i, Some j -> + let rec aux i log_info error = + if stop i j then + error, log_info, None + else ( + let event_case_address = + B.build_event_case_address p_id (B.build_pointer i) in - try_level (Some Priority.highest) error + let error, log_info, exist = + B.exist_case parameter handler log_info error blackboard + event_case_address + in + match exist with + | None -> + let error, log_info, (_seid, eid, _test, _action) = + B.get_static parameter handler log_info error blackboard + event_case_address + in + let error, log_info, level_of_event = + B.level_of_event parameter handler log_info error blackboard eid + in + if level_of_event = level then + error, log_info, Some eid + else + aux (succ i) log_info error + | Some true | Some false -> aux (succ i) log_info error + ) in - error,log_info,list + aux i log_info error - let print_event_case_address parameter handler log_info error blackboard case = - let error,log_info,(_,eid,_,_) = - B.get_static parameter handler log_info error blackboard case in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Event: %i, Predicate: %i" (B.PB.int_of_step_id eid) (B.predicate_id_of_case_address case) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info,() + let get_last_unresolved_event_on_pid parameter handler log_info error + blackboard p_id level = + get_gen_unresolved_event_on_pid B.get_last_linked_event + B.get_first_linked_event B.PB.dec_step_short_id + (fun i j -> i < j) + parameter handler log_info error blackboard p_id level - let propagate_down parameter handler log_info error blackboard event_case_address instruction_list propagate_list = - begin - let error,log_info,bool = B.exist_case parameter handler log_info error blackboard event_case_address in - match bool - with - | Some false -> - (* the case has been removed from the blackboard, nothing to be done *) - error, - log_info, - (blackboard, - instruction_list, - propagate_list, - B.success) - | Some true | None -> - (* we know that the pair (test/action) can been executed *) - let case_address = B.case_address_of_case_event_address event_case_address in - let error,log_info,case_value = B.get parameter handler log_info error case_address blackboard in - let error,log_info,predicate_value = B.predicate_value_of_case_value parameter handler log_info error case_value in - begin - let error,log_info,next_event_case_address = B.follow_pointer_down parameter handler log_info error blackboard event_case_address in - let error,log_info,bool2 = B.exist_case parameter handler log_info error blackboard next_event_case_address in - match bool2 - with - | Some false -> - begin - (* The blackboard is inconsistent: *) - (* Pointers should not point to removed events.*) - let error,() = - warn - parameter error __POS__ - ~message:"inconsistent pointers in blackboard" - (Failure "inconsistent pointers in blackboard") () - in - error, - log_info, - (blackboard, - instruction_list, - propagate_list, - B.success) - end - | Some true -> - begin (* next event is selected *) - let error,log_info,(_next_seid,_next_eid,next_test,next_action) = - B.get_static parameter handler log_info error blackboard next_event_case_address in - let case_address = B.case_address_of_case_event_address event_case_address in - let error,log_info,case_value = B.get parameter handler log_info error case_address blackboard in - let error,log_info,predicate_value = B.predicate_value_of_case_value parameter handler log_info error case_value in - match B.PB.is_unknown next_test,B.PB.is_unknown next_action - with - | true,true -> - begin (* no test, no action in next event *) - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 1):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event is kept but has no test and no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Value is propagated after the next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - (* next event is selected *) - (* no test, no action in next event *) - (* we propagate the value after the next event*) - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 1 log_info in - error, - log_info, - (blackboard, - (Refine_value_after(next_event_case_address,predicate_value))::instruction_list, - propagate_list, - B.success) - end - | true,false -> (* no test, but an action in next event *) - begin - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 2):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event is kept, no test, but an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Nothing to be done" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - (* next event is selected *) - (* no test, but an action in next event *) - (* nothing to propagate downward*) - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 2 log_info in - error, - log_info, - (blackboard, - instruction_list, - propagate_list, - B.success) - end - | false,true -> (* no action, but a test in next event *) - begin - if B.PB.compatible predicate_value next_test - then - (* the test is compatible with the value *) - let error,log_info,conj = B.PB.conj parameter handler log_info error next_test predicate_value in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 3):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event is kept, a test but no action " in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate new predicate_value " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) conj in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " before and after next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - (* next event is selected *) - (* no action, but a test in next event *) - (* the test is compatible with the value *) - (* we propagate the meet of the test and the value before and after the next event *) - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 3 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(next_event_case_address,conj))::(Refine_value_after(next_event_case_address,conj))::instruction_list, - propagate_list, - B.success) - else (* the test and the value are incompatible *) - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 4):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event is kept, a test but no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Cut" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 4 log_info in - (* next event is selected *) - (* no action, but a test in next event *) - (* the test is not compatible with the value *) - (* we cut the exploration *) - error, - log_info, - (blackboard, - [], - [], - B.fail) - end - | false,false -> - begin (*there is a test and an action in the next event *) - if B.PB.compatible predicate_value next_test - then (* the test and the value are compatible *) - let error,log_info,conj = B.PB.conj parameter handler log_info error next_test predicate_value in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 5):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event is kept, a test but no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Action:" in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate new predicate_value " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) conj in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " before the next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 5 log_info in - (* next event is selected *) - (* an action and a test in next event *) - (* the test is compatible with the value *) - (* we propagate the meet of the test and the value before the next event *) - error, - log_info, - (blackboard, - (Refine_value_before(next_event_case_address,conj))::instruction_list, - propagate_list, - B.success) - else (* test and value are incompatible *) - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 6):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event is kept, a test, an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Next event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Cut" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 6 log_info in - (* next event is selected *) - (* an action and a test in next event *) - (* the test is not compatible with the value *) - (* we cut the exploration *) - error, - log_info, - (blackboard, - [], - [], - B.fail) - end - end - | None -> (* we do not know whether the event is played or not *) - begin - let error,log_info,(_next_seid,next_eid,next_test,next_action) = - B.get_static parameter handler log_info error blackboard next_event_case_address in - match B.PB.is_unknown next_action - with - | true -> - begin (* there is no action in the next event *) - match - B.PB.is_unknown next_test - with - | true -> (*there is no test in the next event *) - begin - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 7):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the next event is kept" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is no test, no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The value is propagated after and before the next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***\n" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 7 log_info in - (* we do not know whether the event is played or not *) - (*there is no test in the next event *) - (* there is no action in the next event *) - (* we propagate the value after the next event*) - error, - log_info, - (blackboard, - (Refine_value_after(next_event_case_address,predicate_value))::instruction_list, - propagate_list, - B.success) - end - | false -> - begin (* there is a test in the next event *) - if B.PB.compatible next_test predicate_value - then (* test and predicate_value are compatible *) - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 8):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the next event is kept" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is a test, but no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The value " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " is propagated after and before the next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 8 log_info in - (* we do not know whether the event is played or not *) - (* there is a test in the next event *) - (* there is no action in the next event *) - (* the test is compatible with the value *) - (* we propagate the value after the next event*) - error, - log_info, - ( blackboard, - (Refine_value_after(next_event_case_address,predicate_value))::instruction_list, - propagate_list, - B.success) - else - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 9):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the next event is kept" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is a test, but no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "We discard the next event (%i)" (B.PB.int_of_step_id next_eid) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 9 log_info in - (* we do not know whether the event is played or not *) - (* there is a test in the next event *) - (* there is no action in the next event *) - (* the test is not compatible with the value *) - (* we discard the next event *) - error, - log_info, - (blackboard, - (Discard_event(next_eid)::instruction_list), - propagate_list, - B.success) - end - end - | false -> - begin (* there is an action in the next event *) - if not (B.PB.compatible next_action predicate_value) - then (* the action is not compatible with the value *) - let error,log_info,computed_next_predicate_value = - B.PB.disjunction parameter handler log_info error predicate_value next_action - in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 10):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the next event is kept" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The value " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) computed_next_predicate_value in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " is propagated after the next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 10 log_info in - (* we do not know whether the event is played or not *) - (* there is an action in the next event *) - (* the action is compatible with the value *) - (* we propagate the join of the value and the action after the next event*) - error, - log_info, - (blackboard, - (Refine_value_after(next_event_case_address,computed_next_predicate_value))::instruction_list, - propagate_list, - B.success) - else - begin (*the action is compatible with the value *) - let error,log_info,computed_next_predicate_value = - B.PB.disjunction parameter handler log_info error predicate_value next_action - in - match B.PB.is_unknown next_test - with - | true -> - begin (* there is no test in the next event *) - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 11):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the next event is kept" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is no test, but there is an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The value " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) computed_next_predicate_value in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " is propagated after the next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 11 log_info in - (* we do not know whether the event is played or not *) - (* there is no test in the next event *) - (* there is an action in the next event *) - (* the action is compatible with the value *) - (* we propagate the join of the value and the action after the next event*) - error, - log_info, - (blackboard, - (Refine_value_after(next_event_case_address,computed_next_predicate_value))::instruction_list, - propagate_list, - B.success) - end - | false -> - begin - if B.PB.compatible next_test predicate_value - then - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 12):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the next event is kept" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is a test, but there is an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The value " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) computed_next_predicate_value in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " is propagated after the next event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 12 log_info in - (* we do not know whether the event is played or not *) - (* there is a test in the next event *) - (* there is an action in the next event *) - (* the test is compatible with the value *) - (* the action is compatible with the value *) - (* we propagate the join of the value and the action after the next event*) - error, - log_info, - (blackboard, - (Refine_value_after(next_event_case_address,computed_next_predicate_value))::instruction_list, - propagate_list, - B.success) - else - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_down (case 13):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the next event is kept" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is a test, but there is an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "next event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) next_action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Next event (%i) is discarded" (B.PB.int_of_step_id next_eid) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_down 13 log_info in - (* we do not know whether the event is played or not *) - (* there is a test in the next event *) - (* there is an action in the next event *) - (* the test is not compatible with the value *) - (* we discard the next event *) - error, - log_info, - (blackboard, - (Discard_event(next_eid)::instruction_list), - propagate_list, - B.success) - end - end - end - end - end - end + let get_first_unresolved_event_on_pid parameter handler log_info error + blackboard p_id level = + get_gen_unresolved_event_on_pid B.get_first_linked_event + B.get_last_linked_event B.PB.inc_step_short_id + (fun i j -> i > j) + parameter handler log_info error blackboard p_id level - let rec last_chance_up parameter handler log_info error blackboard predicate_value event_case_address = - let error,log_info,bool = B.exist_case parameter handler log_info error blackboard event_case_address in - match - bool - with - | Some false -> - error,false,log_info,blackboard - | Some true -> - begin - let error,log_info,(_seid,_eid,_test,action) = - B.get_static parameter handler log_info error blackboard event_case_address in - if B.PB.is_unknown action - then - begin - let error,log_info,preview_event_case_address = B.follow_pointer_up parameter handler log_info error blackboard event_case_address in - let preview_case_address = B.case_address_of_case_event_address preview_event_case_address in - let error,log_info,preview_case_value = B.get parameter handler log_info error preview_case_address blackboard in - let error,log_info,preview_predicate_value = B.predicate_value_of_case_value parameter handler log_info error preview_case_value in - if B.PB.compatible preview_predicate_value predicate_value - then - let error,log_info,bool = B.is_boundary parameter handler log_info error blackboard event_case_address in - if bool - then - let log_info = StoryProfiling.StoryStats.add_look_up_case 1 log_info in - error,not (B.PB.is_undefined predicate_value),log_info,blackboard - else - last_chance_up parameter handler log_info error blackboard predicate_value preview_event_case_address - else - let log_info = StoryProfiling.StoryStats.add_look_up_case 2 log_info in - error,true,log_info,blackboard - end - else - begin - if B.PB.more_refined action predicate_value - then - error,false,log_info,blackboard - else - let log_info = StoryProfiling.StoryStats.add_look_up_case 3 log_info in - error,true,log_info,blackboard - end - end + let get_gen_unresolved_event first last succ stop parameter handler log_info + error blackboard level = + let rec aux i log_info error = + if stop i last then + error, log_info, None + else ( + let error, log_info, exist = + B.is_selected_event parameter handler log_info error i blackboard + in + match exist with | None -> - begin - let error,log_info,(_seid,_eid,_test,action) = - B.get_static parameter handler log_info error blackboard event_case_address in - if B.PB.more_refined action predicate_value - then - error,false,log_info,blackboard - else - begin - let error,log_info,preview_event_case_address = B.follow_pointer_up parameter handler log_info error blackboard event_case_address in - let preview_case_address = B.case_address_of_case_event_address preview_event_case_address in - let error,log_info,preview_case_value = B.get parameter handler log_info error preview_case_address blackboard in - let error,log_info,preview_predicate_value = B.predicate_value_of_case_value parameter handler log_info error preview_case_value in - if B.PB.compatible preview_predicate_value predicate_value - then - last_chance_up parameter handler log_info error blackboard predicate_value preview_event_case_address - else - let log_info = StoryProfiling.StoryStats.add_look_up_case 4 log_info in - error,true,log_info,blackboard - end - end - - let last_chance_up parameter handler log_info error blackboard predicate_value address = - if B.PB.is_unknown predicate_value - then error,false,log_info,blackboard - else last_chance_up parameter handler log_info error blackboard predicate_value address - - let last_chance_up = - if look_up_for_better_cut - then last_chance_up - else (fun _ _ log_info error blackboard _ _ -> - error, - false, - log_info, - blackboard) - - - let propagate_up parameter handler log_info error blackboard event_case_address instruction_list propagate_list = - begin - let error,log_info,bool = B.exist_case parameter handler log_info error blackboard event_case_address in - match bool - with - | Some false -> - (* the case has been removed from the blackboard, nothing to be done *) - error, - log_info, - (blackboard, - instruction_list, - propagate_list, - B.success) - | Some true -> - (* we know that the pair (test/action) has been executed *) - let error,log_info,(_seid,_eid,test,action) = - B.get_static parameter handler log_info error blackboard event_case_address in - let case_address = B.case_address_of_case_event_address event_case_address in - let error,log_info,case_value = B.get parameter handler log_info error case_address blackboard in - let error,log_info,predicate_value = B.predicate_value_of_case_value parameter handler log_info error case_value in - begin - if B.PB.is_unknown action - then - (* no action, we keep on propagating with the conjonction of the test of the value *) - begin - if B.PB.compatible test predicate_value - then - let error,log_info,new_value = B.PB.conj parameter handler log_info error test predicate_value in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 1):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The event before is kept, there is no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Refine before the event (before) with the state " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) new_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 1 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(event_case_address,new_value))::instruction_list, - propagate_list, - B.success) - else - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 2):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The event before is kept, there is no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Cut" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 2 log_info in - error, - log_info, - (blackboard, - [], - [], - B.fail) - end - else - if B.PB.more_refined action predicate_value - then - if B.PB.is_undefined test - then (*the wire has just be created, nothing to be done *) - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 3):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The event before is kept, there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Nothing to be done" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 3 log_info in - error, - log_info, - (blackboard, - instruction_list, - propagate_list, - B.success) - else (*we know that the wire was defined before*) - if B.PB.compatible test B.PB.defined - then - begin - let error,log_info,state = B.PB.conj parameter handler log_info error test B.PB.defined in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 4):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The event before is kept, there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Refine before the event (before) with the state " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) state in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "" in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 4 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(event_case_address,state)::instruction_list), - propagate_list, - B.success) - end - else - begin - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 5):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The event before is kept, there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Cut" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 5 log_info in - error, - log_info, - (blackboard, - [], - [], - B.fail) - end - else (*The event has to be discarded which is absurd *) - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 6):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "The event before is kept, there is an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Cut" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 6 log_info in - error, - log_info, - (blackboard, - [], - [], - B.fail) - end - | None -> - (* we do not know whether the pair (test/action) has been executed *) - let error,log_info,(_seid,eid,test,action) = - B.get_static parameter handler log_info error blackboard event_case_address in - let case_address = B.case_address_of_case_event_address event_case_address in - let error,log_info,case_value = B.get parameter handler log_info error case_address blackboard in - let error,log_info,predicate_value = B.predicate_value_of_case_value parameter handler log_info error case_value in - begin - match B.PB.is_unknown action - with - | true -> - begin - match - B.PB.is_unknown test - with - | true -> - begin - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 7):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is neither a test, nor action " in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Refine before the event (before) with the state " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 7 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(event_case_address,predicate_value))::instruction_list, - propagate_list, - B.success) - end - | false -> - begin - if B.PB.compatible test predicate_value - then - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 8):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is a test, but no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Refine before the event (before) with the state " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 8 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(event_case_address,predicate_value))::instruction_list, - propagate_list, - B.success) - else - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 9):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is a test, but no action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Event before (%i) is discarded" - (B.PB.int_of_step_id eid) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 9 log_info in - error, - log_info, - (blackboard, - (Discard_event(eid))::instruction_list, - propagate_list, - B.success) - end - end - | false -> - begin - let error,log_info,preview_event_case_address = B.follow_pointer_up parameter handler log_info error blackboard event_case_address in - let preview_case_address = B.case_address_of_case_event_address preview_event_case_address in - let error,log_info,preview_case_value = B.get parameter handler log_info error preview_case_address blackboard in - let error,log_info,preview_predicate_value = B.predicate_value_of_case_value parameter handler log_info error preview_case_value in - if B.PB.compatible preview_predicate_value predicate_value - then - if B.PB.more_refined action predicate_value - then - begin - let error,bool,log_info,blackboard = last_chance_up parameter handler log_info error blackboard predicate_value preview_event_case_address - in - if bool - then - begin - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 10):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " there is an action" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "This is the only opportunity to set up the wire, we keep the event" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 10 log_info in - error, - log_info, - (blackboard, - (Keep_event(eid))::instruction_list, - propagate_list, - B.success) - end - else - begin - match - B.PB.is_unknown test - with - | true -> - begin - let error,log_info,new_predicate_value = B.PB.disjunction parameter handler log_info error test predicate_value in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 11):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is an action, but no test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Refine before the event (before) with the state " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) preview_predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 11 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(event_case_address,new_predicate_value))::instruction_list, - propagate_list, - B.success) - end - | false -> - begin - if B.PB.compatible test predicate_value - then - begin - if B.PB.compatible test preview_predicate_value - then - let error,log_info,new_test = B.PB.conj parameter handler log_info error test preview_predicate_value in - let error,log_info,new_predicate_value = B.PB.disjunction parameter handler log_info error new_test predicate_value in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 12):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test:" in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Refine before the event (before) with the state " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) new_predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 12 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(event_case_address,new_predicate_value))::instruction_list, - propagate_list, - B.success) - else - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 13):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test:" in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Discard the event before (%i)" - (B.PB.int_of_step_id eid) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 13 log_info in - error, - log_info, - (blackboard, - (Discard_event(eid))::instruction_list, - propagate_list, - B.success) - end - else - let error,log_info,prev' = B.PB.disjunction parameter handler log_info error predicate_value test in - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 14):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test:" in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Refine before the event (before) with the state " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) prev' in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 14 log_info in - error, - log_info, - (blackboard, - (Refine_value_before(event_case_address,prev'))::instruction_list, - propagate_list, - B.success) - end - end - end - else - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 15):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " there is an action and maybe a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Discard the event before (%i)" - (B.PB.int_of_step_id eid) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 15 log_info in - error, - log_info, - (blackboard, - Discard_event(eid)::instruction_list, - propagate_list, - B.success) - else - if B.PB.more_refined action predicate_value - then - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 16):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test:" in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Previous wire state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) preview_predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Select the event before (%i)" (B.PB.int_of_step_id eid) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 16 log_info in - error, - log_info, - (blackboard, - (Keep_event(eid))::instruction_list, - propagate_list, - B.success) - else - let error,log_info = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Propagate_up (case 17):" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let error,log_info,() = print_event_case_address parameter handler log_info error blackboard event_case_address in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "we do not know if the event before is kept," in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) " there is an action and a test" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Test:" in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) test in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "before event Action: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) action in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Wire_state: " in - let () = B.PB.print_predicate_value (B.PB.CI.Po.K.H.get_debugging_channel parameter) predicate_value in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "Cut" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - error,log_info - else - error,log_info - in - let log_info = StoryProfiling.StoryStats.add_propagation_case_up 17 log_info in - error, - log_info, - (blackboard, - [], - [], - B.fail) - end - end - end - - let propagate parameter handler log_info error blackboard check instruction_list propagate_list = - match check - with - | Propagate_up x -> propagate_up parameter handler log_info error blackboard x instruction_list propagate_list - | Propagate_down x -> propagate_down parameter handler log_info error blackboard x instruction_list propagate_list - - let cut_case parameter handler case (error,log_info,blackboard,instruction_list,propagate_list) = - let error,log_info,pointer_next = B.follow_pointer_down parameter handler log_info error blackboard case in - let error,log_info,pointer_previous = B.follow_pointer_up parameter handler log_info error blackboard case in - (* we remove the case *) - let error,log_info,(blackboard,result) = - B.refine - parameter - handler - log_info - error - (B.exist case) - (B.boolean (Some false)) - blackboard - in - if B.is_failed result - then (error,log_info,blackboard,[],[]),result - else if B.is_ignored result - then (error,log_info,blackboard,instruction_list,propagate_list),result - else - begin - let error,log_info,blackboard = B.dec parameter handler log_info error (B.n_unresolved_events_in_column case) blackboard in - (* we plug pointer next of the previous event *) - let error,log_info,blackboard = - B.overwrite - parameter - handler - log_info - error - (B.pointer_to_next pointer_previous) - (B.pointer pointer_next) - blackboard + let error, log_info, level_of_event = + B.level_of_event parameter handler log_info error blackboard i in - (* we plug pointer previous of the next event *) - let error,log_info,blackboard = - B.overwrite - parameter - handler - log_info - error - (B.pointer_to_previous pointer_next) - (B.pointer pointer_previous) - blackboard - in - (error,log_info,blackboard,instruction_list,propagate_list),result - end - - let look_down parameter handler log_info error blackboard propagate_list case = - begin - let error,log_info,(_,_,_,action) = B.get_static parameter handler log_info error blackboard case in - if B.PB.is_unknown action - then - error,log_info,blackboard,propagate_list - else - let list_values = B.PB.weakening action in - begin - let propagate_list,error,log_info,blackboard = - List.fold_left - (fun (propagate_list,error,log_info,blackboard) value -> - let rec aux case bool error log_info = - let ca = B.case_address_of_case_event_address case in - let error,log_info,case_value = B.get parameter handler log_info error ca blackboard in - let error,log_info,predicate_value = B.predicate_value_of_case_value parameter handler log_info error case_value in - if B.PB.more_refined predicate_value value - then - let error,log_info,pointer_next = B.follow_pointer_down parameter handler log_info error blackboard case in - let log_info = StoryProfiling.StoryStats.add_look_down_case 1 log_info in - (Propagate_up pointer_next)::propagate_list,error,log_info,blackboard - else - let error,log_info,next_case = B.follow_pointer_down parameter handler log_info error blackboard case in - let error,log_info,exist = B.exist_case parameter handler log_info error blackboard next_case in - match exist - with - | Some true -> - let log_info = StoryProfiling.StoryStats.add_look_down_case 2 log_info in - propagate_list,error,log_info,blackboard - | Some false -> aux next_case bool error log_info - | None -> - let error,log_info,(_,_,_,next_action) = B.get_static parameter handler log_info error blackboard next_case in - if B.PB.more_refined next_action value - then - if bool - then - let log_info = StoryProfiling.StoryStats.add_look_down_case 3 log_info in - propagate_list,error,log_info,blackboard - else - aux next_case true error log_info - else - aux next_case bool error log_info - in - aux case false error log_info) - (propagate_list,error,log_info,blackboard) - list_values - in error,log_info,blackboard,propagate_list - end - end + if level_of_event = level then + error, log_info, Some i + else + aux (succ i) log_info error + | Some true | Some false -> aux (succ i) log_info error + ) + in + aux first log_info error - let look_down = - if look_down_for_better_cut - then look_down - else (fun _ _ log_info error blackboard list _ -> error,log_info,blackboard,list) + let get_last_unresolved_event parameter handler log_info error blackboard + level = + get_gen_unresolved_event + (B.PB.step_id_of_int (B.get_n_eid blackboard)) + B.PB.zero_step_id B.PB.dec_step_id + (fun i j -> i < j) + parameter handler log_info error blackboard level + let get_first_unresolved_event parameter handler log_info error blackboard + level = + get_gen_unresolved_event B.PB.zero_step_id + (B.PB.step_id_of_int (B.get_n_eid blackboard)) + B.PB.inc_step_id + (fun i j -> i > j) + parameter handler log_info error blackboard level - let refine_value_after parameter handler log_info error blackboard address value instruction_list propagate_list = - let case_address = B.value_after address in - let state = B.state value in - let error,log_info,(blackboard,result) = B.refine parameter handler log_info error case_address state blackboard in - if B.is_ignored result - then - error,log_info,(blackboard,instruction_list,propagate_list,result) - else if B.is_failed result - then - error,log_info,(blackboard,[],[],result) - else - let propagate_list = (Propagate_up address)::(Propagate_down address)::propagate_list in - error,log_info,(blackboard,instruction_list,propagate_list,result) + let next_choice parameter handler log_info error blackboard = + let bool, string = + match parameter.B.PB.CI.Po.K.H.current_compression_mode with + | None | Some Story_json.Causal -> false, "" + | Some Story_json.Weak -> + ( Parameter.dump_grid_after_branching_during_weak_compression, + Parameter.xlsweakFileName ) + | Some Story_json.Strong -> + ( Parameter.dump_grid_after_branching_during_strong_compression, + Parameter.xlsstrongFileName ) + in + let () = Priority.n_branch := !Priority.n_branch + 1 in + let error, log_info = + if bool then ( + let error, log_info, () = + B.export_blackboard_to_xls parameter handler log_info error string + !Priority.n_story !Priority.n_branch blackboard + in + error, log_info + ) else + error, log_info + in + let error, priority = + match B.PB.CI.Po.K.H.get_priorities parameter with + | Some x -> error, x + | None -> + warn parameter error __POS__ + ~message:"Compression mode has to been selected" + (Failure "Compression mode has not been selected") Priority.causal + in + let n_p_id = B.get_npredicate_id blackboard in + let error, () = + match priority.Priority.candidate_set_of_events with + | Priority.All_remaining_events -> + warn parameter error __POS__ + ~message:"All_remaining_events strategy is not implemented yet" + (Failure "All remaining events strategy is not implemented yet") () + | Priority.Wire_with_the_least_number_of_events -> error, () + | Priority.Wire_with_the_most_number_of_events -> error, () + in + let best_pair x a b = + match x.Priority.candidate_set_of_events with + | Priority.All_remaining_events + | Priority.Wire_with_the_most_number_of_events -> + Tools.max_pos_int_not_zero a b + | Priority.Wire_with_the_least_number_of_events -> + Tools.min_pos_int_not_zero a b + in + let get_unresolved_event x parameter handler log_info error blackboard p_id + level = + match x.Priority.try_to_remove_first with + | Priority.Late_events -> + (match x.Priority.candidate_set_of_events with + | Priority.All_remaining_events -> + get_last_unresolved_event parameter handler log_info error blackboard + level + | Priority.Wire_with_the_most_number_of_events + | Priority.Wire_with_the_least_number_of_events -> + get_last_unresolved_event_on_pid parameter handler log_info error + blackboard p_id level) + | Priority.Early_events -> + (match x.Priority.candidate_set_of_events with + | Priority.All_remaining_events -> + get_first_unresolved_event parameter handler log_info error blackboard + level + | Priority.Wire_with_the_most_number_of_events + | Priority.Wire_with_the_least_number_of_events -> + get_first_unresolved_event_on_pid parameter handler log_info error + blackboard p_id level) + in + let error, list = + if n_p_id = 0 then + error, [] + else ( + let rec try_level level_opt error = + match level_opt with + | None -> error, [] + | Some level -> + let rec aux level n_p_id step best = + if step = n_p_id then + best + else ( + let grade = + B.get_n_unresolved_events_of_pid_by_level blackboard step + level + in + aux level n_p_id (step + 1) + (best_pair priority best (grade, step)) + ) + in + let n, p_id = + aux level n_p_id 1 + (B.get_n_unresolved_events_of_pid_by_level blackboard 0 level, 0) + in + if n = 0 then + try_level (Priority.lower level) error + else ( + let error, _log_info, event_id = + get_unresolved_event priority parameter handler log_info error + blackboard p_id level + in + match event_id with + | None -> + let log = B.PB.CI.Po.K.H.get_debugging_channel parameter in - let refine_value_before parameter handler log_info error blackboard address value instruction_list propagate_list = - let error,log_info,pointer_previous = B.follow_pointer_up parameter handler log_info error blackboard address in - refine_value_after parameter handler log_info error blackboard pointer_previous value instruction_list propagate_list + let error, () = + warn parameter error __POS__ + ~message: + ("An empty wire has been selected" ^ string_of_int n) + (Failure "An empty wire has been selected") () + in + let () = + Loggers.fprintf log "ERROR 249: %s\n" + (Priority.string_of_level level) + in + try_level (Priority.lower level) error + | Some event_id -> + error, [ Discard_event event_id; Keep_event event_id ] + ) + in + try_level (Some Priority.highest) error + ) + in + error, log_info, list + let print_event_case_address parameter handler log_info error blackboard case + = + let error, log_info, (_, eid, _, _) = + B.get_static parameter handler log_info error blackboard case + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Event: %i, Predicate: %i" (B.PB.int_of_step_id eid) + (B.predicate_id_of_case_address case) + in + let () = + Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info, () - let discard_case parameter handler case (error,log_info,blackboard,instruction_list,propagate_list) = - let error,log_info,pointer_next = B.follow_pointer_down parameter handler log_info error blackboard case in - let error,log_info,pointer_previous = B.follow_pointer_up parameter handler log_info error blackboard case in - (* we remove the case *) - let error,log_info,(blackboard,result) = - B.refine - parameter - handler - log_info - error - (B.exist case) - (B.boolean (Some false)) - blackboard + let propagate_down parameter handler log_info error blackboard + event_case_address instruction_list propagate_list = + let error, log_info, bool = + B.exist_case parameter handler log_info error blackboard + event_case_address + in + match bool with + | Some false -> + (* the case has been removed from the blackboard, nothing to be done *) + error, log_info, (blackboard, instruction_list, propagate_list, B.success) + | Some true | None -> + (* we know that the pair (test/action) can been executed *) + let case_address = + B.case_address_of_case_event_address event_case_address in - if B.is_failed result - then (error,log_info,blackboard,[],[]),result - else if B.is_ignored result - then (error,log_info,blackboard,instruction_list,propagate_list),result - else - let ca = B.case_address_of_case_event_address case in - let error,log_info,case_value = B.get parameter handler log_info error ca blackboard in - let error,log_info,predicate_value = B.predicate_value_of_case_value parameter handler log_info error case_value in - begin - let error,log_info,(blackboard,instruction_list,_,result') = refine_value_after parameter handler log_info error blackboard pointer_previous predicate_value instruction_list propagate_list in - if B.is_failed result' - then (error,log_info,blackboard,[],[]),result' - else - let error,log_info,blackboard = B.dec parameter handler log_info error (B.n_unresolved_events_in_column case) blackboard in - let error,log_info,(_,event,_,_) = B.get_static parameter handler log_info error blackboard case in - let error,log_info,level = B.level_of_event parameter handler log_info error blackboard event in - let error,log_info,blackboard = B.dec parameter handler log_info error - (B.n_unresolved_events_in_column_at_level case level) blackboard in - (* we plug pointer next of the previous event *) - let error,log_info,blackboard = - B.overwrite - parameter - handler - log_info - error - (B.pointer_to_next pointer_previous) - (B.pointer pointer_next) - blackboard - in - (* we plug pointer previous of the next event *) - let error,log_info,blackboard = - B.overwrite - parameter - handler - log_info - error - (B.pointer_to_previous pointer_next) - (B.pointer pointer_previous) - blackboard - in - let propagate_list = - (Propagate_up pointer_next)::(Propagate_down pointer_previous)::(Propagate_up pointer_previous)::propagate_list - in - let error,log_info,blackboard,propagate_list = - look_down parameter handler log_info error blackboard propagate_list case - in - (error,log_info,blackboard,instruction_list,propagate_list),result - end - - let keep_case parameter handler case (error,log_info,blackboard,instruction_list,propagate_list) = - (* we keep the case *) - let error,log_info,(blackboard,result) = - B.refine - parameter - handler - log_info - error - (B.exist case) - (B.boolean (Some true)) - blackboard + let error, log_info, case_value = + B.get parameter handler log_info error case_address blackboard in - if B.is_failed result - then - (error,log_info,blackboard,[],[]),result - else if B.is_ignored result - then - (error,log_info,blackboard,instruction_list,propagate_list),result - else - begin - let error,log_info,pointer_previous = B.follow_pointer_up parameter handler log_info error blackboard case in - let error,log_info,_pointer_next = - B.follow_pointer_down parameter handler log_info error blackboard case in - let error,log_info,(_seid,eid,test,action) = - B.get_static parameter handler log_info error blackboard case in - begin - let error,log_info,(blackboard,instruction_list,_,result') = - refine_value_before parameter handler log_info error blackboard case test instruction_list propagate_list in - let error,log_info,(blackboard,instruction_list,_,result'') = - refine_value_after parameter handler log_info error blackboard case action instruction_list propagate_list in - if B.is_failed result' || B.is_failed result'' - then - (error, - log_info, - blackboard, - [], - []), - B.fail - else - let error,log_info,blackboard = B.dec parameter handler log_info error (B.n_unresolved_events_in_column case) blackboard in - let error,log_info,level = B.level_of_event parameter handler log_info error blackboard eid in - let error,log_info,blackboard = B.dec parameter handler log_info error (B.n_unresolved_events_in_column_at_level case level) blackboard in - let propagate_list = - (Propagate_up case)::(Propagate_down case)::(Propagate_down pointer_previous)::(Propagate_up pointer_previous)::propagate_list - in - (error, - log_info, - blackboard, - instruction_list, - propagate_list), - result - end - end - - let keep_event parameter handler log_info error blackboard step_id instruction_list propagate_list = - let error,log_info,(blackboard,success) = - B.refine parameter handler log_info error - (B.is_exist_event step_id) - (B.boolean (Some true)) - blackboard + let error, log_info, predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + case_value + in + let error, log_info, next_event_case_address = + B.follow_pointer_down parameter handler log_info error blackboard + event_case_address in - if B.is_failed success - then - error,log_info,(blackboard,[],[],success) - else if B.is_ignored success - then - error,log_info,(blackboard,instruction_list,propagate_list,success) - else - let log_info = StoryProfiling.StoryStats.inc_selected_events log_info in - let () = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "We keep event %i" (B.PB.int_of_step_id step_id) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - () + let error, log_info, bool2 = + B.exist_case parameter handler log_info error blackboard + next_event_case_address + in + (match bool2 with + | Some false -> + (* The blackboard is inconsistent: *) + (* Pointers should not point to removed events.*) + let error, () = + warn parameter error __POS__ + ~message:"inconsistent pointers in blackboard" + (Failure "inconsistent pointers in blackboard") () in - let error,log_info,blackboard = B.dec parameter handler log_info error (B.n_unresolved_events) blackboard in - let error,log_info,list = B.case_list_of_eid parameter handler log_info error blackboard step_id in - let rec aux l x success = - match l - with - | [] -> x,success - | t::q -> - begin - let y,success2 = keep_case parameter handler t x in - if B.is_ignored success2 - then - aux q y success - else if B.is_succeeded success2 - then aux q y success2 - else - y,success2 - end + ( error, + log_info, + (blackboard, instruction_list, propagate_list, B.success) ) + | Some true -> + (* next event is selected *) + let error, log_info, (_next_seid, _next_eid, next_test, next_action) = + B.get_static parameter handler log_info error blackboard + next_event_case_address in - let (error,log_info,blackboard,instruction_list,propagate_list),success = aux list (error,log_info,blackboard,instruction_list,propagate_list) B.ignore in - error,log_info,(blackboard,instruction_list,propagate_list,success) - - let gen_event f_case g parameter handler log_info error blackboard step_id instruction_list propagate_list = - let error,log_info,(blackboard,success) = - B.refine parameter handler log_info error - (B.is_exist_event step_id) - (B.boolean (Some false)) - blackboard - in - if B.is_failed success - then - error,log_info,(blackboard,[],[],success) - else if B.is_ignored success - then - error,log_info,(blackboard,instruction_list,propagate_list,success) - else - begin - let () = - if debug_mode - then - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "We remove event %i" (B.PB.int_of_step_id step_id) in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (B.PB.CI.Po.K.H.get_debugging_channel parameter) "***" in - let () = Loggers.print_newline (B.PB.CI.Po.K.H.get_debugging_channel parameter) in - () + let case_address = + B.case_address_of_case_event_address event_case_address + in + let error, log_info, case_value = + B.get parameter handler log_info error case_address blackboard + in + let error, log_info, predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + case_value + in + (match B.PB.is_unknown next_test, B.PB.is_unknown next_action with + | true, true -> + (* no test, no action in next event *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 1):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event is kept but has no test and no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Value is propagated after the next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + (* next event is selected *) + (* no test, no action in next event *) + (* we propagate the value after the next event*) + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 1 log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_after (next_event_case_address, predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + | true, false -> + (* no test, but an action in next event *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 2):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event is kept, no test, but an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Nothing to be done" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info in - let log_info = g log_info in - let error,log_info,blackboard = B.dec parameter handler log_info error (B.n_unresolved_events) blackboard in - let error,log_info,level = B.level_of_event parameter handler log_info error blackboard step_id in - let error,log_info,blackboard = B.dec parameter handler log_info error (B.n_unresolved_events_at_level level) blackboard in - let error,log_info,list = B.case_list_of_eid parameter handler log_info error blackboard step_id in - let rec aux l x success = - match l - with - | [] -> x,success - | t::q -> - begin - let y,success2 = f_case parameter handler t x in - if B.is_ignored success2 - then aux q y success - else if B.is_succeeded success2 - then aux q y success2 - else y,success2 - end + (* next event is selected *) + (* no test, but an action in next event *) + (* nothing to propagate downward*) + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 2 log_info in - let (error,log_info,blackboard,instruction_list,propagate_list),success = aux list (error,log_info,blackboard,instruction_list,propagate_list) B.ignore in - error,log_info,(blackboard,instruction_list,propagate_list,success) - end + ( error, + log_info, + (blackboard, instruction_list, propagate_list, B.success) ) + | false, true -> + (* no action, but a test in next event *) + if B.PB.compatible predicate_value next_test then ( + (* the test is compatible with the value *) + let error, log_info, conj = + B.PB.conj parameter handler log_info error next_test + predicate_value + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 3):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event is kept, a test but no action " + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate new predicate_value " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + conj + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " before and after next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + (* next event is selected *) + (* no action, but a test in next event *) + (* the test is compatible with the value *) + (* we propagate the meet of the test and the value before and after the next event *) + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 3 log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before (next_event_case_address, conj) + :: Refine_value_after (next_event_case_address, conj) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + (* the test and the value are incompatible *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 4):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event is kept, a test but no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Cut" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 4 log_info + in + (* next event is selected *) + (* no action, but a test in next event *) + (* the test is not compatible with the value *) + (* we cut the exploration *) + error, log_info, (blackboard, [], [], B.fail) + ) + | false, false -> + (*there is a test and an action in the next event *) + if B.PB.compatible predicate_value next_test then ( + (* the test and the value are compatible *) + let error, log_info, conj = + B.PB.conj parameter handler log_info error next_test + predicate_value + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 5):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event is kept, a test but no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Action:" + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate new predicate_value " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + conj + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " before the next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 5 log_info + in + (* next event is selected *) + (* an action and a test in next event *) + (* the test is compatible with the value *) + (* we propagate the meet of the test and the value before the next event *) + ( error, + log_info, + ( blackboard, + Refine_value_before (next_event_case_address, conj) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + (* test and value are incompatible *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 6):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event is kept, a test, an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Next event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Cut" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 6 log_info + in + (* next event is selected *) + (* an action and a test in next event *) + (* the test is not compatible with the value *) + (* we cut the exploration *) + error, log_info, (blackboard, [], [], B.fail) + )) + | None -> + (* we do not know whether the event is played or not *) + let error, log_info, (_next_seid, next_eid, next_test, next_action) = + B.get_static parameter handler log_info error blackboard + next_event_case_address + in + (match B.PB.is_unknown next_action with + | true -> + (* there is no action in the next event *) + (match B.PB.is_unknown next_test with + | true -> + (*there is no test in the next event *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 7):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the next event is kept" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is no test, no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The value is propagated after and before the next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***\n" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 7 log_info + in + (* we do not know whether the event is played or not *) + (*there is no test in the next event *) + (* there is no action in the next event *) + (* we propagate the value after the next event*) + ( error, + log_info, + ( blackboard, + Refine_value_after (next_event_case_address, predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + | false -> + (* there is a test in the next event *) + if B.PB.compatible next_test predicate_value then ( + (* test and predicate_value are compatible *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 8):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the next event is kept" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is a test, but no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The value " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " is propagated after and before the next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 8 log_info + in + (* we do not know whether the event is played or not *) + (* there is a test in the next event *) + (* there is no action in the next event *) + (* the test is compatible with the value *) + (* we propagate the value after the next event*) + ( error, + log_info, + ( blackboard, + Refine_value_after (next_event_case_address, predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 9):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the next event is kept" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is a test, but no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "We discard the next event (%i)" + (B.PB.int_of_step_id next_eid) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 9 log_info + in + (* we do not know whether the event is played or not *) + (* there is a test in the next event *) + (* there is no action in the next event *) + (* the test is not compatible with the value *) + (* we discard the next event *) + ( error, + log_info, + ( blackboard, + Discard_event next_eid :: instruction_list, + propagate_list, + B.success ) ) + )) + | false -> + (* there is an action in the next event *) + if not (B.PB.compatible next_action predicate_value) then ( + (* the action is not compatible with the value *) + let error, log_info, computed_next_predicate_value = + B.PB.disjunction parameter handler log_info error predicate_value + next_action + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 10):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the next event is kept" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The value " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + computed_next_predicate_value + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " is propagated after the next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 10 log_info + in + (* we do not know whether the event is played or not *) + (* there is an action in the next event *) + (* the action is compatible with the value *) + (* we propagate the join of the value and the action after the next event*) + ( error, + log_info, + ( blackboard, + Refine_value_after + (next_event_case_address, computed_next_predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + (*the action is compatible with the value *) + let error, log_info, computed_next_predicate_value = + B.PB.disjunction parameter handler log_info error predicate_value + next_action + in + match B.PB.is_unknown next_test with + | true -> + (* there is no test in the next event *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 11):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the next event is kept" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is no test, but there is an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The value " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + computed_next_predicate_value + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " is propagated after the next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 11 log_info + in + (* we do not know whether the event is played or not *) + (* there is no test in the next event *) + (* there is an action in the next event *) + (* the action is compatible with the value *) + (* we propagate the join of the value and the action after the next event*) + ( error, + log_info, + ( blackboard, + Refine_value_after + (next_event_case_address, computed_next_predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + | false -> + if B.PB.compatible next_test predicate_value then ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 12):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the next event is kept" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is a test, but there is an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The value " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + computed_next_predicate_value + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " is propagated after the next event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 12 + log_info + in + (* we do not know whether the event is played or not *) + (* there is a test in the next event *) + (* there is an action in the next event *) + (* the test is compatible with the value *) + (* the action is compatible with the value *) + (* we propagate the join of the value and the action after the next event*) + ( error, + log_info, + ( blackboard, + Refine_value_after + (next_event_case_address, computed_next_predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_down (case 13):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the next event is kept" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is a test, but there is an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "next event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + next_action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Next event (%i) is discarded" + (B.PB.int_of_step_id next_eid) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_down 13 + log_info + in + (* we do not know whether the event is played or not *) + (* there is a test in the next event *) + (* there is an action in the next event *) + (* the test is not compatible with the value *) + (* we discard the next event *) + ( error, + log_info, + ( blackboard, + Discard_event next_eid :: instruction_list, + propagate_list, + B.success ) ) + ) + ))) + + let rec last_chance_up parameter handler log_info error blackboard + predicate_value event_case_address = + let error, log_info, bool = + B.exist_case parameter handler log_info error blackboard + event_case_address + in + match bool with + | Some false -> error, false, log_info, blackboard + | Some true -> + let error, log_info, (_seid, _eid, _test, action) = + B.get_static parameter handler log_info error blackboard + event_case_address + in + if B.PB.is_unknown action then ( + let error, log_info, preview_event_case_address = + B.follow_pointer_up parameter handler log_info error blackboard + event_case_address + in + let preview_case_address = + B.case_address_of_case_event_address preview_event_case_address + in + let error, log_info, preview_case_value = + B.get parameter handler log_info error preview_case_address blackboard + in + let error, log_info, preview_predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + preview_case_value + in + if B.PB.compatible preview_predicate_value predicate_value then ( + let error, log_info, bool = + B.is_boundary parameter handler log_info error blackboard + event_case_address + in + if bool then ( + let log_info = + StoryProfiling.StoryStats.add_look_up_case 1 log_info + in + error, not (B.PB.is_undefined predicate_value), log_info, blackboard + ) else + last_chance_up parameter handler log_info error blackboard + predicate_value preview_event_case_address + ) else ( + let log_info = + StoryProfiling.StoryStats.add_look_up_case 2 log_info + in + error, true, log_info, blackboard + ) + ) else if B.PB.more_refined action predicate_value then + error, false, log_info, blackboard + else ( + let log_info = StoryProfiling.StoryStats.add_look_up_case 3 log_info in + error, true, log_info, blackboard + ) + | None -> + let error, log_info, (_seid, _eid, _test, action) = + B.get_static parameter handler log_info error blackboard + event_case_address + in + if B.PB.more_refined action predicate_value then + error, false, log_info, blackboard + else ( + let error, log_info, preview_event_case_address = + B.follow_pointer_up parameter handler log_info error blackboard + event_case_address + in + let preview_case_address = + B.case_address_of_case_event_address preview_event_case_address + in + let error, log_info, preview_case_value = + B.get parameter handler log_info error preview_case_address blackboard + in + let error, log_info, preview_predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + preview_case_value + in + if B.PB.compatible preview_predicate_value predicate_value then + last_chance_up parameter handler log_info error blackboard + predicate_value preview_event_case_address + else ( + let log_info = + StoryProfiling.StoryStats.add_look_up_case 4 log_info + in + error, true, log_info, blackboard + ) + ) + + let last_chance_up parameter handler log_info error blackboard predicate_value + address = + if B.PB.is_unknown predicate_value then + error, false, log_info, blackboard + else + last_chance_up parameter handler log_info error blackboard predicate_value + address + + let last_chance_up = + if look_up_for_better_cut then + last_chance_up + else + fun _ _ log_info error blackboard _ _ -> + error, false, log_info, blackboard + + let propagate_up parameter handler log_info error blackboard + event_case_address instruction_list propagate_list = + let error, log_info, bool = + B.exist_case parameter handler log_info error blackboard + event_case_address + in + match bool with + | Some false -> + (* the case has been removed from the blackboard, nothing to be done *) + error, log_info, (blackboard, instruction_list, propagate_list, B.success) + | Some true -> + (* we know that the pair (test/action) has been executed *) + let error, log_info, (_seid, _eid, test, action) = + B.get_static parameter handler log_info error blackboard + event_case_address + in + let case_address = + B.case_address_of_case_event_address event_case_address + in + let error, log_info, case_value = + B.get parameter handler log_info error case_address blackboard + in + let error, log_info, predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + case_value + in + if B.PB.is_unknown action then + (* no action, we keep on propagating with the conjonction of the test of the value *) + if B.PB.compatible test predicate_value then ( + let error, log_info, new_value = + B.PB.conj parameter handler log_info error test predicate_value + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 1):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The event before is kept, there is no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Refine before the event (before) with the state " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + new_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 1 log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before (event_case_address, new_value) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 2):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The event before is kept, there is no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Cut" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 2 log_info + in + error, log_info, (blackboard, [], [], B.fail) + ) + else if B.PB.more_refined action predicate_value then + if B.PB.is_undefined test then ( + (*the wire has just be created, nothing to be done *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 3):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The event before is kept, there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Nothing to be done" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 3 log_info + in + ( error, + log_info, + (blackboard, instruction_list, propagate_list, B.success) ) + ) else if + (*we know that the wire was defined before*) + B.PB.compatible test B.PB.defined + then ( + let error, log_info, state = + B.PB.conj parameter handler log_info error test B.PB.defined + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 4):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The event before is kept, there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Refine before the event (before) with the state " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + state + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "" + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 4 log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before (event_case_address, state) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 5):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The event before is kept, there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Cut" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 5 log_info + in + error, log_info, (blackboard, [], [], B.fail) + ) + else ( + (*The event has to be discarded which is absurd *) + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 6):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "The event before is kept, there is an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Cut" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 6 log_info + in + error, log_info, (blackboard, [], [], B.fail) + ) + | None -> + (* we do not know whether the pair (test/action) has been executed *) + let error, log_info, (_seid, eid, test, action) = + B.get_static parameter handler log_info error blackboard + event_case_address + in + let case_address = + B.case_address_of_case_event_address event_case_address + in + let error, log_info, case_value = + B.get parameter handler log_info error case_address blackboard + in + let error, log_info, predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + case_value + in + (match B.PB.is_unknown action with + | true -> + (match B.PB.is_unknown test with + | true -> + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 7):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is neither a test, nor action " + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Refine before the event (before) with the state " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 7 log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before (event_case_address, predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + | false -> + if B.PB.compatible test predicate_value then ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 8):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is a test, but no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Refine before the event (before) with the state " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 8 log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before (event_case_address, predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 9):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is a test, but no action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Event before (%i) is discarded" (B.PB.int_of_step_id eid) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 9 log_info + in + ( error, + log_info, + ( blackboard, + Discard_event eid :: instruction_list, + propagate_list, + B.success ) ) + )) + | false -> + let error, log_info, preview_event_case_address = + B.follow_pointer_up parameter handler log_info error blackboard + event_case_address + in + let preview_case_address = + B.case_address_of_case_event_address preview_event_case_address + in + let error, log_info, preview_case_value = + B.get parameter handler log_info error preview_case_address blackboard + in + let error, log_info, preview_predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + preview_case_value + in + if B.PB.compatible preview_predicate_value predicate_value then + if B.PB.more_refined action predicate_value then ( + let error, bool, log_info, blackboard = + last_chance_up parameter handler log_info error blackboard + predicate_value preview_event_case_address + in + if bool then ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 10):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " there is an action" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "This is the only opportunity to set up the wire, we \ + keep the event" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 10 log_info + in + ( error, + log_info, + ( blackboard, + Keep_event eid :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + match B.PB.is_unknown test with + | true -> + let error, log_info, new_predicate_value = + B.PB.disjunction parameter handler log_info error test + predicate_value + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 11):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is an action, but no test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Refine before the event (before) with the state " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + preview_predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 11 log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before (event_case_address, new_predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + | false -> + if B.PB.compatible test predicate_value then + if B.PB.compatible test preview_predicate_value then ( + let error, log_info, new_test = + B.PB.conj parameter handler log_info error test + preview_predicate_value + in + let error, log_info, new_predicate_value = + B.PB.disjunction parameter handler log_info error new_test + predicate_value + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 12):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info + error blackboard event_case_address + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test:" + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Refine before the event (before) with the state " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + new_predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 12 + log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before + (event_case_address, new_predicate_value) + :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 13):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info + error blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test:" + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Discard the event before (%i)" + (B.PB.int_of_step_id eid) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 13 + log_info + in + ( error, + log_info, + ( blackboard, + Discard_event eid :: instruction_list, + propagate_list, + B.success ) ) + ) + else ( + let error, log_info, prev' = + B.PB.disjunction parameter handler log_info error + predicate_value test + in + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 14):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info + error blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test:" + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Refine before the event (before) with the state " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + prev' + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 14 + log_info + in + ( error, + log_info, + ( blackboard, + Refine_value_before (event_case_address, prev') + :: instruction_list, + propagate_list, + B.success ) ) + ) + ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 15):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " there is an action and maybe a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Discard the event before (%i)" (B.PB.int_of_step_id eid) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 15 log_info + in + ( error, + log_info, + ( blackboard, + Discard_event eid :: instruction_list, + propagate_list, + B.success ) ) + ) + else if B.PB.more_refined action predicate_value then ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 16):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test:" + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Previous wire state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + preview_predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Select the event before (%i)" (B.PB.int_of_step_id eid) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 16 log_info + in + ( error, + log_info, + ( blackboard, + Keep_event eid :: instruction_list, + propagate_list, + B.success ) ) + ) else ( + let error, log_info = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Propagate_up (case 17):" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let error, log_info, () = + print_event_case_address parameter handler log_info error + blackboard event_case_address + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "we do not know if the event before is kept," + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + " there is an action and a test" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Test:" + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + test + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "before event Action: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + action + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Wire_state: " + in + let () = + B.PB.print_predicate_value + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + predicate_value + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "Cut" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + error, log_info + ) else + error, log_info + in + let log_info = + StoryProfiling.StoryStats.add_propagation_case_up 17 log_info + in + error, log_info, (blackboard, [], [], B.fail) + )) + + let propagate parameter handler log_info error blackboard check + instruction_list propagate_list = + match check with + | Propagate_up x -> + propagate_up parameter handler log_info error blackboard x + instruction_list propagate_list + | Propagate_down x -> + propagate_down parameter handler log_info error blackboard x + instruction_list propagate_list + + let cut_case parameter handler case + (error, log_info, blackboard, instruction_list, propagate_list) = + let error, log_info, pointer_next = + B.follow_pointer_down parameter handler log_info error blackboard case + in + let error, log_info, pointer_previous = + B.follow_pointer_up parameter handler log_info error blackboard case + in + (* we remove the case *) + let error, log_info, (blackboard, result) = + B.refine parameter handler log_info error (B.exist case) + (B.boolean (Some false)) blackboard + in + if B.is_failed result then + (error, log_info, blackboard, [], []), result + else if B.is_ignored result then + (error, log_info, blackboard, instruction_list, propagate_list), result + else ( + let error, log_info, blackboard = + B.dec parameter handler log_info error + (B.n_unresolved_events_in_column case) + blackboard + in + (* we plug pointer next of the previous event *) + let error, log_info, blackboard = + B.overwrite parameter handler log_info error + (B.pointer_to_next pointer_previous) + (B.pointer pointer_next) blackboard + in + (* we plug pointer previous of the next event *) + let error, log_info, blackboard = + B.overwrite parameter handler log_info error + (B.pointer_to_previous pointer_next) + (B.pointer pointer_previous) + blackboard + in + (error, log_info, blackboard, instruction_list, propagate_list), result + ) + + let look_down parameter handler log_info error blackboard propagate_list case + = + let error, log_info, (_, _, _, action) = + B.get_static parameter handler log_info error blackboard case + in + if B.PB.is_unknown action then + error, log_info, blackboard, propagate_list + else ( + let list_values = B.PB.weakening action in + let propagate_list, error, log_info, blackboard = + List.fold_left + (fun (propagate_list, error, log_info, blackboard) value -> + let rec aux case bool error log_info = + let ca = B.case_address_of_case_event_address case in + let error, log_info, case_value = + B.get parameter handler log_info error ca blackboard + in + let error, log_info, predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + case_value + in + if B.PB.more_refined predicate_value value then ( + let error, log_info, pointer_next = + B.follow_pointer_down parameter handler log_info error + blackboard case + in + let log_info = + StoryProfiling.StoryStats.add_look_down_case 1 log_info + in + ( Propagate_up pointer_next :: propagate_list, + error, + log_info, + blackboard ) + ) else ( + let error, log_info, next_case = + B.follow_pointer_down parameter handler log_info error + blackboard case + in + let error, log_info, exist = + B.exist_case parameter handler log_info error blackboard + next_case + in + match exist with + | Some true -> + let log_info = + StoryProfiling.StoryStats.add_look_down_case 2 log_info + in + propagate_list, error, log_info, blackboard + | Some false -> aux next_case bool error log_info + | None -> + let error, log_info, (_, _, _, next_action) = + B.get_static parameter handler log_info error blackboard + next_case + in + if B.PB.more_refined next_action value then + if bool then ( + let log_info = + StoryProfiling.StoryStats.add_look_down_case 3 log_info + in + propagate_list, error, log_info, blackboard + ) else + aux next_case true error log_info + else + aux next_case bool error log_info + ) + in + aux case false error log_info) + (propagate_list, error, log_info, blackboard) + list_values + in + error, log_info, blackboard, propagate_list + ) + + let look_down = + if look_down_for_better_cut then + look_down + else + fun _ _ log_info error blackboard list _ -> + error, log_info, blackboard, list + + let refine_value_after parameter handler log_info error blackboard address + value instruction_list propagate_list = + let case_address = B.value_after address in + let state = B.state value in + let error, log_info, (blackboard, result) = + B.refine parameter handler log_info error case_address state blackboard + in + if B.is_ignored result then + error, log_info, (blackboard, instruction_list, propagate_list, result) + else if B.is_failed result then + error, log_info, (blackboard, [], [], result) + else ( + let propagate_list = + Propagate_up address :: Propagate_down address :: propagate_list + in + error, log_info, (blackboard, instruction_list, propagate_list, result) + ) + + let refine_value_before parameter handler log_info error blackboard address + value instruction_list propagate_list = + let error, log_info, pointer_previous = + B.follow_pointer_up parameter handler log_info error blackboard address + in + refine_value_after parameter handler log_info error blackboard + pointer_previous value instruction_list propagate_list + + let discard_case parameter handler case + (error, log_info, blackboard, instruction_list, propagate_list) = + let error, log_info, pointer_next = + B.follow_pointer_down parameter handler log_info error blackboard case + in + let error, log_info, pointer_previous = + B.follow_pointer_up parameter handler log_info error blackboard case + in + (* we remove the case *) + let error, log_info, (blackboard, result) = + B.refine parameter handler log_info error (B.exist case) + (B.boolean (Some false)) blackboard + in + if B.is_failed result then + (error, log_info, blackboard, [], []), result + else if B.is_ignored result then + (error, log_info, blackboard, instruction_list, propagate_list), result + else ( + let ca = B.case_address_of_case_event_address case in + let error, log_info, case_value = + B.get parameter handler log_info error ca blackboard + in + let error, log_info, predicate_value = + B.predicate_value_of_case_value parameter handler log_info error + case_value + in + let error, log_info, (blackboard, instruction_list, _, result') = + refine_value_after parameter handler log_info error blackboard + pointer_previous predicate_value instruction_list propagate_list + in + if B.is_failed result' then + (error, log_info, blackboard, [], []), result' + else ( + let error, log_info, blackboard = + B.dec parameter handler log_info error + (B.n_unresolved_events_in_column case) + blackboard + in + let error, log_info, (_, event, _, _) = + B.get_static parameter handler log_info error blackboard case + in + let error, log_info, level = + B.level_of_event parameter handler log_info error blackboard event + in + let error, log_info, blackboard = + B.dec parameter handler log_info error + (B.n_unresolved_events_in_column_at_level case level) + blackboard + in + (* we plug pointer next of the previous event *) + let error, log_info, blackboard = + B.overwrite parameter handler log_info error + (B.pointer_to_next pointer_previous) + (B.pointer pointer_next) blackboard + in + (* we plug pointer previous of the next event *) + let error, log_info, blackboard = + B.overwrite parameter handler log_info error + (B.pointer_to_previous pointer_next) + (B.pointer pointer_previous) + blackboard + in + let propagate_list = + Propagate_up pointer_next :: Propagate_down pointer_previous + :: Propagate_up pointer_previous :: propagate_list + in + let error, log_info, blackboard, propagate_list = + look_down parameter handler log_info error blackboard propagate_list + case + in + (error, log_info, blackboard, instruction_list, propagate_list), result + ) + ) + + let keep_case parameter handler case + (error, log_info, blackboard, instruction_list, propagate_list) = + (* we keep the case *) + let error, log_info, (blackboard, result) = + B.refine parameter handler log_info error (B.exist case) + (B.boolean (Some true)) blackboard + in + if B.is_failed result then + (error, log_info, blackboard, [], []), result + else if B.is_ignored result then + (error, log_info, blackboard, instruction_list, propagate_list), result + else ( + let error, log_info, pointer_previous = + B.follow_pointer_up parameter handler log_info error blackboard case + in + let error, log_info, _pointer_next = + B.follow_pointer_down parameter handler log_info error blackboard case + in + let error, log_info, (_seid, eid, test, action) = + B.get_static parameter handler log_info error blackboard case + in + let error, log_info, (blackboard, instruction_list, _, result') = + refine_value_before parameter handler log_info error blackboard case + test instruction_list propagate_list + in + let error, log_info, (blackboard, instruction_list, _, result'') = + refine_value_after parameter handler log_info error blackboard case + action instruction_list propagate_list + in + if B.is_failed result' || B.is_failed result'' then + (error, log_info, blackboard, [], []), B.fail + else ( + let error, log_info, blackboard = + B.dec parameter handler log_info error + (B.n_unresolved_events_in_column case) + blackboard + in + let error, log_info, level = + B.level_of_event parameter handler log_info error blackboard eid + in + let error, log_info, blackboard = + B.dec parameter handler log_info error + (B.n_unresolved_events_in_column_at_level case level) + blackboard + in + let propagate_list = + Propagate_up case :: Propagate_down case + :: Propagate_down pointer_previous :: Propagate_up pointer_previous + :: propagate_list + in + (error, log_info, blackboard, instruction_list, propagate_list), result + ) + ) + + let keep_event parameter handler log_info error blackboard step_id + instruction_list propagate_list = + let error, log_info, (blackboard, success) = + B.refine parameter handler log_info error (B.is_exist_event step_id) + (B.boolean (Some true)) blackboard + in + if B.is_failed success then + error, log_info, (blackboard, [], [], success) + else if B.is_ignored success then + error, log_info, (blackboard, instruction_list, propagate_list, success) + else ( + let log_info = StoryProfiling.StoryStats.inc_selected_events log_info in + let () = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "We keep event %i" + (B.PB.int_of_step_id step_id) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + () + ) + in + let error, log_info, blackboard = + B.dec parameter handler log_info error B.n_unresolved_events blackboard + in + let error, log_info, list = + B.case_list_of_eid parameter handler log_info error blackboard step_id + in + let rec aux l x success = + match l with + | [] -> x, success + | t :: q -> + let y, success2 = keep_case parameter handler t x in + if B.is_ignored success2 then + aux q y success + else if B.is_succeeded success2 then + aux q y success2 + else + y, success2 + in + let ( (error, log_info, blackboard, instruction_list, propagate_list), + success ) = + aux list + (error, log_info, blackboard, instruction_list, propagate_list) + B.ignore + in + error, log_info, (blackboard, instruction_list, propagate_list, success) + ) + + let gen_event f_case g parameter handler log_info error blackboard step_id + instruction_list propagate_list = + let error, log_info, (blackboard, success) = + B.refine parameter handler log_info error (B.is_exist_event step_id) + (B.boolean (Some false)) blackboard + in + if B.is_failed success then + error, log_info, (blackboard, [], [], success) + else if B.is_ignored success then + error, log_info, (blackboard, instruction_list, propagate_list, success) + else ( + let () = + if debug_mode then ( + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "We remove event %i" + (B.PB.int_of_step_id step_id) + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + "***" + in + let () = + Loggers.print_newline + (B.PB.CI.Po.K.H.get_debugging_channel parameter) + in + () + ) + in + let log_info = g log_info in + let error, log_info, blackboard = + B.dec parameter handler log_info error B.n_unresolved_events blackboard + in + let error, log_info, level = + B.level_of_event parameter handler log_info error blackboard step_id + in + let error, log_info, blackboard = + B.dec parameter handler log_info error + (B.n_unresolved_events_at_level level) + blackboard + in + let error, log_info, list = + B.case_list_of_eid parameter handler log_info error blackboard step_id + in + let rec aux l x success = + match l with + | [] -> x, success + | t :: q -> + let y, success2 = f_case parameter handler t x in + if B.is_ignored success2 then + aux q y success + else if B.is_succeeded success2 then + aux q y success2 + else + y, success2 + in + let ( (error, log_info, blackboard, instruction_list, propagate_list), + success ) = + aux list + (error, log_info, blackboard, instruction_list, propagate_list) + B.ignore + in + error, log_info, (blackboard, instruction_list, propagate_list, success) + ) + + let cut_event = gen_event cut_case StoryProfiling.StoryStats.inc_cut_events - let cut_event = gen_event cut_case StoryProfiling.StoryStats.inc_cut_events - let discard_event = gen_event discard_case StoryProfiling.StoryStats.inc_removed_events + let discard_event = + gen_event discard_case StoryProfiling.StoryStats.inc_removed_events - let apply_instruction parameter handler log_info error blackboard instruction instruction_list propagate_list = - match instruction - with - | Keep_event step_id -> - keep_event parameter handler log_info error blackboard step_id instruction_list propagate_list - | Cut_event step_id -> cut_event parameter handler log_info error blackboard step_id instruction_list propagate_list - | Discard_event step_id -> discard_event parameter handler log_info error blackboard step_id instruction_list propagate_list - | Refine_value_after (address,value) -> refine_value_after parameter handler log_info error blackboard address value instruction_list propagate_list - | Refine_value_before (address,value) -> refine_value_before parameter handler log_info error blackboard address value instruction_list propagate_list - | Skip -> error,log_info,(blackboard,instruction_list,propagate_list,B.ignore) + let apply_instruction parameter handler log_info error blackboard instruction + instruction_list propagate_list = + match instruction with + | Keep_event step_id -> + keep_event parameter handler log_info error blackboard step_id + instruction_list propagate_list + | Cut_event step_id -> + cut_event parameter handler log_info error blackboard step_id + instruction_list propagate_list + | Discard_event step_id -> + discard_event parameter handler log_info error blackboard step_id + instruction_list propagate_list + | Refine_value_after (address, value) -> + refine_value_after parameter handler log_info error blackboard address + value instruction_list propagate_list + | Refine_value_before (address, value) -> + refine_value_before parameter handler log_info error blackboard address + value instruction_list propagate_list + | Skip -> + error, log_info, (blackboard, instruction_list, propagate_list, B.ignore) - let _keep x = Keep_event x - end:Blackboard_with_heuristic) + let _keep x = Keep_event x +end diff --git a/core/cflow/pseudo_inverse.ml b/core/cflow/pseudo_inverse.ml index 3739198555..8b498449da 100644 --- a/core/cflow/pseudo_inverse.ml +++ b/core/cflow/pseudo_inverse.ml @@ -18,542 +18,598 @@ * et en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) +module type Cut_pseudo_inverse = sig + module Po : Po_cut.Po_cut + module A : GenArray.GenArray + val cut : (Trace.t, Trace.t * int) Po.K.H.unary +end -module type Cut_pseudo_inverse = - sig - module Po:Po_cut.Po_cut - module A:GenArray.GenArray +module Pseudo_inv : Cut_pseudo_inverse = struct + module Po = Po_cut.Po_cut + module A = Mods.DynArray + module CPredicateMap = Predicate_maps.QPredicateMap + module PredicateMap = Predicate_maps.PredicateMap - val cut: (Trace.t, ( (Trace.t) * int)) Po.K.H.unary - end + type predicate_info = Predicate_maps.predicate_info + type step_id = int - module Pseudo_inv = - (struct + let string_of_predicate_info = Predicate_maps.string_of_predicate_info - module Po=Po_cut.Po_cut - module A = Mods.DynArray - module CPredicateMap = Predicate_maps.QPredicateMap - module PredicateMap = Predicate_maps.PredicateMap + let string_of_predicate_value pi = + match pi with + | Predicate_maps.Internal_state_is s -> string_of_int s + | Predicate_maps.Undefined -> "#Undef" + | Predicate_maps.Present -> "#Here" + | Predicate_maps.Free -> "#Free" + | Predicate_maps.Bound_to (ag, agent_name, s) -> + "Bound_to " ^ string_of_int ag ^ " " ^ string_of_int agent_name ^ " " + ^ string_of_int s - type predicate_info = Predicate_maps.predicate_info - type step_id = int + type pseudo_inv_blackboard = { + steps_by_column: + (step_id * Predicate_maps.predicate_value * bool) list CPredicateMap.t; + nsteps: step_id; + predicates_of_event: predicate_info list A.t; + is_remove_action: bool A.t; + modified_predicates_of_event: int A.t; + has_mod_without_test: bool A.t; + event: Trace.step option A.t; + agent_list: int list; + } + let init_blackboard n_steps handler = + { + steps_by_column = Po.K.H.get_predicate_map handler; + nsteps = -1; + predicates_of_event = A.make n_steps []; + is_remove_action = A.make n_steps false; + has_mod_without_test = A.make n_steps false; + modified_predicates_of_event = A.create n_steps 0; + event = A.make n_steps None; + agent_list = []; + } - let string_of_predicate_info = Predicate_maps.string_of_predicate_info - - let string_of_predicate_value pi = - match - pi - with - | Predicate_maps.Internal_state_is s -> (string_of_int s) - | Predicate_maps.Undefined -> "#Undef" - | Predicate_maps.Present -> "#Here" - | Predicate_maps.Free -> "#Free" - | Predicate_maps.Bound_to (ag,ag_name,s) -> - "Bound_to "^(string_of_int ag)^" "^(string_of_int ag_name)^" "^(string_of_int s) - - type pseudo_inv_blackboard = - { - steps_by_column: (step_id * Predicate_maps.predicate_value * bool) list CPredicateMap.t ; - nsteps: step_id ; - predicates_of_event: predicate_info list A.t ; - is_remove_action: bool A.t ; - modified_predicates_of_event: int A.t ; - has_mod_without_test: bool A.t ; - event: Trace.step option A.t; - agent_list: int list ; - } - - let init_blackboard n_steps handler = - { - steps_by_column = Po.K.H.get_predicate_map handler; - nsteps = -1 ; - predicates_of_event = A.make n_steps [] ; - is_remove_action = A.make n_steps false ; - has_mod_without_test = A.make n_steps false ; - modified_predicates_of_event = A.create n_steps 0 ; - event = A.make n_steps None ; - agent_list = []; - } - - - let _print_blackboard parameter handler error blackboard = - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter) "Blackboard for removing pseudo inverse element" in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter)"n_events: %i" blackboard.nsteps in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter)in - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter)"Steps_by_column:" in - let () = - CPredicateMap.iter - (fun pred list -> - let () = - Loggers.fprintf (Po.K.H.get_debugging_channel parameter)"%s: " (string_of_predicate_info pred) - in - let _ = - List.iter - (fun (eid,value,bool) -> - Loggers.fprintf (Po.K.H.get_debugging_channel parameter)"(%i,%s%s)," eid (string_of_predicate_value value) (if bool then "(Mod)" else "")) - list - in - Loggers.print_newline (Po.K.H.get_debugging_channel parameter)) - blackboard.steps_by_column - in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter)in - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter) "Events:" in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter)in - let rec aux k = - if k=blackboard.nsteps - then error - else - let event = - try - A.get blackboard.event k - with _ -> - let _ = Loggers.fprintf (Po.K.H.get_debugging_channel parameter) "ERREUR %i 123" k in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter)in - raise Exit - in + let _print_blackboard parameter handler error blackboard = + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "Blackboard for removing pseudo inverse element" + in + let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "n_events: %i" blackboard.nsteps + in + let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "Steps_by_column:" + in + let () = + CPredicateMap.iter + (fun pred list -> + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "%s: " + (string_of_predicate_info pred) + in + let _ = + List.iter + (fun (eid, value, bool) -> + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "(%i,%s%s)," eid + (string_of_predicate_value value) + (if bool then + "(Mod)" + else + "")) + list + in + Loggers.print_newline (Po.K.H.get_debugging_channel parameter)) + blackboard.steps_by_column + in + let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in + let () = + Loggers.fprintf (Po.K.H.get_debugging_channel parameter) "Events:" + in + let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in + let rec aux k = + if k = blackboard.nsteps then + error + else ( + let event = + try A.get blackboard.event k + with _ -> let _ = - match - event - with - | None -> error - | Some event -> - begin - try - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter)"Event %i%a" k - (Trace.print_step ~compact:false ~env:(handler.Po.K.H.env)) - event in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter)in - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter)"Predicates: " in - let list = A.get blackboard.predicates_of_event k in - let () = List.iter (fun pid -> Loggers.fprintf (Po.K.H.get_debugging_channel parameter) "%s," (string_of_predicate_info pid)) list in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in - let bool = A.get blackboard.is_remove_action k in - let () = - if bool - then - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter)"contain a deletion" in - Loggers.print_newline (Po.K.H.get_debugging_channel parameter) - in - let int = A.get blackboard.modified_predicates_of_event k in - let () = Loggers.fprintf (Po.K.H.get_debugging_channel parameter) "%i modified predicates" int in - let () = Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in - error - with _ -> error - end + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "ERREUR %i 123" k in - aux (k+1) - in - let error = aux 0 in - error - - let predicates_of_action _parameter _handler _error blackboard action = - match action with - | Instantiation.Create (ag,interface) -> - let ag_id = Po.K.agent_id_of_agent ag in - let predicate_id = Predicate_maps.Here ag_id in - let list1,list2 = - List.fold_left - (fun (list1,list2) (s_id,opt) -> - let predicate_id = Predicate_maps.Bound_site(ag_id,s_id) in - let list1 = (predicate_id,Predicate_maps.Free)::list1 in - let list2 = predicate_id::list2 in - match opt - with - | None -> list1,list2 - | Some x -> - let predicate_id = Predicate_maps.Internal_state (ag_id,s_id) in - (predicate_id,Predicate_maps.Internal_state_is x)::list1, - predicate_id::list2 - ) - ([predicate_id,Predicate_maps.Present],[predicate_id]) - interface + let () = + Loggers.print_newline (Po.K.H.get_debugging_channel parameter) in - {blackboard with agent_list = ag_id::blackboard.agent_list},list1,list2,false,true - | Instantiation.Mod_internal (site,int) -> - let predicate_id = Predicate_maps.Internal_state (Po.K.agent_id_of_site site,Po.K.site_name_of_site site) in - blackboard,[predicate_id,Predicate_maps.Internal_state_is int],[],false,false - | Instantiation.Bind_to (s1,s2) -> - let ag_id1 = Po.K.agent_id_of_site s1 in - let ag_id2 = Po.K.agent_id_of_site s2 in - let agent_name2 = Po.K.agent_name_of_site s2 in - let site_id1 = Po.K.site_name_of_site s1 in - let site_id2 = Po.K.site_name_of_site s2 in - let predicate_id1 = Predicate_maps.Bound_site (ag_id1,site_id1) in - blackboard,[predicate_id1,Predicate_maps.Bound_to (ag_id2,agent_name2,site_id2)],[],false,false - | Instantiation.Bind (s1,s2) -> - let ag_id1 = Po.K.agent_id_of_site s1 in - let ag_id2 = Po.K.agent_id_of_site s2 in - let agent_name1 = Po.K.agent_name_of_site s1 in - let agent_name2 = Po.K.agent_name_of_site s2 in - let site_id1 = Po.K.site_name_of_site s1 in - let site_id2 = Po.K.site_name_of_site s2 in - let predicate_id1 = Predicate_maps.Bound_site (ag_id1,site_id1) in - let predicate_id2 = Predicate_maps.Bound_site (ag_id2,site_id2) in - blackboard, - [ - predicate_id1,Predicate_maps.Bound_to (ag_id2,agent_name2,site_id2); - predicate_id2,Predicate_maps.Bound_to (ag_id1,agent_name1,site_id1) - ], - [],false,false - | Instantiation.Free s -> - let ag_id = Po.K.agent_id_of_site s in - let site_id = Po.K.site_name_of_site s in - let predicate_id = Predicate_maps.Bound_site (ag_id,site_id) in - blackboard,[predicate_id,Predicate_maps.Free],[],false,false - | Instantiation.Remove ag -> - let ag_id = Po.K.agent_id_of_agent ag in - let predicate_id = Predicate_maps.Here ag_id in - blackboard,[predicate_id,Predicate_maps.Undefined],[],true,false - - let no_remove _parameter _handler _error blackboard eid = - not (A.get blackboard.is_remove_action eid) + raise Exit + in + let _ = + match event with + | None -> error + | Some event -> + (try + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "Event %i%a" k + (Trace.print_step ~compact:false ~env:handler.Po.K.H.env) + event + in + let () = + Loggers.print_newline (Po.K.H.get_debugging_channel parameter) + in + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "Predicates: " + in + let list = A.get blackboard.predicates_of_event k in + let () = + List.iter + (fun pid -> + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "%s," + (string_of_predicate_info pid)) + list + in + let () = + Loggers.print_newline (Po.K.H.get_debugging_channel parameter) + in + let bool = A.get blackboard.is_remove_action k in + let () = + if bool then ( + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "contain a deletion" + in + Loggers.print_newline + (Po.K.H.get_debugging_channel parameter) + ) + in + let int = A.get blackboard.modified_predicates_of_event k in + let () = + Loggers.fprintf + (Po.K.H.get_debugging_channel parameter) + "%i modified predicates" int + in + let () = + Loggers.print_newline (Po.K.H.get_debugging_channel parameter) + in + error + with _ -> error) + in + aux (k + 1) + ) + in + let error = aux 0 in + error - let same_length _parameter _handler _error blackboard eid1 eid2 = - A.get blackboard.has_mod_without_test eid1 - || - A.get blackboard.has_mod_without_test eid2 - || - (A.get blackboard.modified_predicates_of_event eid1) - = - (A.get blackboard.modified_predicates_of_event eid2) + let predicates_of_action _parameter _handler _error blackboard action = + match action with + | Instantiation.Create (ag, interface) -> + let ag_id = Po.K.agent_id_of_agent ag in + let predicate_id = Predicate_maps.Here ag_id in + let list1, list2 = + List.fold_left + (fun (list1, list2) (s_id, opt) -> + let predicate_id = Predicate_maps.Bound_site (ag_id, s_id) in + let list1 = (predicate_id, Predicate_maps.Free) :: list1 in + let list2 = predicate_id :: list2 in + match opt with + | None -> list1, list2 + | Some x -> + let predicate_id = Predicate_maps.Internal_state (ag_id, s_id) in + ( (predicate_id, Predicate_maps.Internal_state_is x) :: list1, + predicate_id :: list2 )) + ([ predicate_id, Predicate_maps.Present ], [ predicate_id ]) + interface + in + ( { blackboard with agent_list = ag_id :: blackboard.agent_list }, + list1, + list2, + false, + true ) + | Instantiation.Mod_internal (site, int) -> + let predicate_id = + Predicate_maps.Internal_state + (Po.K.agent_id_of_site site, Po.K.site_name_of_site site) + in + ( blackboard, + [ predicate_id, Predicate_maps.Internal_state_is int ], + [], + false, + false ) + | Instantiation.Bind_to (s1, s2) -> + let ag_id1 = Po.K.agent_id_of_site s1 in + let ag_id2 = Po.K.agent_id_of_site s2 in + let agent_name2 = Po.K.agent_name_of_site s2 in + let site_id1 = Po.K.site_name_of_site s1 in + let site_id2 = Po.K.site_name_of_site s2 in + let predicate_id1 = Predicate_maps.Bound_site (ag_id1, site_id1) in + ( blackboard, + [ + predicate_id1, Predicate_maps.Bound_to (ag_id2, agent_name2, site_id2); + ], + [], + false, + false ) + | Instantiation.Bind (s1, s2) -> + let ag_id1 = Po.K.agent_id_of_site s1 in + let ag_id2 = Po.K.agent_id_of_site s2 in + let agent_name1 = Po.K.agent_name_of_site s1 in + let agent_name2 = Po.K.agent_name_of_site s2 in + let site_id1 = Po.K.site_name_of_site s1 in + let site_id2 = Po.K.site_name_of_site s2 in + let predicate_id1 = Predicate_maps.Bound_site (ag_id1, site_id1) in + let predicate_id2 = Predicate_maps.Bound_site (ag_id2, site_id2) in + ( blackboard, + [ + predicate_id1, Predicate_maps.Bound_to (ag_id2, agent_name2, site_id2); + predicate_id2, Predicate_maps.Bound_to (ag_id1, agent_name1, site_id1); + ], + [], + false, + false ) + | Instantiation.Free s -> + let ag_id = Po.K.agent_id_of_site s in + let site_id = Po.K.site_name_of_site s in + let predicate_id = Predicate_maps.Bound_site (ag_id, site_id) in + blackboard, [ predicate_id, Predicate_maps.Free ], [], false, false + | Instantiation.Remove ag -> + let ag_id = Po.K.agent_id_of_agent ag in + let predicate_id = Predicate_maps.Here ag_id in + blackboard, [ predicate_id, Predicate_maps.Undefined ], [], true, false + let no_remove _parameter _handler _error blackboard eid = + not (A.get blackboard.is_remove_action eid) - let clean t column blackboard = - match column - with - | [] -> column,blackboard - | head::tail -> - let rec aux list bool = - match list - with - | (eid,_,false)::q -> - begin - if eid = -1 - then - list,bool - else - match - A.get blackboard.event eid - with - | None -> aux q true - | _ -> list,bool - end - | _ -> list,bool - in - let list,bool = aux tail false in - if bool - then - let column = head::list in - let blackboard = - { - blackboard - with - steps_by_column = - CPredicateMap.add t column blackboard.steps_by_column } - in column,blackboard - else - column,blackboard + let same_length _parameter _handler _error blackboard eid1 eid2 = + A.get blackboard.has_mod_without_test eid1 + || A.get blackboard.has_mod_without_test eid2 + || A.get blackboard.modified_predicates_of_event eid1 + = A.get blackboard.modified_predicates_of_event eid2 - let check parameter handler error blackboard = - let eid = blackboard.nsteps in - let predicate_list = A.get blackboard.predicates_of_event eid in - let rec scan predicate_list = - match - predicate_list - with - | [] -> error,None,blackboard,[] - | t::q -> - begin - let column = CPredicateMap.find_default [] t blackboard.steps_by_column in - let column,blackboard = clean t column blackboard in - match - column - with - | (_,_,false)::_ -> scan q (* no modif on a *) - | (_,x,true)::(_,y,_)::_ when x=y -> scan q (* mute modif on a *) - | (a,x,true)::(b,_,true)::(_,y,_)::_ -> - if a=eid && x=y - then - error,Some (a,b),blackboard,q (* a cancels b modif *) - else - error,None,blackboard,q - | _ -> error,None,blackboard,q - end + let clean t column blackboard = + match column with + | [] -> column, blackboard + | head :: tail -> + let rec aux list bool = + match list with + | (eid, _, false) :: q -> + if eid = -1 then + list, bool + else ( + match A.get blackboard.event eid with + | None -> aux q true + | _ -> list, bool + ) + | _ -> list, bool + in + let list, bool = aux tail false in + if bool then ( + let column = head :: list in + let blackboard = + { + blackboard with + steps_by_column = + CPredicateMap.add t column blackboard.steps_by_column; + } in - let error,candidates,blackboard,q = scan predicate_list in - match - candidates - with - | None -> error,None - | Some (eida,eidb) -> - if - no_remove parameter handler error blackboard eidb - && same_length parameter handler error blackboard eida eidb - && - List.for_all - (fun pid -> - let column = - CPredicateMap.find_default [] pid blackboard.steps_by_column - in - let column,_blackboard = clean pid column blackboard in - match - column - with - | (_,_,false)::_ -> true (* no modif on a *) - | (a,x,true)::(b,_,true)::(_,y,_)::_ when b=eidb && a=eida -> - x=y (* if yes, a cancels b modif*) - | (a,x,true)::(_,y,_)::_ when a=eida -> x=y (* is a modif is mute ? *) - | _ -> false) - q - && - List.for_all - (fun pid -> - let column = - CPredicateMap.find_default [] pid blackboard.steps_by_column - in - let column,_blackboard = clean pid column blackboard in - let rec check_aux column = - match - column - with - | (b,x,true)::(_,y,_)::_ when b=eidb -> x=y (* is b modif is mute ? *) - | (b,_,bool)::_ when b=eidb -> not bool (* if yes, b does not do modif *) - | (_,_,_)::tail -> check_aux tail - | [] -> true - in - match column with - | (a,x,true)::(b,_,true)::(_,y,_)::_ when b=eidb && a=eida -> - x=y (* a cancels b modif*) - | _ -> check_aux column (* otherwise check that b has no effect *) - ) - (A.get blackboard.predicates_of_event eidb) - - then error,Some (eida,eidb) - else error,None - + column, blackboard + ) else + column, blackboard - let pop _parameter _handler error blackboard eid = - let predicate_list = A.get blackboard.predicates_of_event eid in - let rec aux l error blackboard = - match l - with - | [] -> error,blackboard - | pid::tail -> - let list = - match CPredicateMap.find_option pid blackboard.steps_by_column with - | Some x -> x - | None -> raise Exit + let check parameter handler error blackboard = + let eid = blackboard.nsteps in + let predicate_list = A.get blackboard.predicates_of_event eid in + let rec scan predicate_list = + match predicate_list with + | [] -> error, None, blackboard, [] + | t :: q -> + let column = + CPredicateMap.find_default [] t blackboard.steps_by_column + in + let column, blackboard = clean t column blackboard in + (match column with + | (_, _, false) :: _ -> scan q (* no modif on a *) + | (_, x, true) :: (_, y, _) :: _ when x = y -> + scan q (* mute modif on a *) + | (a, x, true) :: (b, _, true) :: (_, y, _) :: _ -> + if a = eid && x = y then + error, Some (a, b), blackboard, q (* a cancels b modif *) + else + error, None, blackboard, q + | _ -> error, None, blackboard, q) + in + let error, candidates, blackboard, q = scan predicate_list in + match candidates with + | None -> error, None + | Some (eida, eidb) -> + if + no_remove parameter handler error blackboard eidb + && same_length parameter handler error blackboard eida eidb + && List.for_all + (fun pid -> + let column = + CPredicateMap.find_default [] pid blackboard.steps_by_column + in + let column, _blackboard = clean pid column blackboard in + match column with + | (_, _, false) :: _ -> true (* no modif on a *) + | (a, x, true) :: (b, _, true) :: (_, y, _) :: _ + when b = eidb && a = eida -> + x = y (* if yes, a cancels b modif*) + | (a, x, true) :: (_, y, _) :: _ when a = eida -> + x = y (* is a modif is mute ? *) + | _ -> false) + q + && List.for_all + (fun pid -> + let column = + CPredicateMap.find_default [] pid blackboard.steps_by_column in - begin - let list = - match - list - with - | (a,_,_)::q when a = eid -> q - | _ -> list - in - aux tail error - {blackboard - with - steps_by_column = - CPredicateMap.add pid list blackboard.steps_by_column - } - end + let column, _blackboard = clean pid column blackboard in + let rec check_aux column = + match column with + | (b, x, true) :: (_, y, _) :: _ when b = eidb -> + x = y (* is b modif is mute ? *) + | (b, _, bool) :: _ when b = eidb -> + not bool (* if yes, b does not do modif *) + | (_, _, _) :: tail -> check_aux tail + | [] -> true + in + match column with + | (a, x, true) :: (b, _, true) :: (_, y, _) :: _ + when b = eidb && a = eida -> + x = y (* a cancels b modif*) + | _ -> + check_aux column (* otherwise check that b has no effect *)) + (A.get blackboard.predicates_of_event eidb) + then + error, Some (eida, eidb) + else + error, None + + let pop _parameter _handler error blackboard eid = + let predicate_list = A.get blackboard.predicates_of_event eid in + let rec aux l error blackboard = + match l with + | [] -> error, blackboard + | pid :: tail -> + let list = + match CPredicateMap.find_option pid blackboard.steps_by_column with + | Some x -> x + | None -> raise Exit in - let error,blackboard = aux predicate_list error blackboard in - let _ = A.set blackboard.event eid None in - error,blackboard + let list = + match list with + | (a, _, _) :: q when a = eid -> q + | _ -> list + in + aux tail error + { + blackboard with + steps_by_column = + CPredicateMap.add pid list blackboard.steps_by_column; + } + in + let error, blackboard = aux predicate_list error blackboard in + let _ = A.set blackboard.event eid None in + error, blackboard - let predicates_of_test _parameter _handler _error _blackboard test = - match test - with - | Instantiation.Is_Here (agent) -> - let ag_id = Po.K.agent_id_of_agent agent in - let predicate_id = Predicate_maps.Here ag_id in - [predicate_id] - | Instantiation.Has_Internal(site,_int) -> - let predicate_id = Predicate_maps.Internal_state (Po.K.agent_id_of_site site,Po.K.site_name_of_site site) in - [predicate_id] - | Instantiation.Is_Free s -> - let ag_id = Po.K.agent_id_of_site s in - let site_id = Po.K.site_name_of_site s in - let predicate_id = Predicate_maps.Bound_site (ag_id,site_id) in - [predicate_id] - | Instantiation.Is_Bound_to (s1,s2) -> - let ag_id1 = Po.K.agent_id_of_site s1 in - let ag_id2 = Po.K.agent_id_of_site s2 in - let site_id1 = Po.K.site_name_of_site s1 in - let site_id2 = Po.K.site_name_of_site s2 in - let predicate_id1 = Predicate_maps.Bound_site (ag_id1,site_id1) in - let predicate_id2 = Predicate_maps.Bound_site (ag_id2,site_id2) in - [predicate_id1;predicate_id2] - | Instantiation.Is_Bound s -> - let ag_id = Po.K.agent_id_of_site s in - let site_id = Po.K.site_name_of_site s in - let predicate_id = Predicate_maps.Bound_site (ag_id,site_id) in - [predicate_id] - | Instantiation.Has_Binding_type (s,_) -> - let ag_id = Po.K.agent_id_of_site s in - let site_id = Po.K.site_name_of_site s in - let predicate_id = Predicate_maps.Bound_site (ag_id,site_id) in - [predicate_id] + let predicates_of_test _parameter _handler _error _blackboard test = + match test with + | Instantiation.Is_Here agent -> + let ag_id = Po.K.agent_id_of_agent agent in + let predicate_id = Predicate_maps.Here ag_id in + [ predicate_id ] + | Instantiation.Has_Internal (site, _int) -> + let predicate_id = + Predicate_maps.Internal_state + (Po.K.agent_id_of_site site, Po.K.site_name_of_site site) + in + [ predicate_id ] + | Instantiation.Is_Free s -> + let ag_id = Po.K.agent_id_of_site s in + let site_id = Po.K.site_name_of_site s in + let predicate_id = Predicate_maps.Bound_site (ag_id, site_id) in + [ predicate_id ] + | Instantiation.Is_Bound_to (s1, s2) -> + let ag_id1 = Po.K.agent_id_of_site s1 in + let ag_id2 = Po.K.agent_id_of_site s2 in + let site_id1 = Po.K.site_name_of_site s1 in + let site_id2 = Po.K.site_name_of_site s2 in + let predicate_id1 = Predicate_maps.Bound_site (ag_id1, site_id1) in + let predicate_id2 = Predicate_maps.Bound_site (ag_id2, site_id2) in + [ predicate_id1; predicate_id2 ] + | Instantiation.Is_Bound s -> + let ag_id = Po.K.agent_id_of_site s in + let site_id = Po.K.site_name_of_site s in + let predicate_id = Predicate_maps.Bound_site (ag_id, site_id) in + [ predicate_id ] + | Instantiation.Has_Binding_type (s, _) -> + let ag_id = Po.K.agent_id_of_site s in + let site_id = Po.K.site_name_of_site s in + let predicate_id = Predicate_maps.Bound_site (ag_id, site_id) in + [ predicate_id ] - let add_step parameter handler info error step blackboard = - let pre_event = blackboard.event in - let test_list = Trace.tests_of_step step in - let (action_list,_) = Trace.actions_of_step step in - let side_effect = Trace.side_effects_of_step step in - let build_map list map = - List.fold_left - (fun map (id,value) -> Predicate_maps.PredicateMap.add id value map) - map - list - in - let build_map_test list map = - List.fold_left - (fun map id -> PredicateMap.add id true map ) - map - list - in - let add_state pid (test,action) map = - let test',action' = - PredicateMap.find_default (false,None) pid map in - let test = test || test' in - let action = - match action' - with - | None -> action - | _ -> action' - in - let map = PredicateMap.add pid (test,action) map in - map - in - let unambiguous_side_effects = side_effect in - let test_map = - List.fold_left - (fun map test -> - let test_list = predicates_of_test parameter handler error blackboard test in - build_map_test test_list map) - PredicateMap.empty - test_list - in - let error,blackboard,action_map,test_map,is_remove_action,_is_create_action = - List.fold_left - (fun (error,blackboard,action_map,test_map,bool,bool_creation) action -> - let blackboard,action_list,test_list,bool',bool_creation' = predicates_of_action parameter handler error blackboard action in - error,blackboard,build_map action_list action_map,build_map_test test_list test_map,bool || bool',bool_creation || bool_creation') - (error,blackboard,PredicateMap.empty,test_map,false,false) - (action_list) - in - let error,merged_map = - PredicateMap.monadic_fold2 parameter error - (fun _ e key test action acc -> e,PredicateMap.add key (test,Some action) acc) - (fun _ e key test acc -> e,PredicateMap.add key (test,None) acc) - (fun _ e key action acc -> e,PredicateMap.add key (false,Some action) acc) - test_map - action_map - PredicateMap.empty - in - let merged_map = - List.fold_right - (fun ((a,_),b) map -> - let pid = Predicate_maps.Bound_site(a,b) in - add_state pid (false,Some Predicate_maps.Free) map) - unambiguous_side_effects merged_map - in - let nsid = blackboard.nsteps + 1 in - let _ = A.set blackboard.event nsid (Some step) in - let n_modifications,pre_steps_by_column,list,mod_without_test = - PredicateMap.fold - (fun id (test,action) (n_modifications,map,list,mod_without_test) -> - begin - let old_list = - CPredicateMap.find_default [-1,Predicate_maps.Undefined,false] id map in - let old_value = - match - old_list - with - | (_,v,_)::_ -> v - | [] -> Predicate_maps.Undefined - in - let new_value = - match action - with - | None -> old_value - | Some i -> i - in - let n_modifications,bool_action,mod_without_test = - match action - with - | None -> n_modifications,false,mod_without_test - | Some _ -> (n_modifications+1),true,mod_without_test || test - in - n_modifications, - CPredicateMap.add id ((nsid,new_value,bool_action)::old_list) map, - (id,new_value)::list, - mod_without_test - end) - merged_map - (0,blackboard.steps_by_column,[],false) - in - let _ = - if is_remove_action - then - let _ = A.set blackboard.is_remove_action nsid true in () + let add_step parameter handler info error step blackboard = + let pre_event = blackboard.event in + let test_list = Trace.tests_of_step step in + let action_list, _ = Trace.actions_of_step step in + let side_effect = Trace.side_effects_of_step step in + let build_map list map = + List.fold_left + (fun map (id, value) -> Predicate_maps.PredicateMap.add id value map) + map list + in + let build_map_test list map = + List.fold_left (fun map id -> PredicateMap.add id true map) map list + in + let add_state pid (test, action) map = + let test', action' = PredicateMap.find_default (false, None) pid map in + let test = test || test' in + let action = + match action' with + | None -> action + | _ -> action' + in + let map = PredicateMap.add pid (test, action) map in + map + in + let unambiguous_side_effects = side_effect in + let test_map = + List.fold_left + (fun map test -> + let test_list = + predicates_of_test parameter handler error blackboard test + in + build_map_test test_list map) + PredicateMap.empty test_list + in + let ( error, + blackboard, + action_map, + test_map, + is_remove_action, + _is_create_action ) = + List.fold_left + (fun (error, blackboard, action_map, test_map, bool, bool_creation) + action -> + let blackboard, action_list, test_list, bool', bool_creation' = + predicates_of_action parameter handler error blackboard action + in + ( error, + blackboard, + build_map action_list action_map, + build_map_test test_list test_map, + bool || bool', + bool_creation || bool_creation' )) + (error, blackboard, PredicateMap.empty, test_map, false, false) + action_list + in + let error, merged_map = + PredicateMap.monadic_fold2 parameter error + (fun _ e key test action acc -> + e, PredicateMap.add key (test, Some action) acc) + (fun _ e key test acc -> e, PredicateMap.add key (test, None) acc) + (fun _ e key action acc -> + e, PredicateMap.add key (false, Some action) acc) + test_map action_map PredicateMap.empty + in + let merged_map = + List.fold_right + (fun ((a, _), b) map -> + let pid = Predicate_maps.Bound_site (a, b) in + add_state pid (false, Some Predicate_maps.Free) map) + unambiguous_side_effects merged_map + in + let nsid = blackboard.nsteps + 1 in + let _ = A.set blackboard.event nsid (Some step) in + let n_modifications, pre_steps_by_column, list, mod_without_test = + PredicateMap.fold + (fun id (test, action) (n_modifications, map, list, mod_without_test) -> + let old_list = + CPredicateMap.find_default + [ -1, Predicate_maps.Undefined, false ] + id map + in + let old_value = + match old_list with + | (_, v, _) :: _ -> v + | [] -> Predicate_maps.Undefined + in + let new_value = + match action with + | None -> old_value + | Some i -> i + in + let n_modifications, bool_action, mod_without_test = + match action with + | None -> n_modifications, false, mod_without_test + | Some _ -> n_modifications + 1, true, mod_without_test || test + in + ( n_modifications, + CPredicateMap.add id + ((nsid, new_value, bool_action) :: old_list) + map, + (id, new_value) :: list, + mod_without_test )) + merged_map + (0, blackboard.steps_by_column, [], false) + in + let _ = + if is_remove_action then ( + let _ = A.set blackboard.is_remove_action nsid true in + () + ) + in + let () = + A.set blackboard.predicates_of_event nsid + (List.rev_map fst (List.rev list)) + in + let () = + A.set blackboard.modified_predicates_of_event nsid n_modifications in - let () = A.set blackboard.predicates_of_event nsid (List.rev_map fst (List.rev list)) in - let () = A.set blackboard.modified_predicates_of_event nsid n_modifications in let () = A.set blackboard.has_mod_without_test nsid mod_without_test in let blackboard = { blackboard with - event = pre_event ; - steps_by_column = pre_steps_by_column; - nsteps = nsid; + event = pre_event; + steps_by_column = pre_steps_by_column; + nsteps = nsid; } in - error,info,blackboard + error, info, blackboard let cut parameter handler info error list = let n_steps = List.length list in let blackboard = init_blackboard n_steps handler in - let error,info,blackboard,n_cut = + let error, info, blackboard, n_cut = List.fold_left - (fun (error,info,blackboard,n_cut) step -> - let error,info,blackboard = add_step parameter handler info error step blackboard in - let error,to_pop = check parameter handler error blackboard in - match - to_pop - with - | None -> error,info,blackboard,n_cut - | Some (e1,e2) -> - let error,blackboard = pop parameter handler error blackboard e1 in - let error,blackboard = pop parameter handler error blackboard e2 in - (error,info,blackboard,n_cut+2) ) - (error,info,blackboard,0) + (fun (error, info, blackboard, n_cut) step -> + let error, info, blackboard = + add_step parameter handler info error step blackboard + in + let error, to_pop = check parameter handler error blackboard in + match to_pop with + | None -> error, info, blackboard, n_cut + | Some (e1, e2) -> + let error, blackboard = pop parameter handler error blackboard e1 in + let error, blackboard = pop parameter handler error blackboard e2 in + error, info, blackboard, n_cut + 2) + (error, info, blackboard, 0) list in let list = let rec aux k list = - if k=(-1) - then list - else - match A.get blackboard.event k - with - | Some a -> - aux (k-1) (a::list) - | None -> aux (k-1) list - in aux (blackboard.nsteps) [] + if k = -1 then + list + else ( + match A.get blackboard.event k with + | Some a -> aux (k - 1) (a :: list) + | None -> aux (k - 1) list + ) + in + aux blackboard.nsteps [] in let tab = blackboard.steps_by_column in - let _ = - List.iter (CPredicateMap.recycle tab) blackboard.agent_list - in - error,info, (list,n_cut) + let _ = List.iter (CPredicateMap.recycle tab) blackboard.agent_list in + error, info, (list, n_cut) (* let cut parameter handler info error list = error, info, (list,0)*) - - end:Cut_pseudo_inverse) +end diff --git a/core/cflow/story_json.ml b/core/cflow/story_json.ml index c9f0f9bd50..5582029375 100644 --- a/core/cflow/story_json.ml +++ b/core/cflow/story_json.ml @@ -1,135 +1,99 @@ type current_compression_mode = Weak | Strong | Causal +type new_story = { id: int; graph: Graph_loggers_sig.graph } +type story = New of new_story | Same_as of int - -type new_story = - { - id: int; - graph: Graph_loggers_sig.graph; - } - -type story = - | New of new_story - | Same_as of int - -type 'a one_compression = - { - log_info: 'a Trace.Simulation_info.t list; - story_mode: current_compression_mode; - story: story - } +type 'a one_compression = { + log_info: 'a Trace.Simulation_info.t list; + story_mode: current_compression_mode; + story: story; +} let string_of_json = function | `String s -> s - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct string",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct string", x)) let int_of_json = function | `Int s -> s - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct int",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct int", x)) let new_story_to_json new_story = `Assoc - [ - "id", `Int new_story.id; - "graph", Graph_json.to_json new_story.graph; - ] + [ "id", `Int new_story.id; "graph", Graph_json.to_json new_story.graph ] let new_story_of_json = function | `Assoc l as x when List.length l = 2 -> - begin - try - { - id = int_of_json (List.assoc "id" l); - graph = Graph_json.of_json (List.assoc "graph" l) - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct new story",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct new story",x)) + (try + { + id = int_of_json (List.assoc "id" l); + graph = Graph_json.of_json (List.assoc "graph" l); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct new story", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct new story", x)) let story_to_json story = - match - story - with - | New new_story -> - `Assoc - [ - "new", new_story_to_json new_story - ] - | Same_as int -> - `Assoc - [ - "same_as", `Int int - ] - + match story with + | New new_story -> `Assoc [ "new", new_story_to_json new_story ] + | Same_as int -> `Assoc [ "same_as", `Int int ] let story_of_json = function - | `Assoc ["new", new_story] -> New (new_story_of_json new_story) - | `Assoc ["same_as", `Int int] -> Same_as int - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct story",x)) + | `Assoc [ ("new", new_story) ] -> New (new_story_of_json new_story) + | `Assoc [ ("same_as", `Int int) ] -> Same_as int + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct story", x)) let story_mode_to_json = function -| Causal -> `String "Causal" -| Weak -> `String "Weak" -| Strong -> `String "Strong" + | Causal -> `String "Causal" + | Weak -> `String "Weak" + | Strong -> `String "Strong" let story_mode_of_json = function -| `String "Causal" -> Causal -| `String "Weak" -> Weak -| `String "Strong" -> Strong -| x -> raise (Yojson.Basic.Util.Type_error ("Not a correct story mode",x)) + | `String "Causal" -> Causal + | `String "Weak" -> Weak + | `String "Strong" -> Strong + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct story mode", x)) let to_json log_info_to_json one_compression = `Assoc [ - "log_info", - `List - (List.rev_map - (Trace.Simulation_info.to_json log_info_to_json) - (List.rev one_compression.log_info)); - "story_mode", - story_mode_to_json one_compression.story_mode; - - "story", - story_to_json one_compression.story + ( "log_info", + `List + (List.rev_map + (Trace.Simulation_info.to_json log_info_to_json) + (List.rev one_compression.log_info)) ); + "story_mode", story_mode_to_json one_compression.story_mode; + "story", story_to_json one_compression.story; ] let of_json log_info_of_json = function | `Assoc l as x when List.length l = 3 -> - begin - try - { - log_info = - begin - match List.assoc "log_info" l - with - | `List l -> - List.rev_map - (Trace.Simulation_info.of_json - log_info_of_json) - (List.rev l) - | _y -> - raise (Yojson.Basic.Util.Type_error ("Not a correct story computation",x)) - end - ; - story = story_of_json - (List.assoc "story" l) ; - story_mode = story_mode_of_json (List.assoc "story_mode" l); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct story computation",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct story computation",x)) - -type phase = - | Start - | Inprogress - | Success - | Faillure + (try + { + log_info = + (match List.assoc "log_info" l with + | `List l -> + List.rev_map + (Trace.Simulation_info.of_json log_info_of_json) + (List.rev l) + | _y -> + raise + (Yojson.Basic.Util.Type_error + ("Not a correct story computation", x))); + story = story_of_json (List.assoc "story" l); + story_mode = story_mode_of_json (List.assoc "story_mode" l); + } + with Not_found -> + raise + (Yojson.Basic.Util.Type_error ("Not a correct story computation", x))) + | x -> + raise (Yojson.Basic.Util.Type_error ("Not a correct story computation", x)) + +type phase = Start | Inprogress | Success | Faillure let start = "starting computation" let inprogress = "computation in progress" let success = "computation completed successfully" let faillure = "computation (partially) failed" + let phase_to_json = function | Start -> `String start | Inprogress -> `String inprogress @@ -141,40 +105,37 @@ let phase_of_json = function | `String s when s = inprogress -> Inprogress | `String s when s = success -> Success | `String s when s = faillure -> Faillure - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct phase",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct phase", x)) -type progress_bar = - { - bool: string; - current: int; - total: int - } +type progress_bar = { bool: string; current: int; total: int } let progress_bar_to_json progress_bar = - `Assoc ["progress_bar", - `Assoc ["bool",`String progress_bar.bool; - "current",`Int progress_bar.current; - "total",`Int progress_bar.total] - ] + `Assoc + [ + ( "progress_bar", + `Assoc + [ + "bool", `String progress_bar.bool; + "current", `Int progress_bar.current; + "total", `Int progress_bar.total; + ] ); + ] let progress_bar_of_json = function | `Assoc l as x when List.length l = 1 -> - begin - match List.assoc "progress_bar" l with - | `Assoc l when List.length l = 3 -> - begin - try - { - bool = string_of_json (List.assoc "bool" l); - current = int_of_json (List.assoc "current" l); - total = int_of_json (List.assoc "total" l) - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct progress bar",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct progress bar",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct progress bar",x)) + (match List.assoc "progress_bar" l with + | `Assoc l when List.length l = 3 -> + (try + { + bool = string_of_json (List.assoc "bool" l); + current = int_of_json (List.assoc "current" l); + total = int_of_json (List.assoc "total" l); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct progress bar", x))) + | x -> + raise (Yojson.Basic.Util.Type_error ("Not a correct progress bar", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct progress bar", x)) type 'a message = | Phase of phase * string @@ -182,7 +143,7 @@ type 'a message = | Story of 'a one_compression let message_to_json = function - | Phase (p,m) -> `List [ `String "PHASE"; phase_to_json p; `String m ] + | Phase (p, m) -> `List [ `String "PHASE"; phase_to_json p; `String m ] | Progress p -> `List [ `String "PROGRESS"; progress_bar_to_json p ] | Story s -> `List [ `String "STORY"; to_json (fun _ -> `Null) s ] @@ -190,4 +151,4 @@ let message_of_json = function | `List [ `String "PHASE"; p; `String m ] -> Phase (phase_of_json p, m) | `List [ `String "PROGRESS"; p ] -> Progress (progress_bar_of_json p) | `List [ `String "STORY"; s ] -> Story (of_json (fun _ -> ()) s) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid story message",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid story message", x)) diff --git a/core/cflow/story_json.mli b/core/cflow/story_json.mli index ed54a9a4be..e1e9070c74 100644 --- a/core/cflow/story_json.mli +++ b/core/cflow/story_json.mli @@ -1,34 +1,15 @@ type current_compression_mode = Weak | Strong | Causal +type new_story = { id: int; graph: Graph_loggers_sig.graph } +type story = New of new_story | Same_as of int -type new_story = - { - id: int; - graph: Graph_loggers_sig.graph; - } +type 'a one_compression = { + log_info: 'a Trace.Simulation_info.t list; + story_mode: current_compression_mode; + story: story; +} -type story = - | New of new_story - | Same_as of int - -type 'a one_compression = - { - log_info: 'a Trace.Simulation_info.t list; - story_mode: current_compression_mode; - story: story - } - -type phase = - | Start - | Inprogress - | Success - | Faillure - -type progress_bar = - { - bool: string; - current: int; - total: int - } +type phase = Start | Inprogress | Success | Faillure +type progress_bar = { bool: string; current: int; total: int } type 'a message = | Phase of phase * string diff --git a/core/cflow/tick_stories.ml b/core/cflow/tick_stories.ml index 92d9949bd9..8ec5cf6ce8 100644 --- a/core/cflow/tick_stories.ml +++ b/core/cflow/tick_stories.ml @@ -16,37 +16,40 @@ * et en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - -let tick_stories f conf save_progress_bar (init,last,counter,n_stories) = +let tick_stories f conf save_progress_bar (init, last, counter, n_stories) = let () = - if not init then + if not init then ( let c = ref conf.Configuration.progressSize in let () = Loggers.print_newline f in while !c > 0 do - Loggers.fprintf f "_" ; - c:=!c-1 - done ; + Loggers.fprintf f "_"; + c := !c - 1 + done; Loggers.print_newline f + ) in let n = - if n_stories <=0 && counter = 0 - then conf.Configuration.progressSize - else if counter > n_stories - then 0 - else - let nc = (counter * conf.Configuration.progressSize) / n_stories in - let nl = (last * conf.Configuration.progressSize) / n_stories in + if n_stories <= 0 && counter = 0 then + conf.Configuration.progressSize + else if counter > n_stories then + 0 + else ( + let nc = counter * conf.Configuration.progressSize / n_stories in + let nl = last * conf.Configuration.progressSize / n_stories in nc - nl + ) in let rec aux n = - if n<=0 then () - else - let () = Loggers.fprintf f "%c" (conf.Configuration.progressChar) in - aux (n-1) + if n <= 0 then + () + else ( + let () = Loggers.fprintf f "%c" conf.Configuration.progressChar in + aux (n - 1) + ) in let () = aux n in let () = Loggers.flush_logger f in let () = if counter = n_stories then Loggers.print_newline f in - let bar = (true,counter,counter+1,n_stories) in + let bar = true, counter, counter + 1, n_stories in let () = save_progress_bar bar in bar diff --git a/core/cflow/utilities.ml b/core/cflow/utilities.ml index 2dfaaf7522..fdbadd94c1 100644 --- a/core/cflow/utilities.ml +++ b/core/cflow/utilities.ml @@ -14,79 +14,84 @@ let debug_mode = false -module D=Dag.StoryTable -module S=Generic_branch_and_cut_solver.Solver -module P=StoryProfiling.StoryStats +module D = Dag.StoryTable +module S = Generic_branch_and_cut_solver.Solver +module P = StoryProfiling.StoryStats -type error_log = Exception.method_handler -type parameter = S.PH.B.PB.CI.Po.K.H.parameter +type error_log = Exception.method_handler +type parameter = S.PH.B.PB.CI.Po.K.H.parameter type kappa_handler = S.PH.B.PB.CI.Po.K.H.handler type profiling_info = P.log_info -type shall_we = (parameter -> bool) - +type shall_we = parameter -> bool type step = Trace.step type step_with_side_effects = step * S.PH.B.PB.CI.Po.K.side_effect type step_id = S.PH.B.PB.step_id -type trace = - { - compressed_trace: step_with_side_effects list option ; - pretrace: step list ; - with_potential_ambiguity: bool - } +type trace = { + compressed_trace: step_with_side_effects list option; + pretrace: step list; + with_potential_ambiguity: bool; +} + type trace_runtime_info = profiling_info Trace.Simulation_info.t type 'a with_handlers = - parameter -> ?shall_we_compute:shall_we -> ?shall_we_compute_profiling_information:shall_we -> + parameter -> + ?shall_we_compute:shall_we -> + ?shall_we_compute_profiling_information:shall_we -> ?print_if_zero:shall_we -> - kappa_handler -> profiling_info -> error_log -> 'a -type 'a zeroary = - (error_log * profiling_info * 'a) with_handlers -type ('a,'b) unary = - ('a -> error_log * profiling_info * 'b) with_handlers -type ('a,'b,'c) binary = + kappa_handler -> + profiling_info -> + error_log -> + 'a + +type 'a zeroary = (error_log * profiling_info * 'a) with_handlers +type ('a, 'b) unary = ('a -> error_log * profiling_info * 'b) with_handlers + +type ('a, 'b, 'c) binary = ('a -> 'b -> error_log * profiling_info * 'c) with_handlers -type ('a,'b,'c,'d) ternary = - ('a -> 'b -> 'c ->error_log * profiling_info * 'd) with_handlers -type ('a,'b,'c,'d,'e) quaternary = + +type ('a, 'b, 'c, 'd) ternary = + ('a -> 'b -> 'c -> error_log * profiling_info * 'd) with_handlers + +type ('a, 'b, 'c, 'd, 'e) quaternary = ('a -> 'b -> 'c -> 'd -> error_log * profiling_info * 'e) with_handlers -type ('a,'b,'c,'d,'e,'f) quinternary = + +type ('a, 'b, 'c, 'd, 'e, 'f) quinternary = ('a -> 'b -> 'c -> 'd -> 'e -> error_log * profiling_info * 'f) with_handlers -type ('a,'b,'c,'d,'e,'f,'g) sexternary = - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> error_log * profiling_info * 'g) with_handlers -let (we_shall:shall_we) = (fun _ -> true) -let (we_shall_not:shall_we) = (fun _ -> false) +type ('a, 'b, 'c, 'd, 'e, 'f, 'g) sexternary = + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> error_log * profiling_info * 'g) + with_handlers +let (we_shall : shall_we) = fun _ -> true +let (we_shall_not : shall_we) = fun _ -> false let get_pretrace_of_trace trace = trace.pretrace let size_of_pretrace trace = List.length (get_pretrace_of_trace trace) - let may_initial_sites_be_ambiguous trace = trace.with_potential_ambiguity -let set_ambiguity_level trace x = {trace with with_potential_ambiguity=x} -let _set_pretrace trace x = {trace with pretrace = x} -let _set_compressed_trace trace x = {trace with compressed_trace = x} +let set_ambiguity_level trace x = { trace with with_potential_ambiguity = x } +let _set_pretrace trace x = { trace with pretrace = x } +let _set_compressed_trace trace x = { trace with compressed_trace = x } + let get_compressed_trace trace = - match - trace.compressed_trace - with + match trace.compressed_trace with | Some x -> x - | None -> List.rev_map (fun x -> x,[]) (List.rev (get_pretrace_of_trace trace)) + | None -> + List.rev_map (fun x -> x, []) (List.rev (get_pretrace_of_trace trace)) + let is_compressed_trace trace = trace.compressed_trace != None let trace_of_pretrace_with_ambiguity with_ambiguity pretrace = { - pretrace = pretrace ; - compressed_trace = None ; - with_potential_ambiguity = with_ambiguity ; + pretrace; + compressed_trace = None; + with_potential_ambiguity = with_ambiguity; } let trace_of_pretrace = trace_of_pretrace_with_ambiguity true + let build_compressed_trace x y = - { - compressed_trace = Some y; - pretrace = x; - with_potential_ambiguity = false - } + { compressed_trace = Some y; pretrace = x; with_potential_ambiguity = false } (*let get_log_step = S.PH.B.PB.CI.Po.K.H.get_log_step let get_debugging_mode = S.PH.B.PB.CI.Po.K.H.get_debugging_mode @@ -94,7 +99,8 @@ let build_compressed_trace x y = let get_id_of_event = S.PH.B.PB.CI.Po.K.get_id_of_refined_step let get_simulation_time_of_event = S.PH.B.PB.CI.Po.K.get_time_of_refined_step -let _extend_trace_with_dummy_side_effects l = List.rev_map (fun a -> a,[]) (List.rev l) +let _extend_trace_with_dummy_side_effects l = + List.rev_map (fun a -> a, []) (List.rev l) let print_pretrace parameter _handler = Loggers.fprintf @@ -102,182 +108,175 @@ let print_pretrace parameter _handler = "@[%a@]@." (Pp.list Pp.space (Trace.print_step ~compact:true ?env:None)) -let print_trace parameter handler trace = print_pretrace parameter handler (get_pretrace_of_trace trace) - -let transform_trace_gen f log_message debug_message profiling_event = - (fun parameters ?(shall_we_compute=we_shall) - ?shall_we_compute_profiling_information:(_) - ?(print_if_zero=we_shall) - kappa_handler profiling_info error trace -> - if shall_we_compute parameters - then - let error, profiling_info = StoryProfiling.StoryStats.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters) error profiling_event (Some (fun () -> size_of_pretrace trace)) profiling_info in - let bool = - if - S.PH.B.PB.CI.Po.K.H.get_log_step parameters - then - match log_message - with - | Some log_message -> - let () = - Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameters) - "%s%s" - (Remanent_parameters.get_prefix - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters)) - log_message in - let () = - Loggers.flush_logger (S.PH.B.PB.CI.Po.K.H.get_logger parameters) - in - true - | None -> false - else - false - in - let pretrace = get_pretrace_of_trace trace in - let error,profiling_info,(pretrace',n) = f parameters kappa_handler profiling_info error pretrace in - let trace' = trace_of_pretrace pretrace' in - let trace = - if trace == trace' - then trace - else - set_ambiguity_level trace' (may_initial_sites_be_ambiguous trace) - in - let () = - if - bool - then - if n=0 then - if print_if_zero parameters - then Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameters) - ": nothing has changed @." - else - Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameters) - "@." - else if n > 0 then - Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameters) - ": -%i events @." n - else - Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameters) - ": +%i events @." (-n) - in - let () = - if - S.PH.B.PB.CI.Po.K.H.get_debugging_mode parameters - then - let _ = - match (Loggers.formatter_of_logger - (S.PH.B.PB.CI.Po.K.H.get_debugging_channel parameters)) - with - | Some fmt -> Format.fprintf fmt debug_message - | None -> () - in - print_trace parameters kappa_handler trace - - in - let error, profiling_info = - StoryProfiling.StoryStats.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters) error profiling_event (Some (fun () -> size_of_pretrace trace)) profiling_info - in - error,profiling_info,trace - else - error,profiling_info,trace) - - -type kind = - (* | Solve_ambiguities*) - | May_add_ambiguities - | Neutral +let print_trace parameter handler trace = + print_pretrace parameter handler (get_pretrace_of_trace trace) + +let transform_trace_gen f log_message debug_message profiling_event parameters + ?(shall_we_compute = we_shall) ?shall_we_compute_profiling_information:_ + ?(print_if_zero = we_shall) kappa_handler profiling_info error trace = + if shall_we_compute parameters then ( + let error, profiling_info = + StoryProfiling.StoryStats.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters) + error profiling_event + (Some (fun () -> size_of_pretrace trace)) + profiling_info + in + let bool = + if S.PH.B.PB.CI.Po.K.H.get_log_step parameters then ( + match log_message with + | Some log_message -> + let () = + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameters) + "%s%s" + (Remanent_parameters.get_prefix + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters)) + log_message + in + let () = + Loggers.flush_logger (S.PH.B.PB.CI.Po.K.H.get_logger parameters) + in + true + | None -> false + ) else + false + in + let pretrace = get_pretrace_of_trace trace in + let error, profiling_info, (pretrace', n) = + f parameters kappa_handler profiling_info error pretrace + in + let trace' = trace_of_pretrace pretrace' in + let trace = + if trace == trace' then + trace + else + set_ambiguity_level trace' (may_initial_sites_be_ambiguous trace) + in + let () = + if bool then + if n = 0 then + if print_if_zero parameters then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameters) + ": nothing has changed @." + else + Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameters) "@." + else if n > 0 then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameters) + ": -%i events @." n + else + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameters) + ": +%i events @." (-n) + in + let () = + if S.PH.B.PB.CI.Po.K.H.get_debugging_mode parameters then ( + let _ = + match + Loggers.formatter_of_logger + (S.PH.B.PB.CI.Po.K.H.get_debugging_channel parameters) + with + | Some fmt -> Format.fprintf fmt debug_message + | None -> () + in + print_trace parameters kappa_handler trace + ) + in + let error, profiling_info = + StoryProfiling.StoryStats.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameters) + error profiling_event + (Some (fun () -> size_of_pretrace trace)) + profiling_info + in + error, profiling_info, trace + ) else + error, profiling_info, trace + +type kind = (* | Solve_ambiguities*) + | May_add_ambiguities | Neutral let handle_ambiguities kind b = - match kind - with + match kind with (* | Solve_ambiguities -> false*) | Neutral -> b | May_add_ambiguities -> true -type ambiquities_precondition = Do_not_care | Require_the_abscence_of_ambiguity (*| Better_when_no_ambiguity*) +type ambiquities_precondition = + | Do_not_care + | Require_the_abscence_of_ambiguity (*| Better_when_no_ambiguity*) let must_we_solve_ambiguity _parameters x = - match - x - with + match x with | Do_not_care -> false | Require_the_abscence_of_ambiguity -> true (* | Better_when_no_ambiguity -> S.PH.B.PB.CI.Po.K.H.always_disambiguate parameters*) -let monadic_lift f = (fun _ _ log_info error t -> - let t' = f t in - error,log_info,(t',List.length t - List.length t')) -let _dummy_profiling = (fun _ p -> p) +let monadic_lift f _ _ log_info error t = + let t' = f t in + error, log_info, (t', List.length t - List.length t') + +let _dummy_profiling _ p = p let disambiguate = transform_trace_gen (monadic_lift S.PH.B.PB.CI.Po.K.disambiguate) - (Some "\t- alpha-conversion") - "Trace after having renames agents:\n" + (Some "\t- alpha-conversion") "Trace after having renames agents:\n" StoryProfiling.Agent_ids_disambiguation -let make_unambiguous - parameters - ?(shall_we_compute=we_shall) ?(shall_we_compute_profiling_information=we_shall_not) - ?(print_if_zero=we_shall_not) - kappa_handler profiling_info error trace = - if may_initial_sites_be_ambiguous trace - then - let error,profiling_info,trace' = disambiguate parameters - ~shall_we_compute:(fun parameters -> may_initial_sites_be_ambiguous trace && shall_we_compute parameters) - ~shall_we_compute_profiling_information - ~print_if_zero - kappa_handler profiling_info error trace in - error,profiling_info, - if trace'==trace - then - set_ambiguity_level trace false - else - set_ambiguity_level trace' false - else - error,profiling_info,trace - -let lift_to_care_about_ambiguities f requirement effect = - (fun parameters ?(shall_we_compute=we_shall) - ?(shall_we_compute_profiling_information=we_shall) - ?(print_if_zero=we_shall) - kappa_handler profiling_info error trace -> - if shall_we_compute parameters - then - let error,profiling_info,trace = - if must_we_solve_ambiguity parameters requirement - then - make_unambiguous - parameters - ~shall_we_compute - kappa_handler profiling_info error trace - else - error,profiling_info,trace - in - let error,log_info,trace = - (f: S.PH.B.PB.CI.Po.K.H.parameter -> ?shall_we_compute:shall_we-> +let make_unambiguous parameters ?(shall_we_compute = we_shall) + ?(shall_we_compute_profiling_information = we_shall_not) + ?(print_if_zero = we_shall_not) kappa_handler profiling_info error trace = + if may_initial_sites_be_ambiguous trace then ( + let error, profiling_info, trace' = + disambiguate parameters + ~shall_we_compute:(fun parameters -> + may_initial_sites_be_ambiguous trace && shall_we_compute parameters) + ~shall_we_compute_profiling_information ~print_if_zero kappa_handler + profiling_info error trace + in + ( error, + profiling_info, + if trace' == trace then + set_ambiguity_level trace false + else + set_ambiguity_level trace' false ) + ) else + error, profiling_info, trace + +let lift_to_care_about_ambiguities f requirement effect parameters + ?(shall_we_compute = we_shall) + ?(shall_we_compute_profiling_information = we_shall) + ?(print_if_zero = we_shall) kappa_handler profiling_info error trace = + if shall_we_compute parameters then ( + let error, profiling_info, trace = + if must_we_solve_ambiguity parameters requirement then + make_unambiguous parameters ~shall_we_compute kappa_handler + profiling_info error trace + else + error, profiling_info, trace + in + let error, log_info, trace = + (f + : S.PH.B.PB.CI.Po.K.H.parameter -> + ?shall_we_compute:shall_we -> ?shall_we_compute_profiling_information:shall_we -> ?print_if_zero:shall_we -> S.PH.B.PB.CI.Po.K.H.handler -> StoryProfiling.StoryStats.log_info -> Exception.method_handler -> trace -> - Exception.method_handler * StoryProfiling.StoryStats.log_info * - trace) - parameters - ~shall_we_compute ~shall_we_compute_profiling_information - ~print_if_zero - kappa_handler profiling_info error trace in - let trace = set_ambiguity_level trace (handle_ambiguities effect true) in - error,log_info,trace - else - error,profiling_info,trace) + Exception.method_handler * StoryProfiling.StoryStats.log_info * trace) + parameters ~shall_we_compute ~shall_we_compute_profiling_information + ~print_if_zero kappa_handler profiling_info error trace + in + let trace = set_ambiguity_level trace (handle_ambiguities effect true) in + error, log_info, trace + ) else + error, profiling_info, trace let split_init = lift_to_care_about_ambiguities @@ -286,80 +285,70 @@ let split_init = (Some "\t- splitting initial events") "Trace after having split initial events:\n" StoryProfiling.Decompose_initial_state) - Do_not_care - Neutral + Do_not_care Neutral let cut = lift_to_care_about_ambiguities - (transform_trace_gen - S.PH.B.PB.CI.Po.cut + (transform_trace_gen S.PH.B.PB.CI.Po.cut (Some "\t- cutting concurrent events") "Trace after having removed concurrent events:\n" StoryProfiling.Partial_order_reduction) - Require_the_abscence_of_ambiguity - Neutral + Require_the_abscence_of_ambiguity Neutral type on_the_fly_cut_state = S.PH.B.PB.CI.Po.on_the_fly_state -let on_the_fly_cut_init = - S.PH.B.PB.CI.Po.init_cut -let on_the_fly_cut_step = - S.PH.B.PB.CI.Po.cut_step + +let on_the_fly_cut_init = S.PH.B.PB.CI.Po.init_cut +let on_the_fly_cut_step = S.PH.B.PB.CI.Po.cut_step + let on_the_fly_cut_finalize cut_state = fst (S.PH.B.PB.CI.Po.finalize_cut cut_state) let cut_rev_trace rev_trace = - on_the_fly_cut_finalize - (List.fold_left on_the_fly_cut_step on_the_fly_cut_init rev_trace) - + on_the_fly_cut_finalize + (List.fold_left on_the_fly_cut_step on_the_fly_cut_init rev_trace) let remove_obs_before _parameter _handler log_info error last_eid trace = - error,log_info, - ( + ( error, + log_info, let rec aux l score output = match l with - [] -> List.rev output,score - | t::q -> - if - Trace.step_is_obs t - then - match Trace.simulation_info_of_step t - with None -> aux q score (t::output) - | Some x -> - if Trace.Simulation_info.story_id x >= last_eid - then - List.rev (List.fold_left - (fun list a -> a::list) output l), - score - else - aux q (succ score) output - else aux q score (t::output) + | [] -> List.rev output, score + | t :: q -> + if Trace.step_is_obs t then ( + match Trace.simulation_info_of_step t with + | None -> aux q score (t :: output) + | Some x -> + if Trace.Simulation_info.story_id x >= last_eid then + ( List.rev (List.fold_left (fun list a -> a :: list) output l), + score ) + else + aux q (succ score) output + ) else + aux q score (t :: output) in - aux trace 0 []) + aux trace 0 [] ) let remove_obs_before parameter handler log_info error last_info trace = lift_to_care_about_ambiguities (transform_trace_gen - (fun parameter handler log_info error -> remove_obs_before parameter handler log_info error last_info) + (fun parameter handler log_info error -> + remove_obs_before parameter handler log_info error last_info) (Some "\t- Removing already visited observable hits") "Trace after having removed seen observable hits\n" StoryProfiling.Partial_order_reduction) - Do_not_care - Neutral - parameter handler log_info error trace - -let remove_obs_before - parameter - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) handler log_info error last_info trace = - match last_info - with - | None -> error,log_info,trace + Do_not_care Neutral parameter handler log_info error trace + +let remove_obs_before parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler log_info + error last_info trace = + match last_info with + | None -> error, log_info, trace | Some l -> let last = List.fold_left (fun result x -> - let last_eid = Trace.Simulation_info.story_id x in - max result last_eid) + let last_eid = Trace.Simulation_info.story_id x in + max result last_eid) 0 l in remove_obs_before parameter handler log_info error last trace @@ -368,723 +357,731 @@ let fill_siphon = lift_to_care_about_ambiguities (transform_trace_gen (monadic_lift S.PH.B.PB.CI.Po.K.fill_siphon) - (Some "\t- detecting siphons") - "Trace after having detected siphons:\n" + (Some "\t- detecting siphons") "Trace after having detected siphons:\n" StoryProfiling.Siphon_detection) - Require_the_abscence_of_ambiguity - May_add_ambiguities + Require_the_abscence_of_ambiguity May_add_ambiguities -let (remove_events_after_last_obs: (trace,trace) unary) = +let (remove_events_after_last_obs : (trace, trace) unary) = lift_to_care_about_ambiguities (transform_trace_gen - (monadic_lift ((List_util.remove_suffix_after_last_occurrence Trace.step_is_obs))) + (monadic_lift + (List_util.remove_suffix_after_last_occurrence Trace.step_is_obs)) (Some "\t- removing events occurring after the last observable") "Trace after having removed the events after the last observable" - StoryProfiling.Remove_events_after_last_observable - ) - Do_not_care - Neutral + StoryProfiling.Remove_events_after_last_observable) + Do_not_care Neutral let remove_pseudo_inverse_events = lift_to_care_about_ambiguities - (transform_trace_gen - S.PH.B.PB.CI.cut + (transform_trace_gen S.PH.B.PB.CI.cut (Some "\t- detecting pseudo inverse events") "Trace after having removed pseudo inverse events:\n" StoryProfiling.Pseudo_inverse_deletion) - Do_not_care - Neutral + Do_not_care Neutral type cflow_grid = Causal.grid type enriched_cflow_grid = Causal.enriched_grid -type musical_grid = S.PH.B.blackboard -type story_table = - { - story_counter:int; - story_list: D.table ; - } +type musical_grid = S.PH.B.blackboard +type story_table = { story_counter: int; story_list: D.table } let count_stories story_table = D.count_stories story_table.story_list -type observable_hit = - { - list_of_actions: S.PH.update_order list ; - list_of_events: step_id list ; - runtime_info: unit Trace.Simulation_info.t option} +type observable_hit = { + list_of_actions: S.PH.update_order list; + list_of_events: step_id list; + runtime_info: unit Trace.Simulation_info.t option; +} let get_event_list_from_observable_hit a = a.list_of_events let get_runtime_info_from_observable_hit a = a.runtime_info let _get_list_order a = a.list_of_actions - let error_init = Exception.empty_error_handler -let extract_observable_hits_from_musical_notation a - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) - b profiling_info c d = - let error,profiling_info,l = S.PH.forced_events a b profiling_info c d in - error, - profiling_info, - List.rev_map - (fun (a,b,c) -> - { - list_of_actions = a; - list_of_events = b ; - runtime_info = c - }) - (List.rev l) - -let extract_observable_hit_from_musical_notation - a - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) - b profiling_info c string d = - let error,profiling_info,l = S.PH.forced_events a b profiling_info c d in +let extract_observable_hits_from_musical_notation a ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ b profiling_info + c d = + let error, profiling_info, l = S.PH.forced_events a b profiling_info c d in + ( error, + profiling_info, + List.rev_map + (fun (a, b, c) -> + { list_of_actions = a; list_of_events = b; runtime_info = c }) + (List.rev l) ) + +let extract_observable_hit_from_musical_notation a ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ b profiling_info + c string d = + let error, profiling_info, l = S.PH.forced_events a b profiling_info c d in match l with - | [a,b,c] -> - error,profiling_info, - { - list_of_actions = a; - list_of_events = b; - runtime_info = c} - | [] -> failwith (string^" no story") - | _::_ -> failwith (string^" several stories") + | [ (a, b, c) ] -> + ( error, + profiling_info, + { list_of_actions = a; list_of_events = b; runtime_info = c } ) + | [] -> failwith (string ^ " no story") + | _ :: _ -> failwith (string ^ " several stories") let translate p h profiling_info e b list = - let error,profiling_info,(list,_) = S.translate p h profiling_info e b list in - error,profiling_info,trace_of_pretrace list - -let causal_prefix_of_an_observable_hit - parameter - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) - handler profiling_info error string blackboard (enriched_grid:enriched_cflow_grid) observable_id = + let error, profiling_info, (list, _) = + S.translate p h profiling_info e b list + in + error, profiling_info, trace_of_pretrace list + +let causal_prefix_of_an_observable_hit parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler + profiling_info error string blackboard (enriched_grid : enriched_cflow_grid) + observable_id = let eid = - match - get_event_list_from_observable_hit observable_id - with - | [a] -> a - | [] -> failwith ("no observable in that story"^string) - | _ -> failwith ("several observables in that story"^string) + match get_event_list_from_observable_hit observable_id with + | [ a ] -> a + | [] -> failwith ("no observable in that story" ^ string) + | _ -> failwith ("several observables in that story" ^ string) in let event_id_list = Graph_closure.get_list_in_increasing_order_with_last_event (S.PH.B.PB.int_of_step_id (S.PH.B.PB.inc_step_id eid)) enriched_grid.Causal.prec_star in - let error,profiling_info,output = + let error, profiling_info, output = translate parameter handler profiling_info error blackboard - (List.rev_map S.PH.B.PB.step_id_of_int (List.rev event_id_list)) in - error,profiling_info,output - - + (List.rev_map S.PH.B.PB.step_id_of_int (List.rev event_id_list)) + in + error, profiling_info, output -let export_musical_grid_to_xls - a - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) - b (p:StoryProfiling.StoryStats.log_info) c d e f g - = +let export_musical_grid_to_xls a ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ b + (p : StoryProfiling.StoryStats.log_info) c d e f g = S.PH.B.export_blackboard_to_xls a b p c d e f g -let print_musical_grid - a - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) - b p c d - = +let print_musical_grid a ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ b p c d = S.PH.B.print_blackboard a b p c d +let create_story_table parameters ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler + profiling_info error = + let error, profiling_info, init = + D.init_table parameters handler profiling_info error + in + error, profiling_info, { story_counter = 1; story_list = init } -let create_story_table - parameters - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) - handler profiling_info error = - let error,profiling_info,init = D.init_table parameters handler profiling_info error in - error, - profiling_info, - { - story_counter=1; - story_list= init ; - } - -let _get_trace_of_story (_,_,_,y,_) = trace_of_pretrace y -let _get_info_of_story (_,_,_,_,t) = t - +let _get_trace_of_story (_, _, _, y, _) = trace_of_pretrace y +let _get_info_of_story (_, _, _, _, t) = t let tick_opt parameter bar = - match - bar - with + match bar with | None -> bar - | Some (logger,bar) -> - Some (logger, - Tick_stories.tick_stories - logger Configuration.empty - (S.PH.B.PB.CI.Po.K.H.save_progress_bar parameter) bar) + | Some (logger, bar) -> + Some + ( logger, + Tick_stories.tick_stories logger Configuration.empty + (S.PH.B.PB.CI.Po.K.H.save_progress_bar parameter) + bar ) let close_progress_bar_opt logger = Loggers.print_newline logger let print_fails logger s n = - match - n - with + match n with | 0 -> () | 1 -> Loggers.fprintf logger "@.\t 1 %s has failed@." s | _ -> Loggers.fprintf logger "@.\t %i %ss have failed@." n s let inc_fails a a' b = - if a==a' - then succ b - else b + if a == a' then + succ b + else + b -let fold_story_table_gen logger parameter ?(shall_we_compute=we_shall) ?(shall_we_compute_profiling_information=we_shall) (handler:kappa_handler) (profiling_info:profiling_info) error s - (f:((trace, trace_runtime_info list, 'a, 'a) ternary)) l a = +let fold_story_table_gen logger parameter ?(shall_we_compute = we_shall) + ?(shall_we_compute_profiling_information = we_shall) + (handler : kappa_handler) (profiling_info : profiling_info) error s + (f : (trace, trace_runtime_info list, 'a, 'a) ternary) l a = let n_stories_input = count_stories l in let progress_bar = Some - (logger,Tick_stories.tick_stories logger Configuration.empty - (S.PH.B.PB.CI.Po.K.H.save_progress_bar parameter) (false,0,0,n_stories_input)) + ( logger, + Tick_stories.tick_stories logger Configuration.empty + (S.PH.B.PB.CI.Po.K.H.save_progress_bar parameter) + (false, 0, 0, n_stories_input) ) in - let g parameter handler profiling_info error story info (k,progress_bar,a,n_fails) = + let g parameter handler profiling_info error story info + (k, progress_bar, a, n_fails) = let event = StoryProfiling.Story k in - let error, profiling_info = P.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error event None profiling_info in - let error,profiling_info,a' = f parameter ~shall_we_compute:shall_we_compute ~shall_we_compute_profiling_information:shall_we_compute_profiling_information handler profiling_info error (trace_of_pretrace_with_ambiguity false story) info a in + let error, profiling_info = + P.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event None profiling_info + in + let error, profiling_info, a' = + f parameter ~shall_we_compute ~shall_we_compute_profiling_information + handler profiling_info error + (trace_of_pretrace_with_ambiguity false story) + info a + in let progress_bar = tick_opt parameter progress_bar in let n_fails = inc_fails a a' n_fails in - let error,profiling_info = P.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error event None profiling_info in - error,profiling_info,(succ k,progress_bar,a',n_fails) + let error, profiling_info = + P.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event None profiling_info + in + error, profiling_info, (succ k, progress_bar, a', n_fails) + in + let error, profiling_info, (_, _, a, n_fails) = + D.fold_table parameter handler profiling_info error g l.story_list + (1, progress_bar, a, 0) in - let error,profiling_info,(_,_,a,n_fails) = D.fold_table parameter handler profiling_info error g l.story_list (1,progress_bar,a,0) in let () = close_progress_bar_opt logger in let () = print_fails parameter.S.PH.B.PB.CI.Po.K.H.logger_err s n_fails in - error,(profiling_info:profiling_info),a - -let fold_story_table_with_progress_bar - parameter - ?shall_we_compute ?shall_we_compute_profiling_information - ?print_if_zero:_ - handler profiling_info error s - f l a = + error, (profiling_info : profiling_info), a + +let fold_story_table_with_progress_bar parameter ?shall_we_compute + ?shall_we_compute_profiling_information ?print_if_zero:_ handler + profiling_info error s f l a = fold_story_table_gen (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - parameter - ?shall_we_compute - ?shall_we_compute_profiling_information - handler profiling_info error s f l a - -let fold_story_table_without_progress_bar - parameter - ?shall_we_compute ?shall_we_compute_profiling_information - ?print_if_zero:_ - handler profiling_info error s f l a = - fold_story_table_gen - Loggers.dummy_txt_logger - parameter - ?shall_we_compute - ?shall_we_compute_profiling_information - handler profiling_info error s f l a + parameter ?shall_we_compute ?shall_we_compute_profiling_information handler + profiling_info error s f l a +let fold_story_table_without_progress_bar parameter ?shall_we_compute + ?shall_we_compute_profiling_information ?print_if_zero:_ handler + profiling_info error s f l a = + fold_story_table_gen Loggers.dummy_txt_logger parameter ?shall_we_compute + ?shall_we_compute_profiling_information handler profiling_info error s f l a let get_counter story_list = story_list.story_counter let get_stories story_list = story_list.story_list -let _inc_counter story_list = { story_list with story_counter = succ story_list.story_counter } + +let _inc_counter story_list = + { story_list with story_counter = succ story_list.story_counter } let build_grid parameter handler computation_info error trace bool = - let error,computation_info = StoryProfiling.StoryStats.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Build_grid None computation_info in + let error, computation_info = + StoryProfiling.StoryStats.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Build_grid None computation_info + in let grid = S.PH.B.PB.CI.Po.K.build_grid trace bool handler in - let error,computation_info = StoryProfiling.StoryStats.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Build_grid None computation_info in - error,computation_info,grid + let error, computation_info = + StoryProfiling.StoryStats.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Build_grid None computation_info + in + error, computation_info, grid -let store_trace - (parameter:parameter) - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler computation_info error trace obs_info story_table = - let error,computation_info = StoryProfiling.StoryStats.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Store_trace None computation_info in +let store_trace (parameter : parameter) ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler + computation_info error trace obs_info story_table = + let error, computation_info = + StoryProfiling.StoryStats.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Store_trace None computation_info + in let pretrace = get_pretrace_of_trace trace in let trace2 = get_compressed_trace trace in let bool = not (is_compressed_trace trace) in - let error,computation_info,grid = build_grid parameter handler computation_info error trace2 bool in - let computation_info = P.set_grid_generation computation_info in + let error, computation_info, grid = + build_grid parameter handler computation_info error trace2 bool + in + let computation_info = P.set_grid_generation computation_info in let story_info = List.rev_map (Trace.Simulation_info.update_profiling_info (P.copy computation_info)) (List.rev obs_info) in - let error,computation_info,story_list = D.add_story parameter handler computation_info error grid pretrace story_info story_table.story_list in + let error, computation_info, story_list = + D.add_story parameter handler computation_info error grid pretrace + story_info story_table.story_list + in let story_table = - { - story_list = story_list ; - story_counter = story_table.story_counter +1 - } + { story_list; story_counter = story_table.story_counter + 1 } + in + let error, computation_info = + StoryProfiling.StoryStats.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error StoryProfiling.Store_trace None computation_info in - let error,computation_info = StoryProfiling.StoryStats.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error StoryProfiling.Store_trace None computation_info in - error,computation_info,story_table + error, computation_info, story_table -let flatten_story_table - parameter - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error story_table = - let error,log_info,list = D.hash_list parameter handler log_info error story_table.story_list in - error, - log_info, - {story_table - with - story_list = list} - -let compress - ?heuristic parameter - ?shall_we_compute:_ - ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error trace = - match - parameter.S.PH.B.PB.CI.Po.K.H.current_compression_mode - with - | None -> error,log_info,[trace] +let flatten_story_table parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler log_info + error story_table = + let error, log_info, list = + D.hash_list parameter handler log_info error story_table.story_list + in + error, log_info, { story_table with story_list = list } + +let compress ?heuristic parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler log_info + error trace = + match parameter.S.PH.B.PB.CI.Po.K.H.current_compression_mode with + | None -> error, log_info, [ trace ] | Some Story_json.Causal -> let () = - if S.PH.B.PB.CI.Po.K.H.is_server_mode parameter && - S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter - then - S.PH.B.PB.CI.Po.K.H.push_json - parameter - (Story_json.Phase (Story_json.Inprogress, "Start one causal compression")) + if + S.PH.B.PB.CI.Po.K.H.is_server_mode parameter + && S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter + then + S.PH.B.PB.CI.Po.K.H.push_json parameter + (Story_json.Phase + (Story_json.Inprogress, "Start one causal compression")) in - let error,log_info,trace = cut parameter ~shall_we_compute:we_shall handler log_info error trace - in error,log_info,[trace] + let error, log_info, trace = + cut parameter ~shall_we_compute:we_shall handler log_info error trace + in + error, log_info, [ trace ] | Some (Story_json.Weak | Story_json.Strong) -> - let event,s = match parameter.S.PH.B.PB.CI.Po.K.H.current_compression_mode - with Some Story_json.Weak -> - StoryProfiling.Weak_compression,"Start one weak compression" - | _ -> StoryProfiling.Strong_compression,"Start one strong compression" + let event, s = + match parameter.S.PH.B.PB.CI.Po.K.H.current_compression_mode with + | Some Story_json.Weak -> + StoryProfiling.Weak_compression, "Start one weak compression" + | _ -> StoryProfiling.Strong_compression, "Start one strong compression" in let () = - if S.PH.B.PB.CI.Po.K.H.is_server_mode parameter && - S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter + if + S.PH.B.PB.CI.Po.K.H.is_server_mode parameter + && S.PH.B.PB.CI.Po.K.H.is_server_channel_on parameter then - S.PH.B.PB.CI.Po.K.H.push_json - parameter (Story_json.Phase (Story_json.Inprogress, s)) in - let error, log_info = P.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error event (Some (fun () -> size_of_pretrace trace)) log_info in + S.PH.B.PB.CI.Po.K.H.push_json parameter + (Story_json.Phase (Story_json.Inprogress, s)) + in + let error, log_info = + P.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event + (Some (fun () -> size_of_pretrace trace)) + log_info + in let event_list = get_pretrace_of_trace trace in - let error,log_info,blackboard = S.PH.B.import ?heuristic parameter handler log_info error event_list in - let error,log_info,list = S.PH.forced_events parameter handler log_info error blackboard in + let error, log_info, blackboard = + S.PH.B.import ?heuristic parameter handler log_info error event_list + in + let error, log_info, list = + S.PH.forced_events parameter handler log_info error blackboard + in let list_order = - match list - with - | (list_order,_,_)::_ -> list_order + match list with + | (list_order, _, _) :: _ -> list_order | _ -> [] in - let error,log_info,(blackboard,output,list) = + let error, log_info, (blackboard, output, list) = S.compress parameter handler log_info error blackboard list_order in let list = List.rev_map (fun pretrace -> - let event_list = S.translate_result pretrace in - let event_list = S.PH.B.PB.CI.Po.K.clean_events event_list in - (build_compressed_trace event_list pretrace)) + let event_list = S.translate_result pretrace in + let event_list = S.PH.B.PB.CI.Po.K.clean_events event_list in + build_compressed_trace event_list pretrace) list in let log_info = P.set_story_research_time log_info in - let error,log_info = P.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error event (Some (fun () -> size_of_pretrace trace)) log_info in - let error,() = - if S.PH.B.is_failed output - then + let error, log_info = + P.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event + (Some (fun () -> size_of_pretrace trace)) + log_info + in + let error, () = + if S.PH.B.is_failed output then Exception.warn (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error - __POS__ - ~message:"One compression has failed" - Exit - () + error __POS__ ~message:"One compression has failed" Exit () else error, () in let error = - if debug_mode - then + if debug_mode then ( let () = - Loggers.fprintf - parameter.S.PH.B.PB.CI.Po.K.H.logger_err - "\t\t * result" in + Loggers.fprintf parameter.S.PH.B.PB.CI.Po.K.H.logger_err + "\t\t * result" + in let error = - if S.PH.B.is_failed output - then - let error, _log_info, () = - S.PH.B.export_blackboard_to_xls - parameter handler log_info error "FAIL" 0 0 blackboard - in - let () = - Loggers.fprintf - parameter.S.PH.B.PB.CI.Po.K.H.logger_err - "Fail_to_compress" - in - error - else - let () = - Loggers.fprintf - parameter.S.PH.B.PB.CI.Po.K.H.logger_err - "Succeed_to_compress" - in - error + if S.PH.B.is_failed output then ( + let error, _log_info, () = + S.PH.B.export_blackboard_to_xls parameter handler log_info error + "FAIL" 0 0 blackboard + in + let () = + Loggers.fprintf parameter.S.PH.B.PB.CI.Po.K.H.logger_err + "Fail_to_compress" + in + error + ) else ( + let () = + Loggers.fprintf parameter.S.PH.B.PB.CI.Po.K.H.logger_err + "Succeed_to_compress" + in + error + ) in error - else + ) else error in - error,log_info,list + error, log_info, list -let strongly_compress ?heuristic parameter = compress ?heuristic (S.PH.B.PB.CI.Po.K.H.set_compression_strong parameter) -let weakly_compress ?heuristic parameter = compress ?heuristic (S.PH.B.PB.CI.Po.K.H.set_compression_weak parameter) +let strongly_compress ?heuristic parameter = + compress ?heuristic (S.PH.B.PB.CI.Po.K.H.set_compression_strong parameter) + +let weakly_compress ?heuristic parameter = + compress ?heuristic (S.PH.B.PB.CI.Po.K.H.set_compression_weak parameter) let convert_trace_into_grid trace handler = let event_list = get_compressed_trace trace in - S.PH.B.PB.CI.Po.K.build_grid event_list (not (is_compressed_trace trace)) handler - -let convert_trace_into_musical_notation - parameters - ?shall_we_compute:_ - ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - kappa_handler profiling_info error trace = - S.PH.B.import parameters kappa_handler profiling_info error (get_pretrace_of_trace trace) - -let enrich_grid_with_transitive_closure - config logger - ?shall_we_compute:_ - ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error grid = - let error,log_info,output = Causal.enrich_grid (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters logger) handler log_info error config grid in - error,log_info,output - -let enrich_grid_with_transitive_past_of_observables_with_a_progress_bar = enrich_grid_with_transitive_closure Graph_closure.config_big_graph_with_progress_bar -let enrich_grid_with_transitive_past_of_observables_without_a_progress_bar = enrich_grid_with_transitive_closure Graph_closure.config_big_graph_without_progress_bar -let _enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar = enrich_grid_with_transitive_closure Graph_closure.config_big_graph_without_progress_bar -let enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar = enrich_grid_with_transitive_closure Graph_closure.config_small_graph - -let sort_story_list = D.sort_list -let export_story_table - parameter - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error x = - let a,log_info,b = sort_story_list parameter handler log_info error (get_stories x) in - a,log_info,b + S.PH.B.PB.CI.Po.K.build_grid event_list + (not (is_compressed_trace trace)) + handler + +let convert_trace_into_musical_notation parameters ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ kappa_handler + profiling_info error trace = + S.PH.B.import parameters kappa_handler profiling_info error + (get_pretrace_of_trace trace) + +let enrich_grid_with_transitive_closure config logger ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler log_info + error grid = + let error, log_info, output = + Causal.enrich_grid + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters logger) + handler log_info error config grid + in + error, log_info, output + +let enrich_grid_with_transitive_past_of_observables_with_a_progress_bar = + enrich_grid_with_transitive_closure + Graph_closure.config_big_graph_with_progress_bar + +let enrich_grid_with_transitive_past_of_observables_without_a_progress_bar = + enrich_grid_with_transitive_closure + Graph_closure.config_big_graph_without_progress_bar + +let _enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar = + enrich_grid_with_transitive_closure + Graph_closure.config_big_graph_without_progress_bar + +let enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar = + enrich_grid_with_transitive_closure Graph_closure.config_small_graph + +let sort_story_list = D.sort_list + +let export_story_table parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler log_info + error x = + let a, log_info, b = + sort_story_list parameter handler log_info error (get_stories x) + in + a, log_info, b + let has_obs x = List.exists Trace.step_is_obs (get_pretrace_of_trace x) -let fold_left_with_progress_bar ?(event=StoryProfiling.Dummy) - parameter ?(shall_we_compute=we_shall) ?(shall_we_compute_profiling_information=we_shall) - ?(print_if_zero=we_shall) - handler profiling_information error (f:('a,'b,'a) binary) a list = - let n = List.length list in - let string,(error,profiling_information) = - if StoryProfiling.StoryStats.is_dummy event - then "",(error,profiling_information) - else StoryProfiling.string_of_step_kind event, - StoryProfiling.StoryStats.add_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error event (Some (fun _ -> List.length list)) profiling_information - in - let progress_bar = - Tick_stories.tick_stories - (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - Configuration.empty - (Remanent_parameters.save_progress_bar - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - (false,0,0,n) - in - let error,profiling_information,_,_,a,n_fail = - let rec aux list (error,profiling_information,bar,k,a,n_fail) = - let event = StoryProfiling.Story k in - match - list - with - | [] -> error,profiling_information,bar,k,a,n_fail - | x::tail -> - let error, profiling_information = P.add_event - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error event - None profiling_information - in - let output_opt = - try - let error,profiling_information,a' = - f - parameter - ~shall_we_compute - ~shall_we_compute_profiling_information - ~print_if_zero - handler - profiling_information - error - a x - in - let bar = - Tick_stories.tick_stories - (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - Configuration.empty - (Remanent_parameters.save_progress_bar - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - bar - in - let n_fail = inc_fails a a' n_fail in - let error,profiling_information = - P.close_event - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error event None profiling_information - in - Some (error,profiling_information,bar,k+1,a',n_fail) - with Sys.Break -> None - in - match output_opt - with - | None -> - let error,profiling_information = - P.close_event - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - error event None profiling_information - in - (error,profiling_information,bar,k+1,a,n_fail) - | Some remanent -> - aux tail remanent +let fold_left_with_progress_bar ?(event = StoryProfiling.Dummy) parameter + ?(shall_we_compute = we_shall) + ?(shall_we_compute_profiling_information = we_shall) + ?(print_if_zero = we_shall) handler profiling_information error + (f : ('a, 'b, 'a) binary) a list = + let n = List.length list in + let string, (error, profiling_information) = + if StoryProfiling.StoryStats.is_dummy event then + "", (error, profiling_information) + else + ( StoryProfiling.string_of_step_kind event, + StoryProfiling.StoryStats.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event + (Some (fun _ -> List.length list)) + profiling_information ) + in + let progress_bar = + Tick_stories.tick_stories + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + Configuration.empty + (Remanent_parameters.save_progress_bar + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) + (false, 0, 0, n) + in + let error, profiling_information, _, _, a, n_fail = + let rec aux list (error, profiling_information, bar, k, a, n_fail) = + let event = StoryProfiling.Story k in + match list with + | [] -> error, profiling_information, bar, k, a, n_fail + | x :: tail -> + let error, profiling_information = + P.add_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event None profiling_information + in + let output_opt = + try + let error, profiling_information, a' = + f parameter ~shall_we_compute + ~shall_we_compute_profiling_information ~print_if_zero handler + profiling_information error a x + in + let bar = + Tick_stories.tick_stories + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + Configuration.empty + (Remanent_parameters.save_progress_bar + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) + bar + in + let n_fail = inc_fails a a' n_fail in + let error, profiling_information = + P.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event None profiling_information + in + Some (error, profiling_information, bar, k + 1, a', n_fail) + with Sys.Break -> None + in + (match output_opt with + | None -> + let error, profiling_information = + P.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event None profiling_information + in + error, profiling_information, bar, k + 1, a, n_fail + | Some remanent -> aux tail remanent) in - aux list (error,profiling_information,progress_bar,1,a,0) + aux list (error, profiling_information, progress_bar, 1, a, 0) in let () = close_progress_bar_opt (S.PH.B.PB.CI.Po.K.H.get_logger parameter) in - let error,profiling_information = - if StoryProfiling.StoryStats.is_dummy event - then error,profiling_information - else StoryProfiling.StoryStats.close_event (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) error event None profiling_information + let error, profiling_information = + if StoryProfiling.StoryStats.is_dummy event then + error, profiling_information + else + StoryProfiling.StoryStats.close_event + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) + error event None profiling_information in let () = print_fails parameter.S.PH.B.PB.CI.Po.K.H.logger_err string n_fail in - error,profiling_information,a + error, profiling_information, a -let _fold_over_the_causal_past_of_observables_through_a_grid_with_a_progress_bar parameter handler log_info error f t a = +let _fold_over_the_causal_past_of_observables_through_a_grid_with_a_progress_bar + parameter handler log_info error f t a = let grid = convert_trace_into_grid t handler in - Causal.fold_over_causal_past_of_obs - parameter - handler - log_info - error - Graph_closure.config_big_graph_with_progress_bar - grid - f (error,log_info,a) + Causal.fold_over_causal_past_of_obs parameter handler log_info error + Graph_closure.config_big_graph_with_progress_bar grid f (error, log_info, a) - -let fold_over_the_causal_past_of_observables_with_a_progress_bar - parameter +let fold_over_the_causal_past_of_observables_with_a_progress_bar parameter ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error log_step debug_mode counter f t a = + ?print_if_zero:_ handler log_info error log_step debug_mode counter f t a = let () = - if log_step parameter - then + if log_step parameter then Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameter) "%s\t- blackboard generation @." + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "%s\t- blackboard generation @." (Remanent_parameters.get_prefix (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) in - let error,log_info,blackboard = convert_trace_into_musical_notation parameter handler log_info error t in - let error,log_info,list = extract_observable_hits_from_musical_notation parameter handler log_info error blackboard in + let error, log_info, blackboard = + convert_trace_into_musical_notation parameter handler log_info error t + in + let error, log_info, list = + extract_observable_hits_from_musical_notation parameter handler log_info + error blackboard + in let n_stories = List.length list in let () = - if log_step parameter - then - Loggers.fprintf (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + if log_step parameter then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) "%s\t- computing causal past of each observed events (%i)@." (Remanent_parameters.get_prefix (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - n_stories - in - (* generation of uncompressed stories *) - let () = - if debug_mode parameter - then - Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "%s\t\t* causal compression " - (Remanent_parameters.get_prefix - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - in - let log_info = P.set_start_compression log_info in - let grid = convert_trace_into_grid t handler in - let output = + n_stories + in + (* generation of uncompressed stories *) + let () = + if debug_mode parameter then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "%s\t\t* causal compression " + (Remanent_parameters.get_prefix + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) + in + let log_info = P.set_start_compression log_info in + let grid = convert_trace_into_grid t handler in + let output = Causal.fold_over_causal_past_of_obs (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter) - handler - log_info - error - Graph_closure.config_big_graph_with_progress_bar + handler log_info error Graph_closure.config_big_graph_with_progress_bar grid - (fun parameter' handler log_info error observable_hit causal_past (counter,list,a) -> - match list with - | [] -> error,log_info,Stop.success (counter,list,a) - | head::tail -> - let error,log_info = StoryProfiling.StoryStats.add_event parameter' error (StoryProfiling.Story counter) None log_info in - let observable_id = head in - let log_info = P.reset_log log_info in - let () = - if - debug_mode parameter - then - Loggers.fprintf - (S.PH.B.PB.CI.Po.K.H.get_logger parameter) - "%s\t\t* causal compression " - (Remanent_parameters.get_prefix - (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) - in - (* we translate the list of event ids into a trace thanks to the blackboad *) - let error,log_info,trace = - translate - parameter handler log_info error blackboard - (List.rev_map S.PH.B.PB.step_id_of_int - (observable_hit::causal_past)) - in - (* we collect run time info about the observable *) - let info = - match get_runtime_info_from_observable_hit observable_id - with - | None -> [] - | Some info -> - let info = - {info with Trace.Simulation_info.story_id = counter} in - let info = - Trace.Simulation_info.update_profiling_info log_info info - in - [info] - in - let error,log_info,a = (f:('a,'b,'c,'d) ternary) parameter handler log_info error trace info a in - let error,log_info = StoryProfiling.StoryStats.close_event parameter' error (StoryProfiling.Story counter) None log_info in - error,log_info,Stop.success_or_stop - (fun a -> Stop.success (counter+1,tail,a)) - (fun b -> Stop.stop (b,counter)) - a) - (counter,List.rev list,a) + (fun parameter' handler log_info error observable_hit causal_past + (counter, list, a) -> + match list with + | [] -> error, log_info, Stop.success (counter, list, a) + | head :: tail -> + let error, log_info = + StoryProfiling.StoryStats.add_event parameter' error + (StoryProfiling.Story counter) None log_info + in + let observable_id = head in + let log_info = P.reset_log log_info in + let () = + if debug_mode parameter then + Loggers.fprintf + (S.PH.B.PB.CI.Po.K.H.get_logger parameter) + "%s\t\t* causal compression " + (Remanent_parameters.get_prefix + (S.PH.B.PB.CI.Po.K.H.get_kasa_parameters parameter)) + in + (* we translate the list of event ids into a trace thanks to the blackboad *) + let error, log_info, trace = + translate parameter handler log_info error blackboard + (List.rev_map S.PH.B.PB.step_id_of_int + (observable_hit :: causal_past)) + in + (* we collect run time info about the observable *) + let info = + match get_runtime_info_from_observable_hit observable_id with + | None -> [] + | Some info -> + let info = + { info with Trace.Simulation_info.story_id = counter } + in + let info = + Trace.Simulation_info.update_profiling_info log_info info + in + [ info ] + in + let error, log_info, a = + (f : ('a, 'b, 'c, 'd) ternary) + parameter handler log_info error trace info a + in + let error, log_info = + StoryProfiling.StoryStats.close_event parameter' error + (StoryProfiling.Story counter) None log_info + in + ( error, + log_info, + Stop.success_or_stop + (fun a -> Stop.success (counter + 1, tail, a)) + (fun b -> Stop.stop (b, counter)) + a )) + (counter, List.rev list, a) in Stop.success_or_stop - (fun (error,log_info,(_,_,a)) -> error,log_info,Stop.success a) - (fun (error,log_info,(a,counter)) -> error,log_info,Stop.stop (a,counter)) + (fun (error, log_info, (_, _, a)) -> error, log_info, Stop.success a) + (fun (error, log_info, (a, counter)) -> + error, log_info, Stop.stop (a, counter)) output let copy_log_info = P.copy type canonical_form = Dag.canonical_form + let compare_canonical_form = Dag.compare_canonic -let compute_canonical_form - parameter - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error trace = + +let compute_canonical_form parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler log_info + error trace = let grid = convert_trace_into_grid trace handler in - let error, log_info, graph = Dag.graph_of_grid parameter handler log_info error grid in - let error, log_info, canonic = Dag.canonicalize parameter handler log_info error graph in - (error:error_log),(log_info:profiling_info),(canonic:canonical_form) + let error, log_info, graph = + Dag.graph_of_grid parameter handler log_info error grid + in + let error, log_info, canonic = + Dag.canonicalize parameter handler log_info error graph + in + (error : error_log), (log_info : profiling_info), (canonic : canonical_form) -module Event = - (struct - type event = step - type eid = int - type 'a t = 'a array +module Event : Black_list.Event with type event = step = struct + type event = step + type eid = int + type 'a t = 'a array - let key_of_event event = - if - (Trace.step_is_rule event || Trace.step_is_pert event) - && not (Trace.has_creation_of_step event) - then - get_id_of_event event - else - None + let key_of_event event = + if + (Trace.step_is_rule event || Trace.step_is_pert event) + && not (Trace.has_creation_of_step event) + then + get_id_of_event event + else + None + + let init eid default = Array.make eid default + + let set t eid value = + let () = Array.set t eid value in + t - let init eid default = Array.make eid default - let set t eid value = - let () = Array.set t eid value in - t + let get t eid = Array.get t eid +end - let get t eid = Array.get t eid - end: Black_list.Event with type event = step) +module BlackList : Black_list.Blacklist with type Event.event = step = +Black_list.Make ((Event : Black_list.Event with type event = step)) -module BlackList = - (Black_list.Make((Event: Black_list.Event with type event = step)): Black_list.Blacklist with type Event.event = step) type black_list = BlackList.t let create_black_list n = BlackList.init n -let black_list - _parameter - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - _handler log_info error trace blacklist = +let black_list _parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ _handler log_info + error trace blacklist = let blacklist = List.fold_left - (fun blacklist (event,_) -> - BlackList.black_list event blacklist) + (fun blacklist (event, _) -> BlackList.black_list event blacklist) blacklist (get_compressed_trace trace) in error, log_info, blacklist let remove_blacklisted_event _handler log_info error blacklist trace = - let list,int = + let list, int = List.fold_left - (fun (trace,int) event -> - if BlackList.is_black_listed event blacklist - then (trace,succ int) - else (event::trace,int)) - ([],0) - trace + (fun (trace, int) event -> + if BlackList.is_black_listed event blacklist then + trace, succ int + else + event :: trace, int) + ([], 0) trace in - error, log_info, ((List.rev list), int) + error, log_info, (List.rev list, int) -let remove_blacklisted_event - parameter - ?shall_we_compute:_ ?shall_we_compute_profiling_information:_ - ?print_if_zero:_ - handler log_info error blacklist trace = +let remove_blacklisted_event parameter ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler log_info + error blacklist trace = lift_to_care_about_ambiguities (transform_trace_gen - (fun _parameter handler log_info error -> remove_blacklisted_event handler log_info error blacklist) - None - "" - StoryProfiling.Removing_blacklisted_events) - Do_not_care - Neutral - parameter handler log_info error trace + (fun _parameter handler log_info error -> + remove_blacklisted_event handler log_info error blacklist) + None "" StoryProfiling.Removing_blacklisted_events) + Do_not_care Neutral parameter handler log_info error trace let last_eid_in_pretrace trace = let l = List.rev (get_pretrace_of_trace trace) in let rec aux = function | [] -> 0 - | h::t -> - begin - match - get_id_of_event h - with - | None -> aux t - | Some eid -> eid - end - in aux l + | h :: t -> + (match get_id_of_event h with + | None -> aux t + | Some eid -> eid) + in + aux l let pop_json = S.PH.B.PB.CI.Po.K.H.pop_json + let profiling_state_to_json parameters = `Assoc [ - "profiling information", - Loggers.to_json (S.PH.B.PB.CI.Po.K.H.get_profiling_logger parameters) + ( "profiling information", + Loggers.to_json (S.PH.B.PB.CI.Po.K.H.get_profiling_logger parameters) ); ] let error_list_to_json parameters = `Assoc [ - "errors", - Loggers.to_json (S.PH.B.PB.CI.Po.K.H.get_debugging_channel parameters) + ( "errors", + Loggers.to_json (S.PH.B.PB.CI.Po.K.H.get_debugging_channel parameters) ); ] let computation_steps_to_json parameters = `Assoc [ - "computation steps", - Loggers.to_json (S.PH.B.PB.CI.Po.K.H.get_logger parameters) + ( "computation steps", + Loggers.to_json (S.PH.B.PB.CI.Po.K.H.get_logger parameters) ); ] diff --git a/core/cflow/utilities.mli b/core/cflow/utilities.mli index 541082b765..bacf27b635 100644 --- a/core/cflow/utilities.mli +++ b/core/cflow/utilities.mli @@ -20,225 +20,260 @@ (** High-level elementary primitives to generate stories *) -module S:Generic_branch_and_cut_solver.Solver +module S : Generic_branch_and_cut_solver.Solver + type error_log = Exception.method_handler +val error_init : error_log (** error_init is an empty log of errors *) -val error_init: error_log type parameter = S.PH.B.PB.CI.Po.K.H.parameter type kappa_handler = S.PH.B.PB.CI.Po.K.H.handler type profiling_info = StoryProfiling.StoryStats.log_info -type shall_we = (parameter -> bool) +type shall_we = parameter -> bool (** enriched types for functions: *) type 'a with_handlers = - parameter -> ?shall_we_compute:shall_we -> ?shall_we_compute_profiling_information:shall_we -> - ?print_if_zero:shall_we -> kappa_handler -> profiling_info -> error_log -> 'a -type 'a zeroary = - (error_log * profiling_info * 'a) with_handlers -type ('a,'b) unary = - ('a -> error_log * profiling_info * 'b) with_handlers -type ('a,'b,'c) binary = + parameter -> + ?shall_we_compute:shall_we -> + ?shall_we_compute_profiling_information:shall_we -> + ?print_if_zero:shall_we -> + kappa_handler -> + profiling_info -> + error_log -> + 'a + +type 'a zeroary = (error_log * profiling_info * 'a) with_handlers +type ('a, 'b) unary = ('a -> error_log * profiling_info * 'b) with_handlers + +type ('a, 'b, 'c) binary = ('a -> 'b -> error_log * profiling_info * 'c) with_handlers -type ('a,'b,'c,'d) ternary = - ('a -> 'b -> 'c ->error_log * profiling_info * 'd) with_handlers -type ('a,'b,'c,'d,'e) quaternary = + +type ('a, 'b, 'c, 'd) ternary = + ('a -> 'b -> 'c -> error_log * profiling_info * 'd) with_handlers + +type ('a, 'b, 'c, 'd, 'e) quaternary = ('a -> 'b -> 'c -> 'd -> error_log * profiling_info * 'e) with_handlers -type ('a,'b,'c,'d,'e,'f) quinternary = + +type ('a, 'b, 'c, 'd, 'e, 'f) quinternary = ('a -> 'b -> 'c -> 'd -> 'e -> error_log * profiling_info * 'f) with_handlers -type ('a,'b,'c,'d,'e,'f,'g) sexternary = - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> error_log * profiling_info * 'g) with_handlers -val fold_left_with_progress_bar: ?event:StoryProfiling.step_kind -> (('a,'b,'a) binary,'a,'b list,'a) ternary +type ('a, 'b, 'c, 'd, 'e, 'f, 'g) sexternary = + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> error_log * profiling_info * 'g) + with_handlers + +val fold_left_with_progress_bar : + ?event:StoryProfiling.step_kind -> + (('a, 'b, 'a) binary, 'a, 'b list, 'a) ternary (* Json interactions *) -val pop_json: +val pop_json : parameter -> StoryProfiling.StoryStats.log_info Story_json.message option -val profiling_state_to_json: parameter -> Yojson.Basic.t -val error_list_to_json: parameter -> Yojson.Basic.t -val computation_steps_to_json: parameter -> Yojson.Basic.t + +val profiling_state_to_json : parameter -> Yojson.Basic.t +val error_list_to_json : parameter -> Yojson.Basic.t +val computation_steps_to_json : parameter -> Yojson.Basic.t (* on the fly causal compression *) type on_the_fly_cut_state + val on_the_fly_cut_init : on_the_fly_cut_state + val on_the_fly_cut_step : on_the_fly_cut_state -> Trace.step -> on_the_fly_cut_state + val on_the_fly_cut_finalize : on_the_fly_cut_state -> Trace.step list -val cut_rev_trace: +val cut_rev_trace : Trace.step list (*reverse order*) -> Trace.step list (* correct order *) -(** traces *) type trace +(** traces *) -(** Runtime information about a trace provided by the simulator*) type trace_runtime_info = profiling_info Trace.Simulation_info.t +(** Runtime information about a trace provided by the simulator*) -val size_of_pretrace: trace -> int - -val last_eid_in_pretrace: trace -> int - -val print_trace: parameter -> kappa_handler -> trace -> unit +val size_of_pretrace : trace -> int +val last_eid_in_pretrace : trace -> int +val print_trace : parameter -> kappa_handler -> trace -> unit +val has_obs : trace -> bool (** check wether there is an observable in a trace *) -val has_obs: trace -> bool +val trace_of_pretrace : Trace.t -> trace (** convert a list of refined steps into a trace *) -val trace_of_pretrace: Trace.t -> trace +val get_pretrace_of_trace : trace -> Trace.t (** conversely, convert a trace in a list of refined steps *) -val get_pretrace_of_trace: trace -> Trace.t +val get_simulation_time_of_event : Trace.step -> float option (** get the date of an event in the simulation (only proper events have a time) *) -val get_simulation_time_of_event: Trace.step -> float option +val get_id_of_event : Trace.step -> int option (** get the id of an event in the simulation (only proper events have an id) *) -val get_id_of_event: Trace.step -> int option +val remove_events_after_last_obs : (trace, trace) unary (** remove the events after the last observable *) -val remove_events_after_last_obs: (trace,trace) unary +val split_init : (trace, trace) unary (** split_init split init event agent-wise *) -val split_init: (trace,trace) unary +val fill_siphon : (trace, trace) unary (** fill_siphon adds spurious init event, to break causal dependences; Currently, it inserts an init event when an agent return to its initial state; other heuristics may be considered; The output has to be disanbiguated, otherwise it is useless (compression will remove the ficitious init events) It should work in quasi linear time (I think)*) -val fill_siphon: (trace,trace) unary +val cut : (trace, trace) unary (** cut performs partial order reduction and remove orthogonal events *) -val cut: (trace,trace) unary +val remove_pseudo_inverse_events : (trace, trace) unary (** remove_pseudo_inverse_events removes pseudo inverse events *) -val remove_pseudo_inverse_events: (trace,trace) unary +val remove_obs_before : (trace_runtime_info list option, trace, trace) binary (** remove_obs_before removes the observable_hits before the simulation info prodided as a first argument*) -val remove_obs_before: (trace_runtime_info list option,trace,trace) binary +val make_unambiguous : (trace, trace) unary (** reallocate agent id to avoid conflict (implicitly called by cut and fill_siphon) *) -val make_unambiguous: (trace,trace) unary +val weakly_compress : + ?heuristic:Priority.priorities -> (trace, trace list) unary (** compute the weak compression of a given trace, if parameter.compute_all_stories, then each minimal stories is computed, otherwise, only the first found one is provided; the optional argument heuristic can be used to redefined the heuristic that select which event to try to discard first. *) -val weakly_compress: - ?heuristic:Priority.priorities -> (trace,trace list) unary +val strongly_compress : + ?heuristic:Priority.priorities -> (trace, trace list) unary (** compute the strong compression of a given trace, if parameter.compute_all_stories, then each minimal stories is computed, otherwise, only the first found one is provided; the optional argument heuristic can be used to redefined the heuristic that select which event to try to discard first. *) -val strongly_compress: - ?heuristic:Priority.priorities -> (trace,trace list) unary +val fold_over_the_causal_past_of_observables_with_a_progress_bar : + ( shall_we, + shall_we, + int, + (trace, trace_runtime_info list, 'a, ('a, 'b) Stop.stop) ternary, + trace, + 'a, + ('a, 'b * int) Stop.stop ) + sexternary (** fold over the causal past of each observable in a given trace, the first argument indicates whether we display the current steps on the err output; the second arfument indicated whether the function is launched in debug mode or not *) -val fold_over_the_causal_past_of_observables_with_a_progress_bar: - (shall_we,shall_we,int, - (trace,trace_runtime_info list,'a,('a,'b) Stop.stop) ternary, - trace,'a,('a,'b*int) Stop.stop) sexternary type black_list -val create_black_list: int -> black_list -val black_list: (trace,black_list,black_list) binary -val remove_blacklisted_event: (black_list,trace,trace) binary +val create_black_list : int -> black_list +val black_list : (trace, black_list, black_list) binary +val remove_blacklisted_event : (black_list, trace, trace) binary -(** Story table *) type story_table +(** Story table *) +val create_story_table : story_table zeroary (** Initialization *) -val create_story_table: - story_table zeroary +val count_stories : story_table -> int (** Give the number of stories (up to isomorphism classes) stored in a table *) -val count_stories: story_table -> int +val store_trace : + (trace, trace_runtime_info list, story_table, story_table) ternary (** Store trace in story table *) -val store_trace: (trace,trace_runtime_info list,story_table,story_table) ternary (** Apply a function on each trace (and each list of runtime information associated to this trace), the string contains the message to display in case of faillure of one call of the ternary function*) -val fold_story_table_with_progress_bar: - (string,(trace,trace_runtime_info list,'a,'a) ternary,story_table,'a,'a) quaternary - +val fold_story_table_with_progress_bar : + ( string, + (trace, trace_runtime_info list, 'a, 'a) ternary, + story_table, + 'a, + 'a ) + quaternary + +val fold_story_table_without_progress_bar : + ( string, + (trace, trace_runtime_info list, 'a, 'a) ternary, + story_table, + 'a, + 'a ) + quaternary (** Apply a function on each trace (and each list of runtime information associated to this trace), the string contains the message to display in case of faillure of one call of the ternary function*) -val fold_story_table_without_progress_bar: - (string,(trace,trace_runtime_info list,'a,'a) ternary,story_table,'a,'a) quaternary +val flatten_story_table : (story_table, story_table) unary (** put together the stories having the same canonic form, this has do be done explicitely on the moment, I will improve this soon*) -val flatten_story_table: (story_table,story_table) unary +val export_story_table : + (story_table, (Trace.t * Causal.grid * trace_runtime_info list) list) unary (** convert a table into a list of grid (with runtime information)*) -val export_story_table: (story_table,(Trace.t*Causal.grid*trace_runtime_info list) list) unary - (** The following functions are for expert only *) +val compress : ?heuristic:Priority.priorities -> (trace, trace list) unary (** compress a trace with the level of abstraction defined in the argument parameter. The optional argument heuristic can be used to tune the heuristic that select which event will be tried to be discarded first. *) -val compress: - ?heuristic:Priority.priorities -> (trace,trace list) unary -val copy_log_info: StoryProfiling.StoryStats.log_info -> StoryProfiling.StoryStats.log_info +val copy_log_info : + StoryProfiling.StoryStats.log_info -> StoryProfiling.StoryStats.log_info type cflow_grid = Causal.grid type enriched_cflow_grid = Causal.enriched_grid -val convert_trace_into_grid: trace -> kappa_handler -> cflow_grid +val convert_trace_into_grid : trace -> kappa_handler -> cflow_grid +val enrich_grid_with_transitive_past_of_observables_with_a_progress_bar : + (cflow_grid, enriched_cflow_grid) unary (** compute transitive closure with different parameters (progress_bar, gc) *) -val enrich_grid_with_transitive_past_of_observables_with_a_progress_bar: - (cflow_grid,enriched_cflow_grid) unary -val enrich_grid_with_transitive_past_of_observables_without_a_progress_bar: - (cflow_grid,enriched_cflow_grid) unary -val enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar: - (cflow_grid,enriched_cflow_grid) unary -(** Cannonic forms *) +val enrich_grid_with_transitive_past_of_observables_without_a_progress_bar : + (cflow_grid, enriched_cflow_grid) unary + +val enrich_grid_with_transitive_past_of_each_node_without_a_progress_bar : + (cflow_grid, enriched_cflow_grid) unary + type canonical_form -val compare_canonical_form: canonical_form -> canonical_form -> int -val compute_canonical_form: (trace, canonical_form) unary +(** Cannonic forms *) + +val compare_canonical_form : canonical_form -> canonical_form -> int +val compute_canonical_form : (trace, canonical_form) unary -(** Blackboard with debugging utilities *) type musical_grid +(** Blackboard with debugging utilities *) + type observable_hit -val get_runtime_info_from_observable_hit: +val get_runtime_info_from_observable_hit : observable_hit -> unit Trace.Simulation_info.t option (** Musical processing *) -val convert_trace_into_musical_notation: - (trace,musical_grid) unary -val extract_observable_hits_from_musical_notation: - (musical_grid,observable_hit list) unary -val extract_observable_hit_from_musical_notation: - (string,musical_grid,observable_hit) binary +val convert_trace_into_musical_notation : (trace, musical_grid) unary + +val extract_observable_hits_from_musical_notation : + (musical_grid, observable_hit list) unary + +val extract_observable_hit_from_musical_notation : + (string, musical_grid, observable_hit) binary -val causal_prefix_of_an_observable_hit: - (string,musical_grid,enriched_cflow_grid,observable_hit,trace) quaternary +val causal_prefix_of_an_observable_hit : + (string, musical_grid, enriched_cflow_grid, observable_hit, trace) quaternary +val export_musical_grid_to_xls : + (string, int, int, musical_grid, unit) quaternary (** Show the current status of the branch and cut assumptions in a libreoffice macro file *) -val export_musical_grid_to_xls: - (string,int,int,musical_grid,unit) quaternary +val print_musical_grid : (musical_grid, unit) unary (** Show the current status of the branch and cut assumptions in ASCII *) -val print_musical_grid: - (musical_grid,unit) unary -val get_counter: story_table -> int (* to be removed from the interface*) +val get_counter : story_table -> int (* to be removed from the interface*) diff --git a/core/cflow/utilities_expert.ml b/core/cflow/utilities_expert.ml index acfef09674..2f95499f2d 100644 --- a/core/cflow/utilities_expert.ml +++ b/core/cflow/utilities_expert.ml @@ -13,24 +13,22 @@ * GNU Library General Public License *) let debug_mode = false - let _ = debug_mode -type parameters = - { - iteration_before_calibrating: int; - global_time_factor_min: float option; - global_time_factor_max: float option; - trace_before_factor_min: int option; - trace_after_factor_min: int option; - trace_before_factor_max: int option; - trace_after_factor_max: int option; - computation_time_factor_min:float option; - computation_time_factor_max:float option; - } +type parameters = { + iteration_before_calibrating: int; + global_time_factor_min: float option; + global_time_factor_max: float option; + trace_before_factor_min: int option; + trace_after_factor_min: int option; + trace_before_factor_max: int option; + trace_after_factor_max: int option; + computation_time_factor_min: float option; + computation_time_factor_max: float option; +} let parameters = - { + { iteration_before_calibrating = 10; global_time_factor_min = Some 5.; global_time_factor_max = Some 20.; @@ -39,117 +37,126 @@ let parameters = trace_before_factor_max = Some 500; trace_after_factor_max = Some 500; computation_time_factor_min = Some 10.; - computation_time_factor_max = Some 500. - } - - -type status_global = - { counter_min: int; - global_time_min: float option; - global_time_max: float option; - cpu_time_min: float option; - cpu_time_max: float option; - cpu_time_ref: float option; - trace_length_before_min: int option; - trace_length_after_min: int option; - trace_length_before_max: int option; - trace_length_after_max: int option; - trace_length_before_ref: int option; - trace_length_after_ref: int option + computation_time_factor_max = Some 500.; } -type status = - { - counter: int; - global_time: float; - trace_length_before: int; - trace_length_after: int; - cpu_time: float; - } +type status_global = { + counter_min: int; + global_time_min: float option; + global_time_max: float option; + cpu_time_min: float option; + cpu_time_max: float option; + cpu_time_ref: float option; + trace_length_before_min: int option; + trace_length_after_min: int option; + trace_length_before_max: int option; + trace_length_after_max: int option; + trace_length_before_ref: int option; + trace_length_after_ref: int option; +} + +type status = { + counter: int; + global_time: float; + trace_length_before: int; + trace_length_after: int; + cpu_time: float; +} let get_status_before counter trace = { - counter=counter; + counter; global_time = Sys.time (); - trace_length_before = Utilities.size_of_pretrace trace ; - trace_length_after= 0; - cpu_time=0. + trace_length_before = Utilities.size_of_pretrace trace; + trace_length_after = 0; + cpu_time = 0.; } + let get_status_after status_before trace = { - status_before - with + status_before with cpu_time = Sys.time () -. status_before.global_time; - trace_length_after = Utilities.size_of_pretrace trace + trace_length_after = Utilities.size_of_pretrace trace; } - let cmp_opt cmp a b = - match - a,b - with - | None,_ | _,None -> 0 - | Some a,Some b -> cmp a b + match a, b with + | None, _ | _, None -> 0 + | Some a, Some b -> cmp a b + +let cmp_float_opt = cmp_opt (compare : float -> float -> int) +let cmp_int_opt = cmp_opt (compare : int -> int -> int) -let cmp_float_opt = cmp_opt (compare:float->float->int) -let cmp_int_opt = cmp_opt (compare:int->int->int) let gen_bin_opt op a b = - match - a,b - with - | None,_ | _,None -> None - | Some a,Some b -> Some (op a b) + match a, b with + | None, _ | _, None -> None + | Some a, Some b -> Some (op a b) -let add_float_opt = gen_bin_opt (+.) +let add_float_opt = gen_bin_opt ( +. ) let mult_float_opt = gen_bin_opt ( *. ) let mult_int_opt = gen_bin_opt ( * ) - let max_opt cmp a b = - match - a - with - None -> Some b - | Some a -> Some (if cmp a b > 0 then a else b) + match a with + | None -> Some b + | Some a -> + Some + (if cmp a b > 0 then + a + else + b) let stop_before global status = status.counter > global.counter_min - && - (cmp_float_opt (Some status.global_time) global.global_time_max > 0 - || cmp_int_opt (Some status.trace_length_before) global.trace_length_before_max > 0 - || - ( - cmp_float_opt (Some status.global_time) global.global_time_min >= 0 - && - cmp_int_opt (Some status.trace_length_before) global.trace_length_before_min >= 0 )) - + && (cmp_float_opt (Some status.global_time) global.global_time_max > 0 + || cmp_int_opt (Some status.trace_length_before) + global.trace_length_before_max + > 0 + || cmp_float_opt (Some status.global_time) global.global_time_min >= 0 + && cmp_int_opt (Some status.trace_length_before) + global.trace_length_before_min + >= 0) let stop_after global status = status.counter > global.counter_min - && - (cmp_float_opt (Some status.global_time) global.global_time_max > 0 + && (cmp_float_opt (Some status.global_time) global.global_time_max > 0 || cmp_float_opt (Some status.cpu_time) global.cpu_time_max > 0 - || cmp_int_opt (Some status.trace_length_before) global.trace_length_before_max > 0 - || cmp_int_opt (Some status.trace_length_after) global.trace_length_after_max > 0 - || - ( - cmp_float_opt (Some status.global_time) global.global_time_min >= 0 - && cmp_float_opt (Some status.cpu_time) global.cpu_time_min >= 0 - && cmp_int_opt (Some status.trace_length_before) global.trace_length_before_min >= 0 - && cmp_int_opt (Some status.trace_length_after) global.trace_length_after_min >= 0)) + || cmp_int_opt (Some status.trace_length_before) + global.trace_length_before_max + > 0 + || cmp_int_opt (Some status.trace_length_after) + global.trace_length_after_max + > 0 + || cmp_float_opt (Some status.global_time) global.global_time_min >= 0 + && cmp_float_opt (Some status.cpu_time) global.cpu_time_min >= 0 + && cmp_int_opt (Some status.trace_length_before) + global.trace_length_before_min + >= 0 + && cmp_int_opt (Some status.trace_length_after) + global.trace_length_after_min + >= 0) let set_status_init cflow_parameters parameters float1 float2 counter = - { counter_min = counter + parameters.iteration_before_calibrating ; - global_time_min = if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters - then - None - else - add_float_opt (Some float2) (mult_float_opt (Some (float2 -. float1)) parameters.global_time_factor_min) ; - global_time_max = if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters - then - None - else - add_float_opt (Some float2) (mult_float_opt (Some (float2 -. float1)) parameters.global_time_factor_max) ; + { + counter_min = counter + parameters.iteration_before_calibrating; + global_time_min = + (if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters + then + None + else + add_float_opt (Some float2) + (mult_float_opt + (Some (float2 -. float1)) + parameters.global_time_factor_min)); + global_time_max = + (if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters + then + None + else + add_float_opt (Some float2) + (mult_float_opt + (Some (float2 -. float1)) + parameters.global_time_factor_max)); cpu_time_min = None; cpu_time_max = None; cpu_time_ref = None; @@ -161,130 +168,138 @@ let set_status_init cflow_parameters parameters float1 float2 counter = trace_length_after_ref = None; } - let update_status_before global status = - if status.counter < global.counter_min - then - { - global - with - trace_length_before_ref = max_opt compare global.trace_length_before_ref status.trace_length_before} + if status.counter < global.counter_min then + { + global with + trace_length_before_ref = + max_opt compare global.trace_length_before_ref + status.trace_length_before; + } else global let update_status_after global status = - if status.counter < global.counter_min - then + if status.counter < global.counter_min then { - global - with - trace_length_after_ref = max_opt compare global.trace_length_after_ref status.trace_length_after; - cpu_time_ref = max_opt compare global.cpu_time_ref status.cpu_time + global with + trace_length_after_ref = + max_opt compare global.trace_length_after_ref status.trace_length_after; + cpu_time_ref = max_opt compare global.cpu_time_ref status.cpu_time; } else global let compute_status_ranges cflow_parameters parameter global_status = { - global_status - with - cpu_time_min = if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters - then - None - else - mult_float_opt global_status.cpu_time_ref parameter.computation_time_factor_min; - cpu_time_max = if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters - then - None - else - mult_float_opt global_status.cpu_time_ref parameter.computation_time_factor_max; - trace_length_before_min = mult_int_opt global_status.trace_length_before_ref parameter.trace_before_factor_min; - trace_length_before_max = mult_int_opt global_status.trace_length_before_ref parameter.trace_before_factor_max; - trace_length_after_min = mult_int_opt global_status.trace_length_after_ref parameter.trace_after_factor_min; - trace_length_after_max = mult_int_opt global_status.trace_length_after_ref parameter.trace_after_factor_max; + global_status with + cpu_time_min = + (if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters + then + None + else + mult_float_opt global_status.cpu_time_ref + parameter.computation_time_factor_min); + cpu_time_max = + (if Utilities.S.PH.B.PB.CI.Po.K.H.get_is_time_independent cflow_parameters + then + None + else + mult_float_opt global_status.cpu_time_ref + parameter.computation_time_factor_max); + trace_length_before_min = + mult_int_opt global_status.trace_length_before_ref + parameter.trace_before_factor_min; + trace_length_before_max = + mult_int_opt global_status.trace_length_before_ref + parameter.trace_before_factor_max; + trace_length_after_min = + mult_int_opt global_status.trace_length_after_ref + parameter.trace_after_factor_min; + trace_length_after_max = + mult_int_opt global_status.trace_length_after_ref + parameter.trace_after_factor_max; } - let fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking_the_trace - cflow_parameters ~shall_we_compute:_ ~shall_we_compute_profiling_information:_ - handler log_info error - we_shall never - parameters - global_trace_simplification - f - (store_result:( - Utilities.trace, - Utilities.trace_runtime_info list, - 'a,'a) Utilities.ternary - ) - trace - (table:'a) - = - let f - cflow_parameters - ?shall_we_compute:(_) ?shall_we_compute_profiling_information:(_) - ?print_if_zero:(_) - handler log_info error trace info (last_info,stop_next,global_status,counter,table) = - if stop_next - then error,log_info,Stop.stop (last_info,table) - else + cflow_parameters ~shall_we_compute:_ + ~shall_we_compute_profiling_information:_ handler log_info error we_shall + never parameters global_trace_simplification f + (store_result : + ( Utilities.trace, + Utilities.trace_runtime_info list, + 'a, + 'a ) + Utilities.ternary) trace (table : 'a) = + let f cflow_parameters ?shall_we_compute:_ + ?shall_we_compute_profiling_information:_ ?print_if_zero:_ handler + log_info error trace info + (last_info, stop_next, global_status, counter, table) = + if stop_next then + error, log_info, Stop.stop (last_info, table) + else ( let status_before = get_status_before counter trace in - let stop = stop_before global_status status_before in + let stop = stop_before global_status status_before in let global_status = update_status_before global_status status_before in - if stop - then error,log_info,Stop.stop (last_info,table) - else - begin - let error,log_info,trace = f cflow_parameters handler log_info error trace in - let status_after = get_status_after status_before trace in - let stop = stop_after global_status status_after in - let error,log_info,table = store_result cflow_parameters ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall handler log_info error trace info table in - let last_info = Some info in - let global_status = update_status_after global_status status_after in - let global_status = - if counter = global_status.counter_min - then - compute_status_ranges cflow_parameters parameters global_status - else - global_status - in - error,log_info,Stop.success (last_info,stop,global_status,succ counter,table) - end + if stop then + error, log_info, Stop.stop (last_info, table) + else ( + let error, log_info, trace = + f cflow_parameters handler log_info error trace + in + let status_after = get_status_after status_before trace in + let stop = stop_after global_status status_after in + let error, log_info, table = + store_result cflow_parameters ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler log_info + error trace info table + in + let last_info = Some info in + let global_status = update_status_after global_status status_after in + let global_status = + if counter = global_status.counter_min then + compute_status_ranges cflow_parameters parameters global_status + else + global_status + in + ( error, + log_info, + Stop.success (last_info, stop, global_status, succ counter, table) ) + ) + ) in let rec aux log_info error counter trace table = - if Utilities.has_obs trace - then - begin - let start_iteration = Sys.time () in - let output = - try - Some (global_trace_simplification 0 (error,log_info,trace)) - with Sys.Break -> None - in - match output - with - | None -> error,log_info,table - | Some (error,log_info,trace) -> - let end_simplification = Sys.time () in - let status = set_status_init cflow_parameters parameters start_iteration end_simplification counter in - let error,log_info,output = - Utilities.fold_over_the_causal_past_of_observables_with_a_progress_bar - cflow_parameters ~shall_we_compute:we_shall ~shall_we_compute_profiling_information:we_shall - handler log_info error - we_shall never - counter - f - trace - (None,false,status,counter,table) - in - Stop.success_or_stop - (fun (_,_,_,_,output) -> error,log_info,output) - (fun ((last_info,table),counter) -> - let error,log_info,trace = Utilities.remove_obs_before cflow_parameters handler log_info error last_info trace in - aux log_info error counter trace table) - output - end - else - error,log_info,table + if Utilities.has_obs trace then ( + let start_iteration = Sys.time () in + let output = + try Some (global_trace_simplification 0 (error, log_info, trace)) + with Sys.Break -> None + in + match output with + | None -> error, log_info, table + | Some (error, log_info, trace) -> + let end_simplification = Sys.time () in + let status = + set_status_init cflow_parameters parameters start_iteration + end_simplification counter + in + let error, log_info, output = + Utilities.fold_over_the_causal_past_of_observables_with_a_progress_bar + cflow_parameters ~shall_we_compute:we_shall + ~shall_we_compute_profiling_information:we_shall handler log_info + error we_shall never counter f trace + (None, false, status, counter, table) + in + Stop.success_or_stop + (fun (_, _, _, _, output) -> error, log_info, output) + (fun ((last_info, table), counter) -> + let error, log_info, trace = + Utilities.remove_obs_before cflow_parameters handler log_info + error last_info trace + in + aux log_info error counter trace table) + output + ) else + error, log_info, table in aux log_info error 1 trace table diff --git a/core/cflow/utilities_expert.mli b/core/cflow/utilities_expert.mli index a5d60c7549..cc762f5130 100644 --- a/core/cflow/utilities_expert.mli +++ b/core/cflow/utilities_expert.mli @@ -1,7 +1,8 @@ type parameters -val parameters: parameters -val fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking_the_trace: +val parameters : parameters + +val fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking_the_trace : Utilities.parameter -> shall_we_compute:'a -> shall_we_compute_profiling_information:'b -> @@ -12,19 +13,19 @@ val fold_over_the_causal_past_of_observables_with_a_progress_bar_while_reshaking Utilities.shall_we -> parameters -> (int -> - Utilities.error_log * Utilities.profiling_info * Utilities.trace -> - Utilities.error_log * Utilities.profiling_info * Utilities.trace) -> + Utilities.error_log * Utilities.profiling_info * Utilities.trace -> + Utilities.error_log * Utilities.profiling_info * Utilities.trace) -> (Utilities.parameter -> - Utilities.kappa_handler -> - Utilities.profiling_info -> - Utilities.error_log -> - Utilities.trace -> - Utilities.error_log * Utilities.profiling_info * Utilities.trace) -> - (Utilities.trace, Utilities.trace_runtime_info list, - 'story_table, 'story_table) - Utilities.ternary -> + Utilities.kappa_handler -> + Utilities.profiling_info -> + Utilities.error_log -> + Utilities.trace -> + Utilities.error_log * Utilities.profiling_info * Utilities.trace) -> + ( Utilities.trace, + Utilities.trace_runtime_info list, + 'story_table, + 'story_table ) + Utilities.ternary -> Utilities.trace -> 'story_table -> - Utilities.error_log * Utilities.profiling_info * - 'story_table - + Utilities.error_log * Utilities.profiling_info * 'story_table diff --git a/core/classical_graphs/dune b/core/classical_graphs/dune index 2a75d62e20..fc8e4318f4 100644 --- a/core/classical_graphs/dune +++ b/core/classical_graphs/dune @@ -1,6 +1,5 @@ (library - (name kappa_classical_graphs) - (libraries yojson kappa-library.generic kappa_logging) - (flags (:standard -w @a - -open Kappa_generic_toolset - -open Kappa_logging))) + (name kappa_classical_graphs) + (libraries yojson kappa-library.generic kappa_logging) + (flags + (:standard -w @a -open Kappa_generic_toolset -open Kappa_logging))) diff --git a/core/classical_graphs/graph_json.ml b/core/classical_graphs/graph_json.ml index 11440df96a..cb693e2ce5 100644 --- a/core/classical_graphs/graph_json.ml +++ b/core/classical_graphs/graph_json.ml @@ -30,7 +30,7 @@ let shape_to_json shape = | Graph_loggers_sig.Invhouse -> `String "Invhouse" | Graph_loggers_sig.Rect -> `String "rect" | Graph_loggers_sig.Ellipse -> `String "ellipse" - | Graph_loggers_sig.Circle-> `String "circle" + | Graph_loggers_sig.Circle -> `String "circle" let headkind_to_json headkind = match headkind with @@ -59,8 +59,7 @@ let color_to_json color = | Graph_loggers_sig.Grey -> `String "grey" let directive_to_json option = - match option - with + match option with | Graph_loggers_sig.Color color -> "color", color_to_json color | Graph_loggers_sig.FillColor color -> "fillcolor", color_to_json color | Graph_loggers_sig.Label string -> "label", `String string @@ -76,52 +75,47 @@ let directive_to_json option = | Graph_loggers_sig.LineStyle linestyle -> "linestyle", linestyle_to_json linestyle | Graph_loggers_sig.Position p -> - "position", - JsonUtil.of_list - (fun json -> Locality.annot_to_yojson - JsonUtil.of_unit ((),json)) - p + ( "position", + JsonUtil.of_list + (fun json -> Loc.yojson_of_annoted JsonUtil.of_unit ((), json)) + p ) | Graph_loggers_sig.Contextual_help s -> - "contextual help", - JsonUtil.of_string s - | Graph_loggers_sig.OnClick json -> - "on_click", json + "contextual help", JsonUtil.of_string s + | Graph_loggers_sig.OnClick json -> "on_click", json let directives_to_json = JsonUtil.of_assoc directive_to_json let node_to_json (id, directives) = - `Assoc [ - "id", `String id; - "directives", directives_to_json directives - ] -let edge_to_json (id1, id2, directives) = - `Assoc [ - "source", `String id1 ; - "target", `String id2; - "directives", directives_to_json directives - ] + `Assoc [ "id", `String id; "directives", directives_to_json directives ] +let edge_to_json (id1, id2, directives) = + `Assoc + [ + "source", `String id1; + "target", `String id2; + "directives", directives_to_json directives; + ] let nodes_to_json = JsonUtil.of_list node_to_json let edges_to_json = JsonUtil.of_list edge_to_json -let to_json graph = - (`Assoc [ - "nodes", nodes_to_json (fst graph); - "edges", edges_to_json (snd graph) - ]: Yojson.Basic.t) +let to_json graph : Yojson.Basic.t = + `Assoc + [ "nodes", nodes_to_json (fst graph); "edges", edges_to_json (snd graph) ] let linestyle_of_json = function | `String "Plain" -> Graph_loggers_sig.Plain | `String "Dotted" -> Graph_loggers_sig.Dotted | `String "Dashed" -> Graph_loggers_sig.Dashed - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct headkind",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct headkind", x)) + let headkind_of_json = function | `String "vee" -> Graph_loggers_sig.Vee | `String "Tee" -> Graph_loggers_sig.Tee | `String "undirected" -> Graph_loggers_sig.No_head | `String "normal" -> Graph_loggers_sig.Normal - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct headkind",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct headkind", x)) + let shape_of_json = function | `String "Invisible" -> Graph_loggers_sig.Invisible | `String "House" -> Graph_loggers_sig.House @@ -129,18 +123,18 @@ let shape_of_json = function | `String "rect" -> Graph_loggers_sig.Rect | `String "ellipse" -> Graph_loggers_sig.Ellipse | `String "circle" -> Graph_loggers_sig.Circle - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct shape",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct shape", x)) let direction_of_json = function | `String "Direct" -> Graph_loggers_sig.Direct | `String "Reverse" -> Graph_loggers_sig.Reverse | `String "Undirected" -> Graph_loggers_sig.Undirected | `String "Both" -> Graph_loggers_sig.Both - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct direction",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct direction", x)) let color_of_json = function | `String "grey" -> Graph_loggers_sig.Grey - | `String "yellow" -> Graph_loggers_sig.Yellow + | `String "yellow" -> Graph_loggers_sig.Yellow | `String "red" -> Graph_loggers_sig.Red | `String "green" -> Graph_loggers_sig.Green | `String "white" -> Graph_loggers_sig.White @@ -149,16 +143,16 @@ let color_of_json = function | `String "lightskyblue" -> Graph_loggers_sig.LightSkyBlue | `String "palegreen" -> Graph_loggers_sig.PaleGreen | `String "brown" -> Graph_loggers_sig.Brown - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct color",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct color", x)) -let directive_of_json = - function +let directive_of_json = function | "color", color -> Graph_loggers_sig.Color (color_of_json color) | "fillcolor", color -> Graph_loggers_sig.FillColor (color_of_json color) - | "label", `String string -> Graph_loggers_sig.Label string + | "label", `String string -> Graph_loggers_sig.Label string | "width", `Int int -> Graph_loggers_sig.Width int | "height", `Int int -> Graph_loggers_sig.Height int - | "direction", direction -> Graph_loggers_sig.Direction (direction_of_json direction) + | "direction", direction -> + Graph_loggers_sig.Direction (direction_of_json direction) | "shape", shape -> Graph_loggers_sig.Shape (shape_of_json shape) | "arrowhead", headkind -> Graph_loggers_sig.ArrowHead (headkind_of_json headkind) @@ -169,62 +163,57 @@ let directive_of_json = | "position", pos_list -> Graph_loggers_sig.Position (JsonUtil.to_list - (fun json -> snd (Locality.annot_of_yojson - (JsonUtil.to_unit - ?error_msg:(Some (JsonUtil.build_msg "position"))) - json)) + (fun json -> + snd + (Loc.annoted_of_yojson + (JsonUtil.to_unit + ?error_msg:(Some (JsonUtil.build_msg "position"))) + json)) pos_list) | "contextual help", contextual_help -> Graph_loggers_sig.Contextual_help (JsonUtil.to_string contextual_help) - | "on_click",json -> - Graph_loggers_sig.OnClick json - | (_,x) -> raise (Yojson.Basic.Util.Type_error ("Not a correct directive",x)) + | "on_click", json -> Graph_loggers_sig.OnClick json + | _, x -> raise (Yojson.Basic.Util.Type_error ("Not a correct directive", x)) let directives_of_json directives = - JsonUtil.to_assoc ~error_msg:(JsonUtil.build_msg "list of directives") + JsonUtil.to_assoc + ~error_msg:(JsonUtil.build_msg "list of directives") directive_of_json directives let id_of_json = function | `String string -> string - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct id",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct id", x)) let node_of_json = function | `Assoc l as x when List.length l = 2 -> - begin - try - id_of_json (List.assoc "id" l), - directives_of_json (List.assoc "directives" l) - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct node",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct node",x)) + (try + ( id_of_json (List.assoc "id" l), + directives_of_json (List.assoc "directives" l) ) + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct node", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct node", x)) let edge_of_json = function | `Assoc l as x when List.length l = 3 -> - begin - try - id_of_json (List.assoc "source" l), - id_of_json (List.assoc "target" l), - directives_of_json (List.assoc "directives" l) - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct edge",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct edge",x)) + (try + ( id_of_json (List.assoc "source" l), + id_of_json (List.assoc "target" l), + directives_of_json (List.assoc "directives" l) ) + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct edge", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct edge", x)) let nodes_of_json = - JsonUtil.to_list - ~error_msg:(JsonUtil.build_msg "node list") node_of_json + JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "node list") node_of_json + let edges_of_json = - JsonUtil.to_list - ~error_msg:(JsonUtil.build_msg "edge list") edge_of_json + JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "edge list") edge_of_json let of_json = function | `Assoc l as x when List.length l = 2 -> - begin - try - nodes_of_json (List.assoc "nodes" l), - edges_of_json (List.assoc "edges" l) - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct environment",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct environment",x)) + (try + ( nodes_of_json (List.assoc "nodes" l), + edges_of_json (List.assoc "edges" l) ) + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct environment", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct environment", x)) diff --git a/core/classical_graphs/graph_json.mli b/core/classical_graphs/graph_json.mli index adcb18431b..f62538e1d5 100644 --- a/core/classical_graphs/graph_json.mli +++ b/core/classical_graphs/graph_json.mli @@ -16,5 +16,5 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -val to_json: Graph_loggers_sig.graph -> Yojson.Basic.t +val to_json : Graph_loggers_sig.graph -> Yojson.Basic.t val of_json : Yojson.Basic.t -> Graph_loggers_sig.graph diff --git a/core/classical_graphs/graph_loggers.ml b/core/classical_graphs/graph_loggers.ml index ae86f762a2..37a8f7995b 100644 --- a/core/classical_graphs/graph_loggers.ml +++ b/core/classical_graphs/graph_loggers.ml @@ -17,9 +17,7 @@ * under the terms of the GNU Library General Public License *) let dot_color_encoding x = - match - x - with + match x with | Graph_loggers_sig.Yellow -> "yellow" | Graph_loggers_sig.Grey -> "grey" | Graph_loggers_sig.Red -> "red" @@ -32,9 +30,7 @@ let dot_color_encoding x = | Graph_loggers_sig.Brown -> "brown" let svg_color_encoding x = - match - x - with + match x with | Graph_loggers_sig.Yellow -> "#ff3" | Graph_loggers_sig.Grey -> "#aaa" | Graph_loggers_sig.Red -> "#f00" @@ -46,66 +42,66 @@ let svg_color_encoding x = | Graph_loggers_sig.PaleGreen -> "#9f9" | Graph_loggers_sig.Brown -> "#fc9" -type node_attribute = - { - node_color: Graph_loggers_sig.color option; - node_fillcolor: Graph_loggers_sig.color option; - node_label: string option ; - node_width: int option ; - node_height: int option ; - node_shape: Graph_loggers_sig.shape option ; - node_positions: Locality.t list ; - node_contextual_help: string option; - node_on_click: Yojson.Basic.t option; - } +type node_attribute = { + node_color: Graph_loggers_sig.color option; + node_fillcolor: Graph_loggers_sig.color option; + node_label: string option; + node_width: int option; + node_height: int option; + node_shape: Graph_loggers_sig.shape option; + node_positions: Loc.t list; + node_contextual_help: string option; + node_on_click: Yojson.Basic.t option; +} -type edge_attribute = - { - edge_color: Graph_loggers_sig.color option; - edge_label: string list option ; - edge_style: Graph_loggers_sig.linestyle ; - edge_direction: Graph_loggers_sig.direction ; - edge_arrowhead: Graph_loggers_sig.headkind ; - edge_arrowtail: Graph_loggers_sig.headkind ; - edge_positions: Locality.t list ; - edge_contextual_help: string option; - edge_on_click: Yojson.Basic.t option; - } +type edge_attribute = { + edge_color: Graph_loggers_sig.color option; + edge_label: string list option; + edge_style: Graph_loggers_sig.linestyle; + edge_direction: Graph_loggers_sig.direction; + edge_arrowhead: Graph_loggers_sig.headkind; + edge_arrowtail: Graph_loggers_sig.headkind; + edge_positions: Loc.t list; + edge_contextual_help: string option; + edge_on_click: Yojson.Basic.t option; +} let dummy_node = { - node_color = None ; - node_fillcolor = None ; - node_label = None ; - node_width = None ; - node_height = None ; - node_shape = None ; - node_positions = [] ; - node_on_click = None ; - node_contextual_help = None ; + node_color = None; + node_fillcolor = None; + node_label = None; + node_width = None; + node_height = None; + node_shape = None; + node_positions = []; + node_on_click = None; + node_contextual_help = None; } let dummy_edge = { - edge_color = None ; - edge_label = None ; - edge_style = Graph_loggers_sig.Plain ; - edge_direction = Graph_loggers_sig.Direct ; - edge_arrowhead = Graph_loggers_sig.Normal ; - edge_arrowtail = Graph_loggers_sig.Normal ; - edge_positions = [] ; - edge_on_click = None ; - edge_contextual_help = None ; + edge_color = None; + edge_label = None; + edge_style = Graph_loggers_sig.Plain; + edge_direction = Graph_loggers_sig.Direct; + edge_arrowhead = Graph_loggers_sig.Normal; + edge_arrowtail = Graph_loggers_sig.Normal; + edge_positions = []; + edge_on_click = None; + edge_contextual_help = None; } let is_no_node_attributes node_attribute = node_attribute = dummy_node + let is_no_edge_attributes edge_attribute = - dummy_edge = - { - edge_attribute - with edge_direction = Graph_loggers_sig.Direct ; - edge_arrowhead = Graph_loggers_sig.Normal ; - edge_arrowtail = Graph_loggers_sig.Normal } + dummy_edge + = { + edge_attribute with + edge_direction = Graph_loggers_sig.Direct; + edge_arrowhead = Graph_loggers_sig.Normal; + edge_arrowtail = Graph_loggers_sig.Normal; + } let between_attributes_in_dot logger bool = if bool then @@ -120,124 +116,107 @@ let between_attributes_in_html logger bool = () let html_deps = - ["http://d3js.org/d3.v3.min.js"; - "http://cpettitt.github.io/project/dagre-d3/latest/dagre-d3.min.js"] + [ + "http://d3js.org/d3.v3.min.js"; + "http://cpettitt.github.io/project/dagre-d3/latest/dagre-d3.min.js"; + ] let shall_I_do_it format filter_in filter_out = let b1 = - match - filter_in - with + match filter_in with | None -> true | Some l -> List.mem format l in - b1 && (not (List.mem format filter_out)) + b1 && not (List.mem format filter_out) let print_preamble_shared_html_js f title = let () = Format.fprintf f "
    @," in - let () = Format.fprintf - f "

    @[%s@]

    @," title - in + let () = Format.fprintf f "

    @[%s@]

    @," title in let () = Format.fprintf f "@," in let () = Format.fprintf f "" t in - match - f_opt - with - | None -> () - | Some f -> - let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "@," in - let dependency f t = - Format.fprintf f "" t - in - let () = Format.fprintf f "@[@,@,@," in - let () = Format.fprintf f "@[@,@," in - let () = Format.fprintf f "%s@," title in - let () = Pp.list ~trailing:Pp.space Pp.space dependency f html_deps in - let () = Format.fprintf f "%t@]@,@," - (fun f -> - let () = Format.fprintf f "@[") - in - let () = Format.fprintf f "@[@," in - let () = print_preamble_shared_html_js f title in - () - end - | Loggers.GEPHI - | Loggers.Matrix | Loggers.Json - | Loggers.Mathematica | Loggers.Maple | Loggers.Matlab - | Loggers.DOTNET | Loggers.Octave | Loggers.SBML - | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS -> () + let () = Format.fprintf f "@[@,@,@," in + let () = Format.fprintf f "@[@,@," in + let () = Format.fprintf f "%s@," title in + let () = Pp.list ~trailing:Pp.space Pp.space dependency f html_deps in + let () = + Format.fprintf f "%t@]@,@," (fun f -> + let () = Format.fprintf f "@[") + in + let () = Format.fprintf f "@[@," in + let () = print_preamble_shared_html_js f title in + ()) + | Loggers.GEPHI | Loggers.Matrix | Loggers.Json | Loggers.Mathematica + | Loggers.Maple | Loggers.Matlab | Loggers.DOTNET | Loggers.Octave + | Loggers.SBML | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS -> + () + ) let string_of_arrow_in_html logger bool title style = - match style - with + match style with | Graph_loggers_sig.Tee | Graph_loggers_sig.Normal -> bool (*| Tee -> let () = between_attributes_in_html logger bool in @@ -252,253 +231,260 @@ let string_of_arrow_in_html logger bool title style = in true | Graph_loggers_sig.No_head -> - (* let () = between_attributes_in_html logger bool in - let () = - Loggers.fprintf logger "%s: \"none\"" title - in - true*) bool + (* let () = between_attributes_in_html logger bool in + let () = + Loggers.fprintf logger "%s: \"none\"" title + in + true*) + bool let merge s s' = - if s = Graph_loggers_sig.No_head then s' else s + if s = Graph_loggers_sig.No_head then + s' + else + s let matrix_string_of_options l = let i = List.fold_left - ( - List.fold_left - (fun i l -> - match l with - Graph_loggers_sig.Color x -> - begin - match x with - | Graph_loggers_sig.Brown -> i*7 - | Graph_loggers_sig.Black -> i - | Graph_loggers_sig.Green -> i*3 - | Graph_loggers_sig.Red -> i*(-1) - | Graph_loggers_sig.Blue -> i*5 - | Graph_loggers_sig.White -> i - | Graph_loggers_sig.LightSkyBlue -> i*11 - | Graph_loggers_sig.PaleGreen -> i*13 - | Graph_loggers_sig.Grey -> i*17 - | Graph_loggers_sig.Yellow -> i*19 - end - | Graph_loggers_sig.Position _ - | Graph_loggers_sig.Contextual_help _ - | Graph_loggers_sig.OnClick _ - | Graph_loggers_sig.ArrowHead _ - | Graph_loggers_sig.ArrowTail _ - | Graph_loggers_sig.FillColor _ - | Graph_loggers_sig.Label _ - | Graph_loggers_sig.Width _ - | Graph_loggers_sig.Height _ - | Graph_loggers_sig.Direction _ - | Graph_loggers_sig.Shape _ - | Graph_loggers_sig.LineStyle _ - -> i - )) 1 l in + (List.fold_left (fun i l -> + match l with + | Graph_loggers_sig.Color x -> + (match x with + | Graph_loggers_sig.Brown -> i * 7 + | Graph_loggers_sig.Black -> i + | Graph_loggers_sig.Green -> i * 3 + | Graph_loggers_sig.Red -> i * -1 + | Graph_loggers_sig.Blue -> i * 5 + | Graph_loggers_sig.White -> i + | Graph_loggers_sig.LightSkyBlue -> i * 11 + | Graph_loggers_sig.PaleGreen -> i * 13 + | Graph_loggers_sig.Grey -> i * 17 + | Graph_loggers_sig.Yellow -> i * 19) + | Graph_loggers_sig.Position _ | Graph_loggers_sig.Contextual_help _ + | Graph_loggers_sig.OnClick _ | Graph_loggers_sig.ArrowHead _ + | Graph_loggers_sig.ArrowTail _ | Graph_loggers_sig.FillColor _ + | Graph_loggers_sig.Label _ | Graph_loggers_sig.Width _ + | Graph_loggers_sig.Height _ | Graph_loggers_sig.Direction _ + | Graph_loggers_sig.Shape _ | Graph_loggers_sig.LineStyle _ -> + i)) + 1 l + in string_of_int i let print_foot_shared_html_js logger = let () = Mods.String2Map.iter - (fun (id1,id2) list -> - let list = List.rev list in - let id1_int = Graph_loggers_sig.int_of_string_id logger id1 in - let id2_int = Graph_loggers_sig.int_of_string_id logger id2 in - let attributes = dummy_edge in - let attributes = - List.fold_left - (fun attributes option_list -> - List.fold_left - (fun attributes option -> - match - option - with - | Graph_loggers_sig.Label s -> - begin - match attributes.edge_label - with - | None -> - {attributes with - edge_label = Some [s] } - | Some s' -> - {attributes with - edge_label = Some (s::","::s') } - end - | Graph_loggers_sig.Color s -> - begin - match attributes.edge_color with - | None -> - {attributes with edge_color = Some s } - | Some s' when s=s' -> attributes - | Some _ -> - {attributes with edge_color = Some Graph_loggers_sig.Brown} - end - | Graph_loggers_sig.LineStyle s -> {attributes with - edge_style = s} - | Graph_loggers_sig.Direction s -> {attributes with - edge_direction = s} - | Graph_loggers_sig.ArrowTail s -> {attributes with - edge_arrowtail = merge s attributes.edge_arrowtail } - | Graph_loggers_sig.ArrowHead s -> {attributes with - edge_arrowhead = merge s - attributes.edge_arrowhead} - | Graph_loggers_sig.Position p -> - {attributes with - edge_positions = - p@attributes.edge_positions - } - | Graph_loggers_sig.Contextual_help s -> - {attributes with - edge_contextual_help = - match attributes.edge_contextual_help with - | None -> Some s - | Some s' -> Some (s'^s)} - | Graph_loggers_sig.OnClick json -> - {attributes with - edge_on_click = Some json} - | Graph_loggers_sig.Shape _ - | Graph_loggers_sig.Width _ - | Graph_loggers_sig.Height _ - | Graph_loggers_sig.FillColor _ -> attributes - ) - attributes option_list) - attributes - list - in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) "g.setEdge(%i,%i,{ " - id1_int - id2_int - in - let attributes = - match attributes.edge_direction - with - | Graph_loggers_sig.Undirected -> - {attributes with - edge_arrowhead=Graph_loggers_sig.No_head ; - edge_arrowtail=Graph_loggers_sig.No_head} - | Graph_loggers_sig.Direct -> - {attributes with - edge_arrowtail=Graph_loggers_sig.No_head} - | Graph_loggers_sig.Reverse -> - {attributes with edge_arrowhead=Graph_loggers_sig.No_head} - | Graph_loggers_sig.Both -> attributes - in - let bool = false in - let bool, s_opt= - match attributes.edge_label - with - | None -> bool,None - | Some string_list -> - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "label: \"" - in - let s = - Format.asprintf - "%a" (fun fmt -> List.iter (Format.fprintf fmt "%s")) (List.rev string_list) - in - let s_opt,s' = - if - String.length s > 100 - then - Some s, (String.sub s 0 100)^"..." - else - None, s - in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "%s\"" s' - in - true, s_opt - in - let bool = - match attributes.edge_color - with - | None -> bool - | Some s -> - let () = between_attributes_in_html logger bool in - let color = svg_color_encoding s in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "style: \"stroke: %s; fill: white\", arrowheadStyle: \"fill: %s; stroke: %s\"" - color color color - in - true - in - let bool = string_of_arrow_in_html logger bool "arrowhead" attributes.edge_arrowhead in - let bool = string_of_arrow_in_html logger bool "arrowtail" attributes.edge_arrowtail in - let () = if bool then () else () in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) " });@," - in - let () = - match s_opt - with None -> () - | Some s -> - Loggers.fprintf - (Graph_loggers_sig.lift logger) "\n" s - in - ()) + (fun (id1, id2) list -> + let list = List.rev list in + let id1_int = Graph_loggers_sig.int_of_string_id logger id1 in + let id2_int = Graph_loggers_sig.int_of_string_id logger id2 in + let attributes = dummy_edge in + let attributes = + List.fold_left + (fun attributes option_list -> + List.fold_left + (fun attributes option -> + match option with + | Graph_loggers_sig.Label s -> + (match attributes.edge_label with + | None -> { attributes with edge_label = Some [ s ] } + | Some s' -> + { attributes with edge_label = Some (s :: "," :: s') }) + | Graph_loggers_sig.Color s -> + (match attributes.edge_color with + | None -> { attributes with edge_color = Some s } + | Some s' when s = s' -> attributes + | Some _ -> + { + attributes with + edge_color = Some Graph_loggers_sig.Brown; + }) + | Graph_loggers_sig.LineStyle s -> + { attributes with edge_style = s } + | Graph_loggers_sig.Direction s -> + { attributes with edge_direction = s } + | Graph_loggers_sig.ArrowTail s -> + { + attributes with + edge_arrowtail = merge s attributes.edge_arrowtail; + } + | Graph_loggers_sig.ArrowHead s -> + { + attributes with + edge_arrowhead = merge s attributes.edge_arrowhead; + } + | Graph_loggers_sig.Position p -> + { + attributes with + edge_positions = p @ attributes.edge_positions; + } + | Graph_loggers_sig.Contextual_help s -> + { + attributes with + edge_contextual_help = + (match attributes.edge_contextual_help with + | None -> Some s + | Some s' -> Some (s' ^ s)); + } + | Graph_loggers_sig.OnClick json -> + { attributes with edge_on_click = Some json } + | Graph_loggers_sig.Shape _ | Graph_loggers_sig.Width _ + | Graph_loggers_sig.Height _ | Graph_loggers_sig.FillColor _ + -> + attributes) + attributes option_list) + attributes list + in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "g.setEdge(%i,%i,{ " id1_int id2_int + in + let attributes = + match attributes.edge_direction with + | Graph_loggers_sig.Undirected -> + { + attributes with + edge_arrowhead = Graph_loggers_sig.No_head; + edge_arrowtail = Graph_loggers_sig.No_head; + } + | Graph_loggers_sig.Direct -> + { attributes with edge_arrowtail = Graph_loggers_sig.No_head } + | Graph_loggers_sig.Reverse -> + { attributes with edge_arrowhead = Graph_loggers_sig.No_head } + | Graph_loggers_sig.Both -> attributes + in + let bool = false in + let bool, s_opt = + match attributes.edge_label with + | None -> bool, None + | Some string_list -> + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "label: \"" + in + let s = + Format.asprintf "%a" + (fun fmt -> List.iter (Format.fprintf fmt "%s")) + (List.rev string_list) + in + let s_opt, s' = + if String.length s > 100 then + Some s, String.sub s 0 100 ^ "..." + else + None, s + in + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "%s\"" s' + in + true, s_opt + in + let bool = + match attributes.edge_color with + | None -> bool + | Some s -> + let () = between_attributes_in_html logger bool in + let color = svg_color_encoding s in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "style: \"stroke: %s; fill: white\", arrowheadStyle: \"fill: \ + %s; stroke: %s\"" + color color color + in + true + in + let bool = + string_of_arrow_in_html logger bool "arrowhead" + attributes.edge_arrowhead + in + let bool = + string_of_arrow_in_html logger bool "arrowtail" + attributes.edge_arrowtail + in + let () = + if bool then + () + else + () + in + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) " });@," in + let () = + match s_opt with + | None -> () + | Some s -> + Loggers.fprintf (Graph_loggers_sig.lift logger) "\n" s + in + ()) (Graph_loggers_sig.get_edge_map logger) in let f_opt = Loggers.formatter_of_logger (Graph_loggers_sig.lift logger) in - match - f_opt - with + match f_opt with | None -> () | Some f -> - let () = Format.fprintf - f "var svg = d3.select(\"svg\"),inner = svg.select(\"g\");@," + let () = + Format.fprintf f + "var svg = d3.select(\"svg\"),inner = svg.select(\"g\");@," in let () = Format.fprintf f "// Set up zoom support@," in - let () = Format.fprintf f "var zoom = d3.behavior.zoom().on(\"zoom\", function() {@," in - let () = Format.fprintf f "inner.attr(\"transform\", \"translate(\" + d3.event.translate + \")\" +@," in - let () = Format.fprintf f "\"scale(\" + d3.event.scale + \")\");@,});@,svg.call(zoom);" in - let () = Format.fprintf f "// Create the renderer@, var render = new dagreD3.render();@," in - let () = Format.fprintf f "// Run the renderer. This is what draws the final graph.@," in + let () = + Format.fprintf f + "var zoom = d3.behavior.zoom().on(\"zoom\", function() {@," + in + let () = + Format.fprintf f + "inner.attr(\"transform\", \"translate(\" + d3.event.translate + \")\" \ + +@," + in + let () = + Format.fprintf f + "\"scale(\" + d3.event.scale + \")\");@,});@,svg.call(zoom);" + in + let () = + Format.fprintf f + "// Create the renderer@, var render = new dagreD3.render();@," + in + let () = + Format.fprintf f + "// Run the renderer. This is what draws the final graph.@," + in let () = Format.fprintf f "render(inner, g);@," in - let () = Format.fprintf f "// Center the graph@,var initialScale = 0.75;@," in + let () = + Format.fprintf f "// Center the graph@,var initialScale = 0.75;@," + in let () = Format.fprintf f "zoom@," in - let () = Format.fprintf - f ".translate([(svg.attr(\"width\") - g.graph().width * initialScale) / 2, 20])@," in + let () = + Format.fprintf f + ".translate([(svg.attr(\"width\") - g.graph().width * initialScale) / \ + 2, 20])@," + in let () = Format.fprintf f ".scale(initialScale)@,.event(svg);@," in - let () = Format.fprintf f "svg.attr('height', g.graph().height * initialScale + 40);" in + let () = + Format.fprintf f + "svg.attr('height', g.graph().height * initialScale + 40);" + in let () = Format.fprintf f "@," in let () = Format.fprintf f "@,
    " in () let print_graph_foot logger = - match - Loggers.get_encoding_format (Graph_loggers_sig.lift logger) - with + match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with | Loggers.DOT -> let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "}" in Loggers.print_newline (Graph_loggers_sig.lift logger) | Loggers.Matrix -> let nodes = Graph_loggers_sig.get_nodes logger in let edges = Graph_loggers_sig.get_edge_map logger in - let () = - Loggers.fprintf (Graph_loggers_sig.lift logger) "\"rules\" :" - in + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "\"rules\" :" in let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in let () = Loggers.open_row (Graph_loggers_sig.lift logger) in let _ = List.fold_left - (fun sep (s,_) -> - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "%s\"%s\"" sep s - in - ", " - ) + (fun sep (s, _) -> + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "%s\"%s\"" sep s + in + ", ") "" nodes in let () = Loggers.close_row (Graph_loggers_sig.lift logger) in @@ -510,154 +496,116 @@ let print_graph_foot logger = let _ = List.fold_left (fun sep _ -> - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "%s1" sep - in - ", " - ) + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "%s1" sep in + ", ") "" nodes in let () = Loggers.close_row (Graph_loggers_sig.lift logger) in let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "," in let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "\"fluxs\" :" - in + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "\"fluxs\" :" in let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in let () = Loggers.open_row (Graph_loggers_sig.lift logger) in let _ = List.fold_left - (fun b (s1,_) -> - let () = - if b then - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "," - in - let () = - Loggers.print_newline - (Graph_loggers_sig.lift logger) - in - () - in - let () = Loggers.open_row (Graph_loggers_sig.lift logger) in - let _ = - List.fold_left - (fun sep (s2,_) -> - let color_value = - match - Mods.String2Map.find_option - (s1,s2) - edges - with - | None -> "0" - | Some options -> matrix_string_of_options options - in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "%s%s" sep color_value in - ", " - ) - "" nodes - in - let () = Loggers.close_row (Graph_loggers_sig.lift logger) in - true - ) false nodes + (fun b (s1, _) -> + let () = + if b then ( + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "," in + let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in + () + ) + in + let () = Loggers.open_row (Graph_loggers_sig.lift logger) in + let _ = + List.fold_left + (fun sep (s2, _) -> + let color_value = + match Mods.String2Map.find_option (s1, s2) edges with + | None -> "0" + | Some options -> matrix_string_of_options options + in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "%s%s" sep color_value + in + ", ") + "" nodes + in + let () = Loggers.close_row (Graph_loggers_sig.lift logger) in + true) + false nodes in let () = Loggers.close_row (Graph_loggers_sig.lift logger) in let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in () - | Loggers.Js_Graph -> - begin - print_foot_shared_html_js logger - end + | Loggers.Js_Graph -> print_foot_shared_html_js logger | Loggers.HTML_Graph -> - begin - let f_opt = - Loggers.formatter_of_logger - (Graph_loggers_sig.lift logger) - in - match - f_opt - with - | None -> () - | Some f -> - let () = print_foot_shared_html_js logger in - let () = Format.fprintf f "@,@]@,@]@." in - () - end - | Loggers.Json | Loggers.GEPHI - | Loggers.Mathematica | Loggers.Maple | Loggers.Matlab | Loggers.Octave - | Loggers.DOTNET | Loggers.SBML | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + let f_opt = Loggers.formatter_of_logger (Graph_loggers_sig.lift logger) in + (match f_opt with + | None -> () + | Some f -> + let () = print_foot_shared_html_js logger in + let () = Format.fprintf f "@,@]@,@]@." in + ()) + | Loggers.Json | Loggers.GEPHI | Loggers.Mathematica | Loggers.Maple + | Loggers.Matlab | Loggers.Octave | Loggers.DOTNET | Loggers.SBML + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular + | Loggers.XLS -> + () -let print_comment - logger - ?filter_in:(filter_in=None) ?filter_out:(filter_out=[]) - string - = +let print_comment logger ?(filter_in = None) ?(filter_out = []) string = let format = Loggers.get_encoding_format (Graph_loggers_sig.lift logger) in - if shall_I_do_it format filter_in filter_out - then - match - format - with + if shall_I_do_it format filter_in filter_out then ( + match format with | Loggers.DOT -> Loggers.fprintf (Graph_loggers_sig.lift logger) "#%s" string | Loggers.HTML_Graph | Loggers.Js_Graph -> Loggers.fprintf (Graph_loggers_sig.lift logger) "%s" string - | Loggers.Json - | Loggers.Matrix - | Loggers.SBML | Loggers.Maple | Loggers.Matlab | Loggers.Mathematica - | Loggers.DOTNET | Loggers.Octave - | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS | Loggers.GEPHI -> () + | Loggers.Json | Loggers.Matrix | Loggers.SBML | Loggers.Maple + | Loggers.Matlab | Loggers.Mathematica | Loggers.DOTNET | Loggers.Octave + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular + | Loggers.XLS | Loggers.GEPHI -> + () + ) let open_asso logger = match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with | Loggers.HTML_Graph | Loggers.Js_Graph -> Loggers.fprintf (Graph_loggers_sig.lift logger) "\t

    \n" - | Loggers.Json - | Loggers.Mathematica - | Loggers.SBML | Loggers.Maple | Loggers.Matlab - | Loggers.DOTNET | Loggers.Octave - | Loggers.Matrix | Loggers.HTML | Loggers.DOT - | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS | Loggers.GEPHI -> () + | Loggers.Json | Loggers.Mathematica | Loggers.SBML | Loggers.Maple + | Loggers.Matlab | Loggers.DOTNET | Loggers.Octave | Loggers.Matrix + | Loggers.HTML | Loggers.DOT | Loggers.HTML_Tabular | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.GEPHI -> + () + let close_asso logger = match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with | Loggers.HTML_Graph | Loggers.Js_Graph -> Loggers.fprintf (Graph_loggers_sig.lift logger) "\t\t

    \n" - | Loggers.Json - | Loggers.DOTNET | Loggers.Mathematica | Loggers.Maple - | Loggers.Matlab | Loggers.Octave | Loggers.SBML - | Loggers.Matrix | Loggers.HTML | Loggers.DOT - | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS | Loggers.GEPHI -> () + | Loggers.Json | Loggers.DOTNET | Loggers.Mathematica | Loggers.Maple + | Loggers.Matlab | Loggers.Octave | Loggers.SBML | Loggers.Matrix + | Loggers.HTML | Loggers.DOT | Loggers.HTML_Tabular | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.GEPHI -> + () let print_asso logger string1 string2 = match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with | Loggers.DOT -> Loggers.fprintf (Graph_loggers_sig.lift logger) "/*%s %s*/" string1 string2 | Loggers.HTML_Graph | Loggers.Js_Graph -> - Loggers.fprintf (Graph_loggers_sig.lift logger) + Loggers.fprintf + (Graph_loggers_sig.lift logger) "\t\t\t
    %s
    %s
    " string1 string2 - | Loggers.Json - | Loggers.DOTNET | Loggers.Matrix | Loggers.SBML + | Loggers.Json | Loggers.DOTNET | Loggers.Matrix | Loggers.SBML | Loggers.Maple | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS | Loggers.GEPHI -> () + | Loggers.XLS | Loggers.GEPHI -> + () let shape_in_dot shape = - match - shape - with + match shape with | Graph_loggers_sig.Invisible -> "style=invis" | Graph_loggers_sig.Invhouse -> "shape=invhouse" | Graph_loggers_sig.House -> "shape=house" @@ -666,9 +614,7 @@ let shape_in_dot shape = | Graph_loggers_sig.Circle -> "shape=circle" let shape_in_html shape = - match - shape - with + match shape with | Graph_loggers_sig.Invisible -> Some "style: \"visibility:hidden\"" | Graph_loggers_sig.Invhouse -> Some "shape: \"invhouse\"" | Graph_loggers_sig.House -> Some "shape: \"house\"" @@ -680,499 +626,425 @@ let string_one_of_linestyle_in_dot _ = "-" let string_two_of_linestyle_in_dot _ = "--" let string_of_arrow_head_in_dot style = - match - style - with + match style with | Graph_loggers_sig.Normal -> ">" | Graph_loggers_sig.Vee -> "|>" | Graph_loggers_sig.Tee -> "|" | Graph_loggers_sig.No_head -> "" let string_of_arrow_tail_in_dot style = - match - style - with + match style with | Graph_loggers_sig.Normal -> "<" | Graph_loggers_sig.Vee -> "<|" | Graph_loggers_sig.Tee -> "|" | Graph_loggers_sig.No_head -> "" - -let print_node logger ?directives:(directives=[]) id = +let print_node logger ?(directives = []) id = let attributes = dummy_node in let attributes = match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with - | Loggers.DOT | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.TXT | Loggers.GEPHI -> + | Loggers.DOT | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.TXT + | Loggers.GEPHI -> List.fold_left (fun attributes option -> - match - option - with - | Graph_loggers_sig.Label s -> {attributes with node_label = Some s } - | Graph_loggers_sig.Color s -> {attributes with node_color = Some s } - | Graph_loggers_sig.FillColor s -> {attributes with node_fillcolor = Some s} - | Graph_loggers_sig.Width i -> {attributes with node_width = Some i} - | Graph_loggers_sig.Height i -> {attributes with node_height = Some i} - | Graph_loggers_sig.Shape s -> {attributes with node_shape = Some s} - | Graph_loggers_sig.Position p -> - {attributes with node_positions = p@attributes.node_positions} - | Graph_loggers_sig.OnClick json -> - {attributes with node_on_click = Some json} - | Graph_loggers_sig.Contextual_help s -> - {attributes with node_contextual_help = - match attributes.node_contextual_help with - | None -> Some s - | Some s' -> Some (s'^s) - } - | Graph_loggers_sig.LineStyle _ - | Graph_loggers_sig.Direction _ - | Graph_loggers_sig.ArrowTail _ - | Graph_loggers_sig.ArrowHead _ -> attributes - ) - attributes - directives - | Loggers.DOTNET | Loggers.Matrix | Loggers.Json - | Loggers.Mathematica| Loggers.Maple | Loggers.Matlab | Loggers.Octave - | Loggers.SBML - | Loggers.TXT_Tabular | Loggers.XLS | Loggers.HTML_Tabular | Loggers.HTML - -> attributes + match option with + | Graph_loggers_sig.Label s -> { attributes with node_label = Some s } + | Graph_loggers_sig.Color s -> { attributes with node_color = Some s } + | Graph_loggers_sig.FillColor s -> + { attributes with node_fillcolor = Some s } + | Graph_loggers_sig.Width i -> { attributes with node_width = Some i } + | Graph_loggers_sig.Height i -> + { attributes with node_height = Some i } + | Graph_loggers_sig.Shape s -> { attributes with node_shape = Some s } + | Graph_loggers_sig.Position p -> + { attributes with node_positions = p @ attributes.node_positions } + | Graph_loggers_sig.OnClick json -> + { attributes with node_on_click = Some json } + | Graph_loggers_sig.Contextual_help s -> + { + attributes with + node_contextual_help = + (match attributes.node_contextual_help with + | None -> Some s + | Some s' -> Some (s' ^ s)); + } + | Graph_loggers_sig.LineStyle _ | Graph_loggers_sig.Direction _ + | Graph_loggers_sig.ArrowTail _ | Graph_loggers_sig.ArrowHead _ -> + attributes) + attributes directives + | Loggers.DOTNET | Loggers.Matrix | Loggers.Json | Loggers.Mathematica + | Loggers.Maple | Loggers.Matlab | Loggers.Octave | Loggers.SBML + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.HTML_Tabular | Loggers.HTML -> + attributes in match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with | Loggers.DOT -> - begin - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "\"%s\"" id - in - let () = - if is_no_node_attributes attributes - then () - else - begin + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "\"%s\"" id in + let () = + if is_no_node_attributes attributes then + () + else ( + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) " [" in + let bool = false in + let bool = + match attributes.node_label with + | None -> bool + | Some string -> let () = Loggers.fprintf (Graph_loggers_sig.lift logger) - " [" - in - let bool = false in - let bool = - match attributes.node_label - with - | None -> bool - | Some string -> - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) "label=\"%s\"" string - in - true - in - let bool = - match attributes.node_shape - with - | None -> bool - | Some shape -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "%s" (shape_in_dot shape) - in - true - in - let bool = - match attributes.node_width - with - | None -> bool - | Some i -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "width=\"%ipx\"" i - in - true + "label=\"%s\"" string in - let bool = - match attributes.node_height - with - | None -> bool - | Some i -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "height=\"%ipx\"" i - in - true + true + in + let bool = + match attributes.node_shape with + | None -> bool + | Some shape -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "%s" (shape_in_dot shape) in - let bool = - match attributes.node_color - with - | None -> bool - | Some s -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "color=\"%s\"" - (dot_color_encoding s) - in - true + true + in + let bool = + match attributes.node_width with + | None -> bool + | Some i -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "width=\"%ipx\"" i in - let bool = - match attributes.node_fillcolor - with - | None -> bool - | Some s -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "fillcolor=\"%s\" style=filled" - (dot_color_encoding s) - in - true + true + in + let bool = + match attributes.node_height with + | None -> bool + | Some i -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "height=\"%ipx\"" i in - let () = if bool then () in + true + in + let bool = + match attributes.node_color with + | None -> bool + | Some s -> + let () = between_attributes_in_dot logger bool in let () = Loggers.fprintf (Graph_loggers_sig.lift logger) - "];" + "color=\"%s\"" (dot_color_encoding s) in + true + in + let bool = + match attributes.node_fillcolor with + | None -> bool + | Some s -> + let () = between_attributes_in_dot logger bool in let () = - Loggers.print_newline (Graph_loggers_sig.lift logger) + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "fillcolor=\"%s\" style=filled" (dot_color_encoding s) in - () - end - in () - end - | Loggers.HTML_Graph -> + true + in + let () = if bool then () in + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "];" in + let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in + () + ) + in + () + | Loggers.HTML_Graph -> let id_int = Graph_loggers_sig.int_of_string_id logger id in let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "g.setNode(%i, { " id_int + Loggers.fprintf (Graph_loggers_sig.lift logger) "g.setNode(%i, { " id_int in let () = - if is_no_node_attributes attributes - then () - else - begin - let string = - match attributes.node_label - with - | None -> id - | Some string -> string - in - let string = String.escaped string in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "label: \"%s\"" string - in - let () = - match attributes.node_shape - with + if is_no_node_attributes attributes then + () + else ( + let string = + match attributes.node_label with + | None -> id + | Some string -> string + in + let string = String.escaped string in + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "label: \"%s\"" string + in + let () = + match attributes.node_shape with + | None -> () + | Some shape -> + (match shape_in_html shape with | None -> () | Some shape -> - begin - match shape_in_html shape - with - | None -> () - | Some shape -> - let () = between_attributes_in_html logger true in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) "%s" shape - in - () - end - in - let () = - match attributes.node_width - with - | None -> () - | Some i -> - let () = between_attributes_in_html logger true in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) "width: \"%i\"" i - in - () - in - let () = - match attributes.node_height - with - | None -> () - | Some i -> - let () = between_attributes_in_html logger true in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) "height: \"%i\"" i - in - () - in - let () = - match attributes.node_color - with - | None -> () - | Some s -> let () = between_attributes_in_html logger true in let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "color: \"%s\"" - (svg_color_encoding s) + Loggers.fprintf (Graph_loggers_sig.lift logger) "%s" shape in - () - in - let () = - match attributes.node_fillcolor - with - | None -> () - | Some s -> - let () = between_attributes_in_html logger true in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "style: \"fill: %s\" " - (svg_color_encoding s) - in - () - in - () - end - in - let () = Loggers.fprintf (Graph_loggers_sig.lift logger) " });@," in - () - | Loggers.TXT -> - begin - match attributes.node_label - with - | None -> + ()) + in let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) "Node: %s" id + match attributes.node_width with + | None -> () + | Some i -> + let () = between_attributes_in_html logger true in + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "width: \"%i\"" i + in + () in - let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in - () - | Some label -> let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "Node:%s, Label:%s" id label + match attributes.node_height with + | None -> () + | Some i -> + let () = between_attributes_in_html logger true in + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "height: \"%i\"" i + in + () + in + let () = + match attributes.node_color with + | None -> () + | Some s -> + let () = between_attributes_in_html logger true in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "color: \"%s\"" (svg_color_encoding s) + in + () + in + let () = + match attributes.node_fillcolor with + | None -> () + | Some s -> + let () = between_attributes_in_html logger true in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "style: \"fill: %s\" " (svg_color_encoding s) + in + () in - let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in () - end - | Loggers.GEPHI - | Loggers.Matrix - | Loggers.Js_Graph - | Loggers.Json -> Graph_loggers_sig.add_node logger id directives - | Loggers.DOTNET | Loggers.Mathematica - | Loggers.Maple | Loggers.Matlab | Loggers.Octave | Loggers.SBML - | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT_Tabular | Loggers.XLS -> () + ) + in + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) " });@," in + () + | Loggers.TXT -> + (match attributes.node_label with + | None -> + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "Node: %s" id in + let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in + () + | Some label -> + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "Node:%s, Label:%s" id label + in + let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in + ()) + | Loggers.GEPHI | Loggers.Matrix | Loggers.Js_Graph | Loggers.Json -> + Graph_loggers_sig.add_node logger id directives + | Loggers.DOTNET | Loggers.Mathematica | Loggers.Maple | Loggers.Matlab + | Loggers.Octave | Loggers.SBML | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT_Tabular | Loggers.XLS -> + () -let print_edge logger ?directives:(directives=[]) ?prefix:(prefix="") id1 id2 = +let print_edge logger ?(directives = []) ?(prefix = "") id1 id2 = let attributes = dummy_edge in let attributes = match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph | Loggers.Js_Graph - | Loggers.Json | Loggers.TXT | Loggers.HTML | Loggers.GEPHI -> + | Loggers.Json | Loggers.TXT | Loggers.HTML | Loggers.GEPHI -> List.fold_left (fun attributes option -> - match - option - with - | Graph_loggers_sig.Label s -> {attributes with edge_label = Some [s] } - | Graph_loggers_sig.Color s -> {attributes with edge_color = Some s } - | Graph_loggers_sig.LineStyle s -> {attributes with edge_style = s} - | Graph_loggers_sig.Direction s -> {attributes with edge_direction = s} - | Graph_loggers_sig.ArrowTail s -> {attributes with edge_arrowtail = s} - | Graph_loggers_sig.ArrowHead s -> {attributes with edge_arrowhead = s} - | Graph_loggers_sig.Position p -> - {attributes with edge_positions = p@attributes.edge_positions} - | Graph_loggers_sig.Contextual_help s -> - {attributes with edge_contextual_help = - match attributes.edge_contextual_help with - | None -> Some s - | Some s' -> Some (s'^s)} - | Graph_loggers_sig.OnClick json -> - {attributes with edge_on_click = Some json} - | Graph_loggers_sig.Shape _ - | Graph_loggers_sig.Width _ - | Graph_loggers_sig.Height _ - | Graph_loggers_sig.FillColor _ -> attributes - ) - attributes - directives - | Loggers.DOTNET | Loggers.Mathematica - | Loggers.Maple | Loggers.Matlab | Loggers.Octave | Loggers.SBML - | Loggers.TXT_Tabular | Loggers.XLS | Loggers.HTML_Tabular -> attributes + match option with + | Graph_loggers_sig.Label s -> + { attributes with edge_label = Some [ s ] } + | Graph_loggers_sig.Color s -> { attributes with edge_color = Some s } + | Graph_loggers_sig.LineStyle s -> { attributes with edge_style = s } + | Graph_loggers_sig.Direction s -> + { attributes with edge_direction = s } + | Graph_loggers_sig.ArrowTail s -> + { attributes with edge_arrowtail = s } + | Graph_loggers_sig.ArrowHead s -> + { attributes with edge_arrowhead = s } + | Graph_loggers_sig.Position p -> + { attributes with edge_positions = p @ attributes.edge_positions } + | Graph_loggers_sig.Contextual_help s -> + { + attributes with + edge_contextual_help = + (match attributes.edge_contextual_help with + | None -> Some s + | Some s' -> Some (s' ^ s)); + } + | Graph_loggers_sig.OnClick json -> + { attributes with edge_on_click = Some json } + | Graph_loggers_sig.Shape _ | Graph_loggers_sig.Width _ + | Graph_loggers_sig.Height _ | Graph_loggers_sig.FillColor _ -> + attributes) + attributes directives + | Loggers.DOTNET | Loggers.Mathematica | Loggers.Maple | Loggers.Matlab + | Loggers.Octave | Loggers.SBML | Loggers.TXT_Tabular | Loggers.XLS + | Loggers.HTML_Tabular -> + attributes in match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with | Loggers.DOT -> - begin - let direction = - match attributes.edge_direction - with - | Graph_loggers_sig.Direct -> - (string_one_of_linestyle_in_dot attributes.edge_style)^(string_of_arrow_head_in_dot Graph_loggers_sig.Normal) - | Graph_loggers_sig.Undirected -> (string_two_of_linestyle_in_dot attributes.edge_style) - | Graph_loggers_sig.Both -> (string_of_arrow_tail_in_dot Graph_loggers_sig.Normal)^(string_one_of_linestyle_in_dot attributes.edge_style)^(string_of_arrow_head_in_dot Graph_loggers_sig.Normal) - | Graph_loggers_sig.Reverse -> (string_of_arrow_tail_in_dot - Graph_loggers_sig.Normal)^(string_one_of_linestyle_in_dot - attributes.edge_style) - in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "\"%s\" %s \"%s\"" id1 direction id2 in - let () = - if is_no_edge_attributes attributes - then - () - else - let () = - Loggers.fprintf (Graph_loggers_sig.lift logger) " [" - in - let bool = false in - let bool = - match attributes.edge_label - with - | None -> bool - | Some string_list -> - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "label=\"" - in - let () = - List.iter - (Loggers.fprintf (Graph_loggers_sig.lift logger) "%s") - (List.rev string_list) - in - let () = - Loggers.fprintf (Graph_loggers_sig.lift logger) "\"" - in - true - in - let bool = - match attributes.edge_style - with - | Graph_loggers_sig.Plain -> bool - | Graph_loggers_sig.Dotted -> - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "style=\"dotted\"" - in - true - | Graph_loggers_sig.Dashed -> - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "style=\"dashed\"" - in - true - in - let bool = - match attributes.edge_color - with - | None -> bool - | Some s -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "color=\"%s\"" - (dot_color_encoding s) - in - true - in - let bool = - match attributes.edge_arrowhead - with - | Graph_loggers_sig.Normal -> bool - | Graph_loggers_sig.Tee -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "arrowhead=\"tee\"" - in - true - | Graph_loggers_sig.Vee -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "arrowhead=\"vee\"" - in - true - | Graph_loggers_sig.No_head -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "arrowhead=\"none\"" - in - true - in - let bool = - match attributes.edge_arrowtail - with - | Graph_loggers_sig.Normal -> bool - | Graph_loggers_sig.Tee -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "arrowtail=\"tee\"" - in - true - | Graph_loggers_sig.Vee -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "arrowtail=\"vee\"" - in - true - | Graph_loggers_sig.No_head -> - let () = between_attributes_in_dot logger bool in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "arrowtail=\"none\"" - in - true - in - let () = if bool then () in - let () = - Loggers.fprintf - (Graph_loggers_sig.lift logger) - "];" - in - let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in - () - in () - end - | Loggers.TXT | Loggers.HTML -> + let direction = + match attributes.edge_direction with + | Graph_loggers_sig.Direct -> + string_one_of_linestyle_in_dot attributes.edge_style + ^ string_of_arrow_head_in_dot Graph_loggers_sig.Normal + | Graph_loggers_sig.Undirected -> + string_two_of_linestyle_in_dot attributes.edge_style + | Graph_loggers_sig.Both -> + string_of_arrow_tail_in_dot Graph_loggers_sig.Normal + ^ string_one_of_linestyle_in_dot attributes.edge_style + ^ string_of_arrow_head_in_dot Graph_loggers_sig.Normal + | Graph_loggers_sig.Reverse -> + string_of_arrow_tail_in_dot Graph_loggers_sig.Normal + ^ string_one_of_linestyle_in_dot attributes.edge_style + in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "\"%s\" %s \"%s\"" id1 direction id2 + in + let () = + if is_no_edge_attributes attributes then + () + else ( + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) " [" in + let bool = false in + let bool = + match attributes.edge_label with + | None -> bool + | Some string_list -> + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "label=\"" + in + let () = + List.iter + (Loggers.fprintf (Graph_loggers_sig.lift logger) "%s") + (List.rev string_list) + in + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "\"" in + true + in + let bool = + match attributes.edge_style with + | Graph_loggers_sig.Plain -> bool + | Graph_loggers_sig.Dotted -> + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "style=\"dotted\"" + in + true + | Graph_loggers_sig.Dashed -> + let () = + Loggers.fprintf (Graph_loggers_sig.lift logger) "style=\"dashed\"" + in + true + in + let bool = + match attributes.edge_color with + | None -> bool + | Some s -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "color=\"%s\"" (dot_color_encoding s) + in + true + in + let bool = + match attributes.edge_arrowhead with + | Graph_loggers_sig.Normal -> bool + | Graph_loggers_sig.Tee -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "arrowhead=\"tee\"" + in + true + | Graph_loggers_sig.Vee -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "arrowhead=\"vee\"" + in + true + | Graph_loggers_sig.No_head -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "arrowhead=\"none\"" + in + true + in + let bool = + match attributes.edge_arrowtail with + | Graph_loggers_sig.Normal -> bool + | Graph_loggers_sig.Tee -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "arrowtail=\"tee\"" + in + true + | Graph_loggers_sig.Vee -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "arrowtail=\"vee\"" + in + true + | Graph_loggers_sig.No_head -> + let () = between_attributes_in_dot logger bool in + let () = + Loggers.fprintf + (Graph_loggers_sig.lift logger) + "arrowtail=\"none\"" + in + true + in + let () = if bool then () in + let () = Loggers.fprintf (Graph_loggers_sig.lift logger) "];" in + let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in + () + ) + in + () + | Loggers.TXT | Loggers.HTML -> let label = - match - attributes.edge_label - with - | None -> [""] + match attributes.edge_label with + | None -> [ "" ] | Some x -> x in let arrow = - match - attributes.edge_arrowhead - with + match attributes.edge_arrowhead with | Graph_loggers_sig.No_head -> "--" - | Graph_loggers_sig.Normal | Graph_loggers_sig.Vee -> "->" + | Graph_loggers_sig.Normal | Graph_loggers_sig.Vee -> "->" | Graph_loggers_sig.Tee -> "-|" in let () = @@ -1187,56 +1059,58 @@ let print_edge logger ?directives:(directives=[]) ?prefix:(prefix="") id1 id2 = in let () = Loggers.print_newline (Graph_loggers_sig.lift logger) in () -| Loggers.GEPHI -| Loggers.Matrix | Loggers.Json | Loggers.HTML_Graph | Loggers.Js_Graph -> - Graph_loggers_sig.add_edge logger id1 id2 directives -| Loggers.DOTNET | Loggers.Mathematica -| Loggers.Maple | Loggers.Matlab | Loggers.Octave | Loggers.SBML -| Loggers.HTML_Tabular | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.GEPHI | Loggers.Matrix | Loggers.Json | Loggers.HTML_Graph + | Loggers.Js_Graph -> + Graph_loggers_sig.add_edge logger id1 id2 directives + | Loggers.DOTNET | Loggers.Mathematica | Loggers.Maple | Loggers.Matlab + | Loggers.Octave | Loggers.SBML | Loggers.HTML_Tabular | Loggers.TXT_Tabular + | Loggers.XLS -> + () -let print_one_to_n_relation - logger ?directives:(directives=[]) - ?style_one:(style_one=Graph_loggers_sig.Plain) - ?style_n:(style_n=Graph_loggers_sig.Plain) id idlist - = - let fictitious = "Fictitious_"^id in +let print_one_to_n_relation logger ?(directives = []) + ?(style_one = Graph_loggers_sig.Plain) ?(style_n = Graph_loggers_sig.Plain) + id idlist = + let fictitious = "Fictitious_" ^ id in let directives_fict = - match - Loggers.get_encoding_format (Graph_loggers_sig.lift logger) - with - | Loggers.HTML_Graph -> - List.rev ((Graph_loggers_sig.Label "")::(Graph_loggers_sig.Shape Graph_loggers_sig.Circle)::(Graph_loggers_sig.Width 0)::(Graph_loggers_sig.Height 0)::(Graph_loggers_sig.FillColor Graph_loggers_sig.Black)::(List.rev directives)) - | Loggers.Js_Graph - | Loggers.Json - | Loggers.Matrix | Loggers.GEPHI - | Loggers.Mathematica | Loggers.Maple | Loggers.Matlab - | Loggers.Octave | Loggers.SBML | Loggers.DOTNET - | Loggers.HTML | Loggers.TXT | Loggers.DOT | Loggers.HTML_Tabular - | Loggers.TXT_Tabular | Loggers.XLS -> - List.rev ((Graph_loggers_sig.Label "")::(Graph_loggers_sig.Shape Graph_loggers_sig.Invisible)::(Graph_loggers_sig.Width 0)::(Graph_loggers_sig.Height 0)::(List.rev directives)) + match Loggers.get_encoding_format (Graph_loggers_sig.lift logger) with + | Loggers.HTML_Graph -> + List.rev + (Graph_loggers_sig.Label "" + :: Graph_loggers_sig.Shape Graph_loggers_sig.Circle + :: Graph_loggers_sig.Width 0 :: Graph_loggers_sig.Height 0 + :: Graph_loggers_sig.FillColor Graph_loggers_sig.Black + :: List.rev directives) + | Loggers.Js_Graph | Loggers.Json | Loggers.Matrix | Loggers.GEPHI + | Loggers.Mathematica | Loggers.Maple | Loggers.Matlab | Loggers.Octave + | Loggers.SBML | Loggers.DOTNET | Loggers.HTML | Loggers.TXT | Loggers.DOT + | Loggers.HTML_Tabular | Loggers.TXT_Tabular | Loggers.XLS -> + List.rev + (Graph_loggers_sig.Label "" + :: Graph_loggers_sig.Shape Graph_loggers_sig.Invisible + :: Graph_loggers_sig.Width 0 :: Graph_loggers_sig.Height 0 + :: List.rev directives) in let directives_one = - if style_one = Graph_loggers_sig.Plain - then + if style_one = Graph_loggers_sig.Plain then directives else - List.rev ((Graph_loggers_sig.LineStyle style_one)::(List.rev directives)) + List.rev (Graph_loggers_sig.LineStyle style_one :: List.rev directives) in let directives_n = - if style_n = Graph_loggers_sig.Plain - then + if style_n = Graph_loggers_sig.Plain then directives else - List.rev ((Graph_loggers_sig.LineStyle style_n)::(List.rev directives)) + List.rev (Graph_loggers_sig.LineStyle style_n :: List.rev directives) in let _ = print_node logger fictitious ~directives:directives_fict in let _ = print_edge logger ~directives:directives_one fictitious id in let _ = List.iter - (fun id' -> - print_edge logger ~directives:directives_n fictitious id') + (fun id' -> print_edge logger ~directives:directives_n fictitious id') idlist in () -let _ = let f t t' = t.edge_on_click, t'.node_on_click in f +let _ = + let f t t' = t.edge_on_click, t'.node_on_click in + f diff --git a/core/classical_graphs/graph_loggers.mli b/core/classical_graphs/graph_loggers.mli index 31879f9364..70ea523b96 100644 --- a/core/classical_graphs/graph_loggers.mli +++ b/core/classical_graphs/graph_loggers.mli @@ -16,26 +16,49 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -val dot_color_encoding: Graph_loggers_sig.color -> string -val shape_in_dot: Graph_loggers_sig.shape -> string +val dot_color_encoding : Graph_loggers_sig.color -> string +val shape_in_dot : Graph_loggers_sig.shape -> string -val print_graph_preamble: +val print_graph_preamble : Graph_loggers_sig.t -> ?filter_in:Loggers.encoding list option -> ?filter_out:Loggers.encoding list -> ?header:string list -> string -> unit -val print_graph_foot: Graph_loggers_sig.t -> unit -val print_comment: + +val print_graph_foot : Graph_loggers_sig.t -> unit + +val print_comment : Graph_loggers_sig.t -> ?filter_in:Loggers.encoding list option -> ?filter_out:Loggers.encoding list -> string -> unit -val open_asso: Graph_loggers_sig.t -> unit -val close_asso: Graph_loggers_sig.t -> unit -val print_asso: Graph_loggers_sig.t -> string -> string -> unit -val print_node: Graph_loggers_sig.t -> ?directives:Graph_loggers_sig.options list -> string -> unit -val print_edge: Graph_loggers_sig.t -> ?directives:Graph_loggers_sig.options list -> ?prefix:string -> string -> string -> unit -val print_one_to_n_relation: Graph_loggers_sig.t -> ?directives:Graph_loggers_sig.options list -> ?style_one:Graph_loggers_sig.linestyle -> ?style_n:Graph_loggers_sig.linestyle -> string -> string list -> unit + +val open_asso : Graph_loggers_sig.t -> unit +val close_asso : Graph_loggers_sig.t -> unit +val print_asso : Graph_loggers_sig.t -> string -> string -> unit + +val print_node : + Graph_loggers_sig.t -> + ?directives:Graph_loggers_sig.options list -> + string -> + unit + +val print_edge : + Graph_loggers_sig.t -> + ?directives:Graph_loggers_sig.options list -> + ?prefix:string -> + string -> + string -> + unit + +val print_one_to_n_relation : + Graph_loggers_sig.t -> + ?directives:Graph_loggers_sig.options list -> + ?style_one:Graph_loggers_sig.linestyle -> + ?style_n:Graph_loggers_sig.linestyle -> + string -> + string list -> + unit diff --git a/core/classical_graphs/graph_loggers_sig.ml b/core/classical_graphs/graph_loggers_sig.ml index eccbad5307..5e1e696022 100644 --- a/core/classical_graphs/graph_loggers_sig.ml +++ b/core/classical_graphs/graph_loggers_sig.ml @@ -21,7 +21,17 @@ type shape = Invisible | House | Rect | Ellipse | Circle | Invhouse type headkind = Normal | Vee | Tee | No_head type linestyle = Plain | Dotted | Dashed -type color = Red | Green | White | Blue | Black | LightSkyBlue | PaleGreen | Brown | Yellow | Grey +type color = + | Red + | Green + | White + | Blue + | Black + | LightSkyBlue + | PaleGreen + | Brown + | Yellow + | Grey type options = | Color of color @@ -36,70 +46,59 @@ type options = | LineStyle of linestyle | OnClick of Yojson.Basic.t | Contextual_help of string - | Position of Locality.t list + | Position of Loc.t list type graph = - (string * options list) list - * (string * string * options list) list + (string * options list) list * (string * string * options list) list -type t = - { - logger: Loggers.t; - id_map: int Mods.StringMap.t ref ; - fresh_id: int ref ; - nodes: (string * options list) list ref ; - edges: (string * string * options list) list ref ; - edges_map: options list list Mods.String2Map.t ref - } +type t = { + logger: Loggers.t; + id_map: int Mods.StringMap.t ref; + fresh_id: int ref; + nodes: (string * options list) list ref; + edges: (string * string * options list) list ref; + edges_map: options list list Mods.String2Map.t ref; +} + +let lift t = t.logger -let lift t = t.logger let extend_logger logger = - {logger; - id_map = ref Mods.StringMap.empty; - fresh_id = ref 1; - nodes = ref []; - edges = ref []; - edges_map = ref Mods.String2Map.empty; + { + logger; + id_map = ref Mods.StringMap.empty; + fresh_id = ref 1; + nodes = ref []; + edges = ref []; + edges_map = ref Mods.String2Map.empty; } let refresh_id t = - let () = t.id_map:= Mods.StringMap.empty in + let () = t.id_map := Mods.StringMap.empty in let () = t.nodes := [] in let () = t.edges := [] in let () = t.fresh_id := 1 in () +let add_node t s d = t.nodes := (s, d) :: !(t.nodes) -let add_node t s d = t.nodes:= (s,d)::(!(t.nodes)) let add_edge t s1 s2 d = - let () = t.edges:= (s1,s2,d)::(!(t.edges)) in + let () = t.edges := (s1, s2, d) :: !(t.edges) in let map = !(t.edges_map) in let old_list = - match - Mods.String2Map.find_option - (s1,s2) - map - with Some l -> l - | None -> [] - in - let () = - t.edges_map := - Mods.String2Map.add (s1,s2) (d::old_list) map + match Mods.String2Map.find_option (s1, s2) map with + | Some l -> l + | None -> [] in + let () = t.edges_map := Mods.String2Map.add (s1, s2) (d :: old_list) map in () - let graph_of_logger logger = List.rev !(logger.nodes), List.rev !(logger.edges) - let get_edge_map t = !(t.edges_map) let get_nodes t = !(t.nodes) - let fresh_id logger = Tools.get_ref logger.fresh_id let int_of_string_id logger string = - match - Mods.StringMap.find_option string !(logger.id_map) - with + match Mods.StringMap.find_option string !(logger.id_map) with | Some a -> a | None -> let i = fresh_id logger in diff --git a/core/classical_graphs/graph_loggers_sig.mli b/core/classical_graphs/graph_loggers_sig.mli index 00c96d7d57..411841ef0a 100644 --- a/core/classical_graphs/graph_loggers_sig.mli +++ b/core/classical_graphs/graph_loggers_sig.mli @@ -17,39 +17,47 @@ * under the terms of the GNU Library General Public License *) type t - type direction = Direct | Reverse | Undirected | Both type shape = Invisible | House | Rect | Ellipse | Circle | Invhouse type headkind = Normal | Vee | Tee | No_head type linestyle = Plain | Dotted | Dashed -type color = Red | Green | White | Blue | Black | LightSkyBlue | PaleGreen | Brown | Yellow | Grey +type color = + | Red + | Green + | White + | Blue + | Black + | LightSkyBlue + | PaleGreen + | Brown + | Yellow + | Grey type options = - | Color of color - | FillColor of color - | Label of string - | Width of int (*pixel*) - | Height of int (*pixel*) - | Direction of direction - | Shape of shape - | ArrowHead of headkind - | ArrowTail of headkind - | LineStyle of linestyle - | OnClick of Yojson.Basic.t - | Contextual_help of string - | Position of Locality.t list + | Color of color + | FillColor of color + | Label of string + | Width of int (*pixel*) + | Height of int (*pixel*) + | Direction of direction + | Shape of shape + | ArrowHead of headkind + | ArrowTail of headkind + | LineStyle of linestyle + | OnClick of Yojson.Basic.t + | Contextual_help of string + | Position of Loc.t list type graph = - (string * options list) list - * (string * string * options list) list + (string * options list) list * (string * string * options list) list -val extend_logger: Loggers.t -> t -val lift: t -> Loggers.t -val refresh_id: t -> unit -val int_of_string_id: t -> string -> int -val graph_of_logger: t -> graph -val add_node: t -> string -> options list -> unit -val add_edge: t -> string -> string -> options list -> unit -val get_edge_map: t -> options list list Mods.String2Map.t -val get_nodes: t -> (string * options list) list +val extend_logger : Loggers.t -> t +val lift : t -> Loggers.t +val refresh_id : t -> unit +val int_of_string_id : t -> string -> int +val graph_of_logger : t -> graph +val add_node : t -> string -> options list -> unit +val add_edge : t -> string -> string -> options list -> unit +val get_edge_map : t -> options list list Mods.String2Map.t +val get_nodes : t -> (string * options list) list diff --git a/core/cli/agent_args.ml b/core/cli/agent_args.ml index 857cf55768..69211d4512 100644 --- a/core/cli/agent_args.ml +++ b/core/cli/agent_args.ml @@ -6,24 +6,28 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type t = { mutable delimiter : char; } -let default : t = { delimiter = Tools.default_message_delimter; } +type t = { mutable delimiter: char } -let options (t :t) : (string * Arg.spec * string) list = [ - ("--delimiter", - Arg.String - (fun d -> - try - let d = Scanf.unescaped d in - let d = if 1 = String.length d then - String.get d 0 - else - raise (Arg.Bad (Format.sprintf "delimeter has multiple characters '%s'" d)) - in - let () = t.delimiter <- d in - () - with Scanf.Scan_failure _ -> - raise (Arg.Bad (Format.sprintf "failed to parse delimeter '%s'" d)) - ), - "Delimiter for message passing") ; +let default : t = { delimiter = Tools.default_message_delimter } + +let options (t : t) : (string * Arg.spec * string) list = + [ + ( "--delimiter", + Arg.String + (fun d -> + try + let d = Scanf.unescaped d in + let d = + if 1 = String.length d then + String.get d 0 + else + raise + (Arg.Bad + (Format.sprintf "delimeter has multiple characters '%s'" d)) + in + let () = t.delimiter <- d in + () + with Scanf.Scan_failure _ -> + raise (Arg.Bad (Format.sprintf "failed to parse delimeter '%s'" d))), + "Delimiter for message passing" ); ] diff --git a/core/cli/agent_args.mli b/core/cli/agent_args.mli index b24e11e8cd..4e1477b525 100644 --- a/core/cli/agent_args.mli +++ b/core/cli/agent_args.mli @@ -1,4 +1,4 @@ -type t = { mutable delimiter : char; } +type t = { mutable delimiter: char } -val options: t -> (string * Arg.spec * string) list -val default: t +val options : t -> (string * Arg.spec * string) list +val default : t diff --git a/core/cli/cli_init.ml b/core/cli/cli_init.ml index d541f17f86..d22d53fdf8 100644 --- a/core/cli/cli_init.ml +++ b/core/cli/cli_init.ml @@ -6,202 +6,272 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type preprocessed_ast = - Configuration.t * (bool * bool * bool) * string * - string option * Signature.s * Contact_map.t * unit NamedDecls.t * - int Mods.StringMap.t * int list * - (Ast.agent, LKappa.rule_agent list, Raw_mixture.t, int, LKappa.rule) Ast.compil * - (LKappa.rule_mixture, Raw_mixture.t, int) Ast.init_statment list option * - float option +type preprocessed_ast = { + conf: Configuration.t; + story_compression: bool * bool * bool; + formatCflow: string; + cflowFile: string option; + ast_compiled_data: LKappa_compiler.ast_compiled_data; + overwrite_init: + (LKappa.rule_mixture, Raw_mixture.t, int) Ast.init_statement list option; + overwrite_t0: float option; +} -let preprocess ~warning ~debugMode ?kasim_args cli_args ast = +type compilation_result = { + conf: Configuration.t; + env: Model.t; + contact_map: Contact_map.t; + updated_alg_vars: int list; + story_compression: (bool * bool * bool) option; + formatCflow: string; + cflowFile: string option; + init_l: (Primitives.alg_expr * Primitives.elementary_rule) list; + counter_opt: Counter.t option; +} + +let preprocess_ast ~warning ~debug_mode ?kasim_args cli_args + (ast : (_, _, _, _, _) Ast.compil) : preprocessed_ast = let () = Format.printf "+ simulation parameters@." in - let conf, - story_compression, formatCflow, cflowFile = - Configuration.parse ast.Ast.configurations in + let conf, story_compression, formatCflow, cflowFile = + Configuration.parse ast.Ast.configurations + in let () = Format.printf "+ Sanity checks@." in let syntax_version = cli_args.Run_cli_args.syntaxVersion in - let var_overwrite,initialMix = + let var_overwrite, initialMix = match kasim_args with - | None -> ([],None) + | None -> [], None | Some kasim_args -> - (kasim_args.Kasim_args.alg_var_overwrite,kasim_args.Kasim_args.initialMix) + kasim_args.Kasim_args.alg_var_overwrite, kasim_args.Kasim_args.initialMix + in + let ast_compiled_data : LKappa_compiler.ast_compiled_data = + LKappa_compiler.compil_of_ast ~warning ~debug_mode ~syntax_version + ~var_overwrite ast in - let (sigs_nd,contact_map,tk_nd,alg_finder,updated_vars,result') = - LKappa_compiler.compil_of_ast - ~warning ~debugMode ~syntax_version var_overwrite ast in - let overwrite_init,overwrite_t0 = match initialMix with - | None -> None,None + let overwrite_init, overwrite_t0 = + match initialMix with + | None -> None, None | Some file -> let compil = match syntax_version with - | Ast.V4 -> - Klexer4.compile Format.std_formatter Ast.empty_compil file + | Ast.V4 -> Klexer4.compile Format.std_formatter Ast.empty_compil file | Ast.V3 -> - KappaLexer.compile Format.std_formatter Ast.empty_compil file in - let conf, _, _, _ = - Configuration.parse compil.Ast.configurations in - Some - (LKappa_compiler.init_of_ast - ~warning ~syntax_version sigs_nd contact_map - tk_nd.NamedDecls.finder alg_finder compil.Ast.init), - conf.Configuration.initial in - conf, - story_compression, formatCflow, cflowFile,sigs_nd,contact_map,tk_nd,alg_finder, - updated_vars,result',overwrite_init,overwrite_t0 + KappaLexer.compile Format.std_formatter Ast.empty_compil file + in + let conf, _, _, _ = Configuration.parse compil.Ast.configurations in + ( Some + (LKappa_compiler.init_of_ast ~warning ~syntax_version + ast_compiled_data.agents_sig ast_compiled_data.contact_map + ast_compiled_data.token_names.NamedDecls.finder + ast_compiled_data.alg_vars_finder compil.Ast.init), + conf.Configuration.initial ) + in + { + conf; + story_compression; + formatCflow; + cflowFile; + ast_compiled_data; + overwrite_init; + overwrite_t0; + } -let get_ast_from_list_of_files syntax_version list = - let f = +let get_ast_from_list_of_files syntax_version file_list = + let compiling_function = match syntax_version with | Ast.V4 -> Klexer4.compile Format.std_formatter - | Ast.V3 -> KappaLexer.compile Format.std_formatter in - List.fold_left f Ast.empty_compil list + | Ast.V3 -> KappaLexer.compile Format.std_formatter + in + List.fold_left compiling_function Ast.empty_compil file_list let get_ast_from_cli_args cli_args = - get_ast_from_list_of_files - cli_args.Run_cli_args.syntaxVersion + get_ast_from_list_of_files cli_args.Run_cli_args.syntaxVersion cli_args.Run_cli_args.inputKappaFileNames -let get_preprocessed_ast_from_cli_args - ~warning ~debugMode ?(kasim_args=Kasim_args.default) cli_args = - let ast = - get_ast_from_list_of_files - cli_args.Run_cli_args.syntaxVersion +let get_preprocessed_ast_from_cli_args ~warning ~debug_mode + ?(kasim_args = Kasim_args.default) cli_args = + let ast : (Ast.agent, Ast.mixture, Ast.mixture, string, Ast.rule) Ast.compil = + get_ast_from_list_of_files cli_args.Run_cli_args.syntaxVersion cli_args.Run_cli_args.inputKappaFileNames in - preprocess ~warning ~debugMode cli_args ~kasim_args ast + preprocess_ast ~warning ~debug_mode cli_args ~kasim_args ast -let get_pack_from_preprocessed_ast ~kasim_args ~compileModeOn preprocessed_ast = - let conf, - story_compression, formatCflow, cflowFile,sigs_nd,contact_map,tk_nd, - _alg_finder, updated_vars,result',overwrite_init,overwrite_t0 - = preprocessed_ast - in - let n,w,s = story_compression in - let () = Format.printf "+ Compiling...@." in - let (env, has_tracking,init_l) = - Eval.compile - ~outputs:Outputs.go - ~pause:(fun f -> f ()) ~return:(fun x -> x) - ~debugMode:!Parameter.debugModeOn - ~sharing:kasim_args.Kasim_args.sharing +type compilation_pack = { + compilation_result: compilation_result; + alg_overwrite: (int * Primitives.alg_expr) list; + overwrite_t0: float option; +} + +let get_pack_from_preprocessed_ast kasim_args ~(compile_mode_on : bool) + (preprocessed_ast : preprocessed_ast) : compilation_pack = + let n, w, s = preprocessed_ast.story_compression in + let () = Format.printf "+ Compiling...@." in + let env, has_tracking, init_l = + Eval.compile ~outputs:Outputs.go + ~pause:(fun f -> f ()) + ~return:(fun x -> x) + ~debug_mode:!Parameter.debug_modeOn ~sharing:kasim_args.Kasim_args.sharing ?rescale_init:kasim_args.Kasim_args.rescale - ?overwrite_init ?overwrite_t0 ~compileModeOn sigs_nd tk_nd contact_map result' in + ?overwrite_init:preprocessed_ast.overwrite_init + ?overwrite_t0:preprocessed_ast.overwrite_t0 ~compile_mode_on + preprocessed_ast.ast_compiled_data.agents_sig + preprocessed_ast.ast_compiled_data.token_names + preprocessed_ast.ast_compiled_data.contact_map + preprocessed_ast.ast_compiled_data.result + in let story_compression = - if has_tracking && (n||w||s) then Some story_compression else None in - (conf, env, contact_map, updated_vars, story_compression, - formatCflow, cflowFile,init_l),[],overwrite_t0 + if has_tracking && (n || w || s) then + Some preprocessed_ast.story_compression + else + None + in + { + compilation_result = + { + conf = preprocessed_ast.conf; + env; + contact_map = preprocessed_ast.ast_compiled_data.contact_map; + updated_alg_vars = preprocessed_ast.ast_compiled_data.updated_alg_vars; + story_compression; + formatCflow = preprocessed_ast.formatCflow; + cflowFile = preprocessed_ast.cflowFile; + init_l; + counter_opt = None; + }; + alg_overwrite = []; + overwrite_t0 = preprocessed_ast.overwrite_t0; + } -let get_pack_from_marshalizedfile - ~warning kasim_args cli_args marshalized_file = +let get_pack_from_marshalizedfile ~warning kasim_args cli_args marshalized_file + : compilation_pack = assert (marshalized_file <> ""); try let d = open_in_bin marshalized_file in let () = if cli_args.Run_cli_args.inputKappaFileNames <> [] then - warning ~pos:Locality.dummy - (fun f -> - Format.pp_print_string - f "Simulation package loaded, all kappa files are ignored") in - let () = Format.printf "+ Loading simulation package %s...@." - marshalized_file in - let conf,env,contact,updated,compr,cflow,cflowfile,_ as pack = - (Marshal.from_channel d : - Configuration.t*Model.t*Contact_map.t*int list* - (bool*bool*bool) option*string*string option* - (Primitives.alg_expr * Primitives.elementary_rule) list) in - let () = Stdlib.close_in d in + warning ~pos:Loc.dummy (fun f -> + Format.pp_print_string f + "Simulation package loaded, all kappa files are ignored") + in + let () = + Format.printf "+ Loading simulation package %s...@." marshalized_file + in + let compilation_result : compilation_result = Marshal.from_channel d in + let () = Stdlib.close_in d in let alg_overwrite = List.map - (fun (s,v) -> - Model.num_of_alg (Locality.dummy_annot s) env, - Alg_expr.CONST v) - kasim_args.Kasim_args.alg_var_overwrite in + (fun (s, v) -> + ( Model.num_of_alg (Loc.annot_with_dummy s) compilation_result.env, + Alg_expr.CONST v )) + kasim_args.Kasim_args.alg_var_overwrite + in match kasim_args.Kasim_args.initialMix with - | None -> pack,alg_overwrite,None + | None -> { compilation_result; alg_overwrite; overwrite_t0 = None } | Some file -> let compil = - get_ast_from_list_of_files cli_args.Run_cli_args.syntaxVersion [file] in - let conf', _, _, _ = - Configuration.parse compil.Ast.configurations in + get_ast_from_list_of_files cli_args.Run_cli_args.syntaxVersion [ file ] + in + let overwrite_t0 : float option = + (Configuration.parse compil.Ast.configurations |> fun (a, _, _, _) -> a) + |> fun conf -> conf.Configuration.initial + in + let raw_inits = - LKappa_compiler.init_of_ast - ~warning ~syntax_version:cli_args.Run_cli_args.syntaxVersion - (Model.signatures env) contact - (Model.tokens_finder env) (Model.algs_finder env) compil.Ast.init in - let inits = Eval.compile_inits - ~debugMode:!Parameter.debugModeOn - ~warning ?rescale:kasim_args.Kasim_args.rescale - ~compileModeOn:false contact env raw_inits in - (conf,env,contact,updated,compr,cflow,cflowfile,inits), - alg_overwrite,conf'.Configuration.initial + LKappa_compiler.init_of_ast ~warning + ~syntax_version:cli_args.Run_cli_args.syntaxVersion + (Model.signatures compilation_result.env) + compilation_result.contact_map + (Model.tokens_finder compilation_result.env) + (Model.algs_finder compilation_result.env) + compil.Ast.init + in + let init_l = + Eval.compile_inits ~debug_mode:!Parameter.debug_modeOn ~warning + ?rescale:kasim_args.Kasim_args.rescale ~compile_mode_on:false + compilation_result.contact_map compilation_result.env raw_inits + in + { + compilation_result = { compilation_result with init_l }; + alg_overwrite; + overwrite_t0; + } with | ExceptionDefn.Malformed_Decl _ as e -> raise e | _exn -> Format.printf - "Simulation package seems to have been created with a different version of KaSim, aborting..."; + "Simulation package seems to have been created with a different version \ + of KaSim, aborting..."; exit 1 -let get_compilation_from_pack ~warning kasim_args cli_args pack = - let (conf, env0, contact_map, updated_vars, story_compression, - formatCflows, cflowFile, init_l), - alg_overwrite,overwrite_t0 = pack in - let init_t_from_files = - Option_util.unsome - (Option_util.unsome 0. conf.Configuration.initial) - overwrite_t0 in - let init_t,max_time,init_e,max_event,plot_period = +let get_compilation_from_pack ~warning kasim_args cli_args + (pack : compilation_pack) : compilation_result = + let init_t_from_files = + Option_util.unsome + (Option_util.unsome 0. pack.compilation_result.conf.Configuration.initial) + pack.overwrite_t0 + in + let init_t, max_time, init_e, max_event, plot_period = match kasim_args.Kasim_args.unit with | Kasim_args.Time -> - Option_util.unsome init_t_from_files cli_args.Run_cli_args.minValue, - cli_args.Run_cli_args.maxValue, - None,None, - (match cli_args.Run_cli_args.plotPeriod with - | Some a -> Configuration.DT a - | None -> - Option_util.unsome (Configuration.DT 1.) conf.Configuration.plotPeriod) + ( Option_util.unsome init_t_from_files cli_args.Run_cli_args.minValue, + cli_args.Run_cli_args.maxValue, + None, + None, + (match cli_args.Run_cli_args.plotPeriod with + | Some a -> Configuration.DT a + | None -> + Option_util.unsome (Configuration.DT 1.) + pack.compilation_result.conf.Configuration.plotPeriod) ) | Kasim_args.Event -> - init_t_from_files,None, - Some (int_of_float - (Option_util.unsome 0. cli_args.Run_cli_args.minValue)), - Option_util.map int_of_float cli_args.Run_cli_args.maxValue, - match cli_args.Run_cli_args.plotPeriod with - | Some a -> Configuration.DE (int_of_float (ceil a)) - | None -> - Option_util.unsome (Configuration.DE 1) conf.Configuration.plotPeriod in + ( init_t_from_files, + None, + Some + (int_of_float (Option_util.unsome 0. cli_args.Run_cli_args.minValue)), + Option_util.map int_of_float cli_args.Run_cli_args.maxValue, + (match cli_args.Run_cli_args.plotPeriod with + | Some a -> Configuration.DE (int_of_float (ceil a)) + | None -> + Option_util.unsome (Configuration.DE 1) + pack.compilation_result.conf.Configuration.plotPeriod) ) + in let counter = - Counter.create - ~init_t ?init_e ?max_time ?max_event - ~plot_period ~nb_rules:(Model.nb_rules env0) () in + Counter.create ~init_t ?init_e ?max_time ?max_event ~plot_period + ~nb_rules:(Model.nb_rules pack.compilation_result.env) + () + in let env = - if cli_args.Run_cli_args.batchmode && - kasim_args.Kasim_args.marshalizeOutFile = None then - Model.propagate_constant - ~warning ?max_time:(Counter.max_time counter) - ?max_events:(Counter.max_events counter) updated_vars alg_overwrite env0 - else Model.overwrite_vars alg_overwrite env0 in - (conf, env, contact_map, updated_vars, story_compression, - formatCflows, cflowFile, init_l),counter + if + cli_args.Run_cli_args.batchmode + && kasim_args.Kasim_args.marshalizeOutFile = None + then + Model.propagate_constant ~warning ?max_time:(Counter.max_time counter) + ?max_events:(Counter.max_events counter) + ~updated_vars:pack.compilation_result.updated_alg_vars + ~alg_overwrite:pack.alg_overwrite pack.compilation_result.env + else + Model.overwrite_vars pack.alg_overwrite pack.compilation_result.env + in + { pack.compilation_result with env; counter_opt = Some counter } -let get_compilation_from_preprocessed_ast - ~warning ?(compileModeOn=false) ?(kasim_args=Kasim_args.default) - cli_args preprocessed = - let pack = - get_pack_from_preprocessed_ast ~kasim_args ~compileModeOn preprocessed in - get_compilation_from_pack ~warning kasim_args cli_args pack +let get_compilation_from_preprocessed_ast ~warning ?(compile_mode_on = false) + ?(kasim_args = Kasim_args.default) cli_args preprocessed_ast : + compilation_result = + let pack = + get_pack_from_preprocessed_ast kasim_args ~compile_mode_on preprocessed_ast + in + get_compilation_from_pack ~warning kasim_args cli_args pack -let get_compilation - ~warning ~debugMode ?(compileModeOn=false) - ?(kasim_args=Kasim_args.default) cli_args = - let pack = - match kasim_args.Kasim_args.marshalizedInFile with - | "" -> - let preprocess = - get_preprocessed_ast_from_cli_args - ~warning ~debugMode cli_args in - get_pack_from_preprocessed_ast - ~kasim_args ~compileModeOn preprocess - | marshalized_file -> - get_pack_from_marshalizedfile - ~warning kasim_args cli_args marshalized_file in - get_compilation_from_pack ~warning kasim_args cli_args pack +let get_compilation ~warning ~debug_mode ?(compile_mode_on = false) + ?(kasim_args = Kasim_args.default) cli_args : compilation_result = + let (pack : compilation_pack) = + match kasim_args.Kasim_args.marshalizedInFile with + | "" -> + let preprocessed_ast = + get_preprocessed_ast_from_cli_args ~warning ~debug_mode cli_args + in + get_pack_from_preprocessed_ast kasim_args ~compile_mode_on + preprocessed_ast + | marshalized_file -> + get_pack_from_marshalizedfile ~warning kasim_args cli_args + marshalized_file + in + get_compilation_from_pack ~warning kasim_args cli_args pack diff --git a/core/cli/cli_init.mli b/core/cli/cli_init.mli index 789f7bd9cf..707ab93a18 100644 --- a/core/cli/cli_init.mli +++ b/core/cli/cli_init.mli @@ -5,38 +5,65 @@ (* | . \ * This file is distributed under the terms of the *) (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type preprocessed_ast +type preprocessed_ast = { + conf: Configuration.t; + story_compression: bool * bool * bool; + formatCflow: string; + cflowFile: string option; + ast_compiled_data: LKappa_compiler.ast_compiled_data; + overwrite_init: + (LKappa.rule_mixture, Raw_mixture.t, int) Ast.init_statement list option; + overwrite_t0: float option; +} + +(* TODO contact map is also in env *) +type compilation_result = { + conf: Configuration.t; + env: Model.t; + contact_map: Contact_map.t; + updated_alg_vars: int list; + story_compression: (bool * bool * bool) option; + formatCflow: string; + cflowFile: string option; + init_l: (Primitives.alg_expr * Primitives.elementary_rule) list; + counter_opt: Counter.t option; + (* TODO Should we keep counter_opt here, or create another type? *) +} + +(* TODO change calls to this *) val get_compilation : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - debugMode:bool -> ?compileModeOn:bool -> ?kasim_args:Kasim_args.t -> + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + debug_mode:bool -> + ?compile_mode_on:bool -> + ?kasim_args:Kasim_args.t -> Run_cli_args.t -> - (Configuration.t * Model.t * Contact_map.t * int list * - (bool*bool*bool) option * string * string option * - (Primitives.alg_expr * Primitives.elementary_rule) list) * - Counter.t + compilation_result -val get_ast_from_list_of_files: +val get_ast_from_list_of_files : Ast.syntax_version -> string list -> Ast.parsing_compil -val get_ast_from_cli_args: - Run_cli_args.t -> Ast.parsing_compil +val get_ast_from_cli_args : Run_cli_args.t -> Ast.parsing_compil -val get_preprocessed_ast_from_cli_args: - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - debugMode:bool -> ?kasim_args:Kasim_args.t -> Run_cli_args.t -> +val get_preprocessed_ast_from_cli_args : + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + debug_mode:bool -> + ?kasim_args:Kasim_args.t -> + Run_cli_args.t -> preprocessed_ast -val preprocess: - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - debugMode:bool -> ?kasim_args:Kasim_args.t -> Run_cli_args.t -> - Ast.parsing_compil -> preprocessed_ast +val preprocess_ast : + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + debug_mode:bool -> + ?kasim_args:Kasim_args.t -> + Run_cli_args.t -> + Ast.parsing_compil -> + preprocessed_ast val get_compilation_from_preprocessed_ast : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - ?compileModeOn:bool -> ?kasim_args:Kasim_args.t -> - Run_cli_args.t -> preprocessed_ast -> - (Configuration.t * Model.t * Contact_map.t * int list * - (bool*bool*bool) option * string * string option * - (Primitives.alg_expr * Primitives.elementary_rule) list) * - Counter.t + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + ?compile_mode_on:bool -> + ?kasim_args:Kasim_args.t -> + Run_cli_args.t -> + preprocessed_ast -> + compilation_result diff --git a/core/cli/common_args.ml b/core/cli/common_args.ml index 8699b7f487..166e5a06db 100644 --- a/core/cli/common_args.ml +++ b/core/cli/common_args.ml @@ -6,90 +6,92 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -let data_set = "Data set",0,None -let output = "Output",1,None -let semantics = "Semantics",2,None -let integration_settings = "Integration settings",3,None -let model_reduction = "Model reduction",4,None -let static_analysis = "Static analysis" , 5,Some Superarg.Expert -let debug_mode = "Debug mode",6,Some Superarg.Expert +let data_set = "Data set", 0, None +let output = "Output", 1, None +let semantics = "Semantics", 2, None +let integration_settings = "Integration settings", 3, None +let model_reduction = "Model reduction", 4, None +let static_analysis = "Static analysis", 5, Some Superarg.Expert +let debug_mode = "Debug mode", 6, Some Superarg.Expert -type t = { mutable backtrace : bool ; - mutable debug : bool } +type t = { mutable backtrace: bool; mutable debug: bool } type t_gui = { - backtrace_gui : bool ref ; - debug_gui : bool ref ; - version_gui : bool ref ; - gluttony_gui : bool ref ; -} -let default : t = { - backtrace = false; debug = false; + backtrace_gui: bool ref; + debug_gui: bool ref; + version_gui: bool ref; + gluttony_gui: bool ref; } +let default : t = { backtrace = false; debug = false } + let default_gui = { - backtrace_gui = ref false ; - debug_gui = ref false ; - version_gui = ref false ; - gluttony_gui = ref false + backtrace_gui = ref false; + debug_gui = ref false; + version_gui = ref false; + gluttony_gui = ref false; } -let do_version = - (fun () -> Format.print_string Version.version_msg; - Format.print_newline () ; exit 0) +let do_version () = + Format.print_string Version.version_msg; + Format.print_newline (); + exit 0 -let do_gluttony = - (fun () -> Gc.set { (Gc.get()) with - Gc.space_overhead = 500 (*default 80*) } ;) +let do_gluttony () = + Gc.set { (Gc.get ()) with Gc.space_overhead = 500 (*default 80*) } let get_from_gui t_gui = - let () = - if !(t_gui.version_gui) then - do_version () - in - let () = - if !(t_gui.gluttony_gui) then - do_gluttony () - in - { - backtrace = !(t_gui.backtrace_gui) ; - debug = !(t_gui.debug_gui) ; - } + let () = if !(t_gui.version_gui) then do_version () in + let () = if !(t_gui.gluttony_gui) then do_gluttony () in + { backtrace = !(t_gui.backtrace_gui); debug = !(t_gui.debug_gui) } let copy_from_gui t_gui t = let t_tmp = get_from_gui t_gui in t.backtrace <- t_tmp.backtrace; t.debug <- t_tmp.debug -let options_gen t t_gui : (string * Arg.spec * Superarg.spec * string * - (Superarg.category * Superarg.position) list * Superarg.level) list = [ - ("--version", - Arg.Unit do_version, - Superarg.Bool t_gui.version_gui, - "display version number", - [],Superarg.Hidden); - ("--debug", Arg.Unit (fun () -> t.debug <- true), - Superarg.Bool t_gui.debug_gui, - "Enable debug mode", - [debug_mode,1],Superarg.Expert) ; - ("--backtrace", Arg.Unit (fun () -> t.backtrace <- true), - Superarg.Bool t_gui.backtrace_gui, - "Backtracing exceptions", - [debug_mode,2],Superarg.Expert) ; - ("--gluttony", - Arg.Unit do_gluttony, - Superarg.Bool t_gui.gluttony_gui, - "Lower gc activity for a faster but memory intensive simulation", - [debug_mode,3],Superarg.Expert) ; -] +let options_gen t t_gui : + (string + * Arg.spec + * Superarg.spec + * string + * (Superarg.category * Superarg.position) list + * Superarg.level) + list = + [ + ( "--version", + Arg.Unit do_version, + Superarg.Bool t_gui.version_gui, + "display version number", + [], + Superarg.Hidden ); + ( "--debug", + Arg.Unit (fun () -> t.debug <- true), + Superarg.Bool t_gui.debug_gui, + "Enable debug mode", + [ debug_mode, 1 ], + Superarg.Expert ); + ( "--backtrace", + Arg.Unit (fun () -> t.backtrace <- true), + Superarg.Bool t_gui.backtrace_gui, + "Backtracing exceptions", + [ debug_mode, 2 ], + Superarg.Expert ); + ( "--gluttony", + Arg.Unit do_gluttony, + Superarg.Bool t_gui.gluttony_gui, + "Lower gc activity for a faster but memory intensive simulation", + [ debug_mode, 3 ], + Superarg.Expert ); + ] let options t = List.rev_map - (fun (a,b,_,c,_,_) -> a,b,c) + (fun (a, b, _, c, _, _) -> a, b, c) (List.rev (options_gen t default_gui)) let options_gui t_gui = List.rev_map - (fun (a,_,b,c,d,e) -> a,b,c,d,e) + (fun (a, _, b, c, d, e) -> a, b, c, d, e) (List.rev (options_gen default t_gui)) diff --git a/core/cli/common_args.mli b/core/cli/common_args.mli index a37ab75f71..bce478b96c 100644 --- a/core/cli/common_args.mli +++ b/core/cli/common_args.mli @@ -6,27 +6,30 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -val data_set: Superarg.category -val output: Superarg.category -val semantics: Superarg.category -val integration_settings: Superarg.category -val model_reduction: Superarg.category -val static_analysis: Superarg.category -val debug_mode: Superarg.category - -type t = { - mutable backtrace : bool; - mutable debug : bool; -} +val data_set : Superarg.category +val output : Superarg.category +val semantics : Superarg.category +val integration_settings : Superarg.category +val model_reduction : Superarg.category +val static_analysis : Superarg.category +val debug_mode : Superarg.category +type t = { mutable backtrace: bool; mutable debug: bool } type t_gui val default : t val default_gui : t_gui + (* return options *) val options : t -> (string * Arg.spec * string) list + val options_gui : t_gui -> - (string * Superarg.spec * string * (Superarg.category * Superarg.position) list * Superarg.level) list + (string + * Superarg.spec + * string + * (Superarg.category * Superarg.position) list + * Superarg.level) + list -val copy_from_gui: t_gui -> t -> unit +val copy_from_gui : t_gui -> t -> unit diff --git a/core/cli/dune b/core/cli/dune index c8748cc11d..dd19581b4d 100644 --- a/core/cli/dune +++ b/core/cli/dune @@ -1,15 +1,28 @@ (library - (name kappa_cli) - (libraries lwt - (select superargTk.ml from - (labltk.jpf -> superargTk.tk.ml) - ( -> superargTk.notk.ml)) - kappa_grammar - kappa-library.runtime kappa_version) - (flags (:standard -w @a - -open Kappa_version - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms - -open Kappa_grammar - -open Kappa_runtime))) + (name kappa_cli) + (libraries + unix lwt + (select + superargTk.ml + from + (labltk.jpf -> superargTk.tk.ml) + (-> superargTk.notk.ml)) + kappa_grammar + kappa-library.runtime + kappa_version) + (flags + (:standard + -w + @a-40-42 + -open + Kappa_version + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms + -open + Kappa_grammar + -open + Kappa_runtime))) diff --git a/core/cli/kappa_files.ml b/core/cli/kappa_files.ml index a14abf5c59..7687ac515e 100644 --- a/core/cli/kappa_files.ml +++ b/core/cli/kappa_files.ml @@ -15,15 +15,20 @@ let fluxFileName = ref "" let mk_dir_r d = let rec aux d = - if not (Sys.file_exists d) then + if not (Sys.file_exists d) then ( let () = aux (Filename.dirname d) in - Unix.mkdir d 0o775 in + Unix.mkdir d 0o775 + ) + in Unix.handle_unix_error aux d let overwrite_permission = ref false let path f = - if Filename.is_implicit f then Filename.concat !outputDirName f else f + if Filename.is_implicit f then + Filename.concat !outputDirName f + else + f let open_out f = let x = path f in @@ -31,66 +36,89 @@ let open_out f = open_out x let rec aux_open_out_fresh base v ext = - try open_out_gen - [Open_wronly; Open_creat; Open_excl; Open_text] - 0o666 (base^"~"^(string_of_int v)^ext) + try + open_out_gen + [ Open_wronly; Open_creat; Open_excl; Open_text ] + 0o666 + (base ^ "~" ^ string_of_int v ^ ext) with Sys_error _ -> aux_open_out_fresh base (succ v) ext let open_out_fresh name concat_list facultative ext = let name = path name in let () = mk_dir_r (Filename.dirname name) in let tmp_name = Tools.chop_suffix_or_extension name ext in - let base = String.concat "_" (tmp_name::concat_list) in - let over_flag = if !overwrite_permission then Open_trunc else Open_excl in + let base = String.concat "_" (tmp_name :: concat_list) in + let over_flag = + if !overwrite_permission then + Open_trunc + else + Open_excl + in let flags = [ Open_wronly; Open_creat; over_flag; Open_text ] in - try open_out_gen flags 0o666 (base^ext) + try open_out_gen flags 0o666 (base ^ ext) with Sys_error _ -> - let base' = if facultative <> "" then base^"_"^facultative else base in - try open_out_gen flags 0o666 (base'^ext) - with Sys_error _ -> - aux_open_out_fresh base' 0 ext + let base' = + if facultative <> "" then + base ^ "_" ^ facultative + else + base + in + (try open_out_gen flags 0o666 (base' ^ ext) + with Sys_error _ -> aux_open_out_fresh base' 0 ext) let set name ext_opt = - if !name <> "" then + if !name <> "" then ( let fname = match ext_opt with | None -> !name | Some ext -> - if (Filename.check_suffix !name ext) then !name + if Filename.check_suffix !name ext then + !name else - (!name^"."^ext) in - name:=fname + !name ^ "." ^ ext + in + name := fname + ) let setOutputName () = - set fluxFileName (Some "dot") ; + set fluxFileName (Some "dot"); set marshalizedOutFile None let check_not_exists = function | "" -> () | file -> let file = path file in - if Sys.file_exists file then + if Sys.file_exists file then ( let () = - Format.eprintf - "File '%s' already exists do you want to erase (y/N)?@." file in + Format.eprintf "File '%s' already exists do you want to erase (y/N)?@." + file + in let answer = Tools.read_input () in - if answer<>"y" && answer<>"Y" && answer<>"yes" && - answer<>"YES" && answer<>"Yes" then exit 1 - else overwrite_permission := true + if + answer <> "y" && answer <> "Y" && answer <> "yes" && answer <> "YES" + && answer <> "Yes" + then + exit 1 + else + overwrite_permission := true + ) let setCheckFileExists ~batchmode outputFile = let () = setOutputName () in - if batchmode then overwrite_permission := true - else + if batchmode then + overwrite_permission := true + else ( let () = check_not_exists !fluxFileName in let () = check_not_exists !marshalizedOutFile in check_not_exists outputFile + ) let with_channel str f = - if str <> "" then + if str <> "" then ( let desc = open_out str in let () = f desc in close_out desc + ) let wrap_formatter f desc = let fr = Format.formatter_of_out_channel desc in @@ -98,15 +126,19 @@ let wrap_formatter f desc = Format.pp_print_flush fr () let set_dir s = - let () = try - if not (Sys.is_directory s) - then (Format.eprintf "'%s' is not a directory@." s ; exit 1) - with Sys_error _ -> mk_dir_r s in + let () = + try + if not (Sys.is_directory s) then ( + Format.eprintf "'%s' is not a directory@." s; + exit 1 + ) + with Sys_error _ -> mk_dir_r s + in outputDirName := s let get_dir () = !outputDirName - let set_marshalized f = marshalizedOutFile := f + let with_marshalized f = match !marshalizedOutFile with | "" -> () @@ -118,23 +150,31 @@ let with_marshalized f = close_out d let set_cflow s = cflowFileName := s + let with_cflow_file l e f = let desc = open_out_fresh !cflowFileName l "" e in let () = wrap_formatter f desc in close_out desc let open_tasks_profiling () = open_out !tasks_profilingName -let open_branch_and_cut_engine_profiling () = open_out !branch_and_cut_engine_profilingName + +let open_branch_and_cut_engine_profiling () = + open_out !branch_and_cut_engine_profilingName + let set_flux nme event = let () = match nme with - | "" -> fluxFileName := "flux"^"_"^(string_of_int event) + | "" -> fluxFileName := "flux" ^ "_" ^ string_of_int event | _ -> fluxFileName := nme in set fluxFileName (Some "dot") let with_flux str f = - with_channel (match str with "" -> !fluxFileName | _ -> str) f + with_channel + (match str with + | "" -> !fluxFileName + | _ -> str) + f let with_snapshot str ext event f = let desc = open_out_fresh str [] (string_of_int event) ext in diff --git a/core/cli/kappa_files.mli b/core/cli/kappa_files.mli index 7844386199..690f13a634 100644 --- a/core/cli/kappa_files.mli +++ b/core/cli/kappa_files.mli @@ -6,9 +6,11 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -(** Utilities on files *) +(** Utilities on files + * Stores file paths used by the kappa system and access to them *) val open_out : string -> out_channel + val open_out_fresh : string -> string list -> string -> string -> out_channel (** [open_out_fresh base concat_list facultative ext] *) @@ -18,20 +20,17 @@ val check_not_exists : string -> unit val setCheckFileExists : batchmode:bool -> string -> unit val set_dir : string -> unit val get_dir : unit -> string - val set_marshalized : string -> unit val with_marshalized : (out_channel -> unit) -> unit - val set_cflow : string -> unit + val with_cflow_file : string list -> string -> (Format.formatter -> unit) -> unit val open_tasks_profiling : unit -> out_channel -val open_branch_and_cut_engine_profiling: unit -> out_channel - +val open_branch_and_cut_engine_profiling : unit -> out_channel val set_flux : string -> int -> unit val with_flux : string -> (out_channel -> unit) -> unit - val with_snapshot : string -> string -> int -> (out_channel -> unit) -> unit val with_channel : string -> (out_channel -> unit) -> unit diff --git a/core/cli/kasim_args.ml b/core/cli/kasim_args.ml index 16f84cb873..c25213b9e7 100644 --- a/core/cli/kasim_args.ml +++ b/core/cli/kasim_args.ml @@ -9,111 +9,118 @@ type directive_unit = Time | Event type t = { - mutable alg_var_overwrite : (string * Nbr.t) list; - mutable marshalizedInFile : string; - mutable initialMix : string option; - mutable rescale : float option; - mutable seedValue : int option; - mutable unit : directive_unit; - mutable marshalizeOutFile : string option; - mutable domainOutputFile : string option; - mutable traceFile : string option; - mutable logFile : string option; - mutable compileMode : bool; - mutable sharing : Pattern.sharing_level; - mutable showEfficiency : bool; - mutable timeIndependent : bool; + mutable alg_var_overwrite: (string * Nbr.t) list; + mutable marshalizedInFile: string; + mutable initialMix: string option; + mutable rescale: float option; + mutable seedValue: int option; + mutable unit: directive_unit; + mutable marshalizeOutFile: string option; + mutable domainOutputFile: string option; + mutable traceFile: string option; + mutable logFile: string option; + mutable compile_mode: bool; + mutable sharing: Pattern.sharing_level; + mutable showEfficiency: bool; + mutable timeIndependent: bool; } -let default : t = { - alg_var_overwrite = []; - rescale = None; - marshalizedInFile = ""; - initialMix = None; - seedValue = None; - unit = Time; - marshalizeOutFile = None; - domainOutputFile = None; - traceFile = None; - logFile = Some "inputs"; - compileMode = false; - sharing = Pattern.Compatible_patterns; - showEfficiency = false; - timeIndependent = false; -} +let default : t = + { + alg_var_overwrite = []; + rescale = None; + marshalizedInFile = ""; + initialMix = None; + seedValue = None; + unit = Time; + marshalizeOutFile = None; + domainOutputFile = None; + traceFile = None; + logFile = Some "inputs"; + compile_mode = false; + sharing = Pattern.Compatible_patterns; + showEfficiency = false; + timeIndependent = false; + } -let options (t :t) : (string * Arg.spec * string) list = [ - ("-mixture", - Arg.String (fun fic -> t.initialMix <- Some fic), - "Take the initial state from this file (ignore %init from other files)") ; - ("-var", - Arg.Tuple - (let tmp_var_name = ref "" in - [Arg.String (fun name -> tmp_var_name := name); - Arg.String (fun var_val -> - t.alg_var_overwrite <- - (!tmp_var_name, - try Nbr.of_string var_val with - Failure _ -> - raise (Arg.Bad ("\""^var_val^"\" is not a valid value"))) - ::t.alg_var_overwrite)]), - "Set a variable to a given value") ; - ("-load-sim", - Arg.String (fun file -> t.marshalizedInFile <- file), - "load simulation package instead of kappa files"); - ("-rescale", - Arg.Float (fun i -> t.rescale <- Some i), - "Apply rescaling factor to initial condition"); - ("-u", - Arg.String - (function - | "time" | "Time" | "t" -> t.unit <- Time - | "event" | "events" | "e" | "Event" | "Events" -> t.unit <- - Event - | s -> raise (Arg.Bad ("Unrecognized unit: "^s))), - "unit (time/event) in which limit and plot period are specified"); - ("-e", - Arg.Int (fun e -> - raise (Arg.Bad ("Option '-e' has been replace by '-u event -l "^ - string_of_int e^"'"))),"Deprecated option"); - ("-make-sim", - Arg.String - (fun marshalizeOutFile -> t.marshalizeOutFile <- Some - marshalizeOutFile), - "save kappa files as a simulation package") ; - ("-dump-cc", - Arg.String - (fun domainOutputFile -> t.domainOutputFile <- Some domainOutputFile), - "file name for dumping the domain of observables") ; - ("-trace", - Arg.String - (fun traceFile -> t.traceFile <- Some traceFile), - "file name for dumping the simulation trace") ; - ("--time-independent", - Arg.Unit (fun () -> t.timeIndependent <- true), - "Disable the use of time is story heuritics (for test suite)"); - ("-seed", Arg.Int (fun i -> t.seedValue <- Some i), - "Seed for the random number generator") ; - ("--print-efficiency", - Arg.Unit (fun () -> t.showEfficiency <- true), - "KaSim tells how fast it runs") ; - ("-sharing", - Arg.String (function - | "no" | "none" | "None" -> t.sharing <- Pattern.No_sharing - | "Compatible" -> t.sharing <- Pattern.Max_sharing - | "max" | "Max" -> t.sharing <- Pattern.Max_sharing - | s -> raise (Arg.Bad ("Unrecognized sharing level: "^s))), - "Level of sharing computed between patterns \ - during initialization (None/Compatible/Max)"); - ("--compile", - Arg.Unit (fun () -> t.compileMode <- true), - "Display rule compilation as action list") ; - ("-log", - Arg.String - (fun logFile -> t.logFile <- Some logFile), - "file name of the file to regenerate the exact same simulation") ; - ("--no-log", - Arg.Unit - (fun () -> t.logFile <- None), - "Do not generate a file to redo the exact same simulation") ; -] +let options (t : t) : (string * Arg.spec * string) list = + [ + ( "-mixture", + Arg.String (fun fic -> t.initialMix <- Some fic), + "Take the initial state from this file (ignore %init from other files)" ); + ( "-var", + Arg.Tuple + (let tmp_var_name = ref "" in + [ + Arg.String (fun name -> tmp_var_name := name); + Arg.String + (fun var_val -> + t.alg_var_overwrite <- + ( !tmp_var_name, + try Nbr.of_string var_val + with Failure _ -> + raise + (Arg.Bad ("\"" ^ var_val ^ "\" is not a valid value")) ) + :: t.alg_var_overwrite); + ]), + "Set a variable to a given value" ); + ( "-load-sim", + Arg.String (fun file -> t.marshalizedInFile <- file), + "load simulation package instead of kappa files" ); + ( "-rescale", + Arg.Float (fun i -> t.rescale <- Some i), + "Apply rescaling factor to initial condition" ); + ( "-u", + Arg.String + (function + | "time" | "Time" | "t" -> t.unit <- Time + | "event" | "events" | "e" | "Event" | "Events" -> t.unit <- Event + | s -> raise (Arg.Bad ("Unrecognized unit: " ^ s))), + "unit (time/event) in which limit and plot period are specified" ); + ( "-e", + Arg.Int + (fun e -> + raise + (Arg.Bad + ("Option '-e' has been replace by '-u event -l " + ^ string_of_int e ^ "'"))), + "Deprecated option" ); + ( "-make-sim", + Arg.String + (fun marshalizeOutFile -> t.marshalizeOutFile <- Some marshalizeOutFile), + "save kappa files as a simulation package" ); + ( "-dump-cc", + Arg.String + (fun domainOutputFile -> t.domainOutputFile <- Some domainOutputFile), + "file name for dumping the domain of observables" ); + ( "-trace", + Arg.String (fun traceFile -> t.traceFile <- Some traceFile), + "file name for dumping the simulation trace" ); + ( "--time-independent", + Arg.Unit (fun () -> t.timeIndependent <- true), + "Disable the use of time is story heuritics (for test suite)" ); + ( "-seed", + Arg.Int (fun i -> t.seedValue <- Some i), + "Seed for the random number generator" ); + ( "--print-efficiency", + Arg.Unit (fun () -> t.showEfficiency <- true), + "KaSim tells how fast it runs" ); + ( "-sharing", + Arg.String + (function + | "no" | "none" | "None" -> t.sharing <- Pattern.No_sharing + | "Compatible" -> t.sharing <- Pattern.Max_sharing + | "max" | "Max" -> t.sharing <- Pattern.Max_sharing + | s -> raise (Arg.Bad ("Unrecognized sharing level: " ^ s))), + "Level of sharing computed between patterns during initialization \ + (None/Compatible/Max)" ); + ( "--compile", + Arg.Unit (fun () -> t.compile_mode <- true), + "Display rule compilation as action list" ); + ( "-log", + Arg.String (fun logFile -> t.logFile <- Some logFile), + "file name of the file to regenerate the exact same simulation" ); + ( "--no-log", + Arg.Unit (fun () -> t.logFile <- None), + "Do not generate a file to redo the exact same simulation" ); + ] diff --git a/core/cli/kasim_args.mli b/core/cli/kasim_args.mli index d85c326492..a82e882a40 100644 --- a/core/cli/kasim_args.mli +++ b/core/cli/kasim_args.mli @@ -1,21 +1,21 @@ type directive_unit = Time | Event type t = { - mutable alg_var_overwrite : (string * Nbr.t) list; - mutable marshalizedInFile : string; - mutable initialMix : string option; - mutable rescale : float option; - mutable seedValue : int option; - mutable unit : directive_unit; - mutable marshalizeOutFile : string option; - mutable domainOutputFile : string option; - mutable traceFile : string option; - mutable logFile : string option; - mutable compileMode : bool; - mutable sharing : Pattern.sharing_level; - mutable showEfficiency : bool; - mutable timeIndependent : bool; + mutable alg_var_overwrite: (string * Nbr.t) list; + mutable marshalizedInFile: string; + mutable initialMix: string option; + mutable rescale: float option; + mutable seedValue: int option; + mutable unit: directive_unit; + mutable marshalizeOutFile: string option; + mutable domainOutputFile: string option; + mutable traceFile: string option; + mutable logFile: string option; + mutable compile_mode: bool; + mutable sharing: Pattern.sharing_level; + mutable showEfficiency: bool; + mutable timeIndependent: bool; } -val options: t -> (string * Arg.spec * string) list -val default: t +val options : t -> (string * Arg.spec * string) list +val default : t diff --git a/core/cli/outputs.ml b/core/cli/outputs.ml index e26d659df5..7dcf5db096 100644 --- a/core/cli/outputs.ml +++ b/core/cli/outputs.ml @@ -6,10 +6,10 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -let print_desc : (string,out_channel * Format.formatter) Hashtbl.t = +let print_desc : (string, out_channel * Format.formatter) Hashtbl.t = Hashtbl.create 2 -let species_desc : (string,out_channel * Format.formatter) Hashtbl.t = +let species_desc : (string, out_channel * Format.formatter) Hashtbl.t = Hashtbl.create 2 let uuid = Random.State.bits (Random.State.make_self_init ()) @@ -19,20 +19,22 @@ let get_desc file tbl = with Not_found -> let d_chan = Kappa_files.open_out file in let d = Format.formatter_of_out_channel d_chan in - (Hashtbl.add tbl file (d_chan,d) ; d) + Hashtbl.add tbl file (d_chan, d); + d let close_desc () = - Hashtbl.iter (fun _file (d_chan,_d) -> close_out d_chan) print_desc; - Hashtbl.iter (fun _file (d_chan,_d) -> close_out d_chan) species_desc + Hashtbl.iter (fun _file (d_chan, _d) -> close_out d_chan) print_desc; + Hashtbl.iter (fun _file (d_chan, _d) -> close_out d_chan) species_desc let output_flux din_name flux = - Kappa_files.with_flux - din_name - (if Filename.check_suffix din_name ".html" - then Kappa_files.wrap_formatter (fun f -> Data.print_html_din f flux) - else if Filename.check_suffix din_name ".json" - then fun d -> JsonUtil.write_to_channel Data.write_din d flux - else Kappa_files.wrap_formatter (fun f -> Data.print_dot_din ~uuid f flux)) + Kappa_files.with_flux din_name + (if Filename.check_suffix din_name ".html" then + Kappa_files.wrap_formatter (fun f -> Data.print_html_din f flux) + else if Filename.check_suffix din_name ".json" then + fun d -> + JsonUtil.write_to_channel Data.write_din d flux + else + Kappa_files.wrap_formatter (fun f -> Data.print_dot_din ~uuid f flux)) let actsDescr = ref None let emptyActs = ref true @@ -40,55 +42,62 @@ let emptyActs = ref true let init_activities env = function | None -> () | Some s -> - let noCounters = !Parameter.debugModeOn in + let noCounters = !Parameter.debug_modeOn in let desc = Kappa_files.open_out s in let form = Format.formatter_of_out_channel desc in let nb_r = Model.nb_syntactic_rules env in - let () = actsDescr := Some (desc,form,nb_r) in + let () = actsDescr := Some (desc, form, nb_r) in let () = Format.fprintf form "@[{@,rules:@[[" in let () = Tools.iteri - (fun x -> Format.fprintf - form "\"%a\",@," (Model.print_ast_rule ~noCounters ~env) x) - nb_r in + (fun x -> + Format.fprintf form "\"%a\",@," + (Model.print_ast_rule ~noCounters ~env) + x) + nb_r + in Format.fprintf form "\"%a\"]@],@,data:[@," - (Model.print_ast_rule ~noCounters ~env) nb_r + (Model.print_ast_rule ~noCounters ~env) + nb_r let close_activities () = match !actsDescr with | None -> () - | Some (c,f,_) -> + | Some (c, f, _) -> let () = Format.fprintf f "@,]}@]@." in close_out c let output_activities r flux = match !actsDescr with | None -> () - | Some (_,f,last) -> + | Some (_, f, last) -> let () = - if !emptyActs then emptyActs := false else Format.fprintf f ",@," in + if !emptyActs then + emptyActs := false + else + Format.fprintf f ",@," + in let () = Format.fprintf f "@[[%i" r in let () = for i = 0 to last do - let k,k' = try List.assoc i flux with Not_found -> 0.,0. in - Format.fprintf f ",%f" (k'-.k) - done in + let k, k' = try List.assoc i flux with Not_found -> 0., 0. in + Format.fprintf f ",%f" (k' -. k) + done + in Format.fprintf f "]@]" -type fd = { - desc:out_channel; - form:Format.formatter; - is_tsv:bool; -} +type fd = { desc: out_channel; form: Format.formatter; is_tsv: bool } -type format = StandBy of (string * string * string array) - | Raw of fd | Svg of Pp_svg.store +type format = + | StandBy of (string * string * string array) + | Raw of fd + | Svg of Pp_svg.store let plotDescr = ref None let close_plot () = match !plotDescr with - | (None | Some (StandBy _)) -> () + | None | Some (StandBy _) -> () | Some (Raw plot) -> close_out plot.desc | Some (Svg s) -> Pp_svg.to_file s @@ -110,85 +119,93 @@ let initialize activities_file trace_file plotPack env = | Some s -> let desc = Kappa_files.open_out s in let () = Trace.init_trace_file ~uuid env desc in - traceDescr := Some desc in + traceDescr := Some desc + in let () = init_activities env activities_file in match plotPack with | None -> () | Some pack -> plotDescr := Some (StandBy pack) -let launch_plot (filename,title,head) = +let launch_plot (filename, title, head) = let format = if Filename.check_suffix filename ".svg" then - Svg {Pp_svg.file = filename; - Pp_svg.title = title; - Pp_svg.descr = "\"uuid\" : \""^string_of_int uuid^"\""; - Pp_svg.legend = head; - Pp_svg.points = []; - } - else + Svg + { + Pp_svg.file = filename; + Pp_svg.title; + Pp_svg.descr = "\"uuid\" : \"" ^ string_of_int uuid ^ "\""; + Pp_svg.legend = head; + Pp_svg.points = []; + } + else ( let d_chan = Kappa_files.open_out filename in let d = Format.formatter_of_out_channel d_chan in let is_tsv = Filename.check_suffix filename ".tsv" in let () = if not is_tsv then Format.fprintf d "# %s@." title in - let () = if not is_tsv - then Format.fprintf d "# \"uuid\" : \"%i\"@." uuid in + let () = + if not is_tsv then Format.fprintf d "# \"uuid\" : \"%i\"@." uuid + in let () = Data.print_plot_legend ~is_tsv d head in - Raw {desc=d_chan; form=d; is_tsv} in - plotDescr := Some format + Raw { desc = d_chan; form = d; is_tsv } + ) + in + plotDescr := Some format let rec plot_now l = match !plotDescr with | None -> assert false - | Some (StandBy p) -> let () = launch_plot p in plot_now l + | Some (StandBy p) -> + let () = launch_plot p in + plot_now l | Some (Raw fd) -> Data.print_plot_line ~is_tsv:fd.is_tsv Nbr.print_option fd.form l | Some (Svg s) -> s.Pp_svg.points <- l :: s.Pp_svg.points let snapshot file s = if Filename.check_suffix file ".dot" then - Kappa_files.with_snapshot - file ".dot" s.Data.snapshot_event + Kappa_files.with_snapshot file ".dot" s.Data.snapshot_event (Kappa_files.wrap_formatter (fun f -> Data.print_dot_snapshot ~uuid f s)) else if Filename.check_suffix file ".json" then - Kappa_files.with_snapshot - file ".json" s.Data.snapshot_event - (fun d -> JsonUtil.write_to_channel Data.write_snapshot d s) + Kappa_files.with_snapshot file ".json" s.Data.snapshot_event (fun d -> + JsonUtil.write_to_channel Data.write_snapshot d s) else - Kappa_files.with_snapshot - file ".ka" s.Data.snapshot_event + Kappa_files.with_snapshot file ".ka" s.Data.snapshot_event (Kappa_files.wrap_formatter (fun f -> Data.print_snapshot ~uuid f s)) let print_species time f mixture = Format.fprintf f "%g: @[%a@]@." time User_graph.print_cc mixture -let warning_buffer: - (Locality.t option*(Format.formatter -> unit)) list ref = ref [] +let warning_buffer : (Loc.t option * (Format.formatter -> unit)) list ref = + ref [] let go = function - | Data.Snapshot (f,s) -> snapshot f s - | Data.DIN (n,f) -> output_flux n f - | Data.DeltaActivities (r,flux) -> output_activities r flux + | Data.Snapshot (f, s) -> snapshot f s + | Data.DIN (n, f) -> output_flux n f + | Data.DeltaActivities (r, flux) -> output_activities r flux | Data.Plot x -> plot_now x | Data.Print p -> let desc = match p.Data.file_line_name with - None -> Format.formatter_of_out_channel stdout + | None -> Format.formatter_of_out_channel stdout | Some file -> get_desc file print_desc in Format.fprintf desc "%s@." p.Data.file_line_text | Data.Log s -> Format.printf "%s@." s - | Data.Warning (pos,msg) -> warning_buffer := (pos,msg)::!warning_buffer + | Data.Warning (pos, msg) -> warning_buffer := (pos, msg) :: !warning_buffer | Data.TraceStep step -> - begin match !traceDescr with - | None -> () - | Some d -> - let () = - if !traceNotEmpty then output_char d ',' else traceNotEmpty := true in - JsonUtil.write_to_channel Trace.write_step d step - end - | Data.Species (file,time,mixture) -> - let desc = get_desc file species_desc in - print_species time desc mixture + (match !traceDescr with + | None -> () + | Some d -> + let () = + if !traceNotEmpty then + output_char d ',' + else + traceNotEmpty := true + in + JsonUtil.write_to_channel Trace.write_step d step) + | Data.Species (file, time, mixture) -> + let desc = get_desc file species_desc in + print_species time desc mixture let inputsDesc = ref None @@ -196,7 +213,8 @@ let flush_warning () = let l = List.rev !warning_buffer in let () = warning_buffer := [] in List.iter - (fun (pos,msg) -> Data.print_warning ?pos Format.err_formatter msg) l + (fun (pos, msg) -> Data.print_warning ?pos Format.err_formatter msg) + l let close_input ?event () = match !inputsDesc with @@ -205,9 +223,11 @@ let close_input ?event () = let () = match event with | None -> () - | Some event -> Format.fprintf - (Format.formatter_of_out_channel inputs) - "@.%%mod: [E] = %i do $STOP;@." event in + | Some event -> + Format.fprintf + (Format.formatter_of_out_channel inputs) + "@.%%mod: [E] = %i do $STOP;@." event + in close_out inputs let close ?event () = @@ -221,8 +241,7 @@ let close ?event () = let initial_inputs conf env init ~filename = let inputs = Kappa_files.open_out_fresh filename [] "" ".ka" in let inputs_form = Format.formatter_of_out_channel inputs in - let () = - Data.print_initial_inputs ~uuid conf env inputs_form init in + let () = Data.print_initial_inputs ~uuid conf env inputs_form init in inputsDesc := Some inputs let input_modifications env event mods = @@ -231,8 +250,7 @@ let input_modifications env event mods = | Some inputs -> Format.fprintf (Format.formatter_of_out_channel inputs) - "%%mod: [E] = %i do %a@." - event + "%%mod: [E] = %i do %a@." event (Pp.list ~trailing:Pp.colon Pp.colon - (Kappa_printer.modification ~noCounters:!Parameter.debugModeOn ~env)) + (Kappa_printer.modification ~noCounters:!Parameter.debug_modeOn ~env)) mods diff --git a/core/cli/outputs.mli b/core/cli/outputs.mli index 06d50e95e8..ff429b486e 100644 --- a/core/cli/outputs.mli +++ b/core/cli/outputs.mli @@ -9,16 +9,20 @@ (** Deal with simulation output *) val initialize : - string option -> string option -> (string * string * string array) option -> - Model.t -> unit + string option -> + string option -> + (string * string * string array) option -> + Model.t -> + unit val initial_inputs : - Configuration.t -> Model.t -> + Configuration.t -> + Model.t -> (Primitives.alg_expr * Primitives.elementary_rule) list -> - filename:string -> unit + filename:string -> + unit val input_modifications : Model.t -> int -> Primitives.modification list -> unit - val go : Data.t -> unit val flush_warning : unit -> unit val close : ?event:int -> unit -> unit diff --git a/core/cli/parameter.ml b/core/cli/parameter.ml index 9ef8756bdb..bba815a528 100644 --- a/core/cli/parameter.ml +++ b/core/cli/parameter.ml @@ -11,34 +11,37 @@ let defaultExtArraySize = ref 5 let defaultGraphSize = ref 5 let defaultLiftSetSize = ref 5 let defaultHeapSize = ref 5 -let debugModeOn = ref false +let debug_modeOn = ref false (* expert option for stories *) - (** Memory **) - (* Number of potential states that are put in the cache per binding site, so as to handler with side effects in stories. None -> Unlimited cache *) - let cache_size = ref (None:int option) - (** Precomputation **) - (* Cut concurrent events (for all observables) before generating the blackboard *) - let do_global_cut = true +(* Number of potential states that are put in the cache per binding site, so as to handler with side effects in stories. None -> Unlimited cache *) - (* Cut pseudo-inverse events *) - let cut_pseudo_inverse_event = true +(** Memory **) +let cache_size = ref (None : int option) - (* Cut concurrent events (for the current observale) before generating the blackboard *) - let do_local_cut = true +(* Cut concurrent events (for all observables) before generating the blackboard *) - (* Cut separable components *) - let do_detect_separable_components = true +(** Precomputation **) +let do_global_cut = true - (** Propagation heuristics **) - (* Whenever we do not know whether an event has to be selected or, not, check whether this is not the last one that can parform a requested action *) - let look_up_for_better_cut = true +(* Cut pseudo-inverse events *) +let cut_pseudo_inverse_event = true - (* Whenever an event is removed, checked whether there is not only one left to perform a required action *) - let look_down_for_better_cut = true +(* Cut concurrent events (for the current observale) before generating the blackboard *) +let do_local_cut = true - let log_number_of_causal_flows = true +(* Cut separable components *) +let do_detect_separable_components = true + +(* Whenever we do not know whether an event has to be selected or, not, check whether this is not the last one that can parform a requested action *) + +(** Propagation heuristics **) +let look_up_for_better_cut = true + +(* Whenever an event is removed, checked whether there is not only one left to perform a required action *) +let look_down_for_better_cut = true +let log_number_of_causal_flows = true (*User definable values*) let time_independent = ref false @@ -51,5 +54,4 @@ let dump_grid_after_branching_during_weak_compression = false let dump_grid_after_branching_during_strong_compression = false let xlsweakFileName = "grid_weak_compression" let xlsstrongFileName = "grid_strong_compression" - let get_cache_size () = !cache_size diff --git a/core/cli/parameter.mli b/core/cli/parameter.mli index 941b95137e..833702327d 100644 --- a/core/cli/parameter.mli +++ b/core/cli/parameter.mli @@ -1,25 +1,21 @@ -val xlsweakFileName: string -val xlsstrongFileName: string -val get_cache_size: unit -> int option - -val dump_grid_after_branching_during_strong_compression: bool -val dump_grid_after_branching_during_weak_compression: bool -val dump_grid_before_strong_compression: bool -val dump_grid_before_weak_compression: bool - -val blacklist_events: bool ref -val time_independent: bool ref - -val do_local_cut: bool -val do_detect_separable_components:bool -val look_up_for_better_cut:bool -val look_down_for_better_cut:bool -val log_number_of_causal_flows:bool -val defaultLiftSetSize:int ref -val defaultHeapSize:int ref -val debugModeOn:bool ref -val do_global_cut:bool -val cut_pseudo_inverse_event:bool - -val defaultExtArraySize: int ref -val defaultGraphSize: int ref +val xlsweakFileName : string +val xlsstrongFileName : string +val get_cache_size : unit -> int option +val dump_grid_after_branching_during_strong_compression : bool +val dump_grid_after_branching_during_weak_compression : bool +val dump_grid_before_strong_compression : bool +val dump_grid_before_weak_compression : bool +val blacklist_events : bool ref +val time_independent : bool ref +val do_local_cut : bool +val do_detect_separable_components : bool +val look_up_for_better_cut : bool +val look_down_for_better_cut : bool +val log_number_of_causal_flows : bool +val defaultLiftSetSize : int ref +val defaultHeapSize : int ref +val debug_modeOn : bool ref +val do_global_cut : bool +val cut_pseudo_inverse_event : bool +val defaultExtArraySize : int ref +val defaultGraphSize : int ref diff --git a/core/cli/pp_svg.ml b/core/cli/pp_svg.ml index d644208763..463e01d8b7 100644 --- a/core/cli/pp_svg.ml +++ b/core/cli/pp_svg.ml @@ -19,12 +19,13 @@ let new_file name = let f = Format.formatter_of_out_channel chan in let () = Format.fprintf f "@[@," in let () = - Format.fprintf - f "@[<>@]@,@," in - (f,chan) + Format.fprintf f + "\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">@]@,@," + in + f, chan let close_file form chan = let () = Format.fprintf form "@]@." in @@ -43,65 +44,88 @@ let style f = let () = Format.fprintf f "text-anchor:end;@ baseline-shift:-.4em;@," in let () = Format.fprintf f "}@]@," in let () = - Format.fprintf f "@[#axes {@,color:black;@,stroke:currentColor;" in + Format.fprintf f "@[#axes {@,color:black;@,stroke:currentColor;" + in let () = Format.fprintf f "@,stroke-size:1px;@,}@]@," in let () = - Format.fprintf f "@[#axes text {@,stroke:none;@,fill:currentColor;@,}@]@," in -(* let () = - Format.fprintf f "@[#data use:hover {@,fill:green;@,}@]@," in*) + Format.fprintf f + "@[#axes text {@,stroke:none;@,fill:currentColor;@,}@]@," + in + (* let () = + Format.fprintf f "@[#data use:hover {@,fill:green;@,}@]@," in*) Format.fprintf f "]]>@,@,@," -let colors = [|"peru";"blue";"purple";"green"|] -let styles = [|"point";"plus";"cross"|] +let colors = [| "peru"; "blue"; "purple"; "green" |] +let styles = [| "point"; "plus"; "cross" |] + let defs f = let () = Format.fprintf f "@," in - let () = Format.fprintf - f "@," in - let () = Format.fprintf - f "@," in + Format.fprintf f + "@," + in + let () = Format.fprintf f "@," in Format.fprintf f "@,@," let legend w f a = let pp_line i' f s = - if i' > 0 then + if i' > 0 then ( let i = pred i' in - let () = Format.fprintf f "@[%s@]@," - (w-15) (10+i*15) s in - Format.fprintf - f "" - styles.(i' mod Array.length styles) colors.(i' mod Array.length colors) - (w-7) (10+i*15) in + let () = + Format.fprintf f "@[%s@]@," (w - 15) + (10 + (i * 15)) + s + in + Format.fprintf f + "" + styles.(i' mod Array.length styles) + colors.(i' mod Array.length colors) + (w - 7) + (10 + (i * 15)) + ) + in Format.fprintf f "@[@,%a@]@,@,@," (Pp.array Pp.cut pp_line) a let get_limits l = - let dummy_values = (0.,-1.,1.) in + let dummy_values = 0., -1., 1. in let rec aux t_max va_min va_max = function | [] -> - if va_min = va_max then - t_max,va_min -. 1., va_max +. 1. - else - t_max,min va_min 0.,va_max - | va::q -> - aux (max (Option_util.unsome 0. (Nbr.to_float va.(0))) t_max) - (Tools.array_fold_lefti (fun i a x -> match Nbr.to_float x with + if va_min = va_max then + t_max, va_min -. 1., va_max +. 1. + else + t_max, min va_min 0., va_max + | va :: q -> + aux + (max (Option_util.unsome 0. (Nbr.to_float va.(0))) t_max) + (Tools.array_fold_lefti + (fun i a x -> + match Nbr.to_float x with | Some x when i <> 0 -> min a x - | _ -> a) va_min va) - (Tools.array_fold_lefti (fun i a x -> match Nbr.to_float x with + | _ -> a) + va_min va) + (Tools.array_fold_lefti + (fun i a x -> + match Nbr.to_float x with | Some x when i <> 0 -> max a x - | _ -> a) va_max va) q in + | _ -> a) + va_max va) + q + in match l with | [] -> dummy_values - | va::_ when Array.length va < 2 -> dummy_values + | va :: _ when Array.length va < 2 -> dummy_values | l -> aux 0. infinity 0. l -let draw_in_data ((t_max,va_min,va_max),(zero_w,zero_h,draw_w,draw_h)) = +let draw_in_data ((t_max, va_min, va_max), (zero_w, zero_h, draw_w, draw_h)) = let delta_va = va_max -. va_min in let zero_w' = float_of_int zero_w in let zero_h' = float_of_int zero_h in @@ -111,102 +135,120 @@ let draw_in_data ((t_max,va_min,va_max),(zero_w,zero_h,draw_w,draw_h)) = match Nbr.to_float y with | None -> () | Some y' -> - f (zero_w' +. (((Option_util.unsome 0. @@ Nbr.to_float x) *. draw_w') /. t_max)) - (zero_h' -. (((y' -. va_min) *. draw_h') /. delta_va)) + f + (zero_w' + +. ((Option_util.unsome 0. @@ Nbr.to_float x) *. draw_w' /. t_max)) + (zero_h' -. ((y' -. va_min) *. draw_h' /. delta_va)) let graduation_step draw_l min_grad_l va_min va_max = let nbr_delta = va_max -. va_min in - let delta_va = match classify_float nbr_delta with + let delta_va = + match classify_float nbr_delta with | FP_zero -> 1. - | FP_normal | FP_subnormal | FP_infinite | FP_nan -> nbr_delta in + | FP_normal | FP_subnormal | FP_infinite | FP_nan -> nbr_delta + in let nb_grad = ceil (float draw_l /. float min_grad_l) in let exact_step = delta_va /. nb_grad in - let delta_grad = 10. ** (log10 exact_step) in - let va_min' = - delta_grad *. floor ( va_min /. exact_step) in - let va_max' = match classify_float nbr_delta with + let delta_grad = 10. ** log10 exact_step in + let va_min' = delta_grad *. floor (va_min /. exact_step) in + let va_max' = + match classify_float nbr_delta with | FP_zero -> va_min' +. 1. | FP_normal | FP_subnormal | FP_infinite | FP_nan -> - delta_grad *. ceil ( va_max /. exact_step) in - (va_min',int_of_float nb_grad,delta_grad,va_max') + delta_grad *. ceil (va_max /. exact_step) + in + va_min', int_of_float nb_grad, delta_grad, va_max' -let axis (w,h) (b_op,b_w,b_h) f l = - let (t_max,va_min,va_max) = get_limits l in +let axis (w, h) (b_op, b_w, b_h) f l = + let t_max, va_min, va_max = get_limits l in let data_w = w - (b_op + b_w) in let data_h = h - (b_op + b_h) in - let (_,nb_w,grad_w,t_max') = - graduation_step data_w b_w 0. t_max in - let (va_min',nb_h,grad_h,va_max') = - graduation_step data_h b_w va_min va_max in - let draw_fun = draw_in_data ((t_max',va_min',va_max'), - (b_w,h-b_h,data_w,data_h)) in + let _, nb_w, grad_w, t_max' = graduation_step data_w b_w 0. t_max in + let va_min', nb_h, grad_h, va_max' = + graduation_step data_h b_w va_min va_max + in + let draw_fun = + draw_in_data ((t_max', va_min', va_max'), (b_w, h - b_h, data_w, data_h)) + in let () = Format.fprintf f "@," in - let () = - Format.fprintf f "@[@," in + let () = Format.fprintf f "@[@," in let () = Format.fprintf f "Observable values@," in - let () = Format.fprintf f "@[<>@]@," - b_w b_op b_w (data_h+b_op) in + let () = + Format.fprintf f "@[<>@]@," b_w b_op b_w + (data_h + b_op) + in let () = Tools.iteri (fun i -> - let v = grad_h *. float i in - draw_fun (fun x y -> - let () = Format.fprintf f "%.3g@," - (x -. 8.) y v in - Format.fprintf f "@," - (x -. 5.) y (x +. 5.) y) - Nbr.zero (Nbr.F v)) (succ nb_h) in - let () = - Format.fprintf f "@]@,@[@," in + let v = grad_h *. float i in + draw_fun + (fun x y -> + let () = + Format.fprintf f "%.3g@," (x -. 8.) + y v + in + Format.fprintf f "@," + (x -. 5.) y (x +. 5.) y) + Nbr.zero (Nbr.F v)) + (succ nb_h) + in + let () = Format.fprintf f "@]@,@[@," in let () = Format.fprintf f "Time (arbitrary unit)@," in let () = - Format.fprintf f "@[<>@]@," - b_w (h-b_h) (w-b_op) (h-b_h) in + Format.fprintf f "@[<>@]@," b_w (h - b_h) + (w - b_op) (h - b_h) + in let () = Tools.iteri (fun i -> - let v = grad_w *. float i in - draw_fun (fun x y -> - let () = Format.fprintf f "%.3g@," - x (y +. 8.) v in - Format.fprintf - f "@," - x (y -. 5.) x (y +. 5.)) - (Nbr.F v) (Nbr.F va_min')) (succ nb_w) in + let v = grad_w *. float i in + draw_fun + (fun x y -> + let () = + Format.fprintf f "%.3g@," x + (y +. 8.) v + in + Format.fprintf f "@," + x (y -. 5.) x (y +. 5.)) + (Nbr.F v) (Nbr.F va_min')) + (succ nb_w) + in let () = Format.fprintf f "@]@,@,@," in draw_fun let data draw_fun l f p = let one_point s t i f va = - draw_fun (fun x y -> + draw_fun + (fun x y -> let () = - Format.fprintf - f "@[<>@," - styles.(i mod Array.length styles) x y in - Format.fprintf f "%s t=%a v=%a@,@]@," - s Nbr.pretty_print t Nbr.print va - ) t va in - Format.fprintf - f "@,%a@,@," - (Pp.array Pp.empty - (fun i f s -> - if i > 0 then - Format.fprintf - f "@[@,%a@]@," - (pred i) colors.(i mod Array.length colors) - (Pp.list Pp.empty - (fun f e -> one_point s e.(0) i f e.(i))) - p)) l + Format.fprintf f "@[<>@," + styles.(i mod Array.length styles) + x y + in + Format.fprintf f "%s t=%a v=%a@,@]@," s + Nbr.pretty_print t Nbr.print va) + t va + in + Format.fprintf f "@,%a@,@," + (Pp.array Pp.empty (fun i f s -> + if i > 0 then + Format.fprintf f + "@[@,%a@]@," + (pred i) + colors.(i mod Array.length colors) + (Pp.list Pp.empty (fun f e -> one_point s e.(0) i f e.(i))) + p)) + l -let draw (w,h as size) border f s = - let () = Format.fprintf - f "@[<>@]@," w h in - let () = Format.fprintf f "%s@,%s@,@," - s.title s.descr in +let draw ((w, h) as size) border f s = + let () = + Format.fprintf f "@[<>@]@," w h in + let () = + Format.fprintf f "%s@,%s@,@," s.title s.descr + in let () = style f in let () = defs f in let draw_fun = axis size border f s.points in @@ -214,18 +256,18 @@ let draw (w,h as size) border f s = let () = data draw_fun s.legend f s.points in Format.fprintf f "" -let to_string ?(width=800) s = +let to_string ?(width = 800) s = let b = Buffer.create 1024 in let f = Format.formatter_of_buffer b in - let size = (width,int_of_float (float width /. sqrt 2.)) in - let border = (10,70,25) in + let size = width, int_of_float (float width /. sqrt 2.) in + let border = 10, 70, 25 in let () = draw size border f s in let () = Format.pp_print_newline f () in Buffer.contents b let to_file s = - let (form,chan) = new_file s.file in - let size = (800,600) in - let border = (10,70,25) in + let form, chan = new_file s.file in + let size = 800, 600 in + let border = 10, 70, 25 in let () = draw size border form s in close_file form chan diff --git a/core/cli/progress_report.ml b/core/cli/progress_report.ml index 43aa8277bf..b9804a3ba5 100644 --- a/core/cli/progress_report.ml +++ b/core/cli/progress_report.ml @@ -6,16 +6,12 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type bar = { - mutable ticks : int ; - bar_size : int ; - bar_char : char ; -} +type bar = { mutable ticks: int; bar_size: int; bar_char: char } type text = { - mutable last_length : int; - mutable last_event_nb : int; - mutable last_time : float; + mutable last_length: int; + mutable last_event_nb: int; + mutable last_time: float; } type t = Bar of bar | Text of text @@ -23,62 +19,76 @@ type t = Bar of bar | Text of text let inc_tick c = c.ticks <- c.ticks + 1 let create bar_size bar_char = - if Unix.isatty Unix.stdout - then Text { last_length = 0; last_time = -5.; last_event_nb = 0; } - else + if Unix.isatty Unix.stdout then + Text { last_length = 0; last_time = -5.; last_event_nb = 0 } + else ( let () = for _ = bar_size downto 1 do Format.pp_print_string Format.std_formatter "_" - done in + done + in let () = Format.pp_print_newline Format.std_formatter () in - Bar { ticks = 0; bar_size; bar_char; } + Bar { ticks = 0; bar_size; bar_char } + ) let pp_not_null f x = match x with - | Some x -> - Format.fprintf f " (%.2f%%)" (x *. 100.) + | Some x -> Format.fprintf f " (%.2f%%)" (x *. 100.) | None -> () let pp_text delta_t time t_r event e_r f s = let string = - Format.asprintf "%.2f time units%a in %i events%a%t" - time pp_not_null t_r event pp_not_null e_r - (fun f -> match delta_t with - | None -> () - | Some dt -> - Format.fprintf f " (just did %.1f events/s)" - (float_of_int (event - s.last_event_nb) /. dt)) in + Format.asprintf "%.2f time units%a in %i events%a%t" time pp_not_null t_r + event pp_not_null e_r (fun f -> + match delta_t with + | None -> () + | Some dt -> + Format.fprintf f " (just did %.1f events/s)" + (float_of_int (event - s.last_event_nb) /. dt)) + in let () = Format.fprintf f "%s%s%s@?" (String.make s.last_length '\b') string - (String.make (max 0 (s.last_length - String.length string)) ' ') in + (String.make (max 0 (s.last_length - String.length string)) ' ') + in s.last_length <- String.length string let rec aux_tick something s n = if n <= 0 then - if something then Format.pp_print_flush Format.std_formatter () else () - else + if something then + Format.pp_print_flush Format.std_formatter () + else + () + else ( let () = Format.pp_print_char Format.std_formatter s.bar_char in let () = inc_tick s in aux_tick true s (pred n) + ) let tick ~efficiency time t_r event e_r = function | Bar s -> - let n_t = Option_util.unsome 0. t_r *. (float_of_int s.bar_size) in - let n_e = Option_util.unsome 0. e_r *. (float_of_int s.bar_size) in + let n_t = Option_util.unsome 0. t_r *. float_of_int s.bar_size in + let n_e = Option_util.unsome 0. e_r *. float_of_int s.bar_size in aux_tick false s (int_of_float (max n_t n_e) - s.ticks) | Text s -> let run = Sys.time () in let dt = run -. s.last_time in - if dt > 0.5 then - let () = pp_text (if efficiency then Some dt else None) - time t_r event e_r Format.std_formatter s in + if dt > 0.5 then ( + let () = + pp_text + (if efficiency then + Some dt + else + None) + time t_r event e_r Format.std_formatter s + in let () = s.last_event_nb <- event in s.last_time <- Sys.time () + ) let complete_progress_bar time event t = (match t with - | Bar t -> aux_tick false t (t.bar_size - t.ticks) - | Text s -> pp_text None time None event None Format.std_formatter s); + | Bar t -> aux_tick false t (t.bar_size - t.ticks) + | Text s -> pp_text None time None event None Format.std_formatter s); Format.pp_print_newline Format.std_formatter () diff --git a/core/cli/progress_report.mli b/core/cli/progress_report.mli index 89c7f59f35..a913736da3 100644 --- a/core/cli/progress_report.mli +++ b/core/cli/progress_report.mli @@ -11,7 +11,8 @@ type t val create : int -> char -> t + val tick : - efficiency:bool -> - float -> float option -> int -> float option -> t -> unit + efficiency:bool -> float -> float option -> int -> float option -> t -> unit + val complete_progress_bar : float -> int -> t -> unit diff --git a/core/cli/run_cli_args.ml b/core/cli/run_cli_args.ml index ab7e628142..58061fc36b 100644 --- a/core/cli/run_cli_args.ml +++ b/core/cli/run_cli_args.ml @@ -7,46 +7,46 @@ (******************************************************************************) type t = { - mutable inputKappaFileNames : string list; - mutable minValue : float option; - mutable maxValue : float option; - mutable plotPeriod : float option; - mutable outputDataFile : string option; - mutable outputDirectory : string; - mutable batchmode : bool; - mutable interactive : bool; - mutable syntaxVersion : Ast.syntax_version; + mutable inputKappaFileNames: string list; + mutable minValue: float option; + mutable maxValue: float option; + mutable plotPeriod: float option; + mutable outputDataFile: string option; + mutable outputDirectory: string; + mutable batchmode: bool; + mutable interactive: bool; + mutable syntaxVersion: Ast.syntax_version; } -type t_gui = +type t_gui = { + inputKappaFileNames_gui: string list ref; + minValue_gui: float option ref; + maxValue_gui: float option ref; + plotPeriod_gui: float option ref; + outputDataFile_gui: string option ref; + outputDirectory_gui: string ref; + syntaxVersion_gui: string ref; + batchmode_gui: string ref; +} + +let default : t = { - inputKappaFileNames_gui : string list ref; - minValue_gui : float option ref; - maxValue_gui : float option ref; - plotPeriod_gui : float option ref; - outputDataFile_gui : string option ref; - outputDirectory_gui : string ref; - syntaxVersion_gui : string ref; - batchmode_gui : string ref; + inputKappaFileNames = []; + minValue = None; + maxValue = None; + plotPeriod = None; + outputDataFile = None; + outputDirectory = "."; + syntaxVersion = Ast.V4; + batchmode = false; + interactive = false; } -let default : t = { - inputKappaFileNames = []; - minValue = None ; - maxValue = None; - plotPeriod = None; - outputDataFile = None; - outputDirectory = "."; - syntaxVersion = Ast.V4; - batchmode = false; - interactive = false; -} - let default_gui = { inputKappaFileNames_gui = ref []; minValue_gui = ref (Some 0.); - maxValue_gui = ref (Some 1.); + maxValue_gui = ref (Some 1.); plotPeriod_gui = ref (Some 0.01); outputDataFile_gui = ref (Some "data.csv"); outputDirectory_gui = ref "."; @@ -56,12 +56,13 @@ let default_gui = let rec aux l accu = match l with - | (v,var_val)::tail -> + | (v, var_val) :: tail -> aux tail - ((v, - (try Nbr.of_string var_val with - Failure _ -> - raise (Arg.Bad ("\""^var_val^"\" is not a valid value")))) ::accu) + (( v, + try Nbr.of_string var_val + with Failure _ -> + raise (Arg.Bad ("\"" ^ var_val ^ "\" is not a valid value")) ) + :: accu) | [] -> accu let get_from_gui t_gui = @@ -72,13 +73,14 @@ let get_from_gui t_gui = inputKappaFileNames = !(t_gui.inputKappaFileNames_gui); outputDataFile = !(t_gui.outputDataFile_gui); outputDirectory = !(t_gui.outputDirectory_gui); - syntaxVersion = (match !(t_gui.syntaxVersion_gui) with - | "3" | "v3" | "V3" -> Ast.V3 - | "4" | "v4" | "V4" -> Ast.V4 - | _s -> Ast.V4); - batchmode = (Tools.lowercase (!(t_gui.batchmode_gui)))="batch" ; - interactive = (Tools.lowercase (!(t_gui.batchmode_gui)))="interactive"; -} + syntaxVersion = + (match !(t_gui.syntaxVersion_gui) with + | "3" | "v3" | "V3" -> Ast.V3 + | "4" | "v4" | "V4" -> Ast.V4 + | _s -> Ast.V4); + batchmode = Tools.lowercase !(t_gui.batchmode_gui) = "batch"; + interactive = Tools.lowercase !(t_gui.batchmode_gui) = "interactive"; + } let copy_from_gui t_gui t = let t_tmp = get_from_gui t_gui in @@ -88,108 +90,143 @@ let copy_from_gui t_gui t = t.inputKappaFileNames <- t_tmp.inputKappaFileNames; t.outputDataFile <- t_tmp.outputDataFile; t.outputDirectory <- t_tmp.outputDirectory; - t.syntaxVersion <- t_tmp.syntaxVersion ; - t.batchmode <- t_tmp.batchmode ; + t.syntaxVersion <- t_tmp.syntaxVersion; + t.batchmode <- t_tmp.batchmode; t.interactive <- t_tmp.interactive -let options_gen (t :t) (t_gui :t_gui) : (string * Arg.spec * Superarg.spec * string * (Superarg.category * Superarg.position) list * Superarg.level) list = [ - ("-i", - Arg.String (fun fic -> - t.inputKappaFileNames <- fic::t.inputKappaFileNames), - Superarg.String_list t_gui.inputKappaFileNames_gui, - "name of a kappa file to use as input (can be used multiple times for multiple input files)", - [],Superarg.Hidden); - ("-initial", - Arg.Float (fun time -> t.minValue <- Some time), - (Superarg.Float_opt t_gui.minValue_gui), - "Min time of simulation (arbitrary time unit)", - [Common_args.data_set,0; - Common_args.integration_settings,0], - Superarg.Normal); - ("-l", - Arg.Float(fun time -> t.maxValue <- Some time), - (Superarg.Float_opt t_gui.maxValue_gui), - "Limit of the simulation", - [ - Common_args.data_set,1; - Common_args.integration_settings,1],Superarg.Normal); - ("-t", - Arg.Float (fun f -> - raise (Arg.Bad ("Option '-t' has been replace by '[-u time] -l "^ - string_of_float f^"'"))), - (Superarg.Float_opt t_gui.maxValue_gui), - "Deprecated option", - [],Superarg.Hidden); - ("-p", - Arg.Float (fun pointNumberValue -> t.plotPeriod <- Some pointNumberValue), - Superarg.Float_opt t_gui.plotPeriod_gui, - "plot period: time interval between points in plot (default: 1.0)", - [Common_args.data_set,2;Common_args.integration_settings,2],Superarg.Normal); - ("-o", - Arg.String - (fun outputDataFile -> t.outputDataFile <- Some outputDataFile), - Superarg.String_opt t_gui.outputDataFile_gui, - "file name for data output", - [ - Common_args.data_set,3; - Common_args.output,3; - Common_args.integration_settings,3], Superarg.Hidden) ; - ("-d", - Arg.String (fun outputDirectory -> t.outputDirectory <- outputDirectory), - Superarg.String t_gui.outputDirectory_gui, - "Specifies directory name where output file(s) should be stored", - [ - Common_args.data_set,100; - Common_args.output,100; - Common_args.semantics,100; - Common_args.integration_settings,100; - Common_args.model_reduction,100; - Common_args.static_analysis,100; - Common_args.debug_mode,100 - ], - Superarg.Normal) ; - ("-mode", - Arg.String - (fun m -> if m = "batch" then t.batchmode <- true - else if m = "interactive" then t.interactive <- true), - Superarg.Choice - (["batch","batch mode";"interactive","interactive mode"],[],t_gui.batchmode_gui), - "either \"batch\" to never ask anything to the user or \"interactive\" to ask something before doing anything", - [Common_args.output,7;Common_args.debug_mode,7], Superarg.Expert) ; - ("-syntax", - Arg.String (function +let options_gen (t : t) (t_gui : t_gui) : + (string + * Arg.spec + * Superarg.spec + * string + * (Superarg.category * Superarg.position) list + * Superarg.level) + list = + [ + ( "-i", + Arg.String + (fun fic -> t.inputKappaFileNames <- fic :: t.inputKappaFileNames), + Superarg.String_list t_gui.inputKappaFileNames_gui, + "name of a kappa file to use as input (can be used multiple times for \ + multiple input files)", + [], + Superarg.Hidden ); + ( "-initial", + Arg.Float (fun time -> t.minValue <- Some time), + Superarg.Float_opt t_gui.minValue_gui, + "Min time of simulation (arbitrary time unit)", + [ Common_args.data_set, 0; Common_args.integration_settings, 0 ], + Superarg.Normal ); + ( "-l", + Arg.Float (fun time -> t.maxValue <- Some time), + Superarg.Float_opt t_gui.maxValue_gui, + "Limit of the simulation", + [ Common_args.data_set, 1; Common_args.integration_settings, 1 ], + Superarg.Normal ); + ( "-t", + Arg.Float + (fun f -> + raise + (Arg.Bad + ("Option '-t' has been replace by '[-u time] -l " + ^ string_of_float f ^ "'"))), + Superarg.Float_opt t_gui.maxValue_gui, + "Deprecated option", + [], + Superarg.Hidden ); + ( "-p", + Arg.Float (fun pointNumberValue -> t.plotPeriod <- Some pointNumberValue), + Superarg.Float_opt t_gui.plotPeriod_gui, + "plot period: time interval between points in plot (default: 1.0)", + [ Common_args.data_set, 2; Common_args.integration_settings, 2 ], + Superarg.Normal ); + ( "-o", + Arg.String (fun outputDataFile -> t.outputDataFile <- Some outputDataFile), + Superarg.String_opt t_gui.outputDataFile_gui, + "file name for data output", + [ + Common_args.data_set, 3; + Common_args.output, 3; + Common_args.integration_settings, 3; + ], + Superarg.Hidden ); + ( "-d", + Arg.String (fun outputDirectory -> t.outputDirectory <- outputDirectory), + Superarg.String t_gui.outputDirectory_gui, + "Specifies directory name where output file(s) should be stored", + [ + Common_args.data_set, 100; + Common_args.output, 100; + Common_args.semantics, 100; + Common_args.integration_settings, 100; + Common_args.model_reduction, 100; + Common_args.static_analysis, 100; + Common_args.debug_mode, 100; + ], + Superarg.Normal ); + ( "-mode", + Arg.String + (fun m -> + if m = "batch" then + t.batchmode <- true + else if m = "interactive" then + t.interactive <- true), + Superarg.Choice + ( [ "batch", "batch mode"; "interactive", "interactive mode" ], + [], + t_gui.batchmode_gui ), + "either \"batch\" to never ask anything to the user or \"interactive\" \ + to ask something before doing anything", + [ Common_args.output, 7; Common_args.debug_mode, 7 ], + Superarg.Expert ); + ( "-syntax", + Arg.String + (function | "3" | "v3" | "V3" -> t.syntaxVersion <- Ast.V3 | "4" | "v4" | "V4" -> t.syntaxVersion <- Ast.V4 - | s -> raise (Arg.Bad ("\""^s^"\" is not a valid syntax version")) - ), - Superarg.Choice - (["3","old";"v3","old";"V3","old";"4","new";"v4","new";"V4","new"],[],t_gui.syntaxVersion_gui), - "Use explicit notation for free site", - [Common_args.semantics,8], Superarg.Normal); -] + | s -> raise (Arg.Bad ("\"" ^ s ^ "\" is not a valid syntax version"))), + Superarg.Choice + ( [ + "3", "old"; + "v3", "old"; + "V3", "old"; + "4", "new"; + "v4", "new"; + "V4", "new"; + ], + [], + t_gui.syntaxVersion_gui ), + "Use explicit notation for free site", + [ Common_args.semantics, 8 ], + Superarg.Normal ); + ] let options t = List.rev_map - (fun (a,b,_,c,_,_) -> a,b,c) + (fun (a, b, _, c, _, _) -> a, b, c) (List.rev (options_gen t default_gui)) let options_gui t_gui = - (List.rev_map - (fun (a,_,b,c,d,e) -> a,b,c,d,e) - (List.rev (options_gen default t_gui))) - @[ - "--output-plot", - Superarg.String_opt t_gui.outputDataFile_gui, - "file name for data output", - [ - Common_args.output,1; - Common_args.semantics,1; - Common_args.integration_settings,1 - ],Superarg.Normal; - "--data-file", - Superarg.String_opt t_gui.outputDataFile_gui, - "file name for data output", - [ - Common_args.output,1; Common_args.semantics,2; - Common_args.integration_settings,3 - ],Superarg.Hidden;] + List.rev_map + (fun (a, _, b, c, d, e) -> a, b, c, d, e) + (List.rev (options_gen default t_gui)) + @ [ + ( "--output-plot", + Superarg.String_opt t_gui.outputDataFile_gui, + "file name for data output", + [ + Common_args.output, 1; + Common_args.semantics, 1; + Common_args.integration_settings, 1; + ], + Superarg.Normal ); + ( "--data-file", + Superarg.String_opt t_gui.outputDataFile_gui, + "file name for data output", + [ + Common_args.output, 1; + Common_args.semantics, 2; + Common_args.integration_settings, 3; + ], + Superarg.Hidden ); + ] diff --git a/core/cli/run_cli_args.mli b/core/cli/run_cli_args.mli index 90a05eeb25..eb09b9f6ca 100644 --- a/core/cli/run_cli_args.mli +++ b/core/cli/run_cli_args.mli @@ -1,37 +1,38 @@ type t = { - mutable inputKappaFileNames : string list; - mutable minValue : float option; - mutable maxValue : float option; - mutable plotPeriod : float option; - mutable outputDataFile : string option; - mutable outputDirectory : string; - mutable batchmode : bool; - mutable interactive : bool; - mutable syntaxVersion : Ast.syntax_version; + mutable inputKappaFileNames: string list; + mutable minValue: float option; + mutable maxValue: float option; + mutable plotPeriod: float option; + mutable outputDataFile: string option; + mutable outputDirectory: string; + mutable batchmode: bool; + mutable interactive: bool; + mutable syntaxVersion: Ast.syntax_version; } -type t_gui = - { - inputKappaFileNames_gui : string list ref; - minValue_gui : float option ref; - maxValue_gui : float option ref; - plotPeriod_gui : float option ref; - outputDataFile_gui : string option ref; - outputDirectory_gui : string ref; - syntaxVersion_gui : string ref; - batchmode_gui : string ref; - } - - val default: t - - val options: t -> (string * Arg.spec * string) list - val options_gui: t_gui -> - (string * Superarg.spec * string * - (Superarg.category * int) list * Superarg.level) - list +type t_gui = { + inputKappaFileNames_gui: string list ref; + minValue_gui: float option ref; + maxValue_gui: float option ref; + plotPeriod_gui: float option ref; + outputDataFile_gui: string option ref; + outputDirectory_gui: string ref; + syntaxVersion_gui: string ref; + batchmode_gui: string ref; +} -val copy_from_gui: t_gui -> t -> unit +val default : t +val options : t -> (string * Arg.spec * string) list -val aux: ('a * string) list -> ('a * Nbr.t) list -> ('a * Nbr.t) list +val options_gui : + t_gui -> + (string + * Superarg.spec + * string + * (Superarg.category * int) list + * Superarg.level) + list -val default_gui: t_gui +val copy_from_gui : t_gui -> t -> unit +val aux : ('a * string) list -> ('a * Nbr.t) list -> ('a * Nbr.t) list +val default_gui : t_gui diff --git a/core/cli/superarg.ml b/core/cli/superarg.ml index c5a650354c..7e24fbd315 100755 --- a/core/cli/superarg.ml +++ b/core/cli/superarg.ml @@ -6,57 +6,57 @@ Note that the spec type is really different. Copyright (C) Antoine Mine' 2006 - *) +*) -let expert_mode = ref false (* shows expert options *) -let dev_mode = ref false (* accept _ALL_ options *) +let expert_mode = ref false (* shows expert options *) +let dev_mode = ref false (* accept _ALL_ options *) (* Types *) (* ***** *) - -type key = string (* command-line argument *) -type msg = string (* help message *) +type key = string (* command-line argument *) +type msg = string (* help message *) (* type of option *) type level = - Normal (* always shown & accepted *) - | Expert (* shown in expert or developper mode, always accepted *) - | Developper (* only shown & accepted in developper mode *) - | Hidden (* never shown *) - - module StringInt = - struct - type t = string * int * (level option) - let compare (a,b,_) (c,d,_) = - let cmp = compare b d in - if cmp=0 - then compare a c - else cmp - let print fmt (a,b,_) = Format.fprintf fmt "%s:%i" a b - end - - module StringIntSetMap = SetMap.Make(StringInt) - module StringIntMap = StringIntSetMap.Map - module StringIntSet = StringIntSetMap.Set - - module StringSetMap = Mods.StringSetMap - module StringSet = StringSetMap.Set - module StringMap = StringSetMap.Map + | Normal (* always shown & accepted *) + | Expert (* shown in expert or developper mode, always accepted *) + | Developper (* only shown & accepted in developper mode *) + | Hidden (* never shown *) + +module StringInt = struct + type t = string * int * level option + + let compare (a, b, _) (c, d, _) = + let cmp = compare b d in + if cmp = 0 then + compare a c + else + cmp + + let print fmt (a, b, _) = Format.fprintf fmt "%s:%i" a b +end + +module StringIntSetMap = SetMap.Make (StringInt) +module StringIntMap = StringIntSetMap.Map +module StringIntSet = StringIntSetMap.Set +module StringSetMap = Mods.StringSetMap +module StringSet = StringSetMap.Set +module StringMap = StringSetMap.Map let min_level a b = - match a,b with - | Normal,_ | _,Normal -> Normal - | Expert,_ | _,Expert -> Expert - | Developper,_ | _,Developper -> Developper - | Hidden,Hidden -> Hidden + match a, b with + | Normal, _ | _, Normal -> Normal + | Expert, _ | _, Expert -> Expert + | Developper, _ | _, Developper -> Developper + | Hidden, Hidden -> Hidden let max_level a b = - match a,b with - | Hidden,_ | _,Hidden -> Hidden - | Developper,_ | _,Developper -> Developper - | Expert,_ | _,Expert -> Expert - | Normal,Normal -> Normal + match a, b with + | Hidden, _ | _, Hidden -> Hidden + | Developper, _ | _, Developper -> Developper + | Expert, _ | _, Expert -> Expert + | Normal, Normal -> Normal let max_level_opt a b = match b with @@ -64,376 +64,443 @@ let max_level_opt a b = | Some b -> max_level a b type position = int -type category = string * position * (level option) +type category = string * position * level option type spec = - | Void (* To skip a line *) - | Bool of bool ref (* Sets a boolean value *) - | Int of int ref (* Sets an integer value *) - | Int_opt of int option ref (* Sets an optional integer value *) - | String of string ref (* Sets a string value *) - | String_opt of string option ref (* Sets an optional string value *) - | String_list of string list ref (* Sets a list of strings *) - | StringNbr_list of (string * string) list ref (* Sets a list of pairs of strings *) - | Float of float ref (* Sets a float value *) - | Float_opt of float option ref (* Sets an optional float value *) - - (* one or several options among a list *) - | Choice of (key * msg) list * key list * (key ref) - | Choice_list of (key * msg) list * (key list ref) - - (* meta-options to set several options at once: - - 1st option list is appended as-is when the option is used - - when 2-st list is not empty, the meta option takes an argument that - is passed to each option in the list - - the keys in both lists must appear as regular options as well! - *) - | Multi of (key list) * (key list) + | Void (* To skip a line *) + | Bool of bool ref (* Sets a boolean value *) + | Int of int ref (* Sets an integer value *) + | Int_opt of int option ref (* Sets an optional integer value *) + | String of string ref (* Sets a string value *) + | String_opt of string option ref (* Sets an optional string value *) + | String_list of string list ref (* Sets a list of strings *) + | StringNbr_list of + (string * string) list ref (* Sets a list of pairs of strings *) + | Float of float ref (* Sets a float value *) + | Float_opt of float option ref (* Sets an optional float value *) + (* one or several options among a list *) + | Choice of (key * msg) list * key list * key ref + | Choice_list of (key * msg) list * key list ref + (* meta-options to set several options at once: + - 1st option list is appended as-is when the option is used + - when 2-st list is not empty, the meta option takes an argument that + is passed to each option in the list + - the keys in both lists must appear as regular options as well! + *) + | Multi of key list * key list (* meta-options, take a list of (k,ext):key*string and give to the option k the parameter s^ext *) - | MultiExt of (key*string) list - + | MultiExt of (key * string) list type t = (key * spec * msg * (category * position) list * level) list - (* Utilities *) (* ********* *) -let show_level (lvl:level) : bool = match lvl with +let show_level (lvl : level) : bool = + match lvl with | Normal -> true | Expert -> !expert_mode | Developper -> !dev_mode && !expert_mode | Hidden -> false -let show_level_opt (lvl_opt:level option) : bool = match lvl_opt with +let show_level_opt (lvl_opt : level option) : bool = + match lvl_opt with | None -> true | Some lvl -> show_level lvl -let accept_level_display (lvl:level) : bool = match lvl with +let accept_level_display (lvl : level) : bool = + match lvl with | Normal | Expert -> true | Developper -> !dev_mode | Hidden -> false -let accept_level_use (lvl:level) : bool = match lvl with +let accept_level_use (lvl : level) : bool = + match lvl with | Normal | Expert | Hidden -> true | Developper -> !dev_mode -let iskey (k:key) = String.length k > 2 && k.[0]='-' && k.[1]='-' +let iskey (k : key) = String.length k > 2 && k.[0] = '-' && k.[1] = '-' (* --XXX => --no-XXX *) -let nokey (k:key) = - if String.length k > 2 && k.[0]='-' && k.[1]='-' - then "--no-"^(String.sub k 2 (String.length k-2)) - else if String.length k > 1 && k.[0]='-' - then "-no-"^(String.sub k 1 (String.length k-1)) - else failwith (k^" option (no) does not begin with -- nor -") +let nokey (k : key) = + if String.length k > 2 && k.[0] = '-' && k.[1] = '-' then + "--no-" ^ String.sub k 2 (String.length k - 2) + else if String.length k > 1 && k.[0] = '-' then + "-no-" ^ String.sub k 1 (String.length k - 1) + else + failwith (k ^ " option (no) does not begin with -- nor -") (* --XXX => --(no-)XXX *) -let altkey (k:key) = - if String.length k > 2 && k.[0]='-' && k.[1]='-' - then "--(no-)"^(String.sub k 2 (String.length k-2)) - else if String.length k > 1 && k.[0]='-' - then "-(no-)"^(String.sub k 1 (String.length k-1)) - else failwith (k^" option (alt) does not begin with -- not - ") - +let altkey (k : key) = + if String.length k > 2 && k.[0] = '-' && k.[1] = '-' then + "--(no-)" ^ String.sub k 2 (String.length k - 2) + else if String.length k > 1 && k.[0] = '-' then + "-(no-)" ^ String.sub k 1 (String.length k - 1) + else + failwith (k ^ " option (alt) does not begin with -- not - ") (* cuts a string into space-separated sub-strings *) -let cut_list (s:string) : string list = +let cut_list (s : string) : string list = let rec doit accum pos = try let i = String.index_from s pos ' ' in - if i=pos then doit accum (i+1) - else doit ((String.sub s pos (i-pos))::accum) (i+1) + if i = pos then + doit accum (i + 1) + else + doit (String.sub s pos (i - pos) :: accum) (i + 1) with Not_found -> - if pos < String.length s - then (String.sub s pos (String.length s-pos))::accum - else accum + if pos < String.length s then + String.sub s pos (String.length s - pos) :: accum + else + accum in List.rev (doit [] 0) (* order by category *) -let p (_,_,_,l,_) (_,_,_,l',_) = - match l,l' with - [_,i],[_,i'] -> compare i i' - | ([] | _::_::_),_ - | _,([] | _::_::_) -> assert false -let order (a:t) = +let p (_, _, _, l, _) (_, _, _, l', _) = + match l, l' with + | [ (_, i) ], [ (_, i') ] -> compare i i' + | ([] | _ :: _ :: _), _ | _, ([] | _ :: _ :: _) -> assert false + +let order (a : t) = let ordered = ref StringIntMap.empty in List.iter - (fun (a,b,c,cat,lvl) -> - if accept_level_use lvl then - List.iter - (fun (cat,i) -> - let asso,old_lvl = - StringIntMap.find_default ([],Hidden) cat !ordered in - ordered := - StringIntMap.add - cat (((a,b,c,[cat,i],lvl)::asso), (min_level lvl old_lvl)) (!ordered) - ) - cat) + (fun (a, b, c, cat, lvl) -> + if accept_level_use lvl then + List.iter + (fun (cat, i) -> + let asso, old_lvl = + StringIntMap.find_default ([], Hidden) cat !ordered + in + ordered := + StringIntMap.add cat + ((a, b, c, [ cat, i ], lvl) :: asso, min_level lvl old_lvl) + !ordered) + cat) a; - ordered := - (StringIntMap.map - (fun (a,b) -> - List.sort p a, - b) - !ordered); + ordered := StringIntMap.map (fun (a, b) -> List.sort p a, b) !ordered; !ordered (* sanity checking *) -let check (a:t) = +let check (a : t) = (* check duplicates & compute option list *) let opts = ref StringSet.empty in - List.iter (fun (key,b,_,_,_) -> - if b=Void then () - else if StringSet.mem key !opts || StringSet.mem (nokey key) !opts - then failwith ("Duplicate option "^key); + List.iter + (fun (key, b, _, _, _) -> + if b = Void then + () + else if StringSet.mem key !opts || StringSet.mem (nokey key) !opts then + failwith ("Duplicate option " ^ key); opts := StringSet.add key !opts; - opts := StringSet.add (nokey key) !opts ) + opts := StringSet.add (nokey key) !opts) a; (* check sub-options in Muli-options *) - List.iter (fun (key,t,_,_,_) -> match t with - Multi (a,b) -> + List.iter + (fun (key, t, _, _, _) -> + match t with + | Multi (a, b) -> let f = List.iter (fun s -> - if iskey s && not (StringSet.mem s !opts) - then failwith ("Unknown option "^s^" in multi-option "^key)) - in f a; f b + if iskey s && not (StringSet.mem s !opts) then + failwith ("Unknown option " ^ s ^ " in multi-option " ^ key)) + in + f a; + f b | Void | Int _ | Float _ | Choice _ | Bool _ | Int_opt _ | String _ - | StringNbr_list _ - | String_opt _ | String_list _ | Float_opt _ | Choice_list (_, _) - | MultiExt _ -> () ) a - - + | StringNbr_list _ | String_opt _ | String_list _ | Float_opt _ + | Choice_list (_, _) + | MultiExt _ -> + ()) + a (* Command-line interface *) (* ********************** *) - (* prints a string with breaks instead of space *) -let print_msg f (s:string) = +let print_msg f (s : string) = Pp.list Pp.space Format.pp_print_string f (cut_list s) (* document the options on the standard output! *) -let print_option verbose f (key,spec,msg,_cat,_lvl) = +let print_option verbose f (key, spec, msg, _cat, _lvl) = let key2 = altkey key in (match spec with - Bool r -> - Format.fprintf f " %s (default: %s)@." key2 - (if !r then "enabled" else "disabled") - | Void -> () - | Int r -> Format.fprintf f " %s (default: %i)@." key !r - | Int_opt r -> - (match !r with - | None -> Format.fprintf f " %s (default: disabled)@." key2 - | Some i -> Format.fprintf f " %s (default: %i)@." key2 i) - | String r -> - (match !r with - | "" -> Format.fprintf f " %s (default: disabled)@." key - | s -> Format.fprintf f " %s (default: %s)@." key s) - | String_opt r -> - (match !r with - | None - | Some "" -> Format.fprintf f " %s (default: disabled)@." key2 - | Some s -> Format.fprintf f - " %s (default %s)@." key2 s) - | String_list r -> - (match !r with - | [] -> Format.fprintf f - " %s ... (default: disabled)@." key2 - | l -> Format.fprintf f " %s ... (default %a)@." key2 - (Pp.list Pp.space Format.pp_print_string) l) - | StringNbr_list r -> - (match !r with - | [] -> Format.fprintf f - " %s <... (default: disabled)@." key2 - | l -> - let rec aux list = - match list with - (h1,h2)::tail -> - let () = - Format.fprintf f " %s (default %s %s)" key2 - h1 h2 - in aux tail - | [] -> Format.fprintf f "@." - in aux l) - | Float r -> Format.fprintf f " %s (default %f)@." key !r - | Float_opt r -> - (match !r with - | None -> Format.fprintf f " %s (default: disabled)@." key2 - | Some v -> Format.fprintf f " %s (default: %f)@." key2 v) - | Choice (l,_,r) -> - Format.fprintf f " %s @[%a@] @ (default: %s)@." - key - (Pp.list - (fun f -> Format.fprintf f " |@ ") - (fun f (key,_msg) -> Format.pp_print_string f key)) l - !r - | Choice_list (l,r) -> - Format.fprintf f " %s @[%a@]@." key2 - (Pp.list - Pp.space - (fun f (key,_msg) -> - Format.fprintf f "[%s%s]" key - (if List.mem key !r then " (default)" else "") - ) - ) l - | Multi (_,[]) -> Format.fprintf f " %s@." key - | Multi _ -> Format.fprintf f " %s @." key - | MultiExt _ -> Format.fprintf f " %s @." key - ); + | Bool r -> + Format.fprintf f " %s (default: %s)@." key2 + (if !r then + "enabled" + else + "disabled") + | Void -> () + | Int r -> Format.fprintf f " %s (default: %i)@." key !r + | Int_opt r -> + (match !r with + | None -> Format.fprintf f " %s (default: disabled)@." key2 + | Some i -> Format.fprintf f " %s (default: %i)@." key2 i) + | String r -> + (match !r with + | "" -> Format.fprintf f " %s (default: disabled)@." key + | s -> Format.fprintf f " %s (default: %s)@." key s) + | String_opt r -> + (match !r with + | None | Some "" -> + Format.fprintf f " %s (default: disabled)@." key2 + | Some s -> Format.fprintf f " %s (default %s)@." key2 s) + | String_list r -> + (match !r with + | [] -> Format.fprintf f " %s ... (default: disabled)@." key2 + | l -> + Format.fprintf f " %s ... (default %a)@." key2 + (Pp.list Pp.space Format.pp_print_string) + l) + | StringNbr_list r -> + (match !r with + | [] -> Format.fprintf f " %s <... (default: disabled)@." key2 + | l -> + let rec aux list = + match list with + | (h1, h2) :: tail -> + let () = + Format.fprintf f " %s (default %s %s)" key2 h1 h2 + in + aux tail + | [] -> Format.fprintf f "@." + in + aux l) + | Float r -> Format.fprintf f " %s (default %f)@." key !r + | Float_opt r -> + (match !r with + | None -> Format.fprintf f " %s (default: disabled)@." key2 + | Some v -> Format.fprintf f " %s (default: %f)@." key2 v) + | Choice (l, _, r) -> + Format.fprintf f " %s @[%a@] @ (default: %s)@." key + (Pp.list + (fun f -> Format.fprintf f " |@ ") + (fun f (key, _msg) -> Format.pp_print_string f key)) + l !r + | Choice_list (l, r) -> + Format.fprintf f " %s @[%a@]@." key2 + (Pp.list Pp.space (fun f (key, _msg) -> + Format.fprintf f "[%s%s]" key + (if List.mem key !r then + " (default)" + else + ""))) + l + | Multi (_, []) -> Format.fprintf f " %s@." key + | Multi _ -> Format.fprintf f " %s @." key + | MultiExt _ -> Format.fprintf f " %s @." key); (* shows description if in verbose mode *) - if verbose && msg<>"" then Format.fprintf f " @[%a@]@." print_msg msg - - + if verbose && msg <> "" then Format.fprintf f " @[%a@]@." print_msg msg -let print_help (header:bool) (verbose:bool) f (a:t) = +let print_help (header : bool) (verbose : bool) f (a : t) = let nb = ref 0 in (* general options *) if header then Format.fprintf f "@.General options@."; - Format.fprintf f " --help Verbose help@."; incr nb; - Format.fprintf f " -h Short help@."; incr nb; - Format.fprintf f " --version Show version number@."; incr nb; - Format.fprintf f " --gui GUI to select@."; incr nb; - Format.fprintf f " --(no-)expert Expert mode (more options)@."; incr nb; + Format.fprintf f " --help Verbose help@."; + incr nb; + Format.fprintf f " -h Short help@."; + incr nb; + Format.fprintf f " --version Show version number@."; + incr nb; + Format.fprintf f " --gui GUI to select@."; + incr nb; + Format.fprintf f " --(no-)expert Expert mode (more options)@."; + incr nb; if verbose && header then Format.fprintf f "@."; (* dump *) StringIntMap.iter - (fun (cat,_,lvl_opt) (l,lvl) -> - if - show_level_opt lvl_opt && show_level lvl - then - begin - if header - then - Format.fprintf f "%s@." cat; - List.iter - (fun ((_,_,_,_,lvl) as x) -> - if show_level lvl then (incr nb; print_option verbose f x) - ) l; - if header && verbose then Format.fprintf f "@." - end - ) (order a); + (fun (cat, _, lvl_opt) (l, lvl) -> + if show_level_opt lvl_opt && show_level lvl then ( + if header then Format.fprintf f "%s@." cat; + List.iter + (fun ((_, _, _, _, lvl) as x) -> + if show_level lvl then ( + incr nb; + print_option verbose f x + )) + l; + if header && verbose then Format.fprintf f "@." + )) + (order a); Format.fprintf f "(%i options)@." !nb - - (* parse the command-line arguments, given as a list of strings, returns the list of non-options (filenames) in reverse order) - *) -let parse_list ~with_tk ?title (a:t) (l:string list) : string list = +*) +let parse_list ~with_tk ?title (a : t) (l : string list) : string list = let long_help = ref false and short_help = ref false - and show_version = ref false - in + and show_version = ref false in let rec doit accum = function - [] -> accum - | opt::rem -> - + | [] -> accum + | opt :: rem -> (* - means no more options: the rest are filenames *) - if opt="-" then List.rev_append rem accum - + if opt = "-" then + List.rev_append rem accum (* help options *) - else if opt="-help" || opt="--help" then - (long_help := true; doit accum rem) - else if opt="-h" then (* shorter list *) - (short_help := true; doit accum rem) - (* version number *) - else if opt="--version" then - (show_version := true ; doit accum rem) - (* expert *) - else if opt="--expert" then (expert_mode := true; doit accum rem) - else if opt="--no-expert" then (expert_mode := false; doit accum rem) - - (* regular option, starting with "-" *) - else if String.length opt > 1 && opt.[0]='-' then - let (key,spec,_,_,_)as aa= + else if opt = "-help" || opt = "--help" then ( + long_help := true; + doit accum rem + ) else if opt = "-h" then ( + (* shorter list *) + short_help := true; + doit accum rem (* version number *) + ) else if opt = "--version" then ( + show_version := true; + doit accum rem (* expert *) + ) else if opt = "--expert" then ( + expert_mode := true; + doit accum rem + ) else if opt = "--no-expert" then ( + expert_mode := false; + doit accum rem (* regular option, starting with "-" *) + ) else if String.length opt > 1 && opt.[0] = '-' then ( + let ((key, spec, _, _, _) as aa) = try List.find - (fun (key,_spec,_msg,_cat,lvl) -> - (accept_level_use lvl) && - (opt=key || (opt=(nokey key))) - ) a + (fun (key, _spec, _msg, _cat, lvl) -> + accept_level_use lvl && (opt = key || opt = nokey key)) + a with Not_found -> - Format.printf "Here is the list of recognized options@.%a@.Unrecognized option: %s@.@." (print_help true false) a opt; + Format.printf + "Here is the list of recognized options@.%a@.Unrecognized \ + option: %s@.@." + (print_help true false) a opt; failwith "bad option" in let rem = - try match spec,rem with - | Bool r, rem -> r := (opt=key); rem - | Int r, (""::rem) when opt=key -> r := 0; rem - | Int r, (v::rem) when opt=key -> r := int_of_string v; rem - | Int_opt r, (""::rem) when opt=key -> r := None; rem - | Int_opt r, (v::rem) when opt=key -> - r := Some (int_of_string v); rem - | Int_opt r, rem -> r := None; rem - | String r, (v::rem) when opt=key -> r := v; rem - | String r, rem -> r := ""; rem - | String_opt r, (""::rem) when opt=key -> r := None; rem - | String_opt r, (v::rem) when opt=key -> r := Some v; rem - | String_opt r, rem -> r := None; rem - | String_list _, (""::rem) when opt=key -> rem - | String_list r, (v::rem) when opt=key -> r := v::(!r); rem - | String_list r, rem -> r := []; rem - | StringNbr_list _, (""::rem) when opt=key -> rem - | StringNbr_list _, ([_]) when opt=key -> failwith "invalid pair" - | StringNbr_list r, (v'::v::rem) when opt=key -> r := (v,v')::(!r); rem - | StringNbr_list r, rem -> r := []; rem - - | Float r, (""::rem) when opt=key -> r := 0.; rem - | Float r, (v::rem) when opt=key -> r := float_of_string v; rem - | Float_opt r, (""::rem) when opt=key -> r := None; rem - | Float_opt r, (v::rem) when opt=key -> - r := Some (float_of_string v); rem - | Float_opt r, rem -> r := None; rem - | Choice (l,l',r), (v::rem) when opt=key -> - if not (List.exists (fun (k,_) -> v=k) l) && - not (List.exists (fun k -> v=k) l') - then failwith "invalid choice"; - r := v; rem - | Choice_list (l,r), (v::rem) when opt=key -> - if not (List.exists (fun (k,_) -> v=k) l) - then failwith "invalid choice"; - r := v::(!r); rem - | Choice_list (_l,r), rem -> r := []; rem - | Multi (x,[]), rem -> ignore (doit [] x); rem - | Multi (x,y), (v::rem) -> + try + match spec, rem with + | Bool r, rem -> + r := opt = key; + rem + | Int r, "" :: rem when opt = key -> + r := 0; + rem + | Int r, v :: rem when opt = key -> + r := int_of_string v; + rem + | Int_opt r, "" :: rem when opt = key -> + r := None; + rem + | Int_opt r, v :: rem when opt = key -> + r := Some (int_of_string v); + rem + | Int_opt r, rem -> + r := None; + rem + | String r, v :: rem when opt = key -> + r := v; + rem + | String r, rem -> + r := ""; + rem + | String_opt r, "" :: rem when opt = key -> + r := None; + rem + | String_opt r, v :: rem when opt = key -> + r := Some v; + rem + | String_opt r, rem -> + r := None; + rem + | String_list _, "" :: rem when opt = key -> rem + | String_list r, v :: rem when opt = key -> + r := v :: !r; + rem + | String_list r, rem -> + r := []; + rem + | StringNbr_list _, "" :: rem when opt = key -> rem + | StringNbr_list _, [ _ ] when opt = key -> failwith "invalid pair" + | StringNbr_list r, v' :: v :: rem when opt = key -> + r := (v, v') :: !r; + rem + | StringNbr_list r, rem -> + r := []; + rem + | Float r, "" :: rem when opt = key -> + r := 0.; + rem + | Float r, v :: rem when opt = key -> + r := float_of_string v; + rem + | Float_opt r, "" :: rem when opt = key -> + r := None; + rem + | Float_opt r, v :: rem when opt = key -> + r := Some (float_of_string v); + rem + | Float_opt r, rem -> + r := None; + rem + | Choice (l, l', r), v :: rem when opt = key -> + if + (not (List.exists (fun (k, _) -> v = k) l)) + && not (List.exists (fun k -> v = k) l') + then + failwith "invalid choice"; + r := v; + rem + | Choice_list (l, r), v :: rem when opt = key -> + if not (List.exists (fun (k, _) -> v = k) l) then + failwith "invalid choice"; + r := v :: !r; + rem + | Choice_list (_l, r), rem -> + r := []; + rem + | Multi (x, []), rem -> ignore (doit [] x); - ignore (List.fold_left (fun _ l -> doit [] [l;v]) - accum y); rem - | MultiExt l,v::rem when opt=key -> - ignore (List.fold_left (fun _ (l,s) -> doit [] [l;v^s]) - accum l);rem - | MultiExt l,rem -> - ignore (List.fold_left (fun _ (l,s) -> doit [] [nokey l;s]) accum l);rem - | Multi _,[] | (Void | Int _ | Float _ | Choice _), _ -> failwith "invalid option or argument" - + | Multi (x, y), v :: rem -> + ignore (doit [] x); + ignore (List.fold_left (fun _ l -> doit [] [ l; v ]) accum y); + rem + | MultiExt l, v :: rem when opt = key -> + ignore + (List.fold_left (fun _ (l, s) -> doit [] [ l; v ^ s ]) accum l); + rem + | MultiExt l, rem -> + ignore + (List.fold_left + (fun _ (l, s) -> doit [] [ nokey l; s ]) + accum l); + rem + | Multi _, [] | (Void | Int _ | Float _ | Choice _), _ -> + failwith "invalid option or argument" with _ -> Format.printf "Wrong option or argument for %s@.%a" opt (print_option false) aa; failwith "bad option" in doit accum rem - - (* does not start with - => this is filename *) - else doit (opt::accum) rem - + (* does not start with - => this is filename *) + ) else + doit (opt :: accum) rem in + let filenames = doit [] l in - if !show_version then - (Format.printf "%s @.(with%s Tk interface)@." - (match title - with - | None -> Version.version_kasa_full_name - | Some x -> x) - (if with_tk then "" else "out"); - exit 0) - else if !long_help then (Format.printf "%a" (print_help true true) a; exit 0) - else if !short_help then (Format.printf "%a" (print_help true false) a; exit 0); + if !show_version then ( + Format.printf "%s @.(with%s Tk interface)@." + (match title with + | None -> Version.version_kasa_full_name + | Some x -> x) + (if with_tk then + "" + else + "out"); + exit 0 + ) else if !long_help then ( + Format.printf "%a" (print_help true true) a; + exit 0 + ) else if !short_help then ( + Format.printf "%a" (print_help true false) a; + exit 0 + ); (* List.concat*) filenames (*(List.map Wordexp.wordexp filenames)*) diff --git a/core/cli/superarg.mli b/core/cli/superarg.mli index 650fc6ba00..1357e48aea 100644 --- a/core/cli/superarg.mli +++ b/core/cli/superarg.mli @@ -1,58 +1,58 @@ type position = int + type level = -| Normal (* always shown & accepted *) -| Expert (* shown in expert or developper mode, always accepted *) -| Developper (* only shown & accepted in developper mode *) -| Hidden (* never shown *) -type category = string * position * (level option) + | Normal (* always shown & accepted *) + | Expert (* shown in expert or developper mode, always accepted *) + | Developper (* only shown & accepted in developper mode *) + | Hidden (* never shown *) + +type category = string * position * level option type key = string type msg = string type spec = - | Void (* To skip a line *) - | Bool of bool ref (* Sets a boolean value *) - | Int of int ref (* Sets an integer value *) - | Int_opt of int option ref (* Sets an optional integer value *) - | String of string ref (* Sets a string value *) - | String_opt of string option ref (* Sets an optional string value *) - | String_list of string list ref (* Sets a list of strings *) - | StringNbr_list of (string * string) list ref (* Sets a list of pairs of strings *) - | Float of float ref (* Sets a float value *) - | Float_opt of float option ref (* Sets an optional float value *) - - (* one or several options among a list *) - | Choice of (key * msg) list * key list * (key ref) - | Choice_list of (key * msg) list * (key list ref) - - (* meta-options to set several options at once: - - 1st option list is appended as-is when the option is used - - when 2-st list is not empty, the meta option takes an argument that - is passed to each option in the list - - the keys in both lists must appear as regular options as well! - *) - | Multi of (key list) * (key list) + | Void (* To skip a line *) + | Bool of bool ref (* Sets a boolean value *) + | Int of int ref (* Sets an integer value *) + | Int_opt of int option ref (* Sets an optional integer value *) + | String of string ref (* Sets a string value *) + | String_opt of string option ref (* Sets an optional string value *) + | String_list of string list ref (* Sets a list of strings *) + | StringNbr_list of + (string * string) list ref (* Sets a list of pairs of strings *) + | Float of float ref (* Sets a float value *) + | Float_opt of float option ref (* Sets an optional float value *) + (* one or several options among a list *) + | Choice of (key * msg) list * key list * key ref + | Choice_list of (key * msg) list * key list ref + (* meta-options to set several options at once: + - 1st option list is appended as-is when the option is used + - when 2-st list is not empty, the meta option takes an argument that + is passed to each option in the list + - the keys in both lists must appear as regular options as well! + *) + | Multi of key list * key list (* meta-options, take a list of (k,ext):key*string and give to the option k the parameter s^ext *) - | MultiExt of (key*string) list - + | MultiExt of (key * string) list type t = (key * spec * msg * (category * position) list * level) list +val accept_level_display : level -> bool +val check : t -> unit +val parse_list : with_tk:bool -> ?title:msg -> t -> msg list -> msg list -val accept_level_display: level -> bool -val check: t -> unit -val parse_list: -with_tk:bool -> ?title:msg -> t -> msg list -> msg list +module StringMap : SetMap.Map with type elt = string +module StringIntSet : SetMap.Set with type elt = string * int * level option +module StringIntMap : SetMap.Map with type elt = string * int * level option -module StringMap:SetMap.Map with type elt = string -module StringIntSet:SetMap.Set with type elt = string * int * (level option) -module StringIntMap:SetMap.Map with type elt = string * int * (level option) +val max_level_opt : level -> level option -> level +val show_level : level -> bool +val expert_mode : bool ref +val nokey : msg -> msg -val max_level_opt: level -> level option -> level -val show_level: level -> bool -val expert_mode: bool ref -val nokey: msg -> msg -val order: +val order : t -> - ((msg * spec * msg * (StringIntSet.elt * position) list * level) list * level) StringIntMap.t + ((msg * spec * msg * (StringIntSet.elt * position) list * level) list * level) + StringIntMap.t -val cut_list: msg -> msg list +val cut_list : msg -> msg list diff --git a/core/cli/superargTk.mli b/core/cli/superargTk.mli index 251ad3f2b2..354a4b2e5b 100644 --- a/core/cli/superargTk.mli +++ b/core/cli/superargTk.mli @@ -1,2 +1,3 @@ exception Exit of string list -val parse: ?title:string -> Superarg.t -> string list ref -> unit + +val parse : ?title:string -> Superarg.t -> string list ref -> unit diff --git a/core/cli/superargTk.notk.ml b/core/cli/superargTk.notk.ml index 33c9649c66..4d0ba3b4b0 100755 --- a/core/cli/superargTk.notk.ml +++ b/core/cli/superargTk.notk.ml @@ -3,25 +3,29 @@ Copyright (C) Antoine Mine' 2006 Light Version (Jerome Feret) This LIGHT version does not require labltk - - *) +*) exception Exit of string list - - (* MAIN *) (* **** *) -let parse ?title (a:Superarg.t) (def:string list ref) = +let parse ?title (a : Superarg.t) (def : string list ref) = Superarg.check a; (* drop the first command-line argument: it is the executable name *) let args = List.tl (Array.to_list Sys.argv) in (* if no argument or "--gui" given, launch the gui, otherwise, parse args *) let rem = - if args=[] || args=["--expert"] || args=["--no-expert"] || List.exists ((=) "--gui") args - then Superarg.parse_list - ~with_tk:false ?title a (if List.exists ((=) "--expert") args then ["--help";"--expert"] else ["--help"]) - else Superarg.parse_list ~with_tk:false ?title a args + if + args = [] || args = [ "--expert" ] || args = [ "--no-expert" ] + || List.exists (( = ) "--gui") args + then + Superarg.parse_list ~with_tk:false ?title a + (if List.exists (( = ) "--expert") args then + [ "--help"; "--expert" ] + else + [ "--help" ]) + else + Superarg.parse_list ~with_tk:false ?title a args in - if rem<>[] then def := rem + if rem <> [] then def := rem diff --git a/core/cli/superargTk.tk.ml b/core/cli/superargTk.tk.ml index a899e0ecdb..79b0a84ade 100755 --- a/core/cli/superargTk.tk.ml +++ b/core/cli/superargTk.tk.ml @@ -1,508 +1,617 @@ (* LablTK GUI for option selection Superarg. Copyright (C) Antoine Mine' 2006 - *) +*) open Tk - module StringSetMap = Mods.StringSetMap module StringMap = StringSetMap.Map -let map = ref StringMap.empty (* key => entry widget *) -let fmap = ref StringMap.empty (* key => frame widget *) +let map = ref StringMap.empty (* key => entry widget *) +let fmap = ref StringMap.empty (* key => frame widget *) (* show / hide options according to current mode *) -let set_visibility (a:Superarg.t) = +let set_visibility (a : Superarg.t) = List.iter - (fun (key,_,_,_,lvl) -> + (fun (key, _, _, _, lvl) -> try let f = - match StringMap.find_option key !fmap - with Some f -> f - | None -> raise Not_found + match StringMap.find_option key !fmap with + | Some f -> f + | None -> raise Not_found in - List.iter (fun f -> Pack.forget [coe f]) f; - if Superarg.show_level lvl - then - List.iter (fun f -> pack ~side:`Top ~anchor:`W [coe f]) f - with Not_found -> () - ) a + List.iter (fun f -> Pack.forget [ coe f ]) f; + if Superarg.show_level lvl then + List.iter (fun f -> pack ~side:`Top ~anchor:`W [ coe f ]) f + with Not_found -> ()) + a -let set_visibility_bis a = - List.iter (fun (f,_) -> Pack.forget [coe f]) a; +let set_visibility_bis a = + List.iter (fun (f, _) -> Pack.forget [ coe f ]) a; List.iter - (fun (f,lvl) -> if Superarg.show_level lvl - then - pack ~side:`Left ~padx:1 ~pady:1 [coe f] - ) + (fun (f, lvl) -> + if Superarg.show_level lvl then pack ~side:`Left ~padx:1 ~pady:1 [ coe f ]) a -let set_visibility (a,b) = +let set_visibility (a, b) = set_visibility a; set_visibility_bis b let plist_to_list l = - List.fold_left - (fun l (a,b) -> a::b::l) - [] - (List.rev l) + List.fold_left (fun l (a, b) -> a :: b :: l) [] (List.rev l) + (* option value => widget value *) -let widget_update_from_spec (a:Superarg.t) = +let widget_update_from_spec (a : Superarg.t) = let set n v = - try Textvariable.set ( - match - StringMap.find_option n !map - with + try + Textvariable.set + (match StringMap.find_option n !map with | None -> raise Not_found | Some a -> a) v with Not_found -> () in List.iter - (fun (key,spec,_msg,_cat,_lvl) -> + (fun (key, spec, _msg, _cat, _lvl) -> match spec with - | Superarg.Void -> () - | Superarg.Bool r -> set key (if !r then "1" else "0") - | Superarg.Int r -> set key (string_of_int (!r)) + | Superarg.Void -> () + | Superarg.Bool r -> + set key + (if !r then + "1" + else + "0") + | Superarg.Int r -> set key (string_of_int !r) | Superarg.Int_opt r -> - set key (match !r with None -> "" | Some i -> string_of_int i) + set key + (match !r with + | None -> "" + | Some i -> string_of_int i) | Superarg.String r -> set key !r - | Superarg.String_opt r -> set key (match !r with None -> "" | Some s -> s) + | Superarg.String_opt r -> + set key + (match !r with + | None -> "" + | Some s -> s) | Superarg.String_list r -> set key (String.concat " " !r) - | Superarg.StringNbr_list r -> set key (String.concat " " (plist_to_list !r)) - | Superarg.Float r -> set key (string_of_float (!r)) + | Superarg.StringNbr_list r -> + set key (String.concat " " (plist_to_list !r)) + | Superarg.Float r -> set key (string_of_float !r) | Superarg.Float_opt r -> - set key (match !r with None -> "" | Some f -> string_of_float f) - | Superarg.Choice (_,_,r) -> set key !r - | Superarg.Choice_list (l,r) -> - List.iter - (fun (k,_) -> set (key^"."^k) (if List.mem k !r then "1" else "0")) - l - | Superarg.Multi (_,[]) -> () - | Superarg.Multi (_,_) -> set key "" - | Superarg.MultiExt _ -> set key "" - ) a + set key + (match !r with + | None -> "" + | Some f -> string_of_float f) + | Superarg.Choice (_, _, r) -> set key !r + | Superarg.Choice_list (l, r) -> + List.iter + (fun (k, _) -> + set + (key ^ "." ^ k) + (if List.mem k !r then + "1" + else + "0")) + l + | Superarg.Multi (_, []) -> () + | Superarg.Multi (_, _) -> set key "" + | Superarg.MultiExt _ -> set key "") + a (* command-line argument => widget value *) -let widget_update_from_cmd (a:Superarg.t) l = +let widget_update_from_cmd (a : Superarg.t) l = let rec doit accum = function - [] -> accum - | ("-help" | "--help" | "-h" | "--gui")::rem -> doit accum rem - | "--expert"::rem -> - Superarg.expert_mode := true; set_visibility (a,[]); doit accum rem - | "--no-expert"::rem -> - Superarg.expert_mode := false; set_visibility (a,[]); doit accum rem - | opt::rem -> - if opt="-" then List.rev_append rem accum else - try - let key,spec,_,_,_ = - List.find (fun (key,_,_,_,_) -> opt=key || opt=(Superarg.nokey key)) a in - let set n v = Textvariable.set - (match StringMap.find_option n !map with - | Some a -> a - | None -> raise Not_found) v - and get n = Textvariable.get - (match StringMap.find_option n !map with - | Some a -> a - | None -> raise Not_found) in - let rem = match spec,rem with - | Superarg.Void , rem -> rem - | Superarg.Bool _, rem -> set key (if opt=key then "1" else "0"); rem - | (Superarg.Int _ | Superarg.Int_opt _ | Superarg.String _ | Superarg.String_opt _ | Superarg.Float _ | - Superarg.Float_opt _ | Superarg.Choice _ ), (v::rem) when opt=key -> - set key v; rem - | (Superarg.String_list _ | Superarg.StringNbr_list _), (v::rem) when opt=key -> - set key ((get key)^" "^v); rem - | (Superarg.Int _ | Superarg.Int_opt _ | Superarg.String _ | Superarg.String_opt _ | Superarg.Float _ | - Superarg.Float_opt _ | Superarg.Choice _ | Superarg.String_list _ | Superarg.StringNbr_list _), rem -> - set key ""; rem - | Superarg.Choice_list _, (v::rem) when opt=key -> - set (key^"."^v) "1"; rem - | Superarg.Choice_list (l,_), rem -> - List.iter (fun (v,_) -> set (key^"."^v) "0") l; rem - | Superarg.Multi (x,[]), rem -> ignore (doit [] x); rem - | Superarg.Multi (x,y), (v::rem) -> - set key v; - if v<>"" then - (ignore (doit [] x); - ignore (List.fold_left (fun _accum l -> doit [] [l;v]) - accum y)); - rem - | Superarg.MultiExt l,(v::rem) -> - set key v; - if v<>"" then - (ignore (List.fold_left (fun _accum (l,ext) -> doit [] [l;v^ext]) - accum l)); - rem - | _, [] -> rem - in - doit accum rem (* option eaten *) - with _ -> doit (opt::accum) rem (* option accumulated *) - in List.rev (doit [] l) - - + | [] -> accum + | ("-help" | "--help" | "-h" | "--gui") :: rem -> doit accum rem + | "--expert" :: rem -> + Superarg.expert_mode := true; + set_visibility (a, []); + doit accum rem + | "--no-expert" :: rem -> + Superarg.expert_mode := false; + set_visibility (a, []); + doit accum rem + | opt :: rem -> + if opt = "-" then + List.rev_append rem accum + else ( + try + let key, spec, _, _, _ = + List.find + (fun (key, _, _, _, _) -> opt = key || opt = Superarg.nokey key) + a + in + let set n v = + Textvariable.set + (match StringMap.find_option n !map with + | Some a -> a + | None -> raise Not_found) + v + and get n = + Textvariable.get + (match StringMap.find_option n !map with + | Some a -> a + | None -> raise Not_found) + in + let rem = + match spec, rem with + | Superarg.Void, rem -> rem + | Superarg.Bool _, rem -> + set key + (if opt = key then + "1" + else + "0"); + rem + | ( ( Superarg.Int _ | Superarg.Int_opt _ | Superarg.String _ + | Superarg.String_opt _ | Superarg.Float _ + | Superarg.Float_opt _ | Superarg.Choice _ ), + v :: rem ) + when opt = key -> + set key v; + rem + | (Superarg.String_list _ | Superarg.StringNbr_list _), v :: rem + when opt = key -> + set key (get key ^ " " ^ v); + rem + | ( ( Superarg.Int _ | Superarg.Int_opt _ | Superarg.String _ + | Superarg.String_opt _ | Superarg.Float _ + | Superarg.Float_opt _ | Superarg.Choice _ + | Superarg.String_list _ | Superarg.StringNbr_list _ ), + rem ) -> + set key ""; + rem + | Superarg.Choice_list _, v :: rem when opt = key -> + set (key ^ "." ^ v) "1"; + rem + | Superarg.Choice_list (l, _), rem -> + List.iter (fun (v, _) -> set (key ^ "." ^ v) "0") l; + rem + | Superarg.Multi (x, []), rem -> + ignore (doit [] x); + rem + | Superarg.Multi (x, y), v :: rem -> + set key v; + if v <> "" then ( + ignore (doit [] x); + ignore + (List.fold_left (fun _accum l -> doit [] [ l; v ]) accum y) + ); + rem + | Superarg.MultiExt l, v :: rem -> + set key v; + if v <> "" then + ignore + (List.fold_left + (fun _accum (l, ext) -> doit [] [ l; v ^ ext ]) + accum l); + rem + | _, [] -> rem + in + doit accum rem (* option eaten *) + with _ -> doit (opt :: accum) rem (* option accumulated *) + ) + in + List.rev (doit [] l) (* widget value => command-line argument, if [short]=[true] no command is output is the value is the default one *) -let cmd_of_widget (a:Superarg.t) short = - let get n = Textvariable.get +let cmd_of_widget (a : Superarg.t) short = + let get n = + Textvariable.get (match StringMap.find_option n !map with - | Some a -> a - | None -> raise Not_found) + | Some a -> a + | None -> raise Not_found) in List.fold_left - (fun accum (key,spec,_msg,cat,_lvl) -> - try match spec with - | Superarg.Void -> accum - | Superarg.Bool r -> - let v = (get key = "1") in - if !r=v && short then accum else - if v then key::accum else (Superarg.nokey key)::accum - | Superarg.Int r -> - let v = get key in - if !r=(int_of_string v) && short then accum else key::v::accum - | Superarg.Int_opt r -> - let v = get key in - if v="" && (!r<>None || not short) then (Superarg.nokey key)::accum - else if v<>"" && (!r<>(Some (int_of_string v)) || not short) - then key::v::accum else accum - | Superarg.String r -> - let v = get key in - if v="" && (!r<>"" || not short) then (Superarg.nokey key)::accum - else if v<>"" && (!r<>v || not short) - then key::v::accum else accum - | Superarg.String_opt r -> - let v = get key in - if v="" && (!r<>None || not short) then (Superarg.nokey key)::accum - else if v<>"" && (!r<>Some v || not short) - then key::v::accum else accum - | Superarg.String_list r -> - let v = Superarg.cut_list (get key) in - if v = !r && short then accum - else if v = [] then (Superarg.nokey key)::accum - else List.fold_right (fun x accum -> key::x::accum) v accum - | Superarg.StringNbr_list r -> - let v = Superarg.cut_list (get key) in - if v = plist_to_list !r && short then accum - else if v = [] then (Superarg.nokey key)::accum - else List.fold_right (fun x accum -> key::x::accum) v accum - | Superarg.Float r -> - let v = get key in - if !r=(float_of_string v) && short then accum else key::v::accum - | Superarg.Float_opt r -> - let v = get key in - if v="" && (!r<>None || not short) then (Superarg.nokey key)::accum - else if v<>"" && (!r<>(Some (float_of_string v)) || not short) - then key::v::accum else accum - | Superarg.Choice (ll,_,r) -> - let v = get key in - if not (List.exists (fun (k,_) -> v=k) ll) - then failwith "invalid Superarg.Choice" - else if !r=v && short then accum else key::v::accum - | Superarg.Choice_list (ll,r) -> - let v = - List.fold_left - (fun accum (k,_) -> - try if get (key^"."^k) = "1" then k::accum else accum - with Not_found -> accum - ) [] ll - in - if !r=v && short then accum - else if v=[] then (Superarg.nokey key)::accum - else List.fold_left (fun accum x -> key::x::accum) accum v - | Superarg.Multi _ -> accum - | Superarg.MultiExt _ -> accum + (fun accum (key, spec, _msg, cat, _lvl) -> + try + match spec with + | Superarg.Void -> accum + | Superarg.Bool r -> + let v = get key = "1" in + if !r = v && short then + accum + else if v then + key :: accum + else + Superarg.nokey key :: accum + | Superarg.Int r -> + let v = get key in + if !r = int_of_string v && short then + accum + else + key :: v :: accum + | Superarg.Int_opt r -> + let v = get key in + if v = "" && (!r <> None || not short) then + Superarg.nokey key :: accum + else if v <> "" && (!r <> Some (int_of_string v) || not short) then + key :: v :: accum + else + accum + | Superarg.String r -> + let v = get key in + if v = "" && (!r <> "" || not short) then + Superarg.nokey key :: accum + else if v <> "" && (!r <> v || not short) then + key :: v :: accum + else + accum + | Superarg.String_opt r -> + let v = get key in + if v = "" && (!r <> None || not short) then + Superarg.nokey key :: accum + else if v <> "" && (!r <> Some v || not short) then + key :: v :: accum + else + accum + | Superarg.String_list r -> + let v = Superarg.cut_list (get key) in + if v = !r && short then + accum + else if v = [] then + Superarg.nokey key :: accum + else + List.fold_right (fun x accum -> key :: x :: accum) v accum + | Superarg.StringNbr_list r -> + let v = Superarg.cut_list (get key) in + if v = plist_to_list !r && short then + accum + else if v = [] then + Superarg.nokey key :: accum + else + List.fold_right (fun x accum -> key :: x :: accum) v accum + | Superarg.Float r -> + let v = get key in + if !r = float_of_string v && short then + accum + else + key :: v :: accum + | Superarg.Float_opt r -> + let v = get key in + if v = "" && (!r <> None || not short) then + Superarg.nokey key :: accum + else if v <> "" && (!r <> Some (float_of_string v) || not short) then + key :: v :: accum + else + accum + | Superarg.Choice (ll, _, r) -> + let v = get key in + if not (List.exists (fun (k, _) -> v = k) ll) then + failwith "invalid Superarg.Choice" + else if !r = v && short then + accum + else + key :: v :: accum + | Superarg.Choice_list (ll, r) -> + let v = + List.fold_left + (fun accum (k, _) -> + try + if get (key ^ "." ^ k) = "1" then + k :: accum + else + accum + with Not_found -> accum) + [] ll + in + if !r = v && short then + accum + else if v = [] then + Superarg.nokey key :: accum + else + List.fold_left (fun accum x -> key :: x :: accum) accum v + | Superarg.Multi _ -> accum + | Superarg.MultiExt _ -> accum with - | Not_found -> accum - | Failure f -> failwith ("Invalid argument type for option "^key^" in "^( - List.fold_left (fun sol ((x,_,_),_) -> sol^" "^x) "" cat)^": "^f) - ) [] (List.rev a) - - + | Failure f -> + failwith + ("Invalid argument type for option " ^ key ^ " in " + ^ List.fold_left (fun sol ((x, _, _), _) -> sol ^ " " ^ x) "" cat + ^ ": " ^ f)) + [] (List.rev a) let balloon_delay = 100 (* create an option widget, add the defined variables to the map *) -let widget_of_spec (a:Superarg.t) key spec msg lvl parent = +let widget_of_spec (a : Superarg.t) key spec msg lvl parent = let f = Frame.create parent in - let old = - StringMap.find_default [] key !fmap in - let fmap' = StringMap.add key (f::old) !fmap in - let _ = fmap:=fmap' in + let old = StringMap.find_default [] key !fmap in + let fmap' = StringMap.add key (f :: old) !fmap in + let _ = fmap := fmap' in let v = - match - StringMap.find_option key (!map) - with + match StringMap.find_option key !map with | Some a -> a | None -> Textvariable.create () in (match spec with | Superarg.Bool _ -> - let chk = Checkbutton.create ~variable:v ~text:key f in - pack ~side:`Left ~anchor:`W [chk]; - Balloon.put ~on:(coe chk) ~ms:balloon_delay msg; - map := StringMap.add key v !map + let chk = Checkbutton.create ~variable:v ~text:key f in + pack ~side:`Left ~anchor:`W [ chk ]; + Balloon.put ~on:(coe chk) ~ms:balloon_delay msg; + map := StringMap.add key v !map | Superarg.Void -> - let lbl = Label.create ~text:(" ") ~padx:20 f in - pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [coe lbl]; - Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg; - | Superarg.Int _ | Superarg.Int_opt _ | Superarg.String _ | Superarg.String_opt _ | Superarg.String_list _ | Superarg.StringNbr_list _ + let lbl = Label.create ~text:" " ~padx:20 f in + pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [ coe lbl ]; + Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg + | Superarg.Int _ | Superarg.Int_opt _ | Superarg.String _ + | Superarg.String_opt _ | Superarg.String_list _ | Superarg.StringNbr_list _ | Superarg.Float _ | Superarg.Float_opt _ -> - let ext = match spec with + let ext = + match spec with | Superarg.Int _ | Superarg.Int_opt _ -> "" | Superarg.String _ | Superarg.String_opt _ -> "" | Superarg.String_list _ | Superarg.StringNbr_list _ -> " ..." | Superarg.Float _ | Superarg.Float_opt _ -> "" - | Superarg.Void - | Superarg.Bool _ - | Superarg.Choice _ - | Superarg.Choice_list _ - | Superarg.Multi _ - | Superarg.MultiExt _ -> "" - in - let lbl = Label.create ~text:(key^" "^ext) ~padx:20 f - and entry = Entry.create ~textvariable:v f in - pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [coe lbl;coe entry]; - Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg; - Balloon.put ~on:(coe entry) ~ms:balloon_delay msg; - map := (*snd*) StringMap.add key v !map - | Superarg.Choice (l,_,_) -> - let lbl = Label.create ~text:key ~padx:20 f in - let fff = Frame.create f in - let ff = Frame.create fff in - let p = ref 0 in - List.iter - (fun (k,msg2) -> - let radio = Radiobutton.create - ~variable:v ~text:k ~value:k ~padx:40 ff in - Grid.configure ~sticky:"w" ~column:(!p mod 3) ~row:(!p / 3) [radio]; - Balloon.put ~on:(coe radio) ~ms:balloon_delay (msg^":\n"^msg2); - incr p - ) l; - pack ~side:`Top ~anchor:`W [coe lbl; coe ff]; - pack ~side:`Left ~anchor:`W [coe fff]; - Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg; - map := StringMap.add key v !map - | Superarg.Choice_list (l,_) -> - let lbl = Label.create ~text:key ~padx:20 f in - let fff = Frame.create f in - let ff = Frame.create fff in - let p = ref 0 in - let nb = 4 in (* number of columns *) - List.iter - (fun (k,msg2) -> - let v = Textvariable.create () in - let chk = - Checkbutton.create ~variable:v ~text:k ~padx:40 ff in - Grid.configure ~sticky:"w" ~column:(!p mod nb) ~row:(!p / nb) [chk]; - incr p; - Balloon.put ~on:(coe chk) ~ms:balloon_delay (msg^":\n"^msg2); - map := StringMap.add (key^"."^k) v !map - ) l; - pack ~side:`Top ~anchor:`W [coe lbl; coe ff]; - pack ~side:`Left ~anchor:`W [coe fff]; - Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg - | Superarg.Multi (x,[]) -> - let update () = ignore (widget_update_from_cmd a x) in - let b = Button.create ~text:key ~padx:20 ~command:update f in - pack ~side:`Left ~anchor:`W [coe b]; - let msg2 = msg^"\n(equivalent to "^(String.concat " " x)^" )" in - Balloon.put ~on:(coe b) ~ms:balloon_delay msg2; - map := StringMap.add key v !map - | Superarg.Multi (x,y) -> - let rec update () = - let s = Textvariable.get v in - if s<>"" then - (ignore (widget_update_from_cmd a x); - List.iter (fun o -> ignore (widget_update_from_cmd a [o;s])) y); - Textvariable.handle v ~callback:update - in - let lbl = Label.create ~text:key ~padx:20 f - and entry = Entry.create ~textvariable:v f in - pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [coe lbl;coe entry]; - let msg2 = msg^"\n(equivalent to "^(String.concat " " (x@y))^" )" in - Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg2; - Balloon.put ~on:(coe entry) ~ms:balloon_delay msg2; - Textvariable.handle v ~callback:update; - map := StringMap.add key v !map - | Superarg.MultiExt l -> - let rec update () = - let s = Textvariable.get v in - if s<>"" then - ( - List.iter (fun (o,ext) -> ignore (widget_update_from_cmd a [o;s^ext])) l); - Textvariable.handle v ~callback:update - in - let lbl = Label.create ~text:key ~padx:20 f - and entry = Entry.create ~textvariable:v f in - pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [coe lbl;coe entry]; - let msg2 = msg^"\n(equivalent to "^(String.concat " " (List.rev_map snd (List.rev l)))^" )" in - Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg2; - Balloon.put ~on:(coe entry) ~ms:balloon_delay msg2; - Textvariable.handle v ~callback:update; - map := StringMap.add key v !map - ); - - let text = match lvl with - | Superarg.Expert -> "(expert)" - | Superarg.Developper -> "(developper)" - | Superarg.Normal | Superarg.Hidden -> "" + | Superarg.Void | Superarg.Bool _ | Superarg.Choice _ + | Superarg.Choice_list _ | Superarg.Multi _ | Superarg.MultiExt _ -> + "" + in + let lbl = Label.create ~text:(key ^ " " ^ ext) ~padx:20 f + and entry = Entry.create ~textvariable:v f in + pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [ coe lbl; coe entry ]; + Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg; + Balloon.put ~on:(coe entry) ~ms:balloon_delay msg; + map := (*snd*) StringMap.add key v !map + | Superarg.Choice (l, _, _) -> + let lbl = Label.create ~text:key ~padx:20 f in + let fff = Frame.create f in + let ff = Frame.create fff in + let p = ref 0 in + List.iter + (fun (k, msg2) -> + let radio = + Radiobutton.create ~variable:v ~text:k ~value:k ~padx:40 ff + in + Grid.configure ~sticky:"w" ~column:(!p mod 3) ~row:(!p / 3) [ radio ]; + Balloon.put ~on:(coe radio) ~ms:balloon_delay (msg ^ ":\n" ^ msg2); + incr p) + l; + pack ~side:`Top ~anchor:`W [ coe lbl; coe ff ]; + pack ~side:`Left ~anchor:`W [ coe fff ]; + Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg; + map := StringMap.add key v !map + | Superarg.Choice_list (l, _) -> + let lbl = Label.create ~text:key ~padx:20 f in + let fff = Frame.create f in + let ff = Frame.create fff in + let p = ref 0 in + let nb = 4 in + (* number of columns *) + List.iter + (fun (k, msg2) -> + let v = Textvariable.create () in + let chk = Checkbutton.create ~variable:v ~text:k ~padx:40 ff in + Grid.configure ~sticky:"w" ~column:(!p mod nb) ~row:(!p / nb) [ chk ]; + incr p; + Balloon.put ~on:(coe chk) ~ms:balloon_delay (msg ^ ":\n" ^ msg2); + map := StringMap.add (key ^ "." ^ k) v !map) + l; + pack ~side:`Top ~anchor:`W [ coe lbl; coe ff ]; + pack ~side:`Left ~anchor:`W [ coe fff ]; + Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg + | Superarg.Multi (x, []) -> + let update () = ignore (widget_update_from_cmd a x) in + let b = Button.create ~text:key ~padx:20 ~command:update f in + pack ~side:`Left ~anchor:`W [ coe b ]; + let msg2 = msg ^ "\n(equivalent to " ^ String.concat " " x ^ " )" in + Balloon.put ~on:(coe b) ~ms:balloon_delay msg2; + map := StringMap.add key v !map + | Superarg.Multi (x, y) -> + let rec update () = + let s = Textvariable.get v in + if s <> "" then ( + ignore (widget_update_from_cmd a x); + List.iter (fun o -> ignore (widget_update_from_cmd a [ o; s ])) y + ); + Textvariable.handle v ~callback:update + in + let lbl = Label.create ~text:key ~padx:20 f + and entry = Entry.create ~textvariable:v f in + pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [ coe lbl; coe entry ]; + let msg2 = msg ^ "\n(equivalent to " ^ String.concat " " (x @ y) ^ " )" in + Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg2; + Balloon.put ~on:(coe entry) ~ms:balloon_delay msg2; + Textvariable.handle v ~callback:update; + map := StringMap.add key v !map + | Superarg.MultiExt l -> + let rec update () = + let s = Textvariable.get v in + if s <> "" then + List.iter + (fun (o, ext) -> ignore (widget_update_from_cmd a [ o; s ^ ext ])) + l; + Textvariable.handle v ~callback:update + in + let lbl = Label.create ~text:key ~padx:20 f + and entry = Entry.create ~textvariable:v f in + pack ~side:`Left ~expand:true ~fill:`X ~anchor:`W [ coe lbl; coe entry ]; + let msg2 = + msg ^ "\n(equivalent to " + ^ String.concat " " (List.rev_map snd (List.rev l)) + ^ " )" + in + Balloon.put ~on:(coe lbl) ~ms:balloon_delay msg2; + Balloon.put ~on:(coe entry) ~ms:balloon_delay msg2; + Textvariable.handle v ~callback:update; + map := StringMap.add key v !map); + + let text = + match lvl with + | Superarg.Expert -> "(expert)" + | Superarg.Developper -> "(developper)" + | Superarg.Normal | Superarg.Hidden -> "" in - if text<>"" then ( + if text <> "" then ( let l = Label.create ~text f in Balloon.put ~on:(coe l) ~ms:balloon_delay msg; - pack ~side:`Left ~anchor:`W [l] - ); - pack ~side:`Top ~anchor:`W [coe f] - - + pack ~side:`Left ~anchor:`W [ l ] + ); + pack ~side:`Top ~anchor:`W [ coe f ] (* notebook *) class pager bparent fparent = - let bars = Frame.create bparent in (* Superarg.Multi-line button bar *) - let bar = ref (Frame.create bars) (* one button line *) + let bars = Frame.create bparent in + (* Superarg.Multi-line button bar *) + let bar = ref (Frame.create bars) (* one button line *) and barsize = ref 0 - and maxbarwidth = 65 (* split bar at this column (in chars) *) - and cont = Frame.create fparent (* current page *) - and cur = ref "" (* current page name *) - and pages = ref StringMap.empty (* all pages *) + and maxbarwidth = 65 (* split bar at this column (in chars) *) + and cont = Frame.create fparent (* current page *) + and cur = ref "" (* current page name *) + and pages = ref StringMap.empty (* all pages *) and pages_lvl = ref [] in object (self) - initializer - pack ~side:`Top [coe !bar]; - pack ~side:`Top [coe bars]; - pack ~side:`Top ~pady:5 ~fill:`Both ~expand:true [coe cont] + pack ~side:`Top [ coe !bar ]; + pack ~side:`Top [ coe bars ]; + pack ~side:`Top ~pady:5 ~fill:`Both ~expand:true [ coe cont ] (* sets the page currently viewed *) method set_page name = (try - let fr,_,b = + let fr, _, b = match StringMap.find_option !cur !pages with | None -> raise Not_found | Some a -> a in cur := ""; Button.configure ~relief:`Raised b; - Pack.forget [coe fr]; - with Not_found -> ()); - (try - let fr,_,b = - match StringMap.find_option name !pages with - | None -> raise Not_found - | Some a -> a - in - cur := name; - Button.configure ~relief:`Sunken b; - pack ~expand:true ~fill:`Both ~anchor:`Center [coe fr]; - with Not_found -> ()) - + Pack.forget [ coe fr ] + with Not_found -> ()); + try + let fr, _, b = + match StringMap.find_option name !pages with + | None -> raise Not_found + | Some a -> a + in + cur := name; + Button.configure ~relief:`Sunken b; + pack ~expand:true ~fill:`Both ~anchor:`Center [ coe fr ] + with Not_found -> () (* gets a page (create if non existing) *) - method get_page name (lvl:Superarg.level): Widget.frame Widget.widget = - try let _,p,_ = - match StringMap.find_option name !pages with - | Some a -> a - | None -> raise Not_found - in p + method get_page name (lvl : Superarg.level) : Widget.frame Widget.widget = + try + let _, p, _ = + match StringMap.find_option name !pages with + | Some a -> a + | None -> raise Not_found + in + p with Not_found -> - if !barsize/maxbarwidth <> (!barsize+String.length name)/maxbarwidth - then (bar := Frame.create bars; pack ~side:`Top [coe !bar]); - let fr = Frame.create ~borderwidth:2 ~relief:`Ridge cont - and lbl = Button.create - ~text:name ~command:(fun () -> self#set_page name) !bar in - let p = Frame.create fr in - pack ~side:`Left ~padx:1 ~pady:1 [coe lbl]; - Grid.column_configure ~minsize:600 (coe fr) 0; - Grid.row_configure ~minsize:400 (coe fr) 0; - Grid.configure ~column:0 ~row:0 [coe p]; - barsize := !barsize + String.length name; - pages := (*snd*) (StringMap.add(*_map*) (*parameters error*) name (fr,p,lbl) !pages); - pages_lvl:= (lbl,lvl)::(!pages_lvl); - if !cur = "" then self#set_page name; - p - - method get_pages_lvl () = List.rev (!pages_lvl) + if + !barsize / maxbarwidth + <> (!barsize + String.length name) / maxbarwidth + then ( + bar := Frame.create bars; + pack ~side:`Top [ coe !bar ] + ); + let fr = Frame.create ~borderwidth:2 ~relief:`Ridge cont + and lbl = + Button.create ~text:name ~command:(fun () -> self#set_page name) !bar + in + let p = Frame.create fr in + pack ~side:`Left ~padx:1 ~pady:1 [ coe lbl ]; + Grid.column_configure ~minsize:600 (coe fr) 0; + Grid.row_configure ~minsize:400 (coe fr) 0; + Grid.configure ~column:0 ~row:0 [ coe p ]; + barsize := !barsize + String.length name; + pages := + (*snd*) + StringMap.add + (*_map*) + (*parameters error*) + name (fr, p, lbl) !pages; + pages_lvl := (lbl, lvl) :: !pages_lvl; + if !cur = "" then self#set_page name; + p + + method get_pages_lvl () = List.rev !pages_lvl end - -let build_spec (a:Superarg.t) bparent fparent = +let build_spec (a : Superarg.t) bparent fparent = let opts = new pager bparent fparent in - Superarg.StringIntMap.iter(*_map*) - (fun _ (l,cat_lvl) -> + Superarg.StringIntMap.iter (*_map*) + (fun _ (l, cat_lvl) -> List.iter - (fun ((key:Superarg.key), - (spec:Superarg.spec), - (msg:Superarg.msg), - (cat:(Superarg.category*Superarg.position) list), - (lvl:Superarg.level)) - -> + (fun ( (key : Superarg.key), + (spec : Superarg.spec), + (msg : Superarg.msg), + (cat : (Superarg.category * Superarg.position) list), + (lvl : Superarg.level) ) -> List.iter - (fun (((cat:string),_,lvl_opt),_) -> - let cat_lvl = Superarg.max_level_opt cat_lvl lvl_opt in - widget_of_spec a key spec msg lvl (opts#get_page cat cat_lvl)) + (fun (((cat : string), _, lvl_opt), _) -> + let cat_lvl = Superarg.max_level_opt cat_lvl lvl_opt in + widget_of_spec a key spec msg lvl (opts#get_page cat cat_lvl)) cat) - l ) + l) (Superarg.order a); let _ = widget_update_from_spec a in opts#get_pages_lvl () - exception Exit of string list (* main *) -let gui ?title (a:Superarg.t) (args:string list) : string list = - +let gui ?title (a : Superarg.t) (args : string list) : string list = let top = openTk () in let () = appname_set (match title with | None -> Version.version_kasa_full_name - | Some x -> x) in + | Some x -> x) + in Balloon.init (); (* option list *) let up = Frame.create top in let left = Frame.create up and right = Frame.create up and middle = Frame.create top in - pack ~side:`Top [up]; - pack ~side:`Top ~expand:true ~fill:`Both [middle]; - pack ~side:`Left ~padx:20 [left; right]; + pack ~side:`Top [ up ]; + pack ~side:`Top ~expand:true ~fill:`Both [ middle ]; + pack ~side:`Left ~padx:20 [ left; right ]; let pages_lvl = build_spec a right middle in (* expert mode *) - let expyes = Radiobutton.create ~text:"Expert" ~value:"1" - ~command:(fun () -> Superarg.expert_mode := true; set_visibility (a,pages_lvl)) left - and expno = Radiobutton.create ~text:"Normal" ~value:"0" - ~command:(fun () -> Superarg.expert_mode := false; set_visibility (a,pages_lvl)) left in - pack ~side:`Top ~anchor:`W [expno;expyes]; + let expyes = + Radiobutton.create ~text:"Expert" ~value:"1" + ~command:(fun () -> + Superarg.expert_mode := true; + set_visibility (a, pages_lvl)) + left + and expno = + Radiobutton.create ~text:"Normal" ~value:"0" + ~command:(fun () -> + Superarg.expert_mode := false; + set_visibility (a, pages_lvl)) + left + in + pack ~side:`Top ~anchor:`W [ expno; expyes ]; (* file list *) let v = Textvariable.create () in let eframe = Frame.create top in let lbl = Label.create ~text:"Filenames: " eframe and entry = Entry.create ~width:80 ~textvariable:v eframe - - and but1 = Button.create ~text:"Add" + and but1 = + Button.create ~text:"Add" ~command:(fun _ -> - Fileselect.f - ~title:"Add filenames" - ~action:(fun l -> - Textvariable.set v ((Textvariable.get v)^" "^(String.concat " " l))) - ~filter:"*.ka" ~file:"" ~multi:true ~sync:true - ) eframe - - and but2 = Button.create ~text:"Clear" - ~command:(fun _ -> Textvariable.set v "") eframe - + Fileselect.f ~title:"Add filenames" + ~action:(fun l -> + Textvariable.set v (Textvariable.get v ^ " " ^ String.concat " " l)) + ~filter:"*.ka" ~file:"" ~multi:true ~sync:true) + eframe + and but2 = + Button.create ~text:"Clear" ~command:(fun _ -> Textvariable.set v "") eframe in + pack ~side:`Left ~expand:true ~fill:`X - [coe lbl; coe entry; coe but1; coe but2]; - pack ~side:`Top ~pady:10 ~expand:true ~fill:`Both [coe eframe]; + [ coe lbl; coe entry; coe but1; coe but2 ]; + pack ~side:`Top ~pady:10 ~expand:true ~fill:`Both [ coe eframe ]; (* extract command-line from widget values *) - let cmd () = (cmd_of_widget a true)@(Superarg.cut_list (Textvariable.get v)) in + let cmd () = cmd_of_widget a true @ Superarg.cut_list (Textvariable.get v) in (* backup save that ignores errors *) let backup name = @@ -514,124 +623,135 @@ let gui ?title (a:Superarg.t) (args:string list) : string list = in (* buttons *) - let bframe = Frame.create top in (* button bar *) + let bframe = Frame.create top in + (* button bar *) let do_launch = ref false in - let quit = Button.create ~text: "Quit" ~command:(fun _ -> closeTk ()) bframe - - and reset = Button.create - ~text: "Reset to default" + let quit = Button.create ~text:"Quit" ~command:(fun _ -> closeTk ()) bframe + and reset = + Button.create ~text:"Reset to default" ~command:(fun _ -> - backup "autosave_pre_reset.options"; - widget_update_from_spec a) bframe - - and import = Button.create - ~text: "Import options" + backup "autosave_pre_reset.options"; + widget_update_from_spec a) + bframe + and import = + Button.create ~text:"Import options" ~command:(fun _ -> - Fileselect.f - ~title:"Merge options from file" - ~action:(function - [name] -> - (try - let f = open_in name in - let b = Buffer.create 128 in - (try while true do - Buffer.add_string b (input_line f); - Buffer.add_char b ' ' - done with End_of_file -> ()); - close_in f; - let x = Superarg.cut_list (Buffer.contents b) in - backup "autosave_pre_import.options"; - let rem = widget_update_from_cmd a x in - Textvariable.set v ((Textvariable.get v)^" "^ - (String.concat " " rem)) - with exc -> - ignore - (Dialog.create ~parent:(coe top) ~title:"Cannot load!" - ~message:(Printexc.to_string exc) ~buttons:["Close"] - ()) ) - | _ -> () - ) - ~filter:"*.options" ~file:"default.options" ~multi:false ~sync:true ) + Fileselect.f ~title:"Merge options from file" + ~action:(function + | [ name ] -> + (try + let f = open_in name in + let b = Buffer.create 128 in + (try + while true do + Buffer.add_string b (input_line f); + Buffer.add_char b ' ' + done + with End_of_file -> ()); + close_in f; + let x = Superarg.cut_list (Buffer.contents b) in + backup "autosave_pre_import.options"; + let rem = widget_update_from_cmd a x in + Textvariable.set v + (Textvariable.get v ^ " " ^ String.concat " " rem) + with exc -> + ignore + (Dialog.create ~parent:(coe top) ~title:"Cannot load!" + ~message:(Printexc.to_string exc) ~buttons:[ "Close" ] ())) + | _ -> ()) + ~filter:"*.options" ~file:"default.options" ~multi:false ~sync:true) bframe - - and save = Button.create - ~text: "Save options" + and save = + Button.create ~text:"Save options" ~command:(fun _ -> - try - let result = String.concat " " (cmd ()) in - Fileselect.f - ~title:"Save file" - ~action:(function - [name] -> - (try - let f = open_out name in - output_string f result; - close_out f - with exc -> - ignore - (Dialog.create ~parent:(coe top) ~title:"Cannot save!" - ~message:(Printexc.to_string exc) ~buttons:["Close"] - ()) ) - | _ -> () ) - ~filter:"*.options" ~file:"default.options" ~multi:false ~sync:true - with exc -> - ignore - (Dialog.create ~parent:(coe top) ~title:"Cannot save!" - ~message:(Printexc.to_string exc) ~buttons:["Close"] - ()) ) + try + let result = String.concat " " (cmd ()) in + Fileselect.f ~title:"Save file" + ~action:(function + | [ name ] -> + (try + let f = open_out name in + output_string f result; + close_out f + with exc -> + ignore + (Dialog.create ~parent:(coe top) ~title:"Cannot save!" + ~message:(Printexc.to_string exc) ~buttons:[ "Close" ] + ())) + | _ -> ()) + ~filter:"*.options" ~file:"default.options" ~multi:false ~sync:true + with exc -> + ignore + (Dialog.create ~parent:(coe top) ~title:"Cannot save!" + ~message:(Printexc.to_string exc) ~buttons:[ "Close" ] ())) bframe - - and go = Button.create - ~text: "Launch analyze" + and go = + Button.create ~text:"Launch analyze" ~command:(fun _ -> - try let _ = cmd () in do_launch := true; closeTk() - with exc -> - ignore - (Dialog.create ~parent:(coe top) ~title:"Cannot launch analysis!" - ~message:(Printexc.to_string exc) ~buttons:["Close"] - ()) - ) bframe + try + let _ = cmd () in + do_launch := true; + closeTk () + with exc -> + ignore + (Dialog.create ~parent:(coe top) ~title:"Cannot launch analysis!" + ~message:(Printexc.to_string exc) ~buttons:[ "Close" ] ())) + bframe in - pack ~side:`Left ~padx:40 ~fill:`X ~expand:true [quit;reset;import;save;go]; - pack ~side:`Top ~fill:`Both ~expand:true [bframe]; + pack ~side:`Left ~padx:40 ~fill:`X ~expand:true + [ quit; reset; import; save; go ]; + pack ~side:`Top ~fill:`Both ~expand:true [ bframe ]; (* get command-line arguments *) let rem = widget_update_from_cmd a args in - Textvariable.set v ((Textvariable.get v)^" "^(String.concat " " rem)); - Radiobutton.select (if !Superarg.expert_mode then expyes else expno); - set_visibility (a,pages_lvl); + Textvariable.set v (Textvariable.get v ^ " " ^ String.concat " " rem); + Radiobutton.select + (if !Superarg.expert_mode then + expyes + else + expno); + set_visibility (a, pages_lvl); (* tk loop *) mainLoop (); (* back from gui *) - if not !do_launch then (backup "autosave_pre_quit.options"; exit 0); + if not !do_launch then ( + backup "autosave_pre_quit.options"; + exit 0 + ); backup "autosave_pre_launch.options"; - Printf.printf "/* The GUI launches the analysis with the options:\n%s\n*/\n" (String.concat " " (cmd ())); flush stdout; + Printf.printf "/* The GUI launches the analysis with the options:\n%s\n*/\n" + (String.concat " " (cmd ())); + flush stdout; Version.tk_is_initialized := true; Superarg.parse_list ~with_tk:true a (cmd ()) (* MAIN *) (* **** *) -let parse ?title (a:Superarg.t) (def:string list ref) = +let parse ?title (a : Superarg.t) (def : string list ref) = Superarg.check a; Version.tk_is_initialized := true; let a = Superarg.order a in let a = Superarg.StringIntMap.fold - (fun _ (list,_) list' -> - List.fold_left - (fun list' a -> a::list') list' (List.rev list)) + (fun _ (list, _) list' -> + List.fold_left (fun list' a -> a :: list') list' (List.rev list)) a [] in (* drop the first command-line argument: it is the executable name *) let args = List.tl (Array.to_list Sys.argv) in (* if no argument or "--gui" given, launch the gui, otherwise, parse args *) let rem = - if args=[] || args=["--expert"] || args=["--no-expert"] || List.exists ((=) "--gui") args - then gui ?title a args else Superarg.parse_list ~with_tk:true ?title a args + if + args = [] || args = [ "--expert" ] || args = [ "--no-expert" ] + || List.exists (( = ) "--gui") args + then + gui ?title a args + else + Superarg.parse_list ~with_tk:true ?title a args in - if rem<>[] then def := rem + if rem <> [] then def := rem diff --git a/core/dataStructures/ExceptionDefn.ml b/core/dataStructures/ExceptionDefn.ml index 51beb1b7ec..f60c25c4dc 100644 --- a/core/dataStructures/ExceptionDefn.ml +++ b/core/dataStructures/ExceptionDefn.ml @@ -6,9 +6,9 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -exception Syntax_Error of string Locality.annot -exception Malformed_Decl of string Locality.annot -exception Internal_Error of string Locality.annot +exception Syntax_Error of string Loc.annoted +exception Malformed_Decl of string Loc.annoted +exception Internal_Error of string Loc.annoted -let warning_buffer: - (Locality.t option*(Format.formatter -> unit)) list ref = ref [] +let warning_buffer : (Loc.t option * (Format.formatter -> unit)) list ref = + ref [] diff --git a/core/dataStructures/ExceptionDefn.mli b/core/dataStructures/ExceptionDefn.mli index 5085850b51..1c5ec22544 100644 --- a/core/dataStructures/ExceptionDefn.mli +++ b/core/dataStructures/ExceptionDefn.mli @@ -1,6 +1,5 @@ -exception Syntax_Error of string Locality.annot -exception Malformed_Decl of string Locality.annot -exception Internal_Error of string Locality.annot +exception Syntax_Error of string Loc.annoted +exception Malformed_Decl of string Loc.annoted +exception Internal_Error of string Loc.annoted -val warning_buffer: - (Locality.t option*(Format.formatter -> unit)) list ref +val warning_buffer : (Loc.t option * (Format.formatter -> unit)) list ref diff --git a/core/dataStructures/base64.ml b/core/dataStructures/base64.ml index 6176180296..e33f07e56d 100644 --- a/core/dataStructures/base64.ml +++ b/core/dataStructures/base64.ml @@ -16,21 +16,29 @@ * *) -let default_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" -let uri_safe_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_" +let default_alphabet = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + +let uri_safe_alphabet = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_" + let padding = '=' -let of_char ?(alphabet=default_alphabet) x = - if x = padding then 0 else String.index alphabet x +let of_char ?(alphabet = default_alphabet) x = + if x = padding then + 0 + else + String.index alphabet x -let to_char ?(alphabet=default_alphabet) x = - alphabet.[x] +let to_char ?(alphabet = default_alphabet) x = alphabet.[x] let decode ?alphabet input = let length = String.length input in let input = - if length mod 4 = 0 then input - else input ^ (String.make (4 - length mod 4) padding) + if length mod 4 = 0 then + input + else + input ^ String.make (4 - (length mod 4)) padding in let length = String.length input in let words = length / 4 in @@ -41,46 +49,60 @@ let decode ?alphabet input = | _ when input.[length - 1] = padding -> 1 | _ -> 0 in - let output = Bigarray.Array1.create Bigarray.char Bigarray.c_layout (words * 3 - padding) in + let output = + Bigarray.Array1.create Bigarray.char Bigarray.c_layout + ((words * 3) - padding) + in for i = 0 to words - 1 do - let a = of_char ?alphabet (String.get input (4 * i + 0)) - and b = of_char ?alphabet (String.get input (4 * i + 1)) - and c = of_char ?alphabet (String.get input (4 * i + 2)) - and d = of_char ?alphabet (String.get input (4 * i + 3)) in + let a = of_char ?alphabet (String.get input ((4 * i) + 0)) + and b = of_char ?alphabet (String.get input ((4 * i) + 1)) + and c = of_char ?alphabet (String.get input ((4 * i) + 2)) + and d = of_char ?alphabet (String.get input ((4 * i) + 3)) in let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in - let x = (n lsr 16) land 255 - and y = (n lsr 8) land 255 - and z = n land 255 in - Bigarray.Array1.set output (3 * i + 0) (char_of_int x); + let x = (n lsr 16) land 255 and y = (n lsr 8) land 255 and z = n land 255 in + Bigarray.Array1.set output ((3 * i) + 0) (char_of_int x); if i <> words - 1 || padding < 2 then - Bigarray.Array1.set output (3 * i + 1) (char_of_int y); + Bigarray.Array1.set output ((3 * i) + 1) (char_of_int y); if i <> words - 1 || padding < 1 then - Bigarray.Array1.set output (3 * i + 2) (char_of_int z); + Bigarray.Array1.set output ((3 * i) + 2) (char_of_int z) done; output -let encode ?(pad=true) ?alphabet input = +let encode ?(pad = true) ?alphabet input = let length = Bigarray.Array1.dim input in - let words = (length + 2) / 3 in (* rounded up *) - let padding_len = if length mod 3 = 0 then 0 else 3 - (length mod 3) in + let words = (length + 2) / 3 in + (* rounded up *) + let padding_len = + if length mod 3 = 0 then + 0 + else + 3 - (length mod 3) + in let output = Bytes.make (words * 4) '\000' in - let get i = if i >= length then 0 else int_of_char (Bigarray.Array1.get input i) in + let get i = + if i >= length then + 0 + else + int_of_char (Bigarray.Array1.get input i) + in for i = 0 to words - 1 do - let x = get (3 * i + 0) - and y = get (3 * i + 1) - and z = get (3 * i + 2) in + let x = get ((3 * i) + 0) + and y = get ((3 * i) + 1) + and z = get ((3 * i) + 2) in let n = (x lsl 16) lor (y lsl 8) lor z in let a = (n lsr 18) land 63 and b = (n lsr 12) land 63 and c = (n lsr 6) land 63 and d = n land 63 in - Bytes.set output (4 * i + 0) (to_char ?alphabet a); - Bytes.set output (4 * i + 1) (to_char ?alphabet b); - Bytes.set output (4 * i + 2) (to_char ?alphabet c); - Bytes.set output (4 * i + 3) (to_char ?alphabet d); + Bytes.set output ((4 * i) + 0) (to_char ?alphabet a); + Bytes.set output ((4 * i) + 1) (to_char ?alphabet b); + Bytes.set output ((4 * i) + 2) (to_char ?alphabet c); + Bytes.set output ((4 * i) + 3) (to_char ?alphabet d) done; for i = 1 to padding_len do - Bytes.set output (Bytes.length output - i) padding; + Bytes.set output (Bytes.length output - i) padding done; - if pad then Bytes.unsafe_to_string output - else Bytes.sub_string output 0 (Bytes.length output - padding_len) + if pad then + Bytes.unsafe_to_string output + else + Bytes.sub_string output 0 (Bytes.length output - padding_len) diff --git a/core/dataStructures/base64.mli b/core/dataStructures/base64.mli index 2e39e5f738..50d4b41030 100644 --- a/core/dataStructures/base64.mli +++ b/core/dataStructures/base64.mli @@ -26,20 +26,20 @@ {e Release %%VERSION%% - %%PKG_HOMEPAGE%% } *) -(** A 64-character string specifying the regular Base64 alphabet. *) val default_alphabet : string +(** A 64-character string specifying the regular Base64 alphabet. *) +val uri_safe_alphabet : string (** A 64-character string specifying the URI- and filename-safe Base64 alphabet. *) -val uri_safe_alphabet : string +val decode : ?alphabet:string -> string -> Bigbuffer.bigstring (** [decode s] decodes the string [s] that is encoded in Base64 format. Will leave trailing NULLs on the string, padding it out to a multiple of 3 characters. [alphabet] defaults to {!default_alphabet}. @raise Not_found if [s] is not a valid Base64 string. *) -val decode : ?alphabet:string -> string -> Bigbuffer.bigstring +val encode : ?pad:bool -> ?alphabet:string -> Bigbuffer.bigstring -> string (** [encode s] encodes the string [s] into base64. If [pad] is false, no trailing padding is added. [pad] defaults to [true], and [alphabet] to {!default_alphabet}. *) -val encode : ?pad:bool -> ?alphabet:string -> Bigbuffer.bigstring -> string diff --git a/core/dataStructures/bigbuffer.ml b/core/dataStructures/bigbuffer.ml index 14550c5a2c..072645141b 100644 --- a/core/dataStructures/bigbuffer.ml +++ b/core/dataStructures/bigbuffer.ml @@ -20,17 +20,28 @@ module BA = Bigarray.Array1 type bigstring = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t -type t = - {mutable buffer : bigstring; - mutable position : int; - mutable length : int; - initial_buffer : bigstring} +type t = { + mutable buffer: bigstring; + mutable position: int; + mutable length: int; + initial_buffer: bigstring; +} let create n = - let n = if n < 1 then 1 else n in - let n = if n > Sys.max_string_length then Sys.max_string_length else n in - let s = BA.create Bigarray.char Bigarray.c_layout n in - {buffer = s; position = 0; length = n; initial_buffer = s} + let n = + if n < 1 then + 1 + else + n + in + let n = + if n > Sys.max_string_length then + Sys.max_string_length + else + n + in + let s = BA.create Bigarray.char Bigarray.c_layout n in + { buffer = s; position = 0; length = n; initial_buffer = s } let contents b = let out = BA.create Bigarray.char Bigarray.c_layout b.position in @@ -54,32 +65,33 @@ let blit src srcoff dst dstoff len = let nth b ofs = if ofs < 0 || ofs >= b.position then - invalid_arg "Buffer.nth" - else BA.unsafe_get b.buffer ofs - + invalid_arg "Buffer.nth" + else + BA.unsafe_get b.buffer ofs let length b = b.position - let clear b = b.position <- 0 let reset b = - b.position <- 0; b.buffer <- b.initial_buffer; + b.position <- 0; + b.buffer <- b.initial_buffer; b.length <- BA.dim b.buffer let resize b more = let len = b.length in let new_len = ref len in - while b.position + more > !new_len do new_len := 2 * !new_len done; - if !new_len > Sys.max_string_length then begin - if b.position + more <= Sys.max_string_length - then new_len := Sys.max_string_length - else failwith "Buffer.add: cannot grow buffer" - end; + while b.position + more > !new_len do + new_len := 2 * !new_len + done; + if !new_len > Sys.max_string_length then + if b.position + more <= Sys.max_string_length then + new_len := Sys.max_string_length + else + failwith "Buffer.add: cannot grow buffer"; let new_buffer = BA.create Bigarray.char Bigarray.c_layout !new_len in (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in this tricky function that is slow anyway. *) - BA.blit (BA.sub b.buffer 0 b.position) - (BA.sub new_buffer 0 b.position); + BA.blit (BA.sub b.buffer 0 b.position) (BA.sub new_buffer 0 b.position); b.buffer <- new_buffer; b.length <- !new_len @@ -170,12 +182,12 @@ let add_char b c = *) let add_substring b s offset len = - if offset < 0 || len < 0 || offset > String.length s - len - then invalid_arg "Buffer.add_substring/add_subbytes"; + if offset < 0 || len < 0 || offset > String.length s - len then + invalid_arg "Buffer.add_substring/add_subbytes"; let new_position = b.position + len in if new_position > b.length then resize b len; for i = 0 to len - 1 do - BA.unsafe_set b.buffer (b.position+i) (String.get s (offset + i)) + BA.unsafe_set b.buffer (b.position + i) (String.get s (offset + i)) done; b.position <- new_position @@ -209,76 +221,76 @@ let output_buffer oc b = output oc (Lwt_bytes.to_bytes b.buffer) 0 b.position *) (*let closing = function - | '(' -> ')' - | '{' -> '}' - | _ -> assert false + | '(' -> ')' + | '{' -> '}' + | _ -> assert false -(* opening and closing: open and close characters, typically ( and ) - k: balance of opening and closing chars - s: the string where we are searching - start: the index where we start the search. *) -let advance_to_closing opening closing k s start = - let rec advance k i lim = - if i >= lim then raise Not_found else - if s.[i] = opening then advance (k + 1) (i + 1) lim else - if s.[i] = closing then - if k = 0 then i else advance (k - 1) (i + 1) lim - else advance k (i + 1) lim in - advance k start (String.length s) + (* opening and closing: open and close characters, typically ( and ) + k: balance of opening and closing chars + s: the string where we are searching + start: the index where we start the search. *) + let advance_to_closing opening closing k s start = + let rec advance k i lim = + if i >= lim then raise Not_found else + if s.[i] = opening then advance (k + 1) (i + 1) lim else + if s.[i] = closing then + if k = 0 then i else advance (k - 1) (i + 1) lim + else advance k (i + 1) lim in + advance k start (String.length s) -let advance_to_non_alpha s start = - let rec advance i lim = - if i >= lim then lim else - match s.[i] with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim - | _ -> i in - advance start (String.length s) + let advance_to_non_alpha s start = + let rec advance i lim = + if i >= lim then lim else + match s.[i] with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim + | _ -> i in + advance start (String.length s) -(* We are just at the beginning of an ident in s, starting at start. *) -let find_ident s start lim = - if start >= lim then raise Not_found else - match s.[start] with - (* Parenthesized ident ? *) - | '(' | '{' as c -> - let new_start = start + 1 in - let stop = advance_to_closing c (closing c) 0 s new_start in - String.sub s new_start (stop - start - 1), stop + 1 - (* Regular ident *) - | _ -> - let stop = advance_to_non_alpha s (start + 1) in - String.sub s start (stop - start), stop + (* We are just at the beginning of an ident in s, starting at start. *) + let find_ident s start lim = + if start >= lim then raise Not_found else + match s.[start] with + (* Parenthesized ident ? *) + | '(' | '{' as c -> + let new_start = start + 1 in + let stop = advance_to_closing c (closing c) 0 s new_start in + String.sub s new_start (stop - start - 1), stop + 1 + (* Regular ident *) + | _ -> + let stop = advance_to_non_alpha s (start + 1) in + String.sub s start (stop - start), stop -(* Substitute $ident, $(ident), or ${ident} in s, - according to the function mapping f. *) -let add_substitute b f s = - let lim = String.length s in - let rec subst previous i = - if i < lim then begin - match s.[i] with - | '$' as current when previous = '\\' -> - add_char b current; - subst ' ' (i + 1) - | '$' -> - let j = i + 1 in - let ident, next_i = find_ident s j lim in - add_string b (f ident); - subst ' ' next_i - | current when previous == '\\' -> - add_char b '\\'; - add_char b current; - subst ' ' (i + 1) - | '\\' as current -> - subst current (i + 1) - | current -> - add_char b current; - subst current (i + 1) - end else - if previous = '\\' then add_char b previous in - subst ' ' 0 + (* Substitute $ident, $(ident), or ${ident} in s, + according to the function mapping f. *) + let add_substitute b f s = + let lim = String.length s in + let rec subst previous i = + if i < lim then begin + match s.[i] with + | '$' as current when previous = '\\' -> + add_char b current; + subst ' ' (i + 1) + | '$' -> + let j = i + 1 in + let ident, next_i = find_ident s j lim in + add_string b (f ident); + subst ' ' next_i + | current when previous == '\\' -> + add_char b '\\'; + add_char b current; + subst ' ' (i + 1) + | '\\' as current -> + subst current (i + 1) + | current -> + add_char b current; + subst current (i + 1) + end else + if previous = '\\' then add_char b previous in + subst ' ' 0 -let truncate b len = - if len < 0 || len > length b then - invalid_arg "Buffer.truncate" - else - b.position <- len + let truncate b len = + if len < 0 || len > length b then + invalid_arg "Buffer.truncate" + else + b.position <- len *) diff --git a/core/dataStructures/buffers.ml b/core/dataStructures/buffers.ml index 113fb5a46f..c15ddf6810 100644 --- a/core/dataStructures/buffers.ml +++ b/core/dataStructures/buffers.ml @@ -1,8 +1,8 @@ -module type Buffers = -sig +module type Buffers = sig type 'a t - val create: int -> 'a -> 'a t - val add: 'a -> 'a t -> 'a t - val iter: ('a -> unit) -> 'a t -> unit - val clean: 'a t -> 'a t + + val create : int -> 'a -> 'a t + val add : 'a -> 'a t -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val clean : 'a t -> 'a t end diff --git a/core/dataStructures/buffers.mli b/core/dataStructures/buffers.mli index 113fb5a46f..c15ddf6810 100644 --- a/core/dataStructures/buffers.mli +++ b/core/dataStructures/buffers.mli @@ -1,8 +1,8 @@ -module type Buffers = -sig +module type Buffers = sig type 'a t - val create: int -> 'a -> 'a t - val add: 'a -> 'a t -> 'a t - val iter: ('a -> unit) -> 'a t -> unit - val clean: 'a t -> 'a t + + val create : int -> 'a -> 'a t + val add : 'a -> 'a t -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val clean : 'a t -> 'a t end diff --git a/core/dataStructures/cache.ml b/core/dataStructures/cache.ml index f75d0703ce..1d2a2c701e 100644 --- a/core/dataStructures/cache.ml +++ b/core/dataStructures/cache.ml @@ -18,129 +18,103 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -module type Cache = -sig - module O:SetMap.OrderedType +module type Cache = sig + module O : SetMap.OrderedType + type t - val last:t -> O.t option - val create: int option -> t - val add: O.t -> t -> t - val fold: (O.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter: (O.t -> unit) -> t -> unit -end -module Cache = - (functor (OO:SetMap.OrderedType) -> - (struct + val last : t -> O.t option + val create : int option -> t + val add : O.t -> t -> t + val fold : (O.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter : (O.t -> unit) -> t -> unit +end +module Cache = +functor + (OO : SetMap.OrderedType) + -> + ( + struct module O = OO - module SM = SetMap.Make(O) + module SM = SetMap.Make (O) module S = SM.Set - type finite_cache = - { - size:int; - offset:int; - cache: O.t option array ; - bag: S.t; - last: O.t option; - } + type finite_cache = { + size: int; + offset: int; + cache: O.t option array; + bag: S.t; + last: O.t option; + } let create_finite n = { - size=n; - offset=0; - cache= Array.make n None; - bag=S.empty; - last=None; - } + size = n; + offset = 0; + cache = Array.make n None; + bag = S.empty; + last = None; + } let next t = let offset = t.offset in - if offset=t.size-1 - then - {t with offset=0} + if offset = t.size - 1 then + { t with offset = 0 } else - {t with offset=offset+1} - - let add_finite key t = - let t = {t with last = Some key} in - if S.mem key t.bag - then - t - else - let t = {t with bag = S.add key t.bag} in - begin + { t with offset = offset + 1 } + + let add_finite key t = + let t = { t with last = Some key } in + if S.mem key t.bag then + t + else ( + let t = { t with bag = S.add key t.bag } in let t = next t in let overwritten_value = t.cache.(t.offset) in let t = - match overwritten_value - with - | None -> t - | Some overwritten_value -> - {t with bag = S.remove overwritten_value t.bag} + match overwritten_value with + | None -> t + | Some overwritten_value -> + { t with bag = S.remove overwritten_value t.bag } in - let _ = t.cache.(t.offset)<-Some key in + let _ = t.cache.(t.offset) <- Some key in t - end + ) - let last_finite t = t.last - - type infinite_cache = - { - inf_bag : S.t ; - last : O.t option - } + let last_finite t = t.last + type infinite_cache = { inf_bag: S.t; last: O.t option } + type t = Finite of finite_cache | Infinite of infinite_cache - type t = - | Finite of finite_cache - | Infinite of infinite_cache + let create_infinite = { inf_bag = S.empty; last = None } - let create_infinite = - { - inf_bag = S.empty ; - last = None - } - - let add_infinite key t = - { - inf_bag = S.add key t.inf_bag ; - last = Some key ; - } + let add_infinite key t = + { inf_bag = S.add key t.inf_bag; last = Some key } - let create size = - match - size - with + let create size = + match size with | None -> Infinite create_infinite | Some a -> Finite (create_finite a) - let last t = - match - t - with + let last t = + match t with | Finite t -> last_finite t | Infinite t -> t.last - let add key t = - match - t - with + let add key t = + match t with | Finite t -> Finite (add_finite key t) | Infinite t -> Infinite (add_infinite key t) - let fold f t a = - match - t - with + let fold f t a = + match t with | Finite t -> S.fold f t.bag a | Infinite t -> S.fold f t.inf_bag a - let iter f t = - match - t - with + let iter f t = + match t with | Finite t -> S.iter f t.bag | Infinite t -> S.iter f t.inf_bag - end:Cache with type O.t = OO.t )) + end : + Cache with type O.t = OO.t) diff --git a/core/dataStructures/cache.mli b/core/dataStructures/cache.mli index 40ebbfbc77..0ce34cb6f6 100644 --- a/core/dataStructures/cache.mli +++ b/core/dataStructures/cache.mli @@ -1,13 +1,13 @@ -module type Cache = -sig - module O:SetMap.OrderedType +module type Cache = sig + module O : SetMap.OrderedType + type t - val last:t -> O.t option - val create: int option -> t - val add: O.t -> t -> t - val fold: (O.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter: (O.t -> unit) -> t -> unit + + val last : t -> O.t option + val create : int option -> t + val add : O.t -> t -> t + val fold : (O.t -> 'a -> 'a) -> t -> 'a -> 'a + val iter : (O.t -> unit) -> t -> unit end -module Cache: - functor (OO:SetMap.OrderedType)-> Cache with type O.t = OO.t +module Cache : functor (OO : SetMap.OrderedType) -> Cache with type O.t = OO.t diff --git a/core/dataStructures/circular_buffers.ml b/core/dataStructures/circular_buffers.ml index 990f5bac3a..9f19ec9db6 100644 --- a/core/dataStructures/circular_buffers.ml +++ b/core/dataStructures/circular_buffers.ml @@ -1,27 +1,22 @@ -type 'a t = - { - size: int; - default: 'a; - mutable start: int; - mutable final: int; - content: 'a array - } +type 'a t = { + size: int; + default: 'a; + mutable start: int; + mutable final: int; + content: 'a array; +} let create i default = let size = max i 2 in - { - size = size; - default = default; - start = 0; - final = 0; - content = Array.make size default - } + { size; default; start = 0; final = 0; content = Array.make size default } let succ i t = - if i = t.size-1 then 0 else succ i + if i = t.size - 1 then + 0 + else + succ i let full t = succ t.final t = t.start - let free_one t = t.start <- succ t.start t let add x t = @@ -32,18 +27,20 @@ let add x t = let iter f t = let rec aux i = - if i <> t.final - then - let () = f (t.content.(i)) in + if i <> t.final then ( + let () = f t.content.(i) in aux (succ i t) + ) in aux t.start let clean t = let rec aux k = - if k = t.size then t - else - let () = t.content.(k)<- t.default in - aux (k+1) + if k = t.size then + t + else ( + let () = t.content.(k) <- t.default in + aux (k + 1) + ) in aux 0 diff --git a/core/dataStructures/circular_buffers.mli b/core/dataStructures/circular_buffers.mli index 025ee78ecb..dad8b1fd34 100644 --- a/core/dataStructures/circular_buffers.mli +++ b/core/dataStructures/circular_buffers.mli @@ -1,2 +1 @@ include Buffers.Buffers - diff --git a/core/dataStructures/color.ml b/core/dataStructures/color.ml index c37b9166d7..2fdf71754c 100644 --- a/core/dataStructures/color.ml +++ b/core/dataStructures/color.ml @@ -9,7 +9,7 @@ type color = Red | Grey | Lightblue | Black let triple_of_color = function - | Red -> (255,0,0) - | Grey -> (128,128,128) - | Lightblue -> (0,0,128) - | Black -> (0,0,0) + | Red -> 255, 0, 0 + | Grey -> 128, 128, 128 + | Lightblue -> 0, 0, 128 + | Black -> 0, 0, 0 diff --git a/core/dataStructures/color.mli b/core/dataStructures/color.mli index ebef785249..072e7b70dd 100644 --- a/core/dataStructures/color.mli +++ b/core/dataStructures/color.mli @@ -1,3 +1,3 @@ type color = Red | Grey | Lightblue | Black -val triple_of_color: color -> int * int * int +val triple_of_color : color -> int * int * int diff --git a/core/dataStructures/crc32.ml b/core/dataStructures/crc32.ml index 69b04bccaa..c09ff9919e 100644 --- a/core/dataStructures/crc32.ml +++ b/core/dataStructures/crc32.ml @@ -1,75 +1,268 @@ (* Copyright (c) 2011, Jonathan Derque - MIT licensed *) -let (&&&) = Int32.logand -let (^^^) = Int32.logxor -let (>>>) = Int32.shift_right_logical +let ( &&& ) = Int32.logand +let ( ^^^ ) = Int32.logxor +let ( >>> ) = Int32.shift_right_logical -let crc_table = [| - 0x00000000l; 0x77073096l; 0xee0e612cl; 0x990951bal; - 0x076dc419l; 0x706af48fl; 0xe963a535l; 0x9e6495a3l; - 0x0edb8832l; 0x79dcb8a4l; 0xe0d5e91el; 0x97d2d988l; - 0x09b64c2bl; 0x7eb17cbdl; 0xe7b82d07l; 0x90bf1d91l; - 0x1db71064l; 0x6ab020f2l; 0xf3b97148l; 0x84be41del; - 0x1adad47dl; 0x6ddde4ebl; 0xf4d4b551l; 0x83d385c7l; - 0x136c9856l; 0x646ba8c0l; 0xfd62f97al; 0x8a65c9ecl; - 0x14015c4fl; 0x63066cd9l; 0xfa0f3d63l; 0x8d080df5l; - 0x3b6e20c8l; 0x4c69105el; 0xd56041e4l; 0xa2677172l; - 0x3c03e4d1l; 0x4b04d447l; 0xd20d85fdl; 0xa50ab56bl; - 0x35b5a8fal; 0x42b2986cl; 0xdbbbc9d6l; 0xacbcf940l; - 0x32d86ce3l; 0x45df5c75l; 0xdcd60dcfl; 0xabd13d59l; - 0x26d930acl; 0x51de003al; 0xc8d75180l; 0xbfd06116l; - 0x21b4f4b5l; 0x56b3c423l; 0xcfba9599l; 0xb8bda50fl; - 0x2802b89el; 0x5f058808l; 0xc60cd9b2l; 0xb10be924l; - 0x2f6f7c87l; 0x58684c11l; 0xc1611dabl; 0xb6662d3dl; - 0x76dc4190l; 0x01db7106l; 0x98d220bcl; 0xefd5102al; - 0x71b18589l; 0x06b6b51fl; 0x9fbfe4a5l; 0xe8b8d433l; - 0x7807c9a2l; 0x0f00f934l; 0x9609a88el; 0xe10e9818l; - 0x7f6a0dbbl; 0x086d3d2dl; 0x91646c97l; 0xe6635c01l; - 0x6b6b51f4l; 0x1c6c6162l; 0x856530d8l; 0xf262004el; - 0x6c0695edl; 0x1b01a57bl; 0x8208f4c1l; 0xf50fc457l; - 0x65b0d9c6l; 0x12b7e950l; 0x8bbeb8eal; 0xfcb9887cl; - 0x62dd1ddfl; 0x15da2d49l; 0x8cd37cf3l; 0xfbd44c65l; - 0x4db26158l; 0x3ab551cel; 0xa3bc0074l; 0xd4bb30e2l; - 0x4adfa541l; 0x3dd895d7l; 0xa4d1c46dl; 0xd3d6f4fbl; - 0x4369e96al; 0x346ed9fcl; 0xad678846l; 0xda60b8d0l; - 0x44042d73l; 0x33031de5l; 0xaa0a4c5fl; 0xdd0d7cc9l; - 0x5005713cl; 0x270241aal; 0xbe0b1010l; 0xc90c2086l; - 0x5768b525l; 0x206f85b3l; 0xb966d409l; 0xce61e49fl; - 0x5edef90el; 0x29d9c998l; 0xb0d09822l; 0xc7d7a8b4l; - 0x59b33d17l; 0x2eb40d81l; 0xb7bd5c3bl; 0xc0ba6cadl; - 0xedb88320l; 0x9abfb3b6l; 0x03b6e20cl; 0x74b1d29al; - 0xead54739l; 0x9dd277afl; 0x04db2615l; 0x73dc1683l; - 0xe3630b12l; 0x94643b84l; 0x0d6d6a3el; 0x7a6a5aa8l; - 0xe40ecf0bl; 0x9309ff9dl; 0x0a00ae27l; 0x7d079eb1l; - 0xf00f9344l; 0x8708a3d2l; 0x1e01f268l; 0x6906c2fel; - 0xf762575dl; 0x806567cbl; 0x196c3671l; 0x6e6b06e7l; - 0xfed41b76l; 0x89d32be0l; 0x10da7a5al; 0x67dd4accl; - 0xf9b9df6fl; 0x8ebeeff9l; 0x17b7be43l; 0x60b08ed5l; - 0xd6d6a3e8l; 0xa1d1937el; 0x38d8c2c4l; 0x4fdff252l; - 0xd1bb67f1l; 0xa6bc5767l; 0x3fb506ddl; 0x48b2364bl; - 0xd80d2bdal; 0xaf0a1b4cl; 0x36034af6l; 0x41047a60l; - 0xdf60efc3l; 0xa867df55l; 0x316e8eefl; 0x4669be79l; - 0xcb61b38cl; 0xbc66831al; 0x256fd2a0l; 0x5268e236l; - 0xcc0c7795l; 0xbb0b4703l; 0x220216b9l; 0x5505262fl; - 0xc5ba3bbel; 0xb2bd0b28l; 0x2bb45a92l; 0x5cb36a04l; - 0xc2d7ffa7l; 0xb5d0cf31l; 0x2cd99e8bl; 0x5bdeae1dl; - 0x9b64c2b0l; 0xec63f226l; 0x756aa39cl; 0x026d930al; - 0x9c0906a9l; 0xeb0e363fl; 0x72076785l; 0x05005713l; - 0x95bf4a82l; 0xe2b87a14l; 0x7bb12bael; 0x0cb61b38l; - 0x92d28e9bl; 0xe5d5be0dl; 0x7cdcefb7l; 0x0bdbdf21l; - 0x86d3d2d4l; 0xf1d4e242l; 0x68ddb3f8l; 0x1fda836el; - 0x81be16cdl; 0xf6b9265bl; 0x6fb077e1l; 0x18b74777l; - 0x88085ae6l; 0xff0f6a70l; 0x66063bcal; 0x11010b5cl; - 0x8f659effl; 0xf862ae69l; 0x616bffd3l; 0x166ccf45l; - 0xa00ae278l; 0xd70dd2eel; 0x4e048354l; 0x3903b3c2l; - 0xa7672661l; 0xd06016f7l; 0x4969474dl; 0x3e6e77dbl; - 0xaed16a4al; 0xd9d65adcl; 0x40df0b66l; 0x37d83bf0l; - 0xa9bcae53l; 0xdebb9ec5l; 0x47b2cf7fl; 0x30b5ffe9l; - 0xbdbdf21cl; 0xcabac28al; 0x53b39330l; 0x24b4a3a6l; - 0xbad03605l; 0xcdd70693l; 0x54de5729l; 0x23d967bfl; - 0xb3667a2el; 0xc4614ab8l; 0x5d681b02l; 0x2a6f2b94l; - 0xb40bbe37l; 0xc30c8ea1l; 0x5a05df1bl; 0x2d02ef8dl -|] +let crc_table = + [| + 0x00000000l; + 0x77073096l; + 0xee0e612cl; + 0x990951bal; + 0x076dc419l; + 0x706af48fl; + 0xe963a535l; + 0x9e6495a3l; + 0x0edb8832l; + 0x79dcb8a4l; + 0xe0d5e91el; + 0x97d2d988l; + 0x09b64c2bl; + 0x7eb17cbdl; + 0xe7b82d07l; + 0x90bf1d91l; + 0x1db71064l; + 0x6ab020f2l; + 0xf3b97148l; + 0x84be41del; + 0x1adad47dl; + 0x6ddde4ebl; + 0xf4d4b551l; + 0x83d385c7l; + 0x136c9856l; + 0x646ba8c0l; + 0xfd62f97al; + 0x8a65c9ecl; + 0x14015c4fl; + 0x63066cd9l; + 0xfa0f3d63l; + 0x8d080df5l; + 0x3b6e20c8l; + 0x4c69105el; + 0xd56041e4l; + 0xa2677172l; + 0x3c03e4d1l; + 0x4b04d447l; + 0xd20d85fdl; + 0xa50ab56bl; + 0x35b5a8fal; + 0x42b2986cl; + 0xdbbbc9d6l; + 0xacbcf940l; + 0x32d86ce3l; + 0x45df5c75l; + 0xdcd60dcfl; + 0xabd13d59l; + 0x26d930acl; + 0x51de003al; + 0xc8d75180l; + 0xbfd06116l; + 0x21b4f4b5l; + 0x56b3c423l; + 0xcfba9599l; + 0xb8bda50fl; + 0x2802b89el; + 0x5f058808l; + 0xc60cd9b2l; + 0xb10be924l; + 0x2f6f7c87l; + 0x58684c11l; + 0xc1611dabl; + 0xb6662d3dl; + 0x76dc4190l; + 0x01db7106l; + 0x98d220bcl; + 0xefd5102al; + 0x71b18589l; + 0x06b6b51fl; + 0x9fbfe4a5l; + 0xe8b8d433l; + 0x7807c9a2l; + 0x0f00f934l; + 0x9609a88el; + 0xe10e9818l; + 0x7f6a0dbbl; + 0x086d3d2dl; + 0x91646c97l; + 0xe6635c01l; + 0x6b6b51f4l; + 0x1c6c6162l; + 0x856530d8l; + 0xf262004el; + 0x6c0695edl; + 0x1b01a57bl; + 0x8208f4c1l; + 0xf50fc457l; + 0x65b0d9c6l; + 0x12b7e950l; + 0x8bbeb8eal; + 0xfcb9887cl; + 0x62dd1ddfl; + 0x15da2d49l; + 0x8cd37cf3l; + 0xfbd44c65l; + 0x4db26158l; + 0x3ab551cel; + 0xa3bc0074l; + 0xd4bb30e2l; + 0x4adfa541l; + 0x3dd895d7l; + 0xa4d1c46dl; + 0xd3d6f4fbl; + 0x4369e96al; + 0x346ed9fcl; + 0xad678846l; + 0xda60b8d0l; + 0x44042d73l; + 0x33031de5l; + 0xaa0a4c5fl; + 0xdd0d7cc9l; + 0x5005713cl; + 0x270241aal; + 0xbe0b1010l; + 0xc90c2086l; + 0x5768b525l; + 0x206f85b3l; + 0xb966d409l; + 0xce61e49fl; + 0x5edef90el; + 0x29d9c998l; + 0xb0d09822l; + 0xc7d7a8b4l; + 0x59b33d17l; + 0x2eb40d81l; + 0xb7bd5c3bl; + 0xc0ba6cadl; + 0xedb88320l; + 0x9abfb3b6l; + 0x03b6e20cl; + 0x74b1d29al; + 0xead54739l; + 0x9dd277afl; + 0x04db2615l; + 0x73dc1683l; + 0xe3630b12l; + 0x94643b84l; + 0x0d6d6a3el; + 0x7a6a5aa8l; + 0xe40ecf0bl; + 0x9309ff9dl; + 0x0a00ae27l; + 0x7d079eb1l; + 0xf00f9344l; + 0x8708a3d2l; + 0x1e01f268l; + 0x6906c2fel; + 0xf762575dl; + 0x806567cbl; + 0x196c3671l; + 0x6e6b06e7l; + 0xfed41b76l; + 0x89d32be0l; + 0x10da7a5al; + 0x67dd4accl; + 0xf9b9df6fl; + 0x8ebeeff9l; + 0x17b7be43l; + 0x60b08ed5l; + 0xd6d6a3e8l; + 0xa1d1937el; + 0x38d8c2c4l; + 0x4fdff252l; + 0xd1bb67f1l; + 0xa6bc5767l; + 0x3fb506ddl; + 0x48b2364bl; + 0xd80d2bdal; + 0xaf0a1b4cl; + 0x36034af6l; + 0x41047a60l; + 0xdf60efc3l; + 0xa867df55l; + 0x316e8eefl; + 0x4669be79l; + 0xcb61b38cl; + 0xbc66831al; + 0x256fd2a0l; + 0x5268e236l; + 0xcc0c7795l; + 0xbb0b4703l; + 0x220216b9l; + 0x5505262fl; + 0xc5ba3bbel; + 0xb2bd0b28l; + 0x2bb45a92l; + 0x5cb36a04l; + 0xc2d7ffa7l; + 0xb5d0cf31l; + 0x2cd99e8bl; + 0x5bdeae1dl; + 0x9b64c2b0l; + 0xec63f226l; + 0x756aa39cl; + 0x026d930al; + 0x9c0906a9l; + 0xeb0e363fl; + 0x72076785l; + 0x05005713l; + 0x95bf4a82l; + 0xe2b87a14l; + 0x7bb12bael; + 0x0cb61b38l; + 0x92d28e9bl; + 0xe5d5be0dl; + 0x7cdcefb7l; + 0x0bdbdf21l; + 0x86d3d2d4l; + 0xf1d4e242l; + 0x68ddb3f8l; + 0x1fda836el; + 0x81be16cdl; + 0xf6b9265bl; + 0x6fb077e1l; + 0x18b74777l; + 0x88085ae6l; + 0xff0f6a70l; + 0x66063bcal; + 0x11010b5cl; + 0x8f659effl; + 0xf862ae69l; + 0x616bffd3l; + 0x166ccf45l; + 0xa00ae278l; + 0xd70dd2eel; + 0x4e048354l; + 0x3903b3c2l; + 0xa7672661l; + 0xd06016f7l; + 0x4969474dl; + 0x3e6e77dbl; + 0xaed16a4al; + 0xd9d65adcl; + 0x40df0b66l; + 0x37d83bf0l; + 0xa9bcae53l; + 0xdebb9ec5l; + 0x47b2cf7fl; + 0x30b5ffe9l; + 0xbdbdf21cl; + 0xcabac28al; + 0x53b39330l; + 0x24b4a3a6l; + 0xbad03605l; + 0xcdd70693l; + 0x54de5729l; + 0x23d967bfl; + 0xb3667a2el; + 0xc4614ab8l; + 0x5d681b02l; + 0x2a6f2b94l; + 0xb40bbe37l; + 0xc30c8ea1l; + 0x5a05df1bl; + 0x2d02ef8dl; + |] let string_fold_left f acc str offset length = let acc_r = ref acc in @@ -88,11 +281,12 @@ let string_fold_left f acc str offset length = type t = int32 let update_crc acc c = - let index = Int32.to_int ((acc ^^^ (Int32.of_int (int_of_char c))) &&& 0xffl) in - (crc_table.(index) ^^^ (acc >>> 8)) &&& 0xffffffffl + let index = Int32.to_int (acc ^^^ Int32.of_int (int_of_char c) &&& 0xffl) in + crc_table.(index) ^^^ (acc >>> 8) &&& 0xffffffffl -let string ?(crc=0l) str offset length = - (string_fold_left update_crc (crc ^^^ 0xffffffffl) str offset length) ^^^ 0xffffffffl +let string ?(crc = 0l) str offset length = + string_fold_left update_crc (crc ^^^ 0xffffffffl) str offset length + ^^^ 0xffffffffl (*let bigstring ?(crc=0l) str = (bigstring_fold_left update_crc (crc ^^^ 0xffffffffl) str) ^^^ 0xffffffffl diff --git a/core/dataStructures/dune b/core/dataStructures/dune index 3519070401..fc931a5322 100644 --- a/core/dataStructures/dune +++ b/core/dataStructures/dune @@ -2,4 +2,5 @@ (name kappa_generic_toolset) (libraries unix yojson result logs stdlib-shims bigarray camlp-streams) (public_name kappa-library.generic) - (flags (:standard -w @a))) + (flags + (:standard -w @a))) diff --git a/core/dataStructures/dynamicArray.ml b/core/dataStructures/dynamicArray.ml index 2cf534d9d9..4e70c43516 100644 --- a/core/dataStructures/dynamicArray.ml +++ b/core/dataStructures/dynamicArray.ml @@ -11,134 +11,143 @@ It uses imperative styles to ensure compatibility with other modules *) module DynArray = - (functor (G:GenArray.GenArray) -> - (struct - type 'a t = - { - mutable array: 'a G.t; - mutable current_size: int; - default: int -> 'a - } - - let create n a = - { - array = G.create n a; - current_size = n; - default = fun _ -> a; - } - - let length a = a.current_size - - let expand t = - let n = length t in - let n' = max (n+1) (n*2) in - let array' = G.init n' t.default in - let () = G.blit t.array 0 array' 0 n in - let () = t.array <- array' in - t.current_size <- n' - - let get a i = - if length a > i then G.get a.array i else a.default i - - let rec set a i v = - let n = length a in - if n>i then G.set a.array i v - else - let () = expand a in - set a i v - - let make = create - - let init n f = - { - array = G.init n f ; - current_size = n ; - default = f - } - - let append a b = - let lb = length b in - let la = length a in - let c = la + lb in - init c (fun x -> if x < la then get a x else get b (x - la)) - - let concat l = - let l = List.filter (fun x -> length x > 0) l in - match l with - | [] -> raise (Invalid_argument "DynamicArray.concat") - | t:: _ -> - let elt = get t 0 in - let c = - List.fold_left - (fun sol a -> sol + length a) - 0 l in - let m = create c elt in - let rec aux k l = - match l with - | [] -> () - | t:: q -> - let s = length t in - let rec aux2 offset k = - if offset = s - then aux k q - else - (set m k (get t offset); - aux2 (offset + 1) (k + 1)) - in - aux2 0 k in - let () = aux 0 l in - m - - let sub a start len = - let size = length a in - if start < 0 || len < 0 || start + len > size - then raise (Invalid_argument "Dynamic_array.sub") - else init len (fun x -> get a (x + start)) - - let copy a = - { - array = G.copy a.array ; - current_size = a.current_size ; - default = a.default ; - } - - let fill a start len x = - let rec aux k i = - if k < len then let () = set a i x in aux (k + 1) (i + 1) in - let size = length a in - if start < 0 || len < 0 || start + len > size - then raise (Invalid_argument "Dynamic_array.fill") - else aux 0 start - - let of_list ~default l = - { - current_size = List.length l; - array = G.of_list ~default l; - default = fun _ -> default; - } - let iter f a = G.iter f a.array - let iteri f a = G.iteri f a.array - let fold_lefti f b a = G.fold_lefti f b a.array - let fold_righti f a b = G.fold_righti f a.array b - let map f a = init (length a) (fun i -> f (get a i)) - - let blit a1 ofs1 a2 ofs2 len = - if len < 0 || ofs1 < 0 || ofs1 > length a1 - len - || ofs2 < 0 || ofs2 > length a2 - len - then invalid_arg "DynamicArray.blit" - else - if ofs1 < ofs2 then - (* Top-down copy *) - for i = len - 1 downto 0 do - G.set a2.array (ofs2 + i) (G.get a1.array (ofs1 + i)) - done - else - (* Bottom-up copy *) - for i = 0 to len - 1 do - G.set a2.array (ofs2 + i) (G.get a1.array (ofs1 + i)) - done - - let print ?trailing pr_s pr_a f a = - G.print ?trailing pr_s pr_a f a.array - - end:GenArray.GenArray)) +functor + (G : GenArray.GenArray) + -> + ( + struct + type 'a t = { + mutable array: 'a G.t; + mutable current_size: int; + default: int -> 'a; + } + + let create n a = + { array = G.create n a; current_size = n; default = (fun _ -> a) } + + let length a = a.current_size + + let expand t = + let n = length t in + let n' = max (n + 1) (n * 2) in + let array' = G.init n' t.default in + let () = G.blit t.array 0 array' 0 n in + let () = t.array <- array' in + t.current_size <- n' + + let get a i = + if length a > i then + G.get a.array i + else + a.default i + + let rec set a i v = + let n = length a in + if n > i then + G.set a.array i v + else ( + let () = expand a in + set a i v + ) + + let make = create + let init n f = { array = G.init n f; current_size = n; default = f } + + let append a b = + let lb = length b in + let la = length a in + let c = la + lb in + init c (fun x -> + if x < la then + get a x + else + get b (x - la)) + + let concat l = + let l = List.filter (fun x -> length x > 0) l in + match l with + | [] -> raise (Invalid_argument "DynamicArray.concat") + | t :: _ -> + let elt = get t 0 in + let c = List.fold_left (fun sol a -> sol + length a) 0 l in + let m = create c elt in + let rec aux k l = + match l with + | [] -> () + | t :: q -> + let s = length t in + let rec aux2 offset k = + if offset = s then + aux k q + else ( + set m k (get t offset); + aux2 (offset + 1) (k + 1) + ) + in + aux2 0 k + in + let () = aux 0 l in + m + + let sub a start len = + let size = length a in + if start < 0 || len < 0 || start + len > size then + raise (Invalid_argument "Dynamic_array.sub") + else + init len (fun x -> get a (x + start)) + + let copy a = + { + array = G.copy a.array; + current_size = a.current_size; + default = a.default; + } + + let fill a start len x = + let rec aux k i = + if k < len then ( + let () = set a i x in + aux (k + 1) (i + 1) + ) + in + let size = length a in + if start < 0 || len < 0 || start + len > size then + raise (Invalid_argument "Dynamic_array.fill") + else + aux 0 start + + let of_list ~default l = + { + current_size = List.length l; + array = G.of_list ~default l; + default = (fun _ -> default); + } + + let iter f a = G.iter f a.array + let iteri f a = G.iteri f a.array + let fold_lefti f b a = G.fold_lefti f b a.array + let fold_righti f a b = G.fold_righti f a.array b + let map f a = init (length a) (fun i -> f (get a i)) + + let blit a1 ofs1 a2 ofs2 len = + if + len < 0 || ofs1 < 0 + || ofs1 > length a1 - len + || ofs2 < 0 + || ofs2 > length a2 - len + then + invalid_arg "DynamicArray.blit" + else if ofs1 < ofs2 then + (* Top-down copy *) + for i = len - 1 downto 0 do + G.set a2.array (ofs2 + i) (G.get a1.array (ofs1 + i)) + done + else + (* Bottom-up copy *) + for i = 0 to len - 1 do + G.set a2.array (ofs2 + i) (G.get a1.array (ofs1 + i)) + done + + let print ?trailing pr_s pr_a f a = G.print ?trailing pr_s pr_a f a.array + end : + GenArray.GenArray) diff --git a/core/dataStructures/dynamicArray.mli b/core/dataStructures/dynamicArray.mli index 1ba2fe28bb..1daddaf9e5 100644 --- a/core/dataStructures/dynamicArray.mli +++ b/core/dataStructures/dynamicArray.mli @@ -1,3 +1 @@ -module DynArray: -functor (_:GenArray.GenArray) -> -GenArray.GenArray +module DynArray : functor (_ : GenArray.GenArray) -> GenArray.GenArray diff --git a/core/dataStructures/fifo.ml b/core/dataStructures/fifo.ml index 113a60e0f5..f875490b8b 100644 --- a/core/dataStructures/fifo.ml +++ b/core/dataStructures/fifo.ml @@ -6,31 +6,16 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type 'a t = - { - waiting_elts: 'a list ; - list: 'a list ; - } - -let empty = - { - waiting_elts = []; - list = [] - } +type 'a t = { waiting_elts: 'a list; list: 'a list } +let empty = { waiting_elts = []; list = [] } let is_empty t = t.waiting_elts = [] && t.list = [] - -let push a t = { t with waiting_elts = a::t.waiting_elts} +let push a t = { t with waiting_elts = a :: t.waiting_elts } let rec pop t = - match - t.list - with - | head::tail -> - {t with list = tail},Some head + match t.list with + | head :: tail -> { t with list = tail }, Some head | [] -> - begin - match t.waiting_elts with - | [] -> t, None - | list -> pop {waiting_elts = [] ; list = List.rev list} - end + (match t.waiting_elts with + | [] -> t, None + | list -> pop { waiting_elts = []; list = List.rev list }) diff --git a/core/dataStructures/fifo.mli b/core/dataStructures/fifo.mli index 36121a635d..dcdb5b7757 100644 --- a/core/dataStructures/fifo.mli +++ b/core/dataStructures/fifo.mli @@ -10,7 +10,7 @@ type 'a t -val empty: 'a t +val empty : 'a t val is_empty : 'a t -> bool -val push : 'a -> 'a t -> 'a t +val push : 'a -> 'a t -> 'a t val pop : 'a t -> 'a t * 'a option diff --git a/core/dataStructures/fractions.ml b/core/dataStructures/fractions.ml index 46f71d429d..b44e74760c 100644 --- a/core/dataStructures/fractions.ml +++ b/core/dataStructures/fractions.ml @@ -1,41 +1,37 @@ -type t = {num:int;den:int} +type t = { num: int; den: int } let sign f = - if f.num = 0 then {num = 0 ; den = 1} - else if f.den < 0 then {num = - f.num; den = - f.den} - else f + if f.num = 0 then + { num = 0; den = 1 } + else if f.den < 0 then + { num = -f.num; den = -f.den } + else + f let simplify f = let gcd = Tools.gcd_2 f.num f.den in - sign {num = f.num/gcd; den = f.den/gcd} - + sign { num = f.num / gcd; den = f.den / gcd } let add a b = - simplify - {num = a.num*b.den + b.num*a.den; - den = b.den*a.den } -let op f = - {f with num = - f.num} + simplify { num = (a.num * b.den) + (b.num * a.den); den = b.den * a.den } +let op f = { f with num = -f.num } let sub a b = add a (op b) - -let mult a b = - simplify - {num = a.num*b.num; - den = a.den*b.den} +let mult a b = simplify { num = a.num * b.num; den = a.den * b.den } let inv a = - if a.num = 0 then None - else Some {num = a.den ; den = a.num} + if a.num = 0 then + None + else + Some { num = a.den; den = a.num } let div a b = match inv b with | None -> None | Some b_inv -> Some (mult a b_inv) -let zero = {num = 0; den =1} - -let is_equal a b = a=b -let of_int i = simplify {num = i; den =1} -let is_zero a = a.num = 0 +let zero = { num = 0; den = 1 } +let is_equal a b = a = b +let of_int i = simplify { num = i; den = 1 } +let is_zero a = a.num = 0 let one = of_int 1 diff --git a/core/dataStructures/fractions.mli b/core/dataStructures/fractions.mli index d14cbc2ee3..bcbf80d8b9 100644 --- a/core/dataStructures/fractions.mli +++ b/core/dataStructures/fractions.mli @@ -1,12 +1,12 @@ -type t = {num:int;den:int} +type t = { num: int; den: int } -val add: t -> t -> t -val sub: t -> t -> t -val mult: t -> t -> t -val inv: t -> t option -val div: t -> t -> t option -val is_equal: t -> t -> bool -val of_int: int -> t -val is_zero: t -> bool -val one: t -val zero: t +val add : t -> t -> t +val sub : t -> t -> t +val mult : t -> t -> t +val inv : t -> t option +val div : t -> t -> t option +val is_equal : t -> t -> bool +val of_int : int -> t +val is_zero : t -> bool +val one : t +val zero : t diff --git a/core/dataStructures/genArray.ml b/core/dataStructures/genArray.ml index f7138f93eb..45b697b1bd 100644 --- a/core/dataStructures/genArray.ml +++ b/core/dataStructures/genArray.ml @@ -9,26 +9,32 @@ (** Signature of array only limited by max_int *) module type GenArray = sig - type 'a t - val create: int -> 'a -> 'a t - val length: 'a t -> int - val get: 'a t -> int -> 'a - val set: 'a t -> int -> 'a -> unit - val init: int -> (int -> 'a) -> 'a t - val make: int -> 'a -> 'a t - val append: 'a t -> 'a t -> 'a t - val concat: 'a t list -> 'a t - val sub: 'a t -> int -> int -> 'a t - val copy: 'a t -> 'a t - val fill: 'a t -> int -> int -> 'a -> unit - val of_list: default:'a -> 'a list -> 'a t - val iter: ('a -> unit) -> 'a t -> unit - val iteri: (int -> 'a -> unit) -> 'a t -> unit - val blit: 'a t -> int -> 'a t -> int -> int -> unit - val fold_lefti: (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b - val fold_righti: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val map: ('a -> 'b) -> 'a t -> 'b t - val print: - ?trailing:(Format.formatter -> unit) -> (Format.formatter -> unit) -> - (int -> Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - end + type 'a t + + val create : int -> 'a -> 'a t + val length : 'a t -> int + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> unit + val init : int -> (int -> 'a) -> 'a t + val make : int -> 'a -> 'a t + val append : 'a t -> 'a t -> 'a t + val concat : 'a t list -> 'a t + val sub : 'a t -> int -> int -> 'a t + val copy : 'a t -> 'a t + val fill : 'a t -> int -> int -> 'a -> unit + val of_list : default:'a -> 'a list -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val iteri : (int -> 'a -> unit) -> 'a t -> unit + val blit : 'a t -> int -> 'a t -> int -> int -> unit + val fold_lefti : (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold_righti : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val map : ('a -> 'b) -> 'a t -> 'b t + + val print : + ?trailing:(Format.formatter -> unit) -> + (Format.formatter -> unit) -> + (int -> Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a t -> + unit +end diff --git a/core/dataStructures/genArray.mli b/core/dataStructures/genArray.mli index f7138f93eb..45b697b1bd 100644 --- a/core/dataStructures/genArray.mli +++ b/core/dataStructures/genArray.mli @@ -9,26 +9,32 @@ (** Signature of array only limited by max_int *) module type GenArray = sig - type 'a t - val create: int -> 'a -> 'a t - val length: 'a t -> int - val get: 'a t -> int -> 'a - val set: 'a t -> int -> 'a -> unit - val init: int -> (int -> 'a) -> 'a t - val make: int -> 'a -> 'a t - val append: 'a t -> 'a t -> 'a t - val concat: 'a t list -> 'a t - val sub: 'a t -> int -> int -> 'a t - val copy: 'a t -> 'a t - val fill: 'a t -> int -> int -> 'a -> unit - val of_list: default:'a -> 'a list -> 'a t - val iter: ('a -> unit) -> 'a t -> unit - val iteri: (int -> 'a -> unit) -> 'a t -> unit - val blit: 'a t -> int -> 'a t -> int -> int -> unit - val fold_lefti: (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b - val fold_righti: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val map: ('a -> 'b) -> 'a t -> 'b t - val print: - ?trailing:(Format.formatter -> unit) -> (Format.formatter -> unit) -> - (int -> Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - end + type 'a t + + val create : int -> 'a -> 'a t + val length : 'a t -> int + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> unit + val init : int -> (int -> 'a) -> 'a t + val make : int -> 'a -> 'a t + val append : 'a t -> 'a t -> 'a t + val concat : 'a t list -> 'a t + val sub : 'a t -> int -> int -> 'a t + val copy : 'a t -> 'a t + val fill : 'a t -> int -> int -> 'a -> unit + val of_list : default:'a -> 'a list -> 'a t + val iter : ('a -> unit) -> 'a t -> unit + val iteri : (int -> 'a -> unit) -> 'a t -> unit + val blit : 'a t -> int -> 'a t -> int -> int -> unit + val fold_lefti : (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b + val fold_righti : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val map : ('a -> 'b) -> 'a t -> 'b t + + val print : + ?trailing:(Format.formatter -> unit) -> + (Format.formatter -> unit) -> + (int -> Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a t -> + unit +end diff --git a/core/dataStructures/hashed_list.ml b/core/dataStructures/hashed_list.ml index 8e4088b907..9b12ce7bb4 100644 --- a/core/dataStructures/hashed_list.ml +++ b/core/dataStructures/hashed_list.ml @@ -1,67 +1,57 @@ -module type Hash = -sig - -type hashed_list -type elt -type cache - -val int_of_hashed_list : hashed_list -> int -val compare : hashed_list -> hashed_list -> int -val init : unit -> cache -val hash : cache -> elt list -> cache * hashed_list -val cons : cache -> elt -> hashed_list -> cache * hashed_list -val empty : hashed_list -val print : Format.formatter -> hashed_list -> unit -val print_cache : Format.formatter -> cache -> unit - +module type Hash = sig + type hashed_list + type elt + type cache + + val int_of_hashed_list : hashed_list -> int + val compare : hashed_list -> hashed_list -> int + val init : unit -> cache + val hash : cache -> elt list -> cache * hashed_list + val cons : cache -> elt -> hashed_list -> cache * hashed_list + val empty : hashed_list + val print : Format.formatter -> hashed_list -> unit + val print_cache : Format.formatter -> cache -> unit end module Make = - functor (A:SetMap.OrderedType) -> +functor + (A : SetMap.OrderedType) + -> struct type elt = A.t type elt_id = int type hashed_list = int - let int_of_hashed_list (h:hashed_list) : int = h - + let int_of_hashed_list (h : hashed_list) : int = h let compare = compare - module SetMap = SetMap.Make(A) + module SetMap = SetMap.Make (A) - type cache = - { - dictionary: elt_id SetMap.Map.t ; - next_elt_id: elt_id ; - cons: hashed_list option Mods.DynArray.t option Mods.DynArray.t ; - next_list_id: hashed_list; - } + type cache = { + dictionary: elt_id SetMap.Map.t; + next_elt_id: elt_id; + cons: hashed_list option Mods.DynArray.t option Mods.DynArray.t; + next_list_id: hashed_list; + } let fst_elt_id = 1 let next_elt_id = succ let fresh_elt_id cache = - cache.next_elt_id, - { - cache with - next_elt_id = next_elt_id cache.next_elt_id - } + ( cache.next_elt_id, + { cache with next_elt_id = next_elt_id cache.next_elt_id } ) let fst_list_id = 1 - let next_list_id = succ let fresh_list_id cache = - { - cache with - next_list_id = next_list_id cache.next_list_id - }, - cache.next_list_id + ( { cache with next_list_id = next_list_id cache.next_list_id }, + cache.next_list_id ) let init () = { - dictionary = SetMap.Map.empty ; - next_elt_id = fst_elt_id ; + dictionary = SetMap.Map.empty; + next_elt_id = fst_elt_id; cons = Mods.DynArray.create 0 None; next_list_id = fst_list_id; } @@ -69,70 +59,59 @@ module Make = let empty = 0 let hash_elt cache elt = - match - SetMap.Map.find_option elt cache.dictionary - with + match SetMap.Map.find_option elt cache.dictionary with | Some i -> cache, i | None -> let id, cache = fresh_elt_id cache in - {cache with dictionary = SetMap.Map.add elt id cache.dictionary}, id + { cache with dictionary = SetMap.Map.add elt id cache.dictionary }, id let cons cache head tail = let cache, hash_head = hash_elt cache head in let subtab = - match - Mods.DynArray.get cache.cons hash_head - with + match Mods.DynArray.get cache.cons hash_head with | Some subtab -> subtab | None -> let subtab = Mods.DynArray.create 0 None in let () = Mods.DynArray.set cache.cons hash_head (Some subtab) in subtab in - match - Mods.DynArray.get subtab tail - with + match Mods.DynArray.get subtab tail with | Some hash -> cache, hash | None -> let cache, hash = fresh_list_id cache in - let () = - Mods.DynArray.set - subtab - tail - (Some hash) - in + let () = Mods.DynArray.set subtab tail (Some hash) in cache, hash - let rec hash cache list = + let rec hash cache list = match list with - | [] -> cache,empty - | h::t -> + | [] -> cache, empty + | h :: t -> let cache, t = hash cache t in cons cache h t - let print formatter = - Format.fprintf formatter "%i" + let print formatter = Format.fprintf formatter "%i" let print_cache formatter cache = let () = - Format.fprintf formatter "Cache\n next_fresh_list_id: %i; next_fresh_elt_id: %i\n" cache.next_list_id cache.next_elt_id + Format.fprintf formatter + "Cache\n next_fresh_list_id: %i; next_fresh_elt_id: %i\n" + cache.next_list_id cache.next_elt_id in let () = SetMap.Map.iter - (fun a i -> - Format.fprintf formatter "DIC:%a:%i\n" A.print a i) + (fun a i -> Format.fprintf formatter "DIC:%a:%i\n" A.print a i) cache.dictionary in Mods.DynArray.iteri (fun a opt -> - match opt with - | None -> () - | Some opt -> - Mods.DynArray.iteri (fun b k -> - match k with - | None -> () - | Some k -> - Format.fprintf formatter - "(%i,%i)->%i \n" a b k) opt) + match opt with + | None -> () + | Some opt -> + Mods.DynArray.iteri + (fun b k -> + match k with + | None -> () + | Some k -> Format.fprintf formatter "(%i,%i)->%i \n" a b k) + opt) cache.cons end diff --git a/core/dataStructures/hashed_list.mli b/core/dataStructures/hashed_list.mli index 009f9078cb..7e131c3677 100644 --- a/core/dataStructures/hashed_list.mli +++ b/core/dataStructures/hashed_list.mli @@ -1,11 +1,9 @@ -module type Hash = -sig +module type Hash = sig type hashed_list type elt type cache val int_of_hashed_list : hashed_list -> int - val compare : hashed_list -> hashed_list -> int val init : unit -> cache val hash : cache -> elt list -> cache * hashed_list @@ -13,7 +11,6 @@ sig val empty : hashed_list val print : Format.formatter -> hashed_list -> unit val print_cache : Format.formatter -> cache -> unit - end -module Make (A:SetMap.OrderedType) : Hash with type elt = A.t +module Make (A : SetMap.OrderedType) : Hash with type elt = A.t diff --git a/core/dataStructures/infinite_buffers.ml b/core/dataStructures/infinite_buffers.ml index 826fac44b1..d63354429d 100644 --- a/core/dataStructures/infinite_buffers.ml +++ b/core/dataStructures/infinite_buffers.ml @@ -1,9 +1,6 @@ type 'a t = 'a list let create _i _default = [] - -let add x t = x::t - +let add x t = x :: t let iter f t = List.iter f (List.rev t) - -let clean _ = [] +let clean _ = [] diff --git a/core/dataStructures/intCollection.ml b/core/dataStructures/intCollection.ml index 75e9835d0d..bfa8e263e3 100644 --- a/core/dataStructures/intCollection.ml +++ b/core/dataStructures/intCollection.ml @@ -7,52 +7,58 @@ (******************************************************************************) type t = { - bag : int Mods.DynArray.t; - mutable size : int; - dict : (int, int) Hashtbl.t + bag: int Mods.DynArray.t; + mutable size: int; + dict: (int, int) Hashtbl.t; } -let create size = { - size = 0; - bag = Mods.DynArray.create size (-1); - dict = Hashtbl.create size; -} +let create size = + { size = 0; bag = Mods.DynArray.create size (-1); dict = Hashtbl.create size } let print f s = - if s.size <= 0 then Pp.empty_set f - else + if s.size <= 0 then + Pp.empty_set f + else ( let () = Format.pp_print_string f "{ " in - let () = for i = 0 to s.size - 2 do + let () = + for i = 0 to s.size - 2 do Format.pp_print_int f (Mods.DynArray.get s.bag i); Pp.comma f - done in + done + in let () = Format.pp_print_int f (Mods.DynArray.get s.bag (s.size - 1)) in Format.pp_print_string f " }" + ) let is_empty s = s.size = 0 let add x s = - if not (Hashtbl.mem s.dict x) then + if not (Hashtbl.mem s.dict x) then ( let () = Mods.DynArray.set s.bag s.size x in let () = Hashtbl.replace s.dict x s.size in s.size <- succ s.size + ) let remove x s = try let pos = Hashtbl.find s.dict x in let () = Hashtbl.remove s.dict x in let () = - if pos < s.size - 1 then + if pos < s.size - 1 then ( let last = Mods.DynArray.get s.bag (s.size - 1) in let () = Hashtbl.replace s.dict last pos in - Mods.DynArray.set s.bag pos last in + Mods.DynArray.set s.bag pos last + ) + in s.size <- pred s.size with Not_found -> () let size s = s.size let random rs s = - if s.size < 1 then None else + if s.size < 1 then + None + else Some (Mods.DynArray.get s.bag (Random.State.int rs s.size)) let fold f s acc = diff --git a/core/dataStructures/intCollection.mli b/core/dataStructures/intCollection.mli index a0c2e5bf3a..d90f7416c9 100644 --- a/core/dataStructures/intCollection.mli +++ b/core/dataStructures/intCollection.mli @@ -10,18 +10,14 @@ type t -val create : int -> t (** [create initial_guess_size] *) +val create : int -> t +(** [create initial_guess_size] *) val is_empty : t -> bool - val size : t -> int - val mem : int -> t -> bool val add : int -> t -> unit val remove : int -> t -> unit - val random : Random.State.t -> t -> int option - val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a - val print : Format.formatter -> t -> unit diff --git a/core/dataStructures/jsonUtil.ml b/core/dataStructures/jsonUtil.ml index 939fb56045..2ed18a0443 100644 --- a/core/dataStructures/jsonUtil.ml +++ b/core/dataStructures/jsonUtil.ml @@ -33,41 +33,43 @@ let read_next_item f st b = let () = Yojson.Basic.read_comma st b in read_between_spaces f st b -let build_msg s = "Not a correct "^s -let of_string (s:string) = `String s +let build_msg s = "Not a correct " ^ s +let of_string (s : string) = `String s -let to_string ?error_msg:(error_msg=build_msg "string") = - function - | `String (s:string) -> s - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) +let to_string ?(error_msg = build_msg "string") = function + | `String (s : string) -> s + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) -let of_int (s:int) = `Int s +let of_int (s : int) = `Int s -let to_int ?error_msg:(error_msg=build_msg "int") = - function - | `Int (s:int) -> s - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) +let to_int ?(error_msg = build_msg "int") = function + | `Int (s : int) -> s + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) -let of_bool (s:bool) = `String (if s then "true" else "false") +let of_bool (s : bool) = + `String + (if s then + "true" + else + "false") -let to_bool ?error_msg:(error_msg=build_msg "boolean") = - function +let to_bool ?(error_msg = build_msg "boolean") = function | `String "true" -> true | `String "false" -> false - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) let of_unit () = `Null -let to_unit ?error_msg:(error_msg=build_msg "unit") = - function +let to_unit ?(error_msg = build_msg "unit") = function | `Null -> () - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) let of_option to_json = function | None -> `Null - | Some x -> match to_json x with + | Some x -> + (match to_json x with | `Null -> failwith "ambiguous JsonUtil.of_option" - | x -> x + | x -> x) let to_option = Yojson.Basic.Util.to_option @@ -76,62 +78,76 @@ let write_option f ob = function | Some x -> f ob x let read_option f p lb = - if Yojson.Basic.read_null_if_possible p lb then None else Some (f p lb) + if Yojson.Basic.read_null_if_possible p lb then + None + else + Some (f p lb) -let of_list to_json l = - `List (List.rev_map to_json (List.rev l)) +let of_list to_json l = `List (List.rev_map to_json (List.rev l)) -let to_list ?error_msg:(error_msg=build_msg "list") of_json = function +let to_list ?(error_msg = build_msg "list") of_json = function | `List l as x -> - begin - try List.rev_map of_json (List.rev l) - with Not_found -> - raise (Yojson.Basic.Util.Type_error (error_msg,x)) - end + (try List.rev_map of_json (List.rev l) + with Not_found -> raise (Yojson.Basic.Util.Type_error (error_msg, x))) | `Null -> [] - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) let write_comma ob = Buffer.add_char ob ',' let rec iter2 f_elt x = function | [] -> () - | y :: l -> write_comma x; f_elt x y; iter2 f_elt x l + | y :: l -> + write_comma x; + f_elt x y; + iter2 f_elt x l let write_list f ob l = let () = Buffer.add_char ob '[' in - let () = match l with + let () = + match l with | [] -> () - | y :: l -> f ob y; iter2 f ob l in + | y :: l -> + f ob y; + iter2 f ob l + in Buffer.add_char ob ']' let of_array to_json a = - `List (Array.fold_right (fun x acc -> to_json x::acc) a []) + `List (Array.fold_right (fun x acc -> to_json x :: acc) a []) -let to_array ?error_msg:(error_msg=build_msg "array") of_json = function +let to_array ?(error_msg = build_msg "array") of_json = function | `List l -> Tools.array_map_of_list of_json l | `Null -> [||] - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) let write_array f ob l = let () = Buffer.add_char ob '[' in let () = if Array.length l > 0 then f ob l.(0) in - let () = Tools.iteri - (fun i -> let () = write_comma ob in f ob l.(succ i)) - (pred (Array.length l)) in + let () = + Tools.iteri + (fun i -> + let () = write_comma ob in + f ob l.(succ i)) + (pred (Array.length l)) + in Buffer.add_char ob ']' let rec iter_seq ob = function | [] -> () - | f::q -> + | f :: q -> let () = write_comma ob in let () = f ob in iter_seq ob q let write_sequence ob l = let () = Buffer.add_char ob '[' in - let () = match l with + let () = + match l with | [] -> () - | f::q -> let () = f ob in iter_seq ob q in + | f :: q -> + let () = f ob in + iter_seq ob q + in Buffer.add_char ob ']' let read_variant read_id read st b = @@ -142,72 +158,54 @@ let read_variant read_id read st b = out let smart_assoc l = - `Assoc (List.rev (List.fold_left (fun acc -> function - | _,(`Null | `Assoc [] | `List []) -> acc - | x -> x::acc) [] l)) - -let of_assoc to_json l = - `Assoc (List.rev_map to_json (List.rev l)) - -let to_assoc - ?error_msg:(error_msg=build_msg "association") - of_json json = - match json - with + `Assoc + (List.rev + (List.fold_left + (fun acc -> function + | _, (`Null | `Assoc [] | `List []) -> acc + | x -> x :: acc) + [] l)) + +let of_assoc to_json l = `Assoc (List.rev_map to_json (List.rev l)) + +let to_assoc ?(error_msg = build_msg "association") of_json json = + match json with | `Assoc l as x -> - begin - try - List.rev_map of_json (List.rev l) - with Not_found -> - raise (Yojson.Basic.Util.Type_error (error_msg,x)) - end + (try List.rev_map of_json (List.rev l) + with Not_found -> raise (Yojson.Basic.Util.Type_error (error_msg, x))) | `Null -> [] - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) let write_field na f ob x = let () = Yojson.Basic.write_string ob na in let () = Buffer.add_char ob ':' in f ob x -let of_pair ?(lab1="first") ?(lab2="second") to_json1 to_json2 (a,b) = +let of_pair ?(lab1 = "first") ?(lab2 = "second") to_json1 to_json2 (a, b) = `Assoc [ lab1, to_json1 a; lab2, to_json2 b ] -let to_triple - ?lab1:(lab1="first") ?lab2:(lab2="second") ?lab3:(lab3="third") - ?error_msg:(error_msg=build_msg "triple") - of_json1 of_json2 of_json3 = - function +let to_triple ?(lab1 = "first") ?(lab2 = "second") ?(lab3 = "third") + ?(error_msg = build_msg "triple") of_json1 of_json2 of_json3 = function | `Assoc l as x when List.length l = 3 -> - begin - try - of_json1 (List.assoc lab1 l), - of_json2 (List.assoc lab2 l), - of_json3 (List.assoc lab3 l) - with Not_found -> - raise (Yojson.Basic.Util.Type_error (error_msg,x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error (error_msg,x)) - -let of_triple ?(lab1="first") ?(lab2="second") ?(lab3="third") - to_json1 to_json2 to_json3 (a,b,c) = - `Assoc [ lab1, to_json1 a; lab2, to_json2 b ; lab3, to_json3 c] - -let to_pair ?lab1:(lab1="first") ?lab2:(lab2="second") - ?error_msg:(error_msg=build_msg "pair") of_json1 of_json2 = - function + (try + ( of_json1 (List.assoc lab1 l), + of_json2 (List.assoc lab2 l), + of_json3 (List.assoc lab3 l) ) + with Not_found -> raise (Yojson.Basic.Util.Type_error (error_msg, x))) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) + +let of_triple ?(lab1 = "first") ?(lab2 = "second") ?(lab3 = "third") to_json1 + to_json2 to_json3 (a, b, c) = + `Assoc [ lab1, to_json1 a; lab2, to_json2 b; lab3, to_json3 c ] + +let to_pair ?(lab1 = "first") ?(lab2 = "second") ?(error_msg = build_msg "pair") + of_json1 of_json2 = function | `Assoc l as x when List.length l = 2 -> - begin - try - of_json1 (List.assoc lab1 l), - of_json2 (List.assoc lab2 l) - with Not_found -> - raise (Yojson.Basic.Util.Type_error (error_msg,x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error (error_msg,x)) - -let write_compact_pair f g ob (x,y) = + (try of_json1 (List.assoc lab1 l), of_json2 (List.assoc lab2 l) + with Not_found -> raise (Yojson.Basic.Util.Type_error (error_msg, x))) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) + +let write_compact_pair f g ob (x, y) = let () = Buffer.add_char ob '[' in let () = f ob x in let () = write_comma ob in @@ -220,347 +218,328 @@ let read_compact_pair f g st b = let () = Yojson.Basic.read_comma st b in let y = read_between_spaces g st b in let () = Yojson.Basic.read_rbr st b in - (x,y) + x, y let compact_to_pair f g = function - | `List [ x; y ] -> (f x, g y) - | x -> raise (Yojson.Basic.Util.Type_error ("Not a compact pair",x)) + | `List [ x; y ] -> f x, g y + | x -> raise (Yojson.Basic.Util.Type_error ("Not a compact pair", x)) -let of_map - ?lab_key:(lab_key="key") - ?lab_value:(lab_value="value") - ~fold key_to_json value_to_json map = +let of_map ?(lab_key = "key") ?(lab_value = "value") ~fold key_to_json + value_to_json map = `List (List.rev (fold - (fun (key:'key) (value:'value) (list:Yojson.Basic.t list) -> - (`Assoc [ - lab_key,key_to_json key; - lab_value,value_to_json value - ])::list - ) - map - []) - ) - -let to_map - ?lab_key:(lab_key="key") - ?lab_value:(lab_value="value") - ?error_msg:(error_msg=build_msg "map") - ~add ~empty json_to_key json_to_value = + (fun (key : 'key) (value : 'value) (list : Yojson.Basic.t list) -> + `Assoc [ lab_key, key_to_json key; lab_value, value_to_json value ] + :: list) + map [])) + +let to_map ?(lab_key = "key") ?(lab_value = "value") + ?(error_msg = build_msg "map") ~add ~empty json_to_key json_to_value = function | `List l -> List.fold_left (fun map x -> - match x - with `Assoc l as x when List.length l = 2 -> - begin - try - add - (json_to_key (List.assoc lab_key l)) - (json_to_value (List.assoc lab_value l)) - map - with Not_found -> - raise - (Yojson.Basic.Util.Type_error (error_msg,x)) - end - | x -> - raise - (Yojson.Basic.Util.Type_error (error_msg,x))) - empty - l - | x -> raise (Yojson.Basic.Util.Type_error (error_msg,x)) - -let of_unix_label = - function - | UnixLabels.E2BIG -> `Assoc ["E2BIG",`Null] - | UnixLabels.EACCES -> `Assoc ["EACCES",`Null] - | UnixLabels.EAGAIN -> `Assoc ["EAGAIN",`Null] - | UnixLabels.EBADF -> `Assoc ["EBADF",`Null] - | UnixLabels.EBUSY -> `Assoc ["EBUSY",`Null] - | UnixLabels.ECHILD -> `Assoc ["ECHILD",`Null] - | UnixLabels.EDEADLK -> `Assoc ["EDEADLK",`Null] - | UnixLabels.EDOM -> `Assoc ["EDOM",`Null] - | UnixLabels.EEXIST -> `Assoc ["EEXIST",`Null] - | UnixLabels.EFAULT -> `Assoc ["EFAULT",`Null] - | UnixLabels.EFBIG -> `Assoc ["EFBIG",`Null] - | UnixLabels.EINTR -> `Assoc ["EINTR",`Null] - | UnixLabels.EINVAL -> `Assoc ["EINVAL",`Null] - | UnixLabels.EIO -> `Assoc ["EIO",`Null] - | UnixLabels.EISDIR -> `Assoc ["EISDIR",`Null] - | UnixLabels.EMFILE -> `Assoc ["EMFILE",`Null] - | UnixLabels.EMLINK -> `Assoc ["EMLINK",`Null] - | UnixLabels.ENAMETOOLONG -> `Assoc ["ENAMETOOLONG",`Null] - | UnixLabels.ENFILE -> `Assoc ["ENFILE",`Null] - | UnixLabels.ENODEV -> `Assoc ["ENODEV",`Null] - | UnixLabels.ENOENT -> `Assoc ["ENOENT",`Null] - | UnixLabels.ENOEXEC -> `Assoc ["ENOEXEC",`Null] - | UnixLabels.ENOLCK -> `Assoc ["ENOLCK",`Null] - | UnixLabels.ENOMEM -> `Assoc ["ENOMEM",`Null] - | UnixLabels.ENOSPC -> `Assoc ["ENOSPC",`Null] - | UnixLabels.ENOSYS -> `Assoc ["ENOSYS",`Null] - | UnixLabels.ENOTDIR -> `Assoc ["ENOTDIR",`Null] - | UnixLabels.ENOTEMPTY -> `Assoc ["ENOTEMPTY",`Null] - | UnixLabels.ENOTTY -> `Assoc ["ENOTTY",`Null] - | UnixLabels.ENXIO -> `Assoc ["ENXIO",`Null] - | UnixLabels.EPERM -> `Assoc ["EPERM",`Null] - | UnixLabels.EPIPE -> `Assoc ["EPIPE",`Null] - | UnixLabels.ERANGE -> `Assoc ["ERANGE",`Null] - | UnixLabels.EROFS -> `Assoc ["EROFS",`Null] - | UnixLabels.ESPIPE -> `Assoc ["ESPIPE",`Null] - | UnixLabels.ESRCH -> `Assoc ["ESRCH",`Null] - | UnixLabels.EXDEV -> `Assoc ["EXDEV",`Null] - | UnixLabels.EWOULDBLOCK -> `Assoc ["EWOULDBLOCK",`Null] - | UnixLabels.EINPROGRESS -> `Assoc ["EINPROGRESS",`Null] - | UnixLabels.EALREADY -> `Assoc ["EALREADY",`Null] - | UnixLabels.ENOTSOCK -> `Assoc ["ENOTSOCK",`Null] - | UnixLabels.EDESTADDRREQ -> `Assoc ["EDESTADDRREQ",`Null] - | UnixLabels.EMSGSIZE -> `Assoc ["EMSGSIZE",`Null] - | UnixLabels.EPROTOTYPE -> `Assoc ["EPROTOTYPE",`Null] - | UnixLabels.ENOPROTOOPT -> `Assoc ["ENOPROTOOPT",`Null] - | UnixLabels.EPROTONOSUPPORT -> `Assoc ["EPROTONOSUPPORT",`Null] - | UnixLabels.ESOCKTNOSUPPORT -> `Assoc ["ESOCKTNOSUPPORT",`Null] - | UnixLabels.EOPNOTSUPP -> `Assoc ["EOPNOTSUPP",`Null] - | UnixLabels.EPFNOSUPPORT -> `Assoc ["EPFNOSUPPORT",`Null] - | UnixLabels.EAFNOSUPPORT -> `Assoc ["EAFNOSUPPORT",`Null] - | UnixLabels.EADDRINUSE -> `Assoc ["EADDRINUSE",`Null] - | UnixLabels.EADDRNOTAVAIL -> `Assoc ["EADDRNOTAVAIL",`Null] - | UnixLabels.ENETDOWN -> `Assoc ["ENETDOWN",`Null] - | UnixLabels.ENETUNREACH -> `Assoc ["ENETUNREACH",`Null] - | UnixLabels.ENETRESET -> `Assoc ["ENETRESET",`Null] - | UnixLabels.ECONNABORTED -> `Assoc ["ECONNABORTED",`Null] - | UnixLabels.ECONNRESET -> `Assoc ["ECONNRESET",`Null] - | UnixLabels.ENOBUFS -> `Assoc ["ENOBUFS",`Null] - | UnixLabels.EISCONN -> `Assoc ["EISCONN",`Null] - | UnixLabels.ENOTCONN -> `Assoc ["ENOTCONN",`Null] - | UnixLabels.ESHUTDOWN -> `Assoc ["ESHUTDOWN",`Null] - | UnixLabels.ETOOMANYREFS -> `Assoc ["ETOOMANYREFS",`Null] - | UnixLabels.ETIMEDOUT -> `Assoc ["ETIMEDOUT",`Null] - | UnixLabels.ECONNREFUSED -> `Assoc ["ECONNREFUSED",`Null] - | UnixLabels.EHOSTDOWN -> `Assoc ["EHOSTDOWN",`Null] - | UnixLabels.EHOSTUNREACH -> `Assoc ["EHOSTUNREACH",`Null] - | UnixLabels.ELOOP -> `Assoc ["ELOOP",`Null] - | UnixLabels.EOVERFLOW -> `Assoc ["EOVERFLOW",`Null] - | UnixLabels.EUNKNOWNERR int -> `Assoc ["EUNKNOWNERR", of_int int] - - -let (to_unix_label : Yojson.Basic.t -> UnixLabels.error) = - function - | `Assoc ["E2BIG",`Null] -> UnixLabels.E2BIG - | `Assoc ["EACCES",`Null] -> UnixLabels.EACCES - | `Assoc ["EAGAIN",`Null] -> UnixLabels.EAGAIN - | `Assoc ["EBADF",`Null] -> UnixLabels.EBADF - | `Assoc ["EBUSY",`Null] -> UnixLabels.EBUSY - | `Assoc ["ECHILD",`Null] -> UnixLabels.ECHILD - | `Assoc ["EDEADLK",`Null] -> UnixLabels.EDEADLK - | `Assoc ["EDOM",`Null] -> UnixLabels.EDOM - | `Assoc ["EEXIST",`Null] -> UnixLabels.EEXIST - | `Assoc ["EFAULT",`Null] -> UnixLabels.EFAULT - | `Assoc ["EFBIG",`Null] -> UnixLabels.EFBIG - | `Assoc ["EINTR",`Null] -> UnixLabels.EINTR - | `Assoc ["EINVAL",`Null] -> UnixLabels.EINVAL - | `Assoc ["EIO",`Null] -> UnixLabels.EIO - | `Assoc ["EISDIR",`Null] -> UnixLabels.EISDIR - | `Assoc ["EMFILE",`Null] -> UnixLabels.EMFILE - | `Assoc ["EMLINK",`Null] -> UnixLabels.EMLINK - | `Assoc ["ENAMETOOLONG",`Null] -> UnixLabels.ENAMETOOLONG - | `Assoc ["ENFILE",`Null] -> UnixLabels.ENFILE - | `Assoc ["ENODEV",`Null] -> UnixLabels.ENODEV - | `Assoc ["ENOENT",`Null] -> UnixLabels.ENOENT - | `Assoc ["ENOEXEC",`Null] -> UnixLabels.ENOEXEC - | `Assoc ["ENOLCK",`Null] -> UnixLabels.ENOLCK - | `Assoc ["ENOMEM",`Null] -> UnixLabels.ENOMEM - | `Assoc ["ENOSPC",`Null] -> UnixLabels.ENOSPC - | `Assoc ["ENOSYS",`Null] -> UnixLabels.ENOSYS - | `Assoc ["ENOTDIR",`Null] -> UnixLabels.ENOTDIR - | `Assoc ["ENOTEMPTY",`Null] -> UnixLabels.ENOTEMPTY - | `Assoc ["ENOTTY",`Null] -> UnixLabels.ENOTTY - | `Assoc ["ENXIO",`Null] -> UnixLabels.ENXIO - | `Assoc ["EPERM",`Null] -> UnixLabels.EPERM - | `Assoc ["EPIPE",`Null] -> UnixLabels.EPIPE - | `Assoc ["ERANGE",`Null] -> UnixLabels.ERANGE - | `Assoc ["EROFS",`Null] -> UnixLabels.EROFS - | `Assoc ["ESPIPE",`Null] -> UnixLabels.ESPIPE - | `Assoc ["ESRCH",`Null] -> UnixLabels.ESRCH - | `Assoc ["EXDEV",`Null] -> UnixLabels.EXDEV - | `Assoc ["EWOULDBLOCK",`Null] -> UnixLabels.EWOULDBLOCK - | `Assoc ["EINPROGRESS",`Null] -> UnixLabels.EINPROGRESS - | `Assoc ["EALREADY",`Null] -> UnixLabels.EALREADY - | `Assoc ["ENOTSOCK",`Null] -> UnixLabels.ENOTSOCK - | `Assoc ["EDESTADDRREQ",`Null] -> UnixLabels.EDESTADDRREQ - | `Assoc ["EMSGSIZE",`Null] -> UnixLabels.EMSGSIZE - | `Assoc ["EPROTOTYPE",`Null] -> UnixLabels.EPROTOTYPE - | `Assoc ["ENOPROTOOPT",`Null] -> UnixLabels.ENOPROTOOPT - | `Assoc ["EPROTONOSUPPORT",`Null] -> UnixLabels.EPROTONOSUPPORT - | `Assoc ["ESOCKTNOSUPPORT",`Null] -> UnixLabels.ESOCKTNOSUPPORT - | `Assoc ["EOPNOTSUPP",`Null] -> UnixLabels.EOPNOTSUPP - | `Assoc ["EPFNOSUPPORT",`Null] -> UnixLabels.EPFNOSUPPORT - | `Assoc ["EAFNOSUPPORT",`Null] -> UnixLabels.EAFNOSUPPORT - | `Assoc ["EADDRINUSE",`Null] -> UnixLabels.EADDRINUSE - | `Assoc ["EADDRNOTAVAIL",`Null] -> UnixLabels.EADDRNOTAVAIL - | `Assoc ["ENETDOWN",`Null] -> UnixLabels.ENETDOWN - | `Assoc ["ENETUNREACH",`Null] -> UnixLabels.ENETUNREACH - | `Assoc ["ENETRESET",`Null] -> UnixLabels.ENETRESET - | `Assoc ["ECONNABORTED",`Null] -> UnixLabels.ECONNABORTED - | `Assoc ["ECONNRESET",`Null] -> UnixLabels.ECONNRESET - | `Assoc ["ENOBUFS",`Null] -> UnixLabels.ENOBUFS - | `Assoc ["EISCONN",`Null] -> UnixLabels.EISCONN - | `Assoc ["ENOTCONN",`Null] -> UnixLabels.ENOTCONN - | `Assoc ["ESHUTDOWN",`Null] -> UnixLabels.ESHUTDOWN - | `Assoc ["ETOOMANYREFS",`Null] -> UnixLabels.ETOOMANYREFS - | `Assoc ["ETIMEDOUT",`Null] -> UnixLabels.ETIMEDOUT - | `Assoc ["ECONNREFUSED",`Null] -> UnixLabels.ECONNREFUSED - | `Assoc ["EHOSTDOWN",`Null] -> UnixLabels.EHOSTDOWN - | `Assoc ["EHOSTUNREACH",`Null] -> UnixLabels.EHOSTUNREACH - | `Assoc ["ELOOP",`Null] -> UnixLabels.ELOOP - | `Assoc ["EOVERFLOW",`Null] -> UnixLabels.EOVERFLOW - | `Assoc ["EUNKNOWNERR",int] -> UnixLabels.EUNKNOWNERR (to_int int) - | x -> - raise (Yojson.Basic.Util.Type_error (build_msg "unix labels error",x)) - -let of_unix_error = - function - | Unix.E2BIG -> `Assoc ["E2BIG",`Null] - | Unix.EACCES -> `Assoc ["EACCES",`Null] - | Unix.EAGAIN -> `Assoc ["EAGAIN",`Null] - | Unix.EBADF -> `Assoc ["EBADF",`Null] - | Unix.EBUSY -> `Assoc ["EBUSY",`Null] - | Unix.ECHILD -> `Assoc ["ECHILD",`Null] - | Unix.EDEADLK -> `Assoc ["EDEADLK",`Null] - | Unix.EDOM -> `Assoc ["EDOM",`Null] - | Unix.EEXIST -> `Assoc ["EEXIST",`Null] - | Unix.EFAULT -> `Assoc ["EFAULT",`Null] - | Unix.EFBIG -> `Assoc ["EFBIG",`Null] - | Unix.EINTR -> `Assoc ["EINTR",`Null] - | Unix.EINVAL -> `Assoc ["EINVAL",`Null] - | Unix.EIO -> `Assoc ["EIO",`Null] - | Unix.EISDIR -> `Assoc ["EISDIR",`Null] - | Unix.EMFILE -> `Assoc ["EMFILE",`Null] - | Unix.EMLINK -> `Assoc ["EMLINK",`Null] - | Unix.ENAMETOOLONG -> `Assoc ["ENAMETOOLONG",`Null] - | Unix.ENFILE -> `Assoc ["ENFILE",`Null] - | Unix.ENODEV -> `Assoc ["ENODEV",`Null] - | Unix.ENOENT -> `Assoc ["ENOENT",`Null] - | Unix.ENOEXEC -> `Assoc ["ENOEXEC",`Null] - | Unix.ENOLCK -> `Assoc ["ENOLCK",`Null] - | Unix.ENOMEM -> `Assoc ["ENOMEM",`Null] - | Unix.ENOSPC -> `Assoc ["ENOSPC",`Null] - | Unix.ENOSYS -> `Assoc ["ENOSYS",`Null] - | Unix.ENOTDIR -> `Assoc ["ENOTDIR",`Null] - | Unix.ENOTEMPTY -> `Assoc ["ENOTEMPTY",`Null] - | Unix.ENOTTY -> `Assoc ["ENOTTY",`Null] - | Unix.ENXIO -> `Assoc ["ENXIO",`Null] - | Unix.EPERM -> `Assoc ["EPERM",`Null] - | Unix.EPIPE -> `Assoc ["EPIPE",`Null] - | Unix.ERANGE -> `Assoc ["ERANGE",`Null] - | Unix.EROFS -> `Assoc ["EROFS",`Null] - | Unix.ESPIPE -> `Assoc ["ESPIPE",`Null] - | Unix.ESRCH -> `Assoc ["ESRCH",`Null] - | Unix.EXDEV -> `Assoc ["EXDEV",`Null] - | Unix.EWOULDBLOCK -> `Assoc ["EWOULDBLOCK",`Null] - | Unix.EINPROGRESS -> `Assoc ["EINPROGRESS",`Null] - | Unix.EALREADY -> `Assoc ["EALREADY",`Null] - | Unix.ENOTSOCK -> `Assoc ["ENOTSOCK",`Null] - | Unix.EDESTADDRREQ -> `Assoc ["EDESTADDRREQ",`Null] - | Unix.EMSGSIZE -> `Assoc ["EMSGSIZE",`Null] - | Unix.EPROTOTYPE -> `Assoc ["EPROTOTYPE",`Null] - | Unix.ENOPROTOOPT -> `Assoc ["ENOPROTOOPT",`Null] - | Unix.EPROTONOSUPPORT -> `Assoc ["EPROTONOSUPPORT",`Null] - | Unix.ESOCKTNOSUPPORT -> `Assoc ["ESOCKTNOSUPPORT",`Null] - | Unix.EOPNOTSUPP -> `Assoc ["EOPNOTSUPP",`Null] - | Unix.EPFNOSUPPORT -> `Assoc ["EPFNOSUPPORT",`Null] - | Unix.EAFNOSUPPORT -> `Assoc ["EAFNOSUPPORT",`Null] - | Unix.EADDRINUSE -> `Assoc ["EADDRINUSE",`Null] - | Unix.EADDRNOTAVAIL -> `Assoc ["EADDRNOTAVAIL",`Null] - | Unix.ENETDOWN -> `Assoc ["ENETDOWN",`Null] - | Unix.ENETUNREACH -> `Assoc ["ENETUNREACH",`Null] - | Unix.ENETRESET -> `Assoc ["ENETRESET",`Null] - | Unix.ECONNABORTED -> `Assoc ["ECONNABORTED",`Null] - | Unix.ECONNRESET -> `Assoc ["ECONNRESET",`Null] - | Unix.ENOBUFS -> `Assoc ["ENOBUFS",`Null] - | Unix.EISCONN -> `Assoc ["EISCONN",`Null] - | Unix.ENOTCONN -> `Assoc ["ENOTCONN",`Null] - | Unix.ESHUTDOWN -> `Assoc ["ESHUTDOWN",`Null] - | Unix.ETOOMANYREFS -> `Assoc ["ETOOMANYREFS",`Null] - | Unix.ETIMEDOUT -> `Assoc ["ETIMEDOUT",`Null] - | Unix.ECONNREFUSED -> `Assoc ["ECONNREFUSED",`Null] - | Unix.EHOSTDOWN -> `Assoc ["EHOSTDOWN",`Null] - | Unix.EHOSTUNREACH -> `Assoc ["EHOSTUNREACH",`Null] - | Unix.ELOOP -> `Assoc ["ELOOP",`Null] - | Unix.EOVERFLOW -> `Assoc ["EOVERFLOW",`Null] - | Unix.EUNKNOWNERR int -> `Assoc ["EUNKNOWNERR", of_int int] - - -let (to_unix_error : Yojson.Basic.t -> Unix.error) = - function - | `Assoc ["E2BIG",`Null] -> Unix.E2BIG - | `Assoc ["EACCES",`Null] -> Unix.EACCES - | `Assoc ["EAGAIN",`Null] -> Unix.EAGAIN - | `Assoc ["EBADF",`Null] -> Unix.EBADF - | `Assoc ["EBUSY",`Null] -> Unix.EBUSY - | `Assoc ["ECHILD",`Null] -> Unix.ECHILD - | `Assoc ["EDEADLK",`Null] -> Unix.EDEADLK - | `Assoc ["EDOM",`Null] -> Unix.EDOM - | `Assoc ["EEXIST",`Null] -> Unix.EEXIST - | `Assoc ["EFAULT",`Null] -> Unix.EFAULT - | `Assoc ["EFBIG",`Null] -> Unix.EFBIG - | `Assoc ["EINTR",`Null] -> Unix.EINTR - | `Assoc ["EINVAL",`Null] -> Unix.EINVAL - | `Assoc ["EIO",`Null] -> Unix.EIO - | `Assoc ["EISDIR",`Null] -> Unix.EISDIR - | `Assoc ["EMFILE",`Null] -> Unix.EMFILE - | `Assoc ["EMLINK",`Null] -> Unix.EMLINK - | `Assoc ["ENAMETOOLONG",`Null] -> Unix.ENAMETOOLONG - | `Assoc ["ENFILE",`Null] -> Unix.ENFILE - | `Assoc ["ENODEV",`Null] -> Unix.ENODEV - | `Assoc ["ENOENT",`Null] -> Unix.ENOENT - | `Assoc ["ENOEXEC",`Null] -> Unix.ENOEXEC - | `Assoc ["ENOLCK",`Null] -> Unix.ENOLCK - | `Assoc ["ENOMEM",`Null] -> Unix.ENOMEM - | `Assoc ["ENOSPC",`Null] -> Unix.ENOSPC - | `Assoc ["ENOSYS",`Null] -> Unix.ENOSYS - | `Assoc ["ENOTDIR",`Null] -> Unix.ENOTDIR - | `Assoc ["ENOTEMPTY",`Null] -> Unix.ENOTEMPTY - | `Assoc ["ENOTTY",`Null] -> Unix.ENOTTY - | `Assoc ["ENXIO",`Null] -> Unix.ENXIO - | `Assoc ["EPERM",`Null] -> Unix.EPERM - | `Assoc ["EPIPE",`Null] -> Unix.EPIPE - | `Assoc ["ERANGE",`Null] -> Unix.ERANGE - | `Assoc ["EROFS",`Null] -> Unix.EROFS - | `Assoc ["ESPIPE",`Null] -> Unix.ESPIPE - | `Assoc ["ESRCH",`Null] -> Unix.ESRCH - | `Assoc ["EXDEV",`Null] -> Unix.EXDEV - | `Assoc ["EWOULDBLOCK",`Null] -> Unix.EWOULDBLOCK - | `Assoc ["EINPROGRESS",`Null] -> Unix.EINPROGRESS - | `Assoc ["EALREADY",`Null] -> Unix.EALREADY - | `Assoc ["ENOTSOCK",`Null] -> Unix.ENOTSOCK - | `Assoc ["EDESTADDRREQ",`Null] -> Unix.EDESTADDRREQ - | `Assoc ["EMSGSIZE",`Null] -> Unix.EMSGSIZE - | `Assoc ["EPROTOTYPE",`Null] -> Unix.EPROTOTYPE - | `Assoc ["ENOPROTOOPT",`Null] -> Unix.ENOPROTOOPT - | `Assoc ["EPROTONOSUPPORT",`Null] -> Unix.EPROTONOSUPPORT - | `Assoc ["ESOCKTNOSUPPORT",`Null] -> Unix.ESOCKTNOSUPPORT - | `Assoc ["EOPNOTSUPP",`Null] -> Unix.EOPNOTSUPP - | `Assoc ["EPFNOSUPPORT",`Null] -> Unix.EPFNOSUPPORT - | `Assoc ["EAFNOSUPPORT",`Null] -> Unix.EAFNOSUPPORT - | `Assoc ["EADDRINUSE",`Null] -> Unix.EADDRINUSE - | `Assoc ["EADDRNOTAVAIL",`Null] -> Unix.EADDRNOTAVAIL - | `Assoc ["ENETDOWN",`Null] -> Unix.ENETDOWN - | `Assoc ["ENETUNREACH",`Null] -> Unix.ENETUNREACH - | `Assoc ["ENETRESET",`Null] -> Unix.ENETRESET - | `Assoc ["ECONNABORTED",`Null] -> Unix.ECONNABORTED - | `Assoc ["ECONNRESET",`Null] -> Unix.ECONNRESET - | `Assoc ["ENOBUFS",`Null] -> Unix.ENOBUFS - | `Assoc ["EISCONN",`Null] -> Unix.EISCONN - | `Assoc ["ENOTCONN",`Null] -> Unix.ENOTCONN - | `Assoc ["ESHUTDOWN",`Null] -> Unix.ESHUTDOWN - | `Assoc ["ETOOMANYREFS",`Null] -> Unix.ETOOMANYREFS - | `Assoc ["ETIMEDOUT",`Null] -> Unix.ETIMEDOUT - | `Assoc ["ECONNREFUSED",`Null] -> Unix.ECONNREFUSED - | `Assoc ["EHOSTDOWN",`Null] -> Unix.EHOSTDOWN - | `Assoc ["EHOSTUNREACH",`Null] -> Unix.EHOSTUNREACH - | `Assoc ["ELOOP",`Null] -> Unix.ELOOP - | `Assoc ["EOVERFLOW",`Null] -> Unix.EOVERFLOW - | `Assoc ["EUNKNOWNERR",int] -> Unix.EUNKNOWNERR (to_int int) - | x -> - raise (Yojson.Basic.Util.Type_error (build_msg "unix error",x)) + match x with + | `Assoc l as x when List.length l = 2 -> + (try + add + (json_to_key (List.assoc lab_key l)) + (json_to_value (List.assoc lab_value l)) + map + with Not_found -> + raise (Yojson.Basic.Util.Type_error (error_msg, x))) + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x))) + empty l + | x -> raise (Yojson.Basic.Util.Type_error (error_msg, x)) + +let of_unix_label = function + | UnixLabels.E2BIG -> `Assoc [ "E2BIG", `Null ] + | UnixLabels.EACCES -> `Assoc [ "EACCES", `Null ] + | UnixLabels.EAGAIN -> `Assoc [ "EAGAIN", `Null ] + | UnixLabels.EBADF -> `Assoc [ "EBADF", `Null ] + | UnixLabels.EBUSY -> `Assoc [ "EBUSY", `Null ] + | UnixLabels.ECHILD -> `Assoc [ "ECHILD", `Null ] + | UnixLabels.EDEADLK -> `Assoc [ "EDEADLK", `Null ] + | UnixLabels.EDOM -> `Assoc [ "EDOM", `Null ] + | UnixLabels.EEXIST -> `Assoc [ "EEXIST", `Null ] + | UnixLabels.EFAULT -> `Assoc [ "EFAULT", `Null ] + | UnixLabels.EFBIG -> `Assoc [ "EFBIG", `Null ] + | UnixLabels.EINTR -> `Assoc [ "EINTR", `Null ] + | UnixLabels.EINVAL -> `Assoc [ "EINVAL", `Null ] + | UnixLabels.EIO -> `Assoc [ "EIO", `Null ] + | UnixLabels.EISDIR -> `Assoc [ "EISDIR", `Null ] + | UnixLabels.EMFILE -> `Assoc [ "EMFILE", `Null ] + | UnixLabels.EMLINK -> `Assoc [ "EMLINK", `Null ] + | UnixLabels.ENAMETOOLONG -> `Assoc [ "ENAMETOOLONG", `Null ] + | UnixLabels.ENFILE -> `Assoc [ "ENFILE", `Null ] + | UnixLabels.ENODEV -> `Assoc [ "ENODEV", `Null ] + | UnixLabels.ENOENT -> `Assoc [ "ENOENT", `Null ] + | UnixLabels.ENOEXEC -> `Assoc [ "ENOEXEC", `Null ] + | UnixLabels.ENOLCK -> `Assoc [ "ENOLCK", `Null ] + | UnixLabels.ENOMEM -> `Assoc [ "ENOMEM", `Null ] + | UnixLabels.ENOSPC -> `Assoc [ "ENOSPC", `Null ] + | UnixLabels.ENOSYS -> `Assoc [ "ENOSYS", `Null ] + | UnixLabels.ENOTDIR -> `Assoc [ "ENOTDIR", `Null ] + | UnixLabels.ENOTEMPTY -> `Assoc [ "ENOTEMPTY", `Null ] + | UnixLabels.ENOTTY -> `Assoc [ "ENOTTY", `Null ] + | UnixLabels.ENXIO -> `Assoc [ "ENXIO", `Null ] + | UnixLabels.EPERM -> `Assoc [ "EPERM", `Null ] + | UnixLabels.EPIPE -> `Assoc [ "EPIPE", `Null ] + | UnixLabels.ERANGE -> `Assoc [ "ERANGE", `Null ] + | UnixLabels.EROFS -> `Assoc [ "EROFS", `Null ] + | UnixLabels.ESPIPE -> `Assoc [ "ESPIPE", `Null ] + | UnixLabels.ESRCH -> `Assoc [ "ESRCH", `Null ] + | UnixLabels.EXDEV -> `Assoc [ "EXDEV", `Null ] + | UnixLabels.EWOULDBLOCK -> `Assoc [ "EWOULDBLOCK", `Null ] + | UnixLabels.EINPROGRESS -> `Assoc [ "EINPROGRESS", `Null ] + | UnixLabels.EALREADY -> `Assoc [ "EALREADY", `Null ] + | UnixLabels.ENOTSOCK -> `Assoc [ "ENOTSOCK", `Null ] + | UnixLabels.EDESTADDRREQ -> `Assoc [ "EDESTADDRREQ", `Null ] + | UnixLabels.EMSGSIZE -> `Assoc [ "EMSGSIZE", `Null ] + | UnixLabels.EPROTOTYPE -> `Assoc [ "EPROTOTYPE", `Null ] + | UnixLabels.ENOPROTOOPT -> `Assoc [ "ENOPROTOOPT", `Null ] + | UnixLabels.EPROTONOSUPPORT -> `Assoc [ "EPROTONOSUPPORT", `Null ] + | UnixLabels.ESOCKTNOSUPPORT -> `Assoc [ "ESOCKTNOSUPPORT", `Null ] + | UnixLabels.EOPNOTSUPP -> `Assoc [ "EOPNOTSUPP", `Null ] + | UnixLabels.EPFNOSUPPORT -> `Assoc [ "EPFNOSUPPORT", `Null ] + | UnixLabels.EAFNOSUPPORT -> `Assoc [ "EAFNOSUPPORT", `Null ] + | UnixLabels.EADDRINUSE -> `Assoc [ "EADDRINUSE", `Null ] + | UnixLabels.EADDRNOTAVAIL -> `Assoc [ "EADDRNOTAVAIL", `Null ] + | UnixLabels.ENETDOWN -> `Assoc [ "ENETDOWN", `Null ] + | UnixLabels.ENETUNREACH -> `Assoc [ "ENETUNREACH", `Null ] + | UnixLabels.ENETRESET -> `Assoc [ "ENETRESET", `Null ] + | UnixLabels.ECONNABORTED -> `Assoc [ "ECONNABORTED", `Null ] + | UnixLabels.ECONNRESET -> `Assoc [ "ECONNRESET", `Null ] + | UnixLabels.ENOBUFS -> `Assoc [ "ENOBUFS", `Null ] + | UnixLabels.EISCONN -> `Assoc [ "EISCONN", `Null ] + | UnixLabels.ENOTCONN -> `Assoc [ "ENOTCONN", `Null ] + | UnixLabels.ESHUTDOWN -> `Assoc [ "ESHUTDOWN", `Null ] + | UnixLabels.ETOOMANYREFS -> `Assoc [ "ETOOMANYREFS", `Null ] + | UnixLabels.ETIMEDOUT -> `Assoc [ "ETIMEDOUT", `Null ] + | UnixLabels.ECONNREFUSED -> `Assoc [ "ECONNREFUSED", `Null ] + | UnixLabels.EHOSTDOWN -> `Assoc [ "EHOSTDOWN", `Null ] + | UnixLabels.EHOSTUNREACH -> `Assoc [ "EHOSTUNREACH", `Null ] + | UnixLabels.ELOOP -> `Assoc [ "ELOOP", `Null ] + | UnixLabels.EOVERFLOW -> `Assoc [ "EOVERFLOW", `Null ] + | UnixLabels.EUNKNOWNERR int -> `Assoc [ "EUNKNOWNERR", of_int int ] + +let (to_unix_label : Yojson.Basic.t -> UnixLabels.error) = function + | `Assoc [ ("E2BIG", `Null) ] -> UnixLabels.E2BIG + | `Assoc [ ("EACCES", `Null) ] -> UnixLabels.EACCES + | `Assoc [ ("EAGAIN", `Null) ] -> UnixLabels.EAGAIN + | `Assoc [ ("EBADF", `Null) ] -> UnixLabels.EBADF + | `Assoc [ ("EBUSY", `Null) ] -> UnixLabels.EBUSY + | `Assoc [ ("ECHILD", `Null) ] -> UnixLabels.ECHILD + | `Assoc [ ("EDEADLK", `Null) ] -> UnixLabels.EDEADLK + | `Assoc [ ("EDOM", `Null) ] -> UnixLabels.EDOM + | `Assoc [ ("EEXIST", `Null) ] -> UnixLabels.EEXIST + | `Assoc [ ("EFAULT", `Null) ] -> UnixLabels.EFAULT + | `Assoc [ ("EFBIG", `Null) ] -> UnixLabels.EFBIG + | `Assoc [ ("EINTR", `Null) ] -> UnixLabels.EINTR + | `Assoc [ ("EINVAL", `Null) ] -> UnixLabels.EINVAL + | `Assoc [ ("EIO", `Null) ] -> UnixLabels.EIO + | `Assoc [ ("EISDIR", `Null) ] -> UnixLabels.EISDIR + | `Assoc [ ("EMFILE", `Null) ] -> UnixLabels.EMFILE + | `Assoc [ ("EMLINK", `Null) ] -> UnixLabels.EMLINK + | `Assoc [ ("ENAMETOOLONG", `Null) ] -> UnixLabels.ENAMETOOLONG + | `Assoc [ ("ENFILE", `Null) ] -> UnixLabels.ENFILE + | `Assoc [ ("ENODEV", `Null) ] -> UnixLabels.ENODEV + | `Assoc [ ("ENOENT", `Null) ] -> UnixLabels.ENOENT + | `Assoc [ ("ENOEXEC", `Null) ] -> UnixLabels.ENOEXEC + | `Assoc [ ("ENOLCK", `Null) ] -> UnixLabels.ENOLCK + | `Assoc [ ("ENOMEM", `Null) ] -> UnixLabels.ENOMEM + | `Assoc [ ("ENOSPC", `Null) ] -> UnixLabels.ENOSPC + | `Assoc [ ("ENOSYS", `Null) ] -> UnixLabels.ENOSYS + | `Assoc [ ("ENOTDIR", `Null) ] -> UnixLabels.ENOTDIR + | `Assoc [ ("ENOTEMPTY", `Null) ] -> UnixLabels.ENOTEMPTY + | `Assoc [ ("ENOTTY", `Null) ] -> UnixLabels.ENOTTY + | `Assoc [ ("ENXIO", `Null) ] -> UnixLabels.ENXIO + | `Assoc [ ("EPERM", `Null) ] -> UnixLabels.EPERM + | `Assoc [ ("EPIPE", `Null) ] -> UnixLabels.EPIPE + | `Assoc [ ("ERANGE", `Null) ] -> UnixLabels.ERANGE + | `Assoc [ ("EROFS", `Null) ] -> UnixLabels.EROFS + | `Assoc [ ("ESPIPE", `Null) ] -> UnixLabels.ESPIPE + | `Assoc [ ("ESRCH", `Null) ] -> UnixLabels.ESRCH + | `Assoc [ ("EXDEV", `Null) ] -> UnixLabels.EXDEV + | `Assoc [ ("EWOULDBLOCK", `Null) ] -> UnixLabels.EWOULDBLOCK + | `Assoc [ ("EINPROGRESS", `Null) ] -> UnixLabels.EINPROGRESS + | `Assoc [ ("EALREADY", `Null) ] -> UnixLabels.EALREADY + | `Assoc [ ("ENOTSOCK", `Null) ] -> UnixLabels.ENOTSOCK + | `Assoc [ ("EDESTADDRREQ", `Null) ] -> UnixLabels.EDESTADDRREQ + | `Assoc [ ("EMSGSIZE", `Null) ] -> UnixLabels.EMSGSIZE + | `Assoc [ ("EPROTOTYPE", `Null) ] -> UnixLabels.EPROTOTYPE + | `Assoc [ ("ENOPROTOOPT", `Null) ] -> UnixLabels.ENOPROTOOPT + | `Assoc [ ("EPROTONOSUPPORT", `Null) ] -> UnixLabels.EPROTONOSUPPORT + | `Assoc [ ("ESOCKTNOSUPPORT", `Null) ] -> UnixLabels.ESOCKTNOSUPPORT + | `Assoc [ ("EOPNOTSUPP", `Null) ] -> UnixLabels.EOPNOTSUPP + | `Assoc [ ("EPFNOSUPPORT", `Null) ] -> UnixLabels.EPFNOSUPPORT + | `Assoc [ ("EAFNOSUPPORT", `Null) ] -> UnixLabels.EAFNOSUPPORT + | `Assoc [ ("EADDRINUSE", `Null) ] -> UnixLabels.EADDRINUSE + | `Assoc [ ("EADDRNOTAVAIL", `Null) ] -> UnixLabels.EADDRNOTAVAIL + | `Assoc [ ("ENETDOWN", `Null) ] -> UnixLabels.ENETDOWN + | `Assoc [ ("ENETUNREACH", `Null) ] -> UnixLabels.ENETUNREACH + | `Assoc [ ("ENETRESET", `Null) ] -> UnixLabels.ENETRESET + | `Assoc [ ("ECONNABORTED", `Null) ] -> UnixLabels.ECONNABORTED + | `Assoc [ ("ECONNRESET", `Null) ] -> UnixLabels.ECONNRESET + | `Assoc [ ("ENOBUFS", `Null) ] -> UnixLabels.ENOBUFS + | `Assoc [ ("EISCONN", `Null) ] -> UnixLabels.EISCONN + | `Assoc [ ("ENOTCONN", `Null) ] -> UnixLabels.ENOTCONN + | `Assoc [ ("ESHUTDOWN", `Null) ] -> UnixLabels.ESHUTDOWN + | `Assoc [ ("ETOOMANYREFS", `Null) ] -> UnixLabels.ETOOMANYREFS + | `Assoc [ ("ETIMEDOUT", `Null) ] -> UnixLabels.ETIMEDOUT + | `Assoc [ ("ECONNREFUSED", `Null) ] -> UnixLabels.ECONNREFUSED + | `Assoc [ ("EHOSTDOWN", `Null) ] -> UnixLabels.EHOSTDOWN + | `Assoc [ ("EHOSTUNREACH", `Null) ] -> UnixLabels.EHOSTUNREACH + | `Assoc [ ("ELOOP", `Null) ] -> UnixLabels.ELOOP + | `Assoc [ ("EOVERFLOW", `Null) ] -> UnixLabels.EOVERFLOW + | `Assoc [ ("EUNKNOWNERR", int) ] -> UnixLabels.EUNKNOWNERR (to_int int) + | x -> raise (Yojson.Basic.Util.Type_error (build_msg "unix labels error", x)) + +let of_unix_error = function + | Unix.E2BIG -> `Assoc [ "E2BIG", `Null ] + | Unix.EACCES -> `Assoc [ "EACCES", `Null ] + | Unix.EAGAIN -> `Assoc [ "EAGAIN", `Null ] + | Unix.EBADF -> `Assoc [ "EBADF", `Null ] + | Unix.EBUSY -> `Assoc [ "EBUSY", `Null ] + | Unix.ECHILD -> `Assoc [ "ECHILD", `Null ] + | Unix.EDEADLK -> `Assoc [ "EDEADLK", `Null ] + | Unix.EDOM -> `Assoc [ "EDOM", `Null ] + | Unix.EEXIST -> `Assoc [ "EEXIST", `Null ] + | Unix.EFAULT -> `Assoc [ "EFAULT", `Null ] + | Unix.EFBIG -> `Assoc [ "EFBIG", `Null ] + | Unix.EINTR -> `Assoc [ "EINTR", `Null ] + | Unix.EINVAL -> `Assoc [ "EINVAL", `Null ] + | Unix.EIO -> `Assoc [ "EIO", `Null ] + | Unix.EISDIR -> `Assoc [ "EISDIR", `Null ] + | Unix.EMFILE -> `Assoc [ "EMFILE", `Null ] + | Unix.EMLINK -> `Assoc [ "EMLINK", `Null ] + | Unix.ENAMETOOLONG -> `Assoc [ "ENAMETOOLONG", `Null ] + | Unix.ENFILE -> `Assoc [ "ENFILE", `Null ] + | Unix.ENODEV -> `Assoc [ "ENODEV", `Null ] + | Unix.ENOENT -> `Assoc [ "ENOENT", `Null ] + | Unix.ENOEXEC -> `Assoc [ "ENOEXEC", `Null ] + | Unix.ENOLCK -> `Assoc [ "ENOLCK", `Null ] + | Unix.ENOMEM -> `Assoc [ "ENOMEM", `Null ] + | Unix.ENOSPC -> `Assoc [ "ENOSPC", `Null ] + | Unix.ENOSYS -> `Assoc [ "ENOSYS", `Null ] + | Unix.ENOTDIR -> `Assoc [ "ENOTDIR", `Null ] + | Unix.ENOTEMPTY -> `Assoc [ "ENOTEMPTY", `Null ] + | Unix.ENOTTY -> `Assoc [ "ENOTTY", `Null ] + | Unix.ENXIO -> `Assoc [ "ENXIO", `Null ] + | Unix.EPERM -> `Assoc [ "EPERM", `Null ] + | Unix.EPIPE -> `Assoc [ "EPIPE", `Null ] + | Unix.ERANGE -> `Assoc [ "ERANGE", `Null ] + | Unix.EROFS -> `Assoc [ "EROFS", `Null ] + | Unix.ESPIPE -> `Assoc [ "ESPIPE", `Null ] + | Unix.ESRCH -> `Assoc [ "ESRCH", `Null ] + | Unix.EXDEV -> `Assoc [ "EXDEV", `Null ] + | Unix.EWOULDBLOCK -> `Assoc [ "EWOULDBLOCK", `Null ] + | Unix.EINPROGRESS -> `Assoc [ "EINPROGRESS", `Null ] + | Unix.EALREADY -> `Assoc [ "EALREADY", `Null ] + | Unix.ENOTSOCK -> `Assoc [ "ENOTSOCK", `Null ] + | Unix.EDESTADDRREQ -> `Assoc [ "EDESTADDRREQ", `Null ] + | Unix.EMSGSIZE -> `Assoc [ "EMSGSIZE", `Null ] + | Unix.EPROTOTYPE -> `Assoc [ "EPROTOTYPE", `Null ] + | Unix.ENOPROTOOPT -> `Assoc [ "ENOPROTOOPT", `Null ] + | Unix.EPROTONOSUPPORT -> `Assoc [ "EPROTONOSUPPORT", `Null ] + | Unix.ESOCKTNOSUPPORT -> `Assoc [ "ESOCKTNOSUPPORT", `Null ] + | Unix.EOPNOTSUPP -> `Assoc [ "EOPNOTSUPP", `Null ] + | Unix.EPFNOSUPPORT -> `Assoc [ "EPFNOSUPPORT", `Null ] + | Unix.EAFNOSUPPORT -> `Assoc [ "EAFNOSUPPORT", `Null ] + | Unix.EADDRINUSE -> `Assoc [ "EADDRINUSE", `Null ] + | Unix.EADDRNOTAVAIL -> `Assoc [ "EADDRNOTAVAIL", `Null ] + | Unix.ENETDOWN -> `Assoc [ "ENETDOWN", `Null ] + | Unix.ENETUNREACH -> `Assoc [ "ENETUNREACH", `Null ] + | Unix.ENETRESET -> `Assoc [ "ENETRESET", `Null ] + | Unix.ECONNABORTED -> `Assoc [ "ECONNABORTED", `Null ] + | Unix.ECONNRESET -> `Assoc [ "ECONNRESET", `Null ] + | Unix.ENOBUFS -> `Assoc [ "ENOBUFS", `Null ] + | Unix.EISCONN -> `Assoc [ "EISCONN", `Null ] + | Unix.ENOTCONN -> `Assoc [ "ENOTCONN", `Null ] + | Unix.ESHUTDOWN -> `Assoc [ "ESHUTDOWN", `Null ] + | Unix.ETOOMANYREFS -> `Assoc [ "ETOOMANYREFS", `Null ] + | Unix.ETIMEDOUT -> `Assoc [ "ETIMEDOUT", `Null ] + | Unix.ECONNREFUSED -> `Assoc [ "ECONNREFUSED", `Null ] + | Unix.EHOSTDOWN -> `Assoc [ "EHOSTDOWN", `Null ] + | Unix.EHOSTUNREACH -> `Assoc [ "EHOSTUNREACH", `Null ] + | Unix.ELOOP -> `Assoc [ "ELOOP", `Null ] + | Unix.EOVERFLOW -> `Assoc [ "EOVERFLOW", `Null ] + | Unix.EUNKNOWNERR int -> `Assoc [ "EUNKNOWNERR", of_int int ] + +let (to_unix_error : Yojson.Basic.t -> Unix.error) = function + | `Assoc [ ("E2BIG", `Null) ] -> Unix.E2BIG + | `Assoc [ ("EACCES", `Null) ] -> Unix.EACCES + | `Assoc [ ("EAGAIN", `Null) ] -> Unix.EAGAIN + | `Assoc [ ("EBADF", `Null) ] -> Unix.EBADF + | `Assoc [ ("EBUSY", `Null) ] -> Unix.EBUSY + | `Assoc [ ("ECHILD", `Null) ] -> Unix.ECHILD + | `Assoc [ ("EDEADLK", `Null) ] -> Unix.EDEADLK + | `Assoc [ ("EDOM", `Null) ] -> Unix.EDOM + | `Assoc [ ("EEXIST", `Null) ] -> Unix.EEXIST + | `Assoc [ ("EFAULT", `Null) ] -> Unix.EFAULT + | `Assoc [ ("EFBIG", `Null) ] -> Unix.EFBIG + | `Assoc [ ("EINTR", `Null) ] -> Unix.EINTR + | `Assoc [ ("EINVAL", `Null) ] -> Unix.EINVAL + | `Assoc [ ("EIO", `Null) ] -> Unix.EIO + | `Assoc [ ("EISDIR", `Null) ] -> Unix.EISDIR + | `Assoc [ ("EMFILE", `Null) ] -> Unix.EMFILE + | `Assoc [ ("EMLINK", `Null) ] -> Unix.EMLINK + | `Assoc [ ("ENAMETOOLONG", `Null) ] -> Unix.ENAMETOOLONG + | `Assoc [ ("ENFILE", `Null) ] -> Unix.ENFILE + | `Assoc [ ("ENODEV", `Null) ] -> Unix.ENODEV + | `Assoc [ ("ENOENT", `Null) ] -> Unix.ENOENT + | `Assoc [ ("ENOEXEC", `Null) ] -> Unix.ENOEXEC + | `Assoc [ ("ENOLCK", `Null) ] -> Unix.ENOLCK + | `Assoc [ ("ENOMEM", `Null) ] -> Unix.ENOMEM + | `Assoc [ ("ENOSPC", `Null) ] -> Unix.ENOSPC + | `Assoc [ ("ENOSYS", `Null) ] -> Unix.ENOSYS + | `Assoc [ ("ENOTDIR", `Null) ] -> Unix.ENOTDIR + | `Assoc [ ("ENOTEMPTY", `Null) ] -> Unix.ENOTEMPTY + | `Assoc [ ("ENOTTY", `Null) ] -> Unix.ENOTTY + | `Assoc [ ("ENXIO", `Null) ] -> Unix.ENXIO + | `Assoc [ ("EPERM", `Null) ] -> Unix.EPERM + | `Assoc [ ("EPIPE", `Null) ] -> Unix.EPIPE + | `Assoc [ ("ERANGE", `Null) ] -> Unix.ERANGE + | `Assoc [ ("EROFS", `Null) ] -> Unix.EROFS + | `Assoc [ ("ESPIPE", `Null) ] -> Unix.ESPIPE + | `Assoc [ ("ESRCH", `Null) ] -> Unix.ESRCH + | `Assoc [ ("EXDEV", `Null) ] -> Unix.EXDEV + | `Assoc [ ("EWOULDBLOCK", `Null) ] -> Unix.EWOULDBLOCK + | `Assoc [ ("EINPROGRESS", `Null) ] -> Unix.EINPROGRESS + | `Assoc [ ("EALREADY", `Null) ] -> Unix.EALREADY + | `Assoc [ ("ENOTSOCK", `Null) ] -> Unix.ENOTSOCK + | `Assoc [ ("EDESTADDRREQ", `Null) ] -> Unix.EDESTADDRREQ + | `Assoc [ ("EMSGSIZE", `Null) ] -> Unix.EMSGSIZE + | `Assoc [ ("EPROTOTYPE", `Null) ] -> Unix.EPROTOTYPE + | `Assoc [ ("ENOPROTOOPT", `Null) ] -> Unix.ENOPROTOOPT + | `Assoc [ ("EPROTONOSUPPORT", `Null) ] -> Unix.EPROTONOSUPPORT + | `Assoc [ ("ESOCKTNOSUPPORT", `Null) ] -> Unix.ESOCKTNOSUPPORT + | `Assoc [ ("EOPNOTSUPP", `Null) ] -> Unix.EOPNOTSUPP + | `Assoc [ ("EPFNOSUPPORT", `Null) ] -> Unix.EPFNOSUPPORT + | `Assoc [ ("EAFNOSUPPORT", `Null) ] -> Unix.EAFNOSUPPORT + | `Assoc [ ("EADDRINUSE", `Null) ] -> Unix.EADDRINUSE + | `Assoc [ ("EADDRNOTAVAIL", `Null) ] -> Unix.EADDRNOTAVAIL + | `Assoc [ ("ENETDOWN", `Null) ] -> Unix.ENETDOWN + | `Assoc [ ("ENETUNREACH", `Null) ] -> Unix.ENETUNREACH + | `Assoc [ ("ENETRESET", `Null) ] -> Unix.ENETRESET + | `Assoc [ ("ECONNABORTED", `Null) ] -> Unix.ECONNABORTED + | `Assoc [ ("ECONNRESET", `Null) ] -> Unix.ECONNRESET + | `Assoc [ ("ENOBUFS", `Null) ] -> Unix.ENOBUFS + | `Assoc [ ("EISCONN", `Null) ] -> Unix.EISCONN + | `Assoc [ ("ENOTCONN", `Null) ] -> Unix.ENOTCONN + | `Assoc [ ("ESHUTDOWN", `Null) ] -> Unix.ESHUTDOWN + | `Assoc [ ("ETOOMANYREFS", `Null) ] -> Unix.ETOOMANYREFS + | `Assoc [ ("ETIMEDOUT", `Null) ] -> Unix.ETIMEDOUT + | `Assoc [ ("ECONNREFUSED", `Null) ] -> Unix.ECONNREFUSED + | `Assoc [ ("EHOSTDOWN", `Null) ] -> Unix.EHOSTDOWN + | `Assoc [ ("EHOSTUNREACH", `Null) ] -> Unix.EHOSTUNREACH + | `Assoc [ ("ELOOP", `Null) ] -> Unix.ELOOP + | `Assoc [ ("EOVERFLOW", `Null) ] -> Unix.EOVERFLOW + | `Assoc [ ("EUNKNOWNERR", int) ] -> Unix.EUNKNOWNERR (to_int int) + | x -> raise (Yojson.Basic.Util.Type_error (build_msg "unix error", x)) + +let std_json_string_of_float x = + let ob = Buffer.create 20 in + Yojson.Basic.write_std_float ob x; + Buffer.contents ob diff --git a/core/dataStructures/jsonUtil.mli b/core/dataStructures/jsonUtil.mli index a34c5e8bd5..730197be41 100644 --- a/core/dataStructures/jsonUtil.mli +++ b/core/dataStructures/jsonUtil.mli @@ -8,141 +8,165 @@ (** Parsing utils *) -val write_to_channel: (Buffer.t -> 'a -> unit) -> out_channel -> 'a -> unit -val string_of_write: (Buffer.t -> 'a -> unit) -> ?len:int -> 'a -> string +val write_to_channel : (Buffer.t -> 'a -> unit) -> out_channel -> 'a -> unit +val string_of_write : (Buffer.t -> 'a -> unit) -> ?len:int -> 'a -> string -val read_of_string: +val read_of_string : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> string -> 'a val read_between_spaces : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> - (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'a val read_next_item : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> - (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'a -val write_comma: Buffer.t -> unit +val write_comma : Buffer.t -> unit (** Jsonify simple types *) -val build_msg: string -> string - -val of_string: string -> Yojson.Basic.t -val to_string: ?error_msg:string -> Yojson.Basic.t -> string - -val of_int: int -> Yojson.Basic.t -val to_int: ?error_msg:string -> Yojson.Basic.t -> int - -val of_bool: bool -> Yojson.Basic.t -val to_bool: ?error_msg:string -> Yojson.Basic.t -> bool - -val of_unit: unit -> Yojson.Basic.t -val to_unit: ?error_msg:string -> Yojson.Basic.t -> unit - -val of_option: ('a -> Yojson.Basic.t) -> 'a option -> Yojson.Basic.t - -val to_option: (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a option +val build_msg : string -> string +val of_string : string -> Yojson.Basic.t +val to_string : ?error_msg:string -> Yojson.Basic.t -> string +val of_int : int -> Yojson.Basic.t +val to_int : ?error_msg:string -> Yojson.Basic.t -> int +val of_bool : bool -> Yojson.Basic.t +val to_bool : ?error_msg:string -> Yojson.Basic.t -> bool +val of_unit : unit -> Yojson.Basic.t +val to_unit : ?error_msg:string -> Yojson.Basic.t -> unit +val of_option : ('a -> Yojson.Basic.t) -> 'a option -> Yojson.Basic.t + +val to_option : (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a option (** Beware: `Null is reserved for None *) -val write_option: - (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a option -> unit +val write_option : (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a option -> unit -val read_option: +val read_option : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> - Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a option + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'a option -val of_list: ('a -> Yojson.Basic.t) -> 'a list -> Yojson.Basic.t +val of_list : ('a -> Yojson.Basic.t) -> 'a list -> Yojson.Basic.t -val to_list: +val to_list : ?error_msg:string -> (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a list -val write_list: (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a list -> unit - -val of_array: ('a -> Yojson.Basic.t) -> 'a array -> Yojson.Basic.t +val write_list : (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a list -> unit +val of_array : ('a -> Yojson.Basic.t) -> 'a array -> Yojson.Basic.t -val to_array: +val to_array : ?error_msg:string -> (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a array -val write_array: (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a array -> unit +val write_array : (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a array -> unit +val write_sequence : Buffer.t -> (Buffer.t -> unit) list -> unit -val write_sequence: Buffer.t -> (Buffer.t -> unit) list -> unit - -val read_variant: +val read_variant : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a -> 'b) -> - Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'b + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'b -val smart_assoc: (string * Yojson.Basic.t) list -> Yojson.Basic.t +val smart_assoc : (string * Yojson.Basic.t) list -> Yojson.Basic.t (** Do not put fields whose value is 'null', '[]' or '\{\}' *) -val of_assoc: - ('a -> string * Yojson.Basic.t) -> 'a list -> Yojson.Basic.t - -val to_assoc: - ?error_msg:string -> (string * Yojson.Basic.t -> 'a) -> - Yojson.Basic.t -> 'a list - -val write_field: - string -> (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a -> unit - -val of_pair: - ?lab1:string -> ?lab2:string -> - ('a -> Yojson.Basic.t) -> ('b -> Yojson.Basic.t) -> - ('a * 'b) -> Yojson.Basic.t - -val to_pair: - ?lab1:string -> ?lab2:string -> ?error_msg:string -> - (Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'b) -> - Yojson.Basic.t -> 'a * 'b - -val write_compact_pair: - (Buffer.t -> 'a -> unit) -> (Buffer.t -> 'b -> unit) -> - Buffer.t -> 'a * 'b -> unit - -val read_compact_pair: +val of_assoc : ('a -> string * Yojson.Basic.t) -> 'a list -> Yojson.Basic.t + +val to_assoc : + ?error_msg:string -> + (string * Yojson.Basic.t -> 'a) -> + Yojson.Basic.t -> + 'a list + +val write_field : string -> (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a -> unit + +val of_pair : + ?lab1:string -> + ?lab2:string -> + ('a -> Yojson.Basic.t) -> + ('b -> Yojson.Basic.t) -> + 'a * 'b -> + Yojson.Basic.t + +val to_pair : + ?lab1:string -> + ?lab2:string -> + ?error_msg:string -> + (Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t -> 'b) -> + Yojson.Basic.t -> + 'a * 'b + +val write_compact_pair : + (Buffer.t -> 'a -> unit) -> + (Buffer.t -> 'b -> unit) -> + Buffer.t -> + 'a * 'b -> + unit + +val read_compact_pair : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'b) -> - Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a * 'b + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'a * 'b val compact_to_pair : - (Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'b) -> - Yojson.Basic.t -> 'a * 'b - -val of_triple: - ?lab1:string -> ?lab2:string -> ?lab3:string -> - ('a -> Yojson.Basic.t) -> ('b -> Yojson.Basic.t) -> - ('c -> Yojson.Basic.t) -> - ('a * 'b * 'c) -> Yojson.Basic.t - -val to_triple: - ?lab1:string -> ?lab2:string -> ?lab3:string -> ?error_msg:string -> - (Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'b) -> - (Yojson.Basic.t -> 'c) -> Yojson.Basic.t -> 'a * 'b * 'c - -val of_map: - ?lab_key:string -> ?lab_value:string -> - fold:(('key -> 'value -> Yojson.Basic.t list -> Yojson.Basic.t list) -> - 'map -> Yojson.Basic.t list -> Yojson.Basic.t list) -> - ('key -> Yojson.Basic.t) -> ('value -> Yojson.Basic.t) -> - 'map -> Yojson.Basic.t - -val to_map: - ?lab_key:string -> ?lab_value:string -> ?error_msg:string -> + (Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'b) -> Yojson.Basic.t -> 'a * 'b + +val of_triple : + ?lab1:string -> + ?lab2:string -> + ?lab3:string -> + ('a -> Yojson.Basic.t) -> + ('b -> Yojson.Basic.t) -> + ('c -> Yojson.Basic.t) -> + 'a * 'b * 'c -> + Yojson.Basic.t + +val to_triple : + ?lab1:string -> + ?lab2:string -> + ?lab3:string -> + ?error_msg:string -> + (Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t -> 'b) -> + (Yojson.Basic.t -> 'c) -> + Yojson.Basic.t -> + 'a * 'b * 'c + +val of_map : + ?lab_key:string -> + ?lab_value:string -> + fold: + (('key -> 'value -> Yojson.Basic.t list -> Yojson.Basic.t list) -> + 'map -> + Yojson.Basic.t list -> + Yojson.Basic.t list) -> + ('key -> Yojson.Basic.t) -> + ('value -> Yojson.Basic.t) -> + 'map -> + Yojson.Basic.t + +val to_map : + ?lab_key:string -> + ?lab_value:string -> + ?error_msg:string -> add:('key -> 'value -> 'map -> 'map) -> empty:'map -> (Yojson.Basic.t -> 'key) -> (Yojson.Basic.t -> 'value) -> - Yojson.Basic.t -> 'map - -val of_unix_label: - UnixLabels.error -> Yojson.Basic.t - -val to_unix_label: - Yojson.Basic.t -> UnixLabels.error - -val of_unix_error: - Unix.error -> Yojson.Basic.t - -val to_unix_error: - Yojson.Basic.t -> Unix.error + Yojson.Basic.t -> + 'map + +val of_unix_label : UnixLabels.error -> Yojson.Basic.t +val to_unix_label : Yojson.Basic.t -> UnixLabels.error +val of_unix_error : Unix.error -> Yojson.Basic.t +val to_unix_error : Yojson.Basic.t -> Unix.error +val std_json_string_of_float : float -> string diff --git a/core/dataStructures/largeArray.ml b/core/dataStructures/largeArray.ml index 2ee8371532..cb0f57cad3 100644 --- a/core/dataStructures/largeArray.ml +++ b/core/dataStructures/largeArray.ml @@ -11,35 +11,54 @@ type 'a t = Unary of 'a array | Binary of 'a array array let max_array_size1 = Sys.max_array_length (* 5 *) let max_array_size2 = - if float_of_int max_array_size1 > sqrt (float_of_int (max_int)) - then max_int - else max_array_size1 * max_array_size1 + if float_of_int max_array_size1 > sqrt (float_of_int max_int) then + max_int + else + max_array_size1 * max_array_size1 -let euclideen p q = (p / q, p mod q) +let euclideen p q = p / q, p mod q let create n a = - if n <= max_array_size1 - then Unary (Array.make n a) - else if n > max_array_size2 then invalid_arg "GenArray: array too large" - else + if n <= max_array_size1 then + Unary (Array.make n a) + else if n > max_array_size2 then + invalid_arg "GenArray: array too large" + else ( let m = let p, q = euclideen n max_array_size1 in let l = Array.make max_array_size1 a in - let m = Array.make (if q = 0 then p else p + 1) l in + let m = + Array.make + (if q = 0 then + p + else + p + 1) + l + in let rec aux k = - if k = (- 1) then m - else (m.(k) <- Array.make max_array_size1 a; aux (k - 1)) + if k = -1 then + m + else ( + m.(k) <- Array.make max_array_size1 a; + aux (k - 1) + ) in - if q = 0 then aux (p - 1) - else (m.(p) <- Array.make q a; aux (p - 1)) - in Binary m + if q = 0 then + aux (p - 1) + else ( + m.(p) <- Array.make q a; + aux (p - 1) + ) + in + Binary m + ) let length = function | Unary a -> Array.length a | Binary a -> let p = Array.length a in let q = Array.length (Array.unsafe_get a (p - 1)) in - (p - 1) * max_array_size1 + q + ((p - 1) * max_array_size1) + q let get2 a p q = Array.unsafe_get (Array.unsafe_get a p) q @@ -62,83 +81,104 @@ let set a i j = let make = create let init n f = - if n < 0 || n > max_array_size2 - then raise (Invalid_argument ("Big_array.init : "^(string_of_int n))) - else if n <= max_array_size1 - then Unary (Array.init n f) - else + if n < 0 || n > max_array_size2 then + raise (Invalid_argument ("Big_array.init : " ^ string_of_int n)) + else if n <= max_array_size1 then + Unary (Array.init n f) + else ( let m = let p, q = euclideen n max_array_size1 in Array.init - (if q = 0 then p else p + 1) + (if q = 0 then + p + else + p + 1) (fun p' -> - if p'= p then - Array.init q (fun x -> f ((p * max_array_size1) + x)) - else - Array.init max_array_size1 (fun x -> f((p'* max_array_size1) + x))) + if p' = p then + Array.init q (fun x -> f ((p * max_array_size1) + x)) + else + Array.init max_array_size1 (fun x -> f ((p' * max_array_size1) + x))) in Binary m + ) let append a b = let lb = length b in let la = length a in let c = la + lb in - init c (fun x -> if x < la then get a x else get b (x - la)) + init c (fun x -> + if x < la then + get a x + else + get b (x - la)) let concat l = let l = List.filter (fun x -> length x > 0) l in match l with | [] -> Unary [||] - | t:: _ -> + | t :: _ -> let elt = get t 0 in let c = List.fold_left (fun sol a -> sol + length a) 0 l in let m = create c elt in let rec aux k l = match l with | [] -> m - | t:: q -> + | t :: q -> let s = length t in let rec aux2 offset k = - if offset = s then aux k q - else (set m k (get t offset); aux2 (offset + 1) (k + 1)) + if offset = s then + aux k q + else ( + set m k (get t offset); + aux2 (offset + 1) (k + 1) + ) in - aux2 0 k in + aux2 0 k + in aux 0 l let sub a start len = let size = length a in - if start < 0 || len < 0 || start + len > size - then raise (Invalid_argument "Big_array.sub") - else if size = 0 - then Unary [||] - else init len (fun x -> get a (x + start)) + if start < 0 || len < 0 || start + len > size then + raise (Invalid_argument "Big_array.sub") + else if size = 0 then + Unary [||] + else + init len (fun x -> get a (x + start)) let copy = function | Unary a -> Unary (Array.copy a) | Binary b' -> let size = Array.length b' in - Binary - (Array.init size (fun x -> Array.copy (b'.(x)))) + Binary (Array.init size (fun x -> Array.copy b'.(x))) let fill a start len x = let size = length a in - if start < 0 || len < 0 || start + len > size - then raise (Invalid_argument "Big_array.fill") - else + if start < 0 || len < 0 || start + len > size then + raise (Invalid_argument "Big_array.fill") + else ( let rec aux k i = - if k < len then let () = set a i x in aux (k + 1) (i + 1) in + if k < len then ( + let () = set a i x in + aux (k + 1) (i + 1) + ) + in aux 0 start + ) let of_list ~default = function | [] -> Unary [||] - | t::_ as l -> + | t :: _ as l -> let _iknowwhatimdoing = default in let size = List.length l in let a = create size t in let rec aux k = function | [] -> a - | t:: q -> let () = set a k t in aux (k + 1) q - in aux 0 l + | t :: q -> + let () = set a k t in + aux (k + 1) q + in + aux 0 l let iter f = function | Unary a -> Array.iter f a @@ -147,15 +187,14 @@ let iter f = function let iteri f = function | Unary a -> Array.iteri f a | Binary a -> - let g k k' = k*max_array_size1+k' in + let g k k' = (k * max_array_size1) + k' in Array.iteri (fun k a -> Array.iteri (fun k' a -> f (g k k') a) a) a let gen g1 g2 h1 h2 f = function | Unary a -> h1 (g1 f a) | Binary a -> h2 (g2 (g1 f) a) -let map f x = - gen Array.map Array.map (fun x -> Unary x) (fun x -> Binary x) f x +let map f x = gen Array.map Array.map (fun x -> Unary x) (fun x -> Binary x) f x (*let geni g1 g2 h1 h2 f = function | Unary a -> h1 (g1 f a) @@ -173,11 +212,14 @@ let map f x = geni Array.mapi Array.mapi (fun x -> Unary x) (fun x -> Binary x)*) let blit a1 ofs1 a2 ofs2 len = - if len < 0 || ofs1 < 0 || ofs1 > length a1 - len - || ofs2 < 0 || ofs2 > length a2 - len - then invalid_arg "Array.blit" - else - if ofs1 < ofs2 then + if + len < 0 || ofs1 < 0 + || ofs1 > length a1 - len + || ofs2 < 0 + || ofs2 > length a2 - len + then + invalid_arg "Array.blit" + else if ofs1 < ofs2 then (* Top-down copy *) for i = len - 1 downto 0 do set a2 (ofs2 + i) (get a1 (ofs1 + i)) @@ -188,25 +230,29 @@ let blit a1 ofs1 a2 ofs2 len = set a2 (ofs2 + i) (get a1 (ofs1 + i)) done -let fold_lefti f init a = +let fold_lefti f init a = let y = ref init in let () = iteri (fun i e -> y := f i !y e) a in !y -let fold_right f a init = +let fold_right f a init = match a with | Unary a -> Array.fold_right f a init | Binary a -> Array.fold_right (Array.fold_right f) a init let fold_righti f a init = - let g k (i,current) = (i-1,f i k current) in - snd (fold_right g a (length a-1,init)) + let g k (i, current) = i - 1, f i k current in + snd (fold_right g a (length a - 1, init)) -let print ?(trailing=(fun _ -> ())) pr_sep pr_el f a = +let print ?(trailing = fun _ -> ()) pr_sep pr_el f a = let rec aux i f = - if i < length a then + if i < length a then ( let () = pr_el i f (get a i) in - if i < length a - 1 then - let () = pr_sep f in aux (succ i) f - else if i > 0 then trailing f - in aux 0 f + if i < length a - 1 then ( + let () = pr_sep f in + aux (succ i) f + ) else if i > 0 then + trailing f + ) + in + aux 0 f diff --git a/core/dataStructures/list_util.ml b/core/dataStructures/list_util.ml index 91a54ca391..4e367a0938 100644 --- a/core/dataStructures/list_util.ml +++ b/core/dataStructures/list_util.ml @@ -9,12 +9,13 @@ let remove_suffix_after_last_occurrence p list = let rec aux list buffer output = match list with - | h::t when p h -> aux t [] ((h::buffer)::output) - | h::t -> aux t (h::buffer) output - | [] -> output in + | h :: t when p h -> aux t [] ((h :: buffer) :: output) + | h :: t -> aux t (h :: buffer) output + | [] -> output + in let rev_concat list = - List.fold_left - (List.fold_left (fun output a -> a::output)) [] list in + List.fold_left (List.fold_left (fun output a -> a :: output)) [] list + in rev_concat (aux list [] []) let rec last = function @@ -24,12 +25,12 @@ let rec last = function let rec aux_pop_last acc = function | [] -> failwith "list_pop_last" - | [ x ] -> (List.rev acc,x) - | h :: t -> aux_pop_last (h::acc) t + | [ x ] -> List.rev acc, x + | h :: t -> aux_pop_last (h :: acc) t let pop_last l = aux_pop_last [] l -let cons_option h t = +let cons_option h t = match h with | Some x -> x :: t | None -> t @@ -37,20 +38,30 @@ let cons_option h t = let rec smart_filter f = function | t :: q as l -> let q' = smart_filter f q in - if f t then if q == q' then l else t::q' else q' + if f t then + if q == q' then + l + else + t :: q' + else + q' | l -> l let rec smart_map f = function | t :: q as l -> let q' = smart_map f q in let t' = f t in - if t' == t && q' == q then l else t' :: q' + if t' == t && q' == q then + l + else + t' :: q' | l -> l let rev_mapi f l = let rec aux_mapi i acc = function | [] -> acc - | h :: q -> aux_mapi (pred i) (f i h :: acc) q in + | h :: q -> aux_mapi (pred i) (f i h :: acc) q + in aux_mapi (List.length l - 1) [] l let rec map_option f = function @@ -60,69 +71,89 @@ let rec map_option f = function let exists_uniq f l = let rec second = function | [] -> true - | h :: t -> not (f h) && second t in + | h :: t -> (not (f h)) && second t + in let rec first = function | [] -> false - | h :: t -> if f h then second t else first t in + | h :: t -> + if f h then + second t + else + first t + in first l let merge_uniq cmp l1 l2 = let rec aux_merge_uniq l1 l2 k = - match l1,l2 with + match l1, l2 with | [], _ -> k l2 | _, [] -> k l1 - | h1::t1, h2::t2 -> + | h1 :: t1, h2 :: t2 -> let c = cmp h1 h2 in if c < 0 then - aux_merge_uniq t1 l2 (fun o -> if o == t1 then k l1 else k (h1::o)) - else if c > 0 then - aux_merge_uniq l1 t2 (fun o -> if o == t2 then k l2 else k (h2::o)) - else - aux_merge_uniq t1 t2 (fun o -> if o == t1 then k l1 else k (h1::o)) in + aux_merge_uniq t1 l2 (fun o -> + if o == t1 then + k l1 + else + k (h1 :: o)) + else if c > 0 then + aux_merge_uniq l1 t2 (fun o -> + if o == t2 then + k l2 + else + k (h2 :: o)) + else + aux_merge_uniq t1 t2 (fun o -> + if o == t1 then + k l1 + else + k (h1 :: o)) + in aux_merge_uniq l1 l2 (fun x -> x) let rec rev_map_append f l acc = match l with | [] -> acc - | h :: t -> rev_map_append f t (f h::acc) + | h :: t -> rev_map_append f t (f h :: acc) -let rec map_flatten f = function (* list_bind *) +let rec map_flatten f = function + (* list_bind *) | [] -> [] | h :: t -> List.append (f h) (map_flatten f t) -(* List.rev - (List.fold_left (fun x y -> List.rev_append y x) [] (List.rev_map f l)) - *) +(* List.rev + (List.fold_left (fun x y -> List.rev_append y x) [] (List.rev_map f l)) +*) let remove_consecutive_double l = let rec aux last l acc = - match - l - with h::q when last=h -> aux last q acc - | h::q -> aux h q (h::acc) - | [] -> List.rev acc + match l with + | h :: q when last = h -> aux last q acc + | h :: q -> aux h q (h :: acc) + | [] -> List.rev acc in match l with - [] -> [] - | h::q -> aux h q [h] + | [] -> [] + | h :: q -> aux h q [ h ] let rec fold_right_map f l x = match l with - | [] -> ([],x) + | [] -> [], x | h :: t -> - let (t',x') = fold_right_map f t x in - let (h',x'') = f h x' in ( h'::t',x'') + let t', x' = fold_right_map f t x in + let h', x'' = f h x' in + h' :: t', x'' let rec fold_left2 f x l1 l2 = match l1, l2 with | [], [] -> x | [], _ :: _ | _ :: _, [] -> raise (Invalid_argument "list_fold_left2") - | h1::t1, h2::t2 -> fold_left2 f (f x h1 h2) t1 t2 + | h1 :: t1, h2 :: t2 -> fold_left2 f (f x h1 h2) t1 t2 let random rs l = List.nth l (Random.State.int rs (List.length l)) -let find_option (p : ('a -> bool)) (l : 'a list) : 'a option = +let find_option (p : 'a -> bool) (l : 'a list) : 'a option = try Some (List.find p l) with Not_found -> None module Infix = struct - let ($$) = cons_option + let ( $$ ) = cons_option end diff --git a/core/dataStructures/list_util.mli b/core/dataStructures/list_util.mli index 81417aeaa8..e182487925 100644 --- a/core/dataStructures/list_util.mli +++ b/core/dataStructures/list_util.mli @@ -10,32 +10,28 @@ val last : 'a list -> 'a val pop_last : 'a list -> 'a list * 'a val cons_option : 'a option -> 'a list -> 'a list val exists_uniq : ('a -> bool) -> 'a list -> bool - val find_option : ('a -> bool) -> 'a list -> 'a option - val rev_map_append : ('a -> 'b) -> 'a list -> 'b list -> 'b list val map_flatten : ('a -> 'b list) -> 'a list -> 'b list -val fold_right_map : - ('a -> 'b -> 'c * 'b) -> 'a list -> 'b -> 'c list * 'b -val fold_left2 : - ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a +val fold_right_map : ('a -> 'b -> 'c * 'b) -> 'a list -> 'b -> 'c list * 'b +val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list val map_option : ('a -> 'b option) -> 'a list -> 'b list val random : Random.State.t -> 'a list -> 'a +val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Set union of 2 sorted list When l1 is included in l2: [merge_uniq l1 l2 == merge_uniq l2 l1 == l2] *) -val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list -(** not tail rec but don't allocate if unecessary *) val smart_filter : ('a -> bool) -> 'a list -> 'a list -val smart_map : ('a -> 'a) -> 'a list -> 'a list +(** not tail rec but don't allocate if unecessary *) +val smart_map : ('a -> 'a) -> 'a list -> 'a list val remove_suffix_after_last_occurrence : ('a -> bool) -> 'a list -> 'a list val remove_consecutive_double : 'a list -> 'a list module Infix : sig - val ($$) : 'a option -> 'a list -> 'a list + val ( $$ ) : 'a option -> 'a list -> 'a list (** [cons_option] *) end diff --git a/core/dataStructures/loc.ml b/core/dataStructures/loc.ml new file mode 100644 index 0000000000..f31ed9407f --- /dev/null +++ b/core/dataStructures/loc.ml @@ -0,0 +1,186 @@ +(******************************************************************************) +(* _ __ * The Kappa Language *) +(* | |/ / * Copyright 2010-2020 CNRS - Harvard Medical School - INRIA - IRIF *) +(* | ' / *********************************************************************) +(* | . \ * This file is distributed under the terms of the *) +(* |_|\_\ * GNU Lesser General Public License Version 3 *) +(******************************************************************************) + +type position = { chr: int; line: int } +type t = { file: string; from_position: position; to_position: position } +type 'a annoted = 'a * t + +let v (v, _) = v +let get_annot (_, annot) = annot +let copy_annot (_, loc) a = a, loc +let map_annot f (a, loc) = f a, loc + +let of_pos start_location end_location = + let () = + assert (start_location.Lexing.pos_fname = end_location.Lexing.pos_fname) + in + { + file = start_location.Lexing.pos_fname; + from_position = + { + chr = start_location.Lexing.pos_cnum - start_location.Lexing.pos_bol; + line = start_location.Lexing.pos_lnum; + }; + to_position = + { + chr = end_location.Lexing.pos_cnum - end_location.Lexing.pos_bol; + line = end_location.Lexing.pos_lnum; + }; + } + +let dummy_position = + { + chr = Lexing.dummy_pos.Lexing.pos_cnum - Lexing.dummy_pos.Lexing.pos_bol; + line = Lexing.dummy_pos.Lexing.pos_lnum; + } + +let dummy = + { + file = Lexing.dummy_pos.Lexing.pos_fname; + from_position = dummy_position; + to_position = dummy_position; + } + +let annot_with_dummy x = x, dummy + +let is_dummy loc = + loc.file = Lexing.dummy_pos.Lexing.pos_fname + && loc.from_position = dummy_position + && loc.to_position = dummy_position + +let is_annoted_with_dummy (_, loc) = is_dummy loc + +let print f loc = + let pr_f f = + if loc.file <> "" then Format.fprintf f "File \"%s\", " loc.file + in + let pr_l f = + if loc.from_position.line = loc.to_position.line then + Format.fprintf f "line %i" loc.from_position.line + else + Format.fprintf f "lines %i-%i" loc.from_position.line loc.to_position.line + in + Format.fprintf f "%t%t, characters %i-%i:" pr_f pr_l loc.from_position.chr + loc.to_position.chr + +let to_string loc = Format.asprintf "@[%a@]" print loc +let print_annoted pr f (x, l) = Format.fprintf f "%a@ %a" print l pr x + +let read_position p lb = + match Yojson.Basic.from_lexbuf ~stream:true p lb with + | `Assoc [ ("line", `Int line); ("chr", `Int chr) ] + | `Assoc [ ("chr", `Int chr); ("line", `Int line) ] -> + { line; chr } + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid position", x)) + +let write_position ob { line; chr } = + Yojson.write_assoc ob [ "line", `Int line; "chr", `Int chr ] + +let to_compact_yojson decls loc = + if is_dummy loc then + `Null + else + `Assoc + ((if loc.from_position.line <> loc.to_position.line then + fun l -> + ("eline", `Int loc.to_position.line) :: l + else + fun l -> + l) + [ + ( "file", + match + Option_util.bind (Mods.StringMap.find_option loc.file) decls + with + | Some i -> `Int i + | None -> `String loc.file ); + "bline", `Int loc.from_position.line; + "bchr", `Int loc.from_position.chr; + "echr", `Int loc.to_position.chr; + ]) + +let of_compact_yojson ?(filenames = [||]) = function + | `Null -> dummy + | `Assoc l as x when List.length l <= 5 -> + (try + let file = + match List.assoc "file" l with + | `String x -> x + | `Int i -> filenames.(i) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location", x)) + in + let of_line = + match List.assoc "bline" l with + | `Int i -> i + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location", x)) + in + let of_chr = + match List.assoc "bchr" l with + | `Int i -> i + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location", x)) + in + let to_chr = + match List.assoc "echr" l with + | `Int i -> i + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location", x)) + in + let to_line = + match Yojson.Basic.Util.member "eline" x with + | `Null -> of_line + | `Int i -> i + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location", x)) + in + { + file; + from_position = { line = of_line; chr = of_chr }; + to_position = { line = to_line; chr = to_chr }; + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Incorrect AST arrow_notation", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location", x)) + +let yojson_of_annoted ?filenames f (x, l) = + let jp = to_compact_yojson filenames l in + if jp = `Null then + `Assoc [ "val", f x ] + else + `Assoc [ "val", f x; "loc", jp ] + +let annoted_of_yojson ?filenames f = function + | `Assoc [ ("val", x); ("loc", l) ] | `Assoc [ ("loc", l); ("val", x) ] -> + f x, of_compact_yojson ?filenames l + | `Assoc [ ("val", x) ] -> f x, dummy + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location", x)) + +let write_range ob f = Yojson.Basic.to_buffer ob (to_compact_yojson None f) + +let string_of_range ?(len = 1024) x = + let ob = Buffer.create len in + write_range ob x; + Buffer.contents ob + +let read_range p lb = + of_compact_yojson ?filenames:None (Yojson.Basic.from_lexbuf ~stream:true p lb) + +let range_of_string s = + read_range (Yojson.Safe.init_lexer ()) (Lexing.from_string s) + +let is_included_in file { line; chr } range = + file = range.file + && line >= range.from_position.line + && line <= range.to_position.line + && (line <> range.from_position.line || chr >= range.from_position.chr) + && (line <> range.to_position.line || chr <= range.to_position.chr) + +let merge b e = + let () = assert (b.file = e.file) in + { + file = b.file; + from_position = b.from_position; + to_position = e.to_position; + } diff --git a/core/dataStructures/loc.mli b/core/dataStructures/loc.mli new file mode 100644 index 0000000000..c147c04698 --- /dev/null +++ b/core/dataStructures/loc.mli @@ -0,0 +1,75 @@ +(******************************************************************************) +(* _ __ * The Kappa Language *) +(* | |/ / * Copyright 2010-2020 CNRS - Harvard Medical School - INRIA - IRIF *) +(* | ' / *********************************************************************) +(* | . \ * This file is distributed under the terms of the *) +(* |_|\_\ * GNU Lesser General Public License Version 3 *) +(******************************************************************************) + +(** Module for type Loc.t annotating structured data with the line range + * in a file which was used to define it *) + +type position = { chr: int; line: int } +type t = { file: string; from_position: position; to_position: position } +type 'a annoted = 'a * t + +val v : 'a annoted -> 'a +(** Extract value from Loc.annoted *) + +val get_annot : 'a annoted -> t +(** Extract annotation from Loc.annoted *) + +val copy_annot : 'b annoted -> 'a -> 'a annoted +(** Create annoted variable with same annotation as existing variable *) + +val map_annot : ('a -> 'b) -> 'a annoted -> 'b annoted +(** Apply operation on variable and keep annotation *) + +val of_pos : Lexing.position -> Lexing.position -> t +val dummy : t +val annot_with_dummy : 'a -> 'a annoted +val is_annoted_with_dummy : 'a annoted -> bool + +val merge : t -> t -> t +(** [merge b e] creates the range from beginning of [b] to the end of [e] + (filename must match) *) + +val is_included_in : string -> position -> t -> bool + +(** {2 I/O} *) + +val to_string : t -> string +val print : Format.formatter -> t -> unit + +val print_annoted : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a annoted -> unit + +val annoted_of_yojson : + ?filenames:string array -> + (Yojson.Basic.t -> 'a) -> + Yojson.Basic.t -> + 'a annoted + +val yojson_of_annoted : + ?filenames:int Mods.StringMap.t -> + ('a -> Yojson.Basic.t) -> + 'a annoted -> + Yojson.Basic.t + +val write_position : Buffer.t -> position -> unit +val read_position : Yojson.Safe.lexer_state -> Lexing.lexbuf -> position + +val write_range : Buffer.t -> t -> unit +(** Output a JSON value of type {!t}. *) + +val string_of_range : ?len:int -> t -> string +(** Serialize a value of type {!t} into a JSON string. + @param len specifies the initial length + of the buffer used internally. + Default: 1024. *) + +val read_range : Yojson.Safe.lexer_state -> Lexing.lexbuf -> t +(** Input JSON data of type {!t}. *) + +val range_of_string : string -> t +(** Deserialize JSON data of type {!t}. *) diff --git a/core/dataStructures/locality.ml b/core/dataStructures/locality.ml deleted file mode 100644 index 7213f572d9..0000000000 --- a/core/dataStructures/locality.ml +++ /dev/null @@ -1,164 +0,0 @@ -(******************************************************************************) -(* _ __ * The Kappa Language *) -(* | |/ / * Copyright 2010-2020 CNRS - Harvard Medical School - INRIA - IRIF *) -(* | ' / *********************************************************************) -(* | . \ * This file is distributed under the terms of the *) -(* |_|\_\ * GNU Lesser General Public License Version 3 *) -(******************************************************************************) - -type position = { chr: int; line: int } -type range = { file : string ; - from_position: position; - to_position: position } - -type t = range - -type 'a annot = 'a * t -type 'a maybe = ?pos:t -> 'a - -let of_pos start_location end_location = - let () = assert - (start_location.Lexing.pos_fname = end_location.Lexing.pos_fname) in - { - file = start_location.Lexing.pos_fname; - from_position = { - chr = start_location.Lexing.pos_cnum - start_location.Lexing.pos_bol; - line = start_location.Lexing.pos_lnum; - }; - to_position = { - chr = end_location.Lexing.pos_cnum - end_location.Lexing.pos_bol; - line = end_location.Lexing.pos_lnum; - }; - } - -let dummy_position = { - chr = Lexing.dummy_pos.Lexing.pos_cnum - Lexing.dummy_pos.Lexing.pos_bol; - line = Lexing.dummy_pos.Lexing.pos_lnum; -} - -let dummy = { - file = Lexing.dummy_pos.Lexing.pos_fname; - from_position = dummy_position; - to_position = dummy_position; -} - -let dummy_annot x = (x, dummy) -let is_dummy loc = - loc.file = Lexing.dummy_pos.Lexing.pos_fname && - loc.from_position = dummy_position && - loc.to_position = dummy_position -let has_dummy_annot (_,loc) = is_dummy loc - -let print f loc = - let pr_f f = - if loc.file <> "" then - Format.fprintf f "File \"%s\", " loc.file in - let pr_l f = - if loc.from_position.line = loc.to_position.line - then Format.fprintf f "line %i" loc.from_position.line - else Format.fprintf f "lines %i-%i" - loc.from_position.line loc.to_position.line - in - Format.fprintf f "%t%t, characters %i-%i:" pr_f pr_l - loc.from_position.chr loc.to_position.chr - -let to_string loc = Format.asprintf "@[%a@]" print loc - -let print_annot pr f (x,l) = - Format.fprintf f "%a@ %a" print l pr x - -let read_position p lb = - match Yojson.Basic.from_lexbuf ~stream:true p lb with - | `Assoc [("line",`Int line);("chr", `Int chr)] - | `Assoc [("chr", `Int chr);("line",`Int line)] -> { line; chr } - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid position",x)) - -let write_position ob { line; chr } = - Yojson.write_assoc ob [("line",`Int line);("chr", `Int chr)] - -let to_compact_yojson decls loc = - if is_dummy loc then `Null - else `Assoc - ((if loc.from_position.line <> loc.to_position.line - then fun l -> ("eline", `Int loc.to_position.line) :: l - else fun l -> l) - [ - ("file", - match Option_util.bind - (Mods.StringMap.find_option loc.file) decls with - | Some i -> `Int i - | None -> `String loc.file); - "bline", `Int loc.from_position.line; - "bchr", `Int loc.from_position.chr; - "echr", `Int loc.to_position.chr; - ]) - -let of_compact_yojson ?(filenames=[||]) = function - | `Null -> dummy - | `Assoc l as x when List.length l <= 5 -> - begin - try - let file = match List.assoc "file" l with - | `String x -> x - | `Int i -> filenames.(i) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location",x)) in - let of_line = match List.assoc "bline" l with - | `Int i -> i - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location",x)) in - let of_chr = match List.assoc "bchr" l with - | `Int i -> i - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location",x)) in - let to_chr = match List.assoc "echr" l with - | `Int i -> i - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location",x)) in - let to_line = match Yojson.Basic.Util.member "eline" x with - | `Null -> of_line - | `Int i -> i - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location",x)) in - { - file; - from_position = { line = of_line; chr = of_chr }; - to_position = { line = to_line; chr = to_chr }; - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Incorrect AST arrow_notation",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location",x)) - -let annot_to_yojson ?filenames f (x,l) = - let jp = to_compact_yojson filenames l in - if jp = `Null then `Assoc [ "val", f x ] else `Assoc [ "val", f x; "loc", jp ] - -let annot_of_yojson ?filenames f = function - | `Assoc [ "val", x; "loc", l ] | `Assoc [ "loc", l; "val", x ] -> - (f x, of_compact_yojson ?filenames l) - | `Assoc [ "val", x ] -> (f x, dummy) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid location",x)) - -let write_range ob f = Yojson.Basic.to_buffer ob (to_compact_yojson None f) - -let string_of_range ?(len = 1024) x = - let ob = Buffer.create len in - write_range ob x; - Buffer.contents ob - -let read_range p lb = - of_compact_yojson - ?filenames:None (Yojson.Basic.from_lexbuf ~stream:true p lb) - -let range_of_string s = - read_range (Yojson.Safe.init_lexer ()) (Lexing.from_string s) - -let is_included_in file { line; chr } range = - file = range.file && - line >= range.from_position.line && - line <= range.to_position.line && - (line <> range.from_position.line || chr >= range.from_position.chr) && - (line <> range.to_position.line || chr <= range.to_position.chr) - -let merge b e = - let () = assert (b.file = e.file) in { - file = b.file; - from_position = b.from_position; - to_position = e.to_position; - } diff --git a/core/dataStructures/locality.mli b/core/dataStructures/locality.mli deleted file mode 100644 index 9aeeb4fcdc..0000000000 --- a/core/dataStructures/locality.mli +++ /dev/null @@ -1,63 +0,0 @@ -(******************************************************************************) -(* _ __ * The Kappa Language *) -(* | |/ / * Copyright 2010-2020 CNRS - Harvard Medical School - INRIA - IRIF *) -(* | ' / *********************************************************************) -(* | . \ * This file is distributed under the terms of the *) -(* |_|\_\ * GNU Lesser General Public License Version 3 *) -(******************************************************************************) - -type position = { chr: int; line: int } -type range = { - file : string ; - from_position: position; - to_position: position -} - -type t = range -type 'a annot = 'a * t -type 'a maybe = ?pos:t -> 'a - -val of_pos : Lexing.position -> Lexing.position -> t -val dummy : t - -val dummy_annot : 'a -> 'a annot -val has_dummy_annot : 'a annot -> bool - -val merge : range -> range -> range -(** [merge b e] creates the range from beginning of [b] to the end of [e] - (filename must match) *) - -val is_included_in : string -> position -> range -> bool - -val to_string: t -> string -val print : Format.formatter -> t -> unit -val print_annot : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a annot -> unit - -val annot_of_yojson : - ?filenames : string array -> - (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a annot -val annot_to_yojson : - ?filenames : int Mods.StringMap.t -> - ('a -> Yojson.Basic.t) -> 'a annot -> Yojson.Basic.t - -val write_position : Buffer.t -> position -> unit - -val read_position : - Yojson.Safe.lexer_state -> Lexing.lexbuf -> position - -val write_range : Buffer.t -> t -> unit - (** Output a JSON value of type {!t}. *) - -val string_of_range : ?len:int -> t -> string - (** Serialize a value of type {!t} into a JSON string. - @param len specifies the initial length - of the buffer used internally. - Default: 1024. *) - -val read_range : - Yojson.Safe.lexer_state -> Lexing.lexbuf -> t - (** Input JSON data of type {!t}. *) - -val range_of_string : string -> t - (** Deserialize JSON data of type {!t}. *) diff --git a/core/dataStructures/mods.ml b/core/dataStructures/mods.ml index 63451f5169..2e8672b166 100644 --- a/core/dataStructures/mods.ml +++ b/core/dataStructures/mods.ml @@ -6,46 +6,70 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -let int_compare (x: int) y = Stdlib.compare x y -let int_pair_compare (p,q) (p',q') = +let int_compare (x : int) y = Stdlib.compare x y + +let int_pair_compare (p, q) (p', q') = let o = int_compare p p' in - if o = 0 then int_compare q q' else o -let string_pair_compare (p,q) (p',q') = + if o = 0 then + int_compare q q' + else + o + +let string_pair_compare (p, q) (p', q') = let o = String.compare p p' in - if o=0 then String.compare q q' else o + if o = 0 then + String.compare q q' + else + o + +let pair_equal eqa eqb (xa, xb) (ya, yb) = eqa xa ya && eqb xb yb -let pair_equal eqa eqb (xa,xb) (ya,yb) = eqa xa ya && eqb xb yb +module StringSetMap = SetMap.Make (struct + type t = string + + let compare = String.compare + let print = Format.pp_print_string +end) -module StringSetMap = - SetMap.Make (struct type t = string - let compare = String.compare - let print = Format.pp_print_string end) module StringSet = StringSetMap.Set module StringMap = StringSetMap.Map -module String2SetMap = - SetMap.Make (struct type t = string*string - let compare = string_pair_compare - let print f (a,b) = - Format.fprintf f "(%s, %s)" a b end) + +module String2SetMap = SetMap.Make (struct + type t = string * string + + let compare = string_pair_compare + let print f (a, b) = Format.fprintf f "(%s, %s)" a b +end) + module String2Map = String2SetMap.Map -module IntSetMap = - SetMap.Make (struct type t = int - let compare = int_compare - let print = Format.pp_print_int end) + +module IntSetMap = SetMap.Make (struct + type t = int + + let compare = int_compare + let print = Format.pp_print_int +end) + module IntSet = IntSetMap.Set module IntMap = IntSetMap.Map -module Int2SetMap = - SetMap.Make (struct type t = int*int - let compare = int_pair_compare - let print f (a,b) = - Format.fprintf f "(%i, %i)" a b end) + +module Int2SetMap = SetMap.Make (struct + type t = int * int + + let compare = int_pair_compare + let print f (a, b) = Format.fprintf f "(%i, %i)" a b +end) + module Int2Set = Int2SetMap.Set module Int2Map = Int2SetMap.Map -module CharSetMap = - SetMap.Make (struct type t = char - let compare = compare - let print = Format.pp_print_char end) + +module CharSetMap = SetMap.Make (struct + type t = char + + let compare = compare + let print = Format.pp_print_char +end) + module CharSet = CharSetMap.Set module CharMap = CharSetMap.Map - -module DynArray = DynamicArray.DynArray(LargeArray) +module DynArray = DynamicArray.DynArray (LargeArray) diff --git a/core/dataStructures/mods.mli b/core/dataStructures/mods.mli index 3ed48a01c7..acaf68f509 100644 --- a/core/dataStructures/mods.mli +++ b/core/dataStructures/mods.mli @@ -9,7 +9,7 @@ (** Datastructures' functors instantiation *) val int_compare : int -> int -> int -val int_pair_compare : (int*int) -> (int*int) -> int +val int_pair_compare : int * int -> int * int -> int val pair_equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> 'a * 'b -> 'a * 'b -> bool @@ -17,20 +17,15 @@ val pair_equal : module StringSetMap : SetMap.S with type elt = string module StringSet = StringSetMap.Set module StringMap = StringSetMap.Map - -module String2SetMap : SetMap.S with type elt = string*string +module String2SetMap : SetMap.S with type elt = string * string module String2Map = String2SetMap.Map - module IntSetMap : SetMap.S with type elt = int module IntSet = IntSetMap.Set module IntMap = IntSetMap.Map - -module Int2SetMap : SetMap.S with type elt = int*int +module Int2SetMap : SetMap.S with type elt = int * int module Int2Set = Int2SetMap.Set module Int2Map = Int2SetMap.Map - module CharSetMap : SetMap.S with type elt = char module CharSet = CharSetMap.Set module CharMap = CharSetMap.Map - module DynArray : GenArray.GenArray diff --git a/core/dataStructures/namedDecls.ml b/core/dataStructures/namedDecls.ml index 57f4108c89..69643f8b28 100644 --- a/core/dataStructures/namedDecls.ml +++ b/core/dataStructures/namedDecls.ml @@ -6,74 +6,87 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type 'a t = - { decls : (string *'a) array; - finder : int Mods.StringMap.t } +type 'a t = { decls: (string * 'a) array; finder: int Mods.StringMap.t } let name_map_of_array ?forbidden a = - let bad = match forbidden with + let bad = + match forbidden with | None -> fun _ -> false - | Some s -> fun x -> Mods.StringSet.mem x s in + | Some s -> fun x -> Mods.StringSet.mem x s + in Tools.array_fold_lefti - (fun i map ((x,pos),_) -> - if bad x || Mods.StringMap.mem x map then - raise (ExceptionDefn.Malformed_Decl - ("Label '"^x^"' already defined", pos)) - else Mods.StringMap.add x i map) + (fun i map ((x, pos), _) -> + if bad x || Mods.StringMap.mem x map then + raise + (ExceptionDefn.Malformed_Decl + ("Label '" ^ x ^ "' already defined", pos)) + else + Mods.StringMap.add x i map) Mods.StringMap.empty a -let create ?forbidden a = { - decls = Array.map (fun ((x,_),y) -> (x,y)) a; - finder = name_map_of_array ?forbidden a -} +let create ?forbidden a = + { + decls = Array.map (fun ((x, _), y) -> x, y) a; + finder = name_map_of_array ?forbidden a; + } -let size nd = Array.length nd.decls +let create_from_list ?forbidden l = create ?forbidden (Array.of_list l) + +(* TODO see if we should keep this *) +let create_no_loc ?forbidden a = + Array.map (fun (x, y) -> (x, Loc.dummy), y) a |> create ?forbidden +let size nd = Array.length nd.decls let elt_name nd i = fst nd.decls.(i) -let elt_id ?(kind="element") nd (s,pos) = +let elt_id ?(kind = "element") nd (s, pos) = match Mods.StringMap.find_option s nd.finder with | Some x -> x | None -> - raise (ExceptionDefn.Malformed_Decl - (Format.asprintf "\"%s\" is not a declared %s." s kind,pos)) + raise + (ExceptionDefn.Malformed_Decl + (Format.asprintf "\"%s\" is not a declared %s." s kind, pos)) let print ~sep pp f nd = - Pp.array sep (fun i f (n,el) -> pp i n f el) f nd.decls + Pp.array sep (fun i f (n, el) -> pp i n f el) f nd.decls + let debug_print pr f nd = - print ~sep:Pp.space (fun i n f el -> - Format.fprintf f "@[%i>%s: @[<2>%a@]@]" - i n pr el) + print ~sep:Pp.space + (fun i n f el -> Format.fprintf f "@[%i>%s: @[<2>%a@]@]" i n pr el) f nd let fold f acc nd = - Tools.array_fold_lefti - (fun i acc (na,x) -> f i na acc x) - acc nd.decls + Tools.array_fold_lefti (fun i acc (na, x) -> f i na acc x) acc nd.decls + +let map f nd = + { decls = Array.map (fun (s, v) -> s, f s v) nd.decls; finder = nd.finder } + +let mapi f nd = + { + decls = Array.mapi (fun i (s, v) -> s, f i s v) nd.decls; + finder = nd.finder; + } -let mapi f nd = { - decls = Array.mapi (fun i (s,v) -> (s,f i s v)) nd.decls; - finder = nd.finder; -} +let elt_val nd i = snd nd.decls.(i) let to_json aux nd = `List (Array.fold_right - (fun (x,a) acc -> `Assoc ([("name",`String x);("decl",aux a)]):: acc) - nd.decls - []) + (fun (x, a) acc -> `Assoc [ "name", `String x; "decl", aux a ] :: acc) + nd.decls []) let of_json aux = function | `List l -> let decls = Tools.array_map_of_list (function - | (`Assoc ([("name",`String x);("decl",a)]) | - `Assoc ([("decl",a);("name",`String x)])) -> - (Locality.dummy_annot x, aux a) + | `Assoc [ ("name", `String x); ("decl", a) ] + | `Assoc [ ("decl", a); ("name", `String x) ] -> + Loc.annot_with_dummy x, aux a | x -> - raise (Yojson.Basic.Util.Type_error - ("Not a valid NamedDecl element",x))) - l in + raise + (Yojson.Basic.Util.Type_error ("Not a valid NamedDecl element", x))) + l + in create decls - | x -> raise (Yojson.Basic.Util.Type_error ("Not a valid NamedDecl",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a valid NamedDecl", x)) diff --git a/core/dataStructures/namedDecls.mli b/core/dataStructures/namedDecls.mli index 01cf27e6fe..b6682431a3 100644 --- a/core/dataStructures/namedDecls.mli +++ b/core/dataStructures/namedDecls.mli @@ -8,27 +8,45 @@ (** Stores a bunch of stuff the user gave a name to *) -type 'a t = private - { decls : (string *'a) array; - (** the name of the stuff * the stuff *) - finder : int Mods.StringMap.t; - (** [fst (fst d.decls.(StringMap.find s d.finder))] MUST be equal to [s] *) - } +type 'a t = private { + decls: (string * 'a) array; (** the name of the stuff * the stuff *) + finder: int Mods.StringMap.t; + (** [fst (fst d.decls.(StringMap.find s d.finder))] MUST be equal to [s] *) +} val create : - ?forbidden:Mods.StringSet.t -> (string Locality.annot *'a) array -> 'a t + ?forbidden:Mods.StringSet.t -> (string Loc.annoted * 'a) array -> 'a t +(** [create ~forbidden string_val_assoc] evaluates to a namedDecls.t from the string-to-variable associations [string_val_assoc] except from strings in [forbidden]. Loc info is not kept. *) +(* TODO should we remove Loc info *) + +val create_from_list : + ?forbidden:Mods.StringSet.t -> (string Loc.annoted * 'a) list -> 'a t + +(* TODO see if better name, what implementation is to be kept *) +val create_no_loc : ?forbidden:Mods.StringSet.t -> (string * 'a) array -> 'a t +(** [create_no_loc] behaves the same as [create], but without the need to provide the Loc info that will be trashed *) + val size : 'a t -> int + val elt_name : 'a t -> int -> string -val elt_id : ?kind:string -> 'a t -> string Locality.annot -> int +(** [elt_name nd i] evaluates to the name declaration of id [i] in [nd], or raises an exception if it doesn't exist *) -val fold : (int -> string -> 'a -> 'b -> 'a) -> 'a -> 'b t -> 'a +val elt_id : ?kind:string -> 'a t -> string Loc.annoted -> int +(** [elt_id ~kind nd (s, pos)] evaluates to the data matching declaration [s] in [nd], or if it doesn't exist, throw and exception with info about [kind] and [pos] *) + +val elt_val : 'a t -> int -> 'a +(** Access data by id *) +val fold : (int -> string -> 'a -> 'b -> 'a) -> 'a -> 'b t -> 'a +val map : (string -> 'a -> 'b) -> 'a t -> 'b t val mapi : (int -> string -> 'a -> 'b) -> 'a t -> 'b t val print : sep:(Format.formatter -> unit) -> (int -> string -> Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a t -> unit + Format.formatter -> + 'a t -> + unit val debug_print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit diff --git a/core/dataStructures/nbr.ml b/core/dataStructures/nbr.ml index 03d4a80edd..3c086633ff 100644 --- a/core/dataStructures/nbr.ml +++ b/core/dataStructures/nbr.ml @@ -9,104 +9,101 @@ type t = F of float | I of int | I64 of Int64.t let cast_bin_op ~op_f ?op_i ?op_i64 x y = - match (x,y) with - | (F x, F y) -> F (op_f x y) - | (I x, F y) -> F (op_f (float_of_int x) y) - | (F x, I y) -> F (op_f x (float_of_int y)) - | (I x, I y) -> - begin - match op_i with - | None -> F (op_f (float_of_int x) (float_of_int y)) - | Some op_i -> I (op_i x y) - end - | (I x, I64 y) -> - begin - match op_i64 with - | None -> F (op_f (float_of_int x) (Int64.to_float y)) - | Some op_i64 -> I64 (op_i64 (Int64.of_int x) y) - end - | (I64 x, I y) -> - begin - match op_i64 with - | None -> F (op_f (Int64.to_float x) (float_of_int y)) - | Some op_i64 -> I64 (op_i64 x (Int64.of_int y)) - end - | (I64 x, I64 y) -> - begin - match op_i64 with - | None -> F (op_f (Int64.to_float x) (Int64.to_float y)) - | Some op_i64 -> I64 (op_i64 x y) - end - | (F x, I64 y) -> F (op_f x (Int64.to_float y)) - | (I64 x, F y) -> F (op_f (Int64.to_float x) y) + match x, y with + | F x, F y -> F (op_f x y) + | I x, F y -> F (op_f (float_of_int x) y) + | F x, I y -> F (op_f x (float_of_int y)) + | I x, I y -> + (match op_i with + | None -> F (op_f (float_of_int x) (float_of_int y)) + | Some op_i -> I (op_i x y)) + | I x, I64 y -> + (match op_i64 with + | None -> F (op_f (float_of_int x) (Int64.to_float y)) + | Some op_i64 -> I64 (op_i64 (Int64.of_int x) y)) + | I64 x, I y -> + (match op_i64 with + | None -> F (op_f (Int64.to_float x) (float_of_int y)) + | Some op_i64 -> I64 (op_i64 x (Int64.of_int y))) + | I64 x, I64 y -> + (match op_i64 with + | None -> F (op_f (Int64.to_float x) (Int64.to_float y)) + | Some op_i64 -> I64 (op_i64 x y)) + | F x, I64 y -> F (op_f x (Int64.to_float y)) + | I64 x, F y -> F (op_f (Int64.to_float x) y) let cast_un_op ?op_f ?op_i ?op_i64 x = match x with | F x -> - begin - match op_f with - | Some op_f -> F (op_f x) - | None -> match op_i with None -> invalid_arg "cast_un" - | Some op_i -> I (op_i (int_of_float x)) - end + (match op_f with + | Some op_f -> F (op_f x) + | None -> + (match op_i with + | None -> invalid_arg "cast_un" + | Some op_i -> I (op_i (int_of_float x)))) | I64 x -> - begin - match op_i64 with - | Some op_i64 -> I64 (op_i64 x) - | None -> match op_f with None -> invalid_arg "cast_un_op" - | Some op_f -> F (op_f (Int64.to_float x)) - end + (match op_i64 with + | Some op_i64 -> I64 (op_i64 x) + | None -> + (match op_f with + | None -> invalid_arg "cast_un_op" + | Some op_f -> F (op_f (Int64.to_float x)))) | I x -> - match op_i with + (match op_i with | Some op_i -> I (op_i x) - | None -> match op_f with None -> invalid_arg "cast_un_op" - | Some op_f -> F (op_f (float_of_int x)) + | None -> + (match op_f with + | None -> invalid_arg "cast_un_op" + | Some op_f -> F (op_f (float_of_int x)))) let compare n1 n2 = - match n1,n2 with - | (F x, F y) -> Stdlib.compare x y - | (I x, I y) -> Stdlib.compare x y - | (F x, I y) -> Stdlib.compare x (float_of_int y) - | (I x, F y) -> Stdlib.compare (float_of_int x) y - | (I x, I64 y) -> Stdlib.compare (Int64.of_int x) y - | (I64 x, I64 y) -> Stdlib.compare x y - | (I64 x, I y) -> Stdlib.compare x (Int64.of_int y) - | (F x, I64 y) -> Stdlib.compare x (Int64.to_float y) - | (I64 x, F y) -> Stdlib.compare (Int64.to_float x) y + match n1, n2 with + | F x, F y -> Stdlib.compare x y + | I x, I y -> Stdlib.compare x y + | F x, I y -> Stdlib.compare x (float_of_int y) + | I x, F y -> Stdlib.compare (float_of_int x) y + | I x, I64 y -> Stdlib.compare (Int64.of_int x) y + | I64 x, I64 y -> Stdlib.compare x y + | I64 x, I y -> Stdlib.compare x (Int64.of_int y) + | F x, I64 y -> Stdlib.compare x (Int64.to_float y) + | I64 x, F y -> Stdlib.compare (Int64.to_float x) y let is_greater n1 n2 = compare n1 n2 > 0 let is_smaller n1 n2 = compare n1 n2 < 0 -let is_equal n1 n2 = compare n1 n2=0 - -let add n1 n2 = cast_bin_op ~op_f:(+.) ~op_i:(+) ~op_i64:Int64.add n1 n2 -let sub n1 n2 = cast_bin_op ~op_f:(-.) ~op_i:(-) ~op_i64:Int64.sub n1 n2 -let mult n1 n2 = cast_bin_op ~op_f:( *.) ~op_i:( * ) ~op_i64:Int64.mul n1 n2 +let is_equal n1 n2 = compare n1 n2 = 0 +let add n1 n2 = cast_bin_op ~op_f:( +. ) ~op_i:( + ) ~op_i64:Int64.add n1 n2 +let sub n1 n2 = cast_bin_op ~op_f:( -. ) ~op_i:( - ) ~op_i64:Int64.sub n1 n2 +let mult n1 n2 = cast_bin_op ~op_f:( *. ) ~op_i:( * ) ~op_i64:Int64.mul n1 n2 let min n1 n2 = cast_bin_op ~op_f:min ~op_i:min ~op_i64:min n1 n2 let max n1 n2 = cast_bin_op ~op_f:max ~op_i:max ~op_i64:max n1 n2 + let rem n1 n2 = - cast_bin_op ~op_i:(mod) ~op_i64:Int64.rem ~op_f:mod_float n1 n2 + cast_bin_op ~op_i:( mod ) ~op_i64:Int64.rem ~op_f:mod_float n1 n2 + let internal_div n1 n2 = - cast_bin_op ~op_i:(/) ~op_i64:Int64.div ~op_f:(/.) n1 n2 + cast_bin_op ~op_i:( / ) ~op_i64:Int64.div ~op_f:( /. ) n1 n2 -let succ n = cast_un_op ~op_f:((+.) 1.) ~op_i:succ ~op_i64:Int64.succ n +let succ n = cast_un_op ~op_f:(( +. ) 1.) ~op_i:succ ~op_i64:Int64.succ n let pred n = cast_un_op ~op_f:(fun x -> x -. 1.) ~op_i:pred ~op_i64:Int64.pred n -let neg n = cast_un_op ~op_f:(~-.) ~op_i:(~-) ~op_i64:Int64.neg n +let neg n = cast_un_op ~op_f:( ~-. ) ~op_i:( ~- ) ~op_i64:Int64.neg n let to_float n = match n with | I x -> Some (float_of_int x) | I64 x -> Some (Int64.to_float x) - | F x -> match classify_float x with + | F x -> + (match classify_float x with | FP_zero | FP_normal | FP_subnormal -> Some x - | FP_infinite | FP_nan -> None + | FP_infinite | FP_nan -> None) let to_int n = match n with - | F x -> (int_of_float x) + | F x -> int_of_float x | I x -> x | I64 x -> Int64.to_int x (*Might exceed thebiggest 32 bits integer*) let zero = I 0 + let is_zero = function | I64 x -> x = Int64.zero | I x -> x = 0 @@ -121,12 +118,15 @@ let is_strictly_positive = function let pos_pow n1 n2 = cast_bin_op ~op_f:( ** ) ~op_i:Tools.pow ~op_i64:Tools.pow64 n1 n2 + let pow x n = - if is_zero n || is_strictly_positive n - then pos_pow x n - else match to_float x with + if is_zero n || is_strictly_positive n then + pos_pow x n + else ( + match to_float x with | Some x -> pos_pow (F (1. /. x)) (neg n) | None -> F nan + ) let print f = function | F x -> Format.fprintf f "%s" (string_of_float x) @@ -142,10 +142,10 @@ let print_option f = function | I x -> Format.fprintf f "%d" x | I64 x -> Format.fprintf f "%Ld" x | F x -> - match classify_float x with + (match classify_float x with | FP_zero | FP_normal | FP_subnormal -> - Format.fprintf f "%s" (string_of_float x) - | FP_infinite | FP_nan -> () + Format.fprintf f "%s" (string_of_float x) + | FP_infinite | FP_nan -> ()) let to_string = function | F x -> string_of_float x @@ -153,60 +153,60 @@ let to_string = function | I x -> string_of_int x let rec iteri f x n = - if is_strictly_positive n then iteri f (f n x) (pred n) else x + if is_strictly_positive n then + iteri f (f n x) (pred n) + else + x let rec maybe_iteri f x n = - if is_strictly_positive n then + if is_strictly_positive n then ( match f n x with | None -> x | Some x' -> maybe_iteri f x' (pred n) - else x + ) else + x let of_string x = - try I (int_of_string x) - with Failure _ -> F (float_of_string x) + try I (int_of_string x) with Failure _ -> F (float_of_string x) let to_yojson = function | I x -> `Int x | I64 x -> `String (Int64.to_string x) | F x -> - match classify_float x with + (match classify_float x with | FP_zero | FP_normal | FP_subnormal -> `Float x - | FP_infinite | FP_nan -> `String (string_of_float x) + | FP_infinite | FP_nan -> `String (string_of_float x)) let of_yojson = function | `Int x -> I x | `Float x -> F x | `String n as x -> - begin - try I64 (Int64.of_string n) - with Failure _ -> try F (float_of_string n) + (try I64 (Int64.of_string n) + with Failure _ -> + (try F (float_of_string n) with Failure _ -> - raise (Yojson.Basic.Util.Type_error ("Not an Nbr",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not an Nbr",x)) + raise (Yojson.Basic.Util.Type_error ("Not an Nbr", x)))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not an Nbr", x)) -let write_t ob f = - Yojson.Basic.to_buffer ob (to_yojson f) +let write_t ob f = Yojson.Basic.to_buffer ob (to_yojson f) let string_of_t ?(len = 1024) x = let ob = Buffer.create len in write_t ob x; Buffer.contents ob -let read_t p lb = - of_yojson (Yojson.Basic.from_lexbuf ~stream:true p lb) - -let t_of_string s = - read_t (Yojson.Safe.init_lexer ()) (Lexing.from_string s) +let read_t p lb = of_yojson (Yojson.Basic.from_lexbuf ~stream:true p lb) +let t_of_string s = read_t (Yojson.Safe.init_lexer ()) (Lexing.from_string s) let of_bin_alg_op = function | Operator.MULT -> mult | Operator.SUM -> add - | Operator.DIV -> fun x y -> - if not (is_zero y) && is_zero (rem x y) - then internal_div x y - else cast_bin_op ~op_f:(/.) x y + | Operator.DIV -> + fun x y -> + if (not (is_zero y)) && is_zero (rem x y) then + internal_div x y + else + cast_bin_op ~op_f:( /. ) x y | Operator.MINUS -> sub | Operator.MODULO -> rem | Operator.MIN -> min diff --git a/core/dataStructures/nbr.mli b/core/dataStructures/nbr.mli index b4a27d8d1d..d5eb894b93 100644 --- a/core/dataStructures/nbr.mli +++ b/core/dataStructures/nbr.mli @@ -9,26 +9,26 @@ (** Kappa numbers (either float, int or int64) and operations on them *) type t = F of float | I of int | I64 of Int64.t + val compare : t -> t -> int val is_greater : t -> t -> bool val is_smaller : t -> t -> bool val is_equal : t -> t -> bool - val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t + val internal_div : t -> t -> t (** euler division when only int are involved, float div else *) val rem : t -> t -> t val pow : t -> t -> t - val min : t -> t -> t val max : t -> t -> t - val succ : t -> t val pred : t -> t val neg : t -> t + val to_float : t -> float option (** [None] when infinity or Not a Number *) @@ -55,10 +55,12 @@ val maybe_iteri : (t -> 'a -> 'a option) -> 'a -> t -> 'a or [f] returns [None] *) val to_string : t -> string + val of_string : string -> t (** @raise Failure "float_of_string" *) val to_yojson : t -> Yojson.Basic.t + val of_yojson : Yojson.Basic.t -> t (** @raise Yojson.Basic.Util.Type_error if incorrect *) diff --git a/core/dataStructures/operator.ml b/core/dataStructures/operator.ml index 0da6ff24d8..bd3d43dea5 100644 --- a/core/dataStructures/operator.ml +++ b/core/dataStructures/operator.ml @@ -8,12 +8,18 @@ type bin_alg_op = MULT | SUM | DIV | MINUS | POW | MODULO | MIN | MAX type un_alg_op = LOG | SQRT | EXP | SINUS | COSINUS | TAN | INT | UMINUS -type state_alg_op = CPUTIME | TIME_VAR | EVENT_VAR | NULL_EVENT_VAR - | TMAX_VAR | EMAX_VAR + +type state_alg_op = + | CPUTIME + | TIME_VAR + | EVENT_VAR + | NULL_EVENT_VAR + | TMAX_VAR + | EMAX_VAR + type bin_bool_op = AND | OR type un_bool_op = NOT type compare_op = GREATER | SMALLER | EQUAL | DIFF - type rev_dep = ALG of int | RULE of int | MODIF of int let bin_alg_op_to_string = function @@ -37,6 +43,7 @@ let print_bin_alg_op fx x fy y f op = Format.fprintf f "(%a %s %a)" fx x (bin_alg_op_to_string op) fy y let bin_alg_op_to_json op = `String (bin_alg_op_to_string op) + let bin_alg_op_of_json = function | `String "*" -> MULT | `String "+" -> SUM @@ -46,7 +53,7 @@ let bin_alg_op_of_json = function | `String "[mod]" -> MODULO | `String "[min]" -> MIN | `String "[max]" -> MAX - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect bin_alg_op",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect bin_alg_op", x)) let un_alg_op_to_string = function | COSINUS -> "[cos]" @@ -58,10 +65,9 @@ let un_alg_op_to_string = function | LOG -> "[log]" | UMINUS -> "-" -let print_un_alg_op f op = - Format.pp_print_string f (un_alg_op_to_string op) - +let print_un_alg_op f op = Format.pp_print_string f (un_alg_op_to_string op) let un_alg_op_to_json op = `String (un_alg_op_to_string op) + let un_alg_op_of_json = function | `String "[cos]" -> COSINUS | `String "[sin]" -> SINUS @@ -71,7 +77,7 @@ let un_alg_op_of_json = function | `String "[int]" -> INT | `String "[log]" -> LOG | `String "-" -> UMINUS - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect un_alg_op",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect un_alg_op", x)) let state_alg_op_to_string = function | CPUTIME -> "[Tsim]" @@ -85,37 +91,37 @@ let print_state_alg_op f op = Format.pp_print_string f (state_alg_op_to_string op) let state_alg_op_to_json op = `String (state_alg_op_to_string op) + let state_alg_op_of_json = function | `String "[Tsim]" -> CPUTIME | `String "[T]" -> TIME_VAR | `String "[E]" -> EVENT_VAR - | `String "[E-]" -> NULL_EVENT_VAR + | `String "[E-]" -> NULL_EVENT_VAR | `String "[Tmax]" -> TMAX_VAR | `String "[Emax]" -> EMAX_VAR - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect state_alg_op",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect state_alg_op", x)) let bin_bool_op_to_string = function | AND -> "&&" | OR -> "||" -let print_bin_bool_op f op = - Format.pp_print_string f (bin_bool_op_to_string op) - +let print_bin_bool_op f op = Format.pp_print_string f (bin_bool_op_to_string op) let bin_bool_op_to_json op = `String (bin_bool_op_to_string op) + let bin_bool_op_of_json = function | `String "&&" -> AND | `String "||" -> OR - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect boolean op",x)) - -let un_bool_op_to_string = function NOT -> "[not]" + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect boolean op", x)) -let print_un_bool_op f op = - Format.pp_print_string f (un_bool_op_to_string op) +let un_bool_op_to_string = function + | NOT -> "[not]" +let print_un_bool_op f op = Format.pp_print_string f (un_bool_op_to_string op) let un_bool_op_to_json op = `String (un_bool_op_to_string op) + let un_bool_op_of_json = function | `String "[not]" -> NOT - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect boolean op",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect boolean op", x)) let compare_op_to_string = function | GREATER -> ">" @@ -123,23 +129,20 @@ let compare_op_to_string = function | EQUAL -> "=" | DIFF -> "!=" -let print_compare_op f op = - Format.pp_print_string f (compare_op_to_string op) - +let print_compare_op f op = Format.pp_print_string f (compare_op_to_string op) let compare_op_to_json op = `String (compare_op_to_string op) + let compare_op_of_json = function | `String ">" -> GREATER | `String "<" -> SMALLER | `String "=" -> EQUAL | `String "!=" -> DIFF - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect compare_op",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect compare_op", x)) let print_rev_dep f = function - | RULE id -> - Format.fprintf f "rate_of_rule [%i]" id + | RULE id -> Format.fprintf f "rate_of_rule [%i]" id (*"rate of rule '%a'" (Model.print_rule env) id*) - | ALG id -> - Format.fprintf f "algebraic variable [%i]" id + | ALG id -> Format.fprintf f "algebraic variable [%i]" id (*"variable '%a'" (Model.print_alg env) id*) | MODIF id -> Format.fprintf f "intervention [%i]" id @@ -152,16 +155,19 @@ let rev_dep_of_yojson = function | `List [ `String "RULE"; `Int id ] -> RULE id | `List [ `String "ALG"; `Int id ] -> ALG id | `List [ `String "MODIF"; `Int id ] -> MODIF id - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect rev_dep",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect rev_dep", x)) + +module DepSetMap = SetMap.Make (struct + type t = rev_dep + + let compare = compare + let print = print_rev_dep +end) -module DepSetMap = SetMap.Make (struct type t = rev_dep - let compare = compare - let print = print_rev_dep end) module DepSet = DepSetMap.Set let depset_to_yojson x = - `List (DepSet.fold - (fun x a -> rev_dep_to_yojson x :: a) x []) + `List (DepSet.fold (fun x a -> rev_dep_to_yojson x :: a) x []) let depset_of_yojson = function | `Null -> DepSet.empty @@ -169,5 +175,4 @@ let depset_of_yojson = function List.fold_left (fun acc x -> DepSet.add (rev_dep_of_yojson x) acc) DepSet.empty l - | x -> raise (Yojson.Basic.Util.Type_error("Invalid depset",x)) - + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid depset", x)) diff --git a/core/dataStructures/operator.mli b/core/dataStructures/operator.mli index adf620e3f7..a539721d77 100644 --- a/core/dataStructures/operator.mli +++ b/core/dataStructures/operator.mli @@ -10,8 +10,15 @@ type bin_alg_op = MULT | SUM | DIV | MINUS | POW | MODULO | MIN | MAX type un_alg_op = LOG | SQRT | EXP | SINUS | COSINUS | TAN | INT | UMINUS -type state_alg_op = CPUTIME | TIME_VAR | EVENT_VAR | NULL_EVENT_VAR - | TMAX_VAR | EMAX_VAR + +type state_alg_op = + | CPUTIME + | TIME_VAR + | EVENT_VAR + | NULL_EVENT_VAR + | TMAX_VAR + | EMAX_VAR + type bin_bool_op = AND | OR type un_bool_op = NOT type compare_op = GREATER | SMALLER | EQUAL | DIFF @@ -19,16 +26,21 @@ type compare_op = GREATER | SMALLER | EQUAL | DIFF (** {2 Printers} *) val bin_alg_op_is_prefix : bin_alg_op -> bool + val print_bin_alg_op : - (Format.formatter -> 'a -> unit) -> 'a -> - (Format.formatter -> 'b -> unit) -> 'b -> - Format.formatter -> bin_alg_op -> unit + (Format.formatter -> 'a -> unit) -> + 'a -> + (Format.formatter -> 'b -> unit) -> + 'b -> + Format.formatter -> + bin_alg_op -> + unit + val print_un_alg_op : Format.formatter -> un_alg_op -> unit val print_state_alg_op : Format.formatter -> state_alg_op -> unit val print_bin_bool_op : Format.formatter -> bin_bool_op -> unit val print_un_bool_op : Format.formatter -> un_bool_op -> unit val print_compare_op : Format.formatter -> compare_op -> unit - val bin_alg_op_to_string : bin_alg_op -> string val un_alg_op_to_string : un_alg_op -> string val state_alg_op_to_string : state_alg_op -> string @@ -54,10 +66,11 @@ val compare_op_of_json : Yojson.Basic.t -> compare_op (** {2 Dependencies management} *) type rev_dep = ALG of int | RULE of int | MODIF of int + module DepSet : SetMap.Set with type elt = rev_dep + val print_rev_dep : Format.formatter -> rev_dep -> unit val rev_dep_to_yojson : rev_dep -> Yojson.Basic.t val rev_dep_of_yojson : Yojson.Basic.t -> rev_dep - val depset_to_yojson : DepSet.t -> Yojson.Basic.t val depset_of_yojson : Yojson.Basic.t -> DepSet.t diff --git a/core/dataStructures/option_util.ml b/core/dataStructures/option_util.ml index 86522df4e7..ed97505e32 100644 --- a/core/dataStructures/option_util.ml +++ b/core/dataStructures/option_util.ml @@ -10,6 +10,11 @@ let unsome default = function | None -> default | Some a -> a +let unsome_or_raise + ?(excep = Invalid_argument "unsome_or_raise was passed a None") = function + | None -> raise excep + | Some a -> a + let map f = function | Some x -> Some (f x) | None -> None diff --git a/core/dataStructures/option_util.mli b/core/dataStructures/option_util.mli index 009fd8e6bd..fd0e2eeaec 100644 --- a/core/dataStructures/option_util.mli +++ b/core/dataStructures/option_util.mli @@ -12,4 +12,5 @@ val map : ('a -> 'b) -> 'a option -> 'b option val fold : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a val bind : ('a -> 'b option) -> 'a option -> 'b option val unsome : 'a -> 'a option -> 'a +val unsome_or_raise : ?excep:exn -> 'a option -> 'a val equal : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool diff --git a/core/dataStructures/pp.ml b/core/dataStructures/pp.ml index fb974223dc..d727c4ff66 100644 --- a/core/dataStructures/pp.ml +++ b/core/dataStructures/pp.ml @@ -8,17 +8,18 @@ open Format -let listi ?(trailing=(fun _ -> ())) pr_sep pr_el f l = +let listi ?(trailing = fun _ -> ()) pr_sep pr_el f l = let rec aux acc f = function | [] -> () - | [el] -> - let () = pr_el acc f el in - trailing f + | [ el ] -> + let () = pr_el acc f el in + trailing f | h :: t -> - let () = pr_el acc f h in - let () = pr_sep f in - aux (succ acc) f t - in aux 0 f l + let () = pr_el acc f h in + let () = pr_sep f in + aux (succ acc) f t + in + aux 0 f l let list ?trailing pr_sep pr_el f l = listi ?trailing pr_sep (fun _ f x -> pr_el f x) f l @@ -27,7 +28,7 @@ let set ?trailing elements pr_sep pr_el f set = list ?trailing pr_sep pr_el f (elements set) let hashtbl pr_sep pr_el f tbl = - list pr_sep pr_el f (Hashtbl.fold (fun a b l -> (a,b)::l) tbl []) + list pr_sep pr_el f (Hashtbl.fold (fun a b l -> (a, b) :: l) tbl []) let bottom f = Format.pp_print_string f "\xE2\x8A\xA5" let nu f = Format.pp_print_string f "\xCE\xBD" @@ -40,39 +41,50 @@ let space f = pp_print_space f () let cut f = pp_print_cut f () let empty _ = () let unit _ () = () -let pair ppa ppb f (a,b) = fprintf f "(%a, %a)" ppa a ppb b -let option ?(with_space=true) pr f = function +let pair ppa ppb f (a, b) = fprintf f "(%a, %a)" ppa a ppb b + +let option ?(with_space = true) pr f = function | None -> () - | Some x -> fprintf f "%t%a" - (fun f -> if with_space then Format.pp_print_space f () else ()) - pr x + | Some x -> + fprintf f "%t%a" + (fun f -> + if with_space then + Format.pp_print_space f () + else + ()) + pr x -let array ?(trailing=(fun _ -> ())) pr_sep pr_el f a = +let array ?(trailing = fun _ -> ()) pr_sep pr_el f a = let rec aux i f = - if i < Array.length a then + if i < Array.length a then ( let () = pr_el i f a.(i) in - if i < Array.length a - 1 then - let () = pr_sep f in aux (succ i) f - else if i > 0 then trailing f - in aux 0 f + if i < Array.length a - 1 then ( + let () = pr_sep f in + aux (succ i) f + ) else if i > 0 then + trailing f + ) + in + aux 0 f let plain_array pr_el f a = let rec aux i f = - if i < Array.length a then + if i < Array.length a then ( let () = Format.fprintf f "%i:%a" i pr_el a.(i) in - if i < Array.length a - 1 then - Format.fprintf f ";@,%t" (aux (succ i)) - in Format.fprintf f "[|%t|]" (aux 0) + if i < Array.length a - 1 then Format.fprintf f ";@,%t" (aux (succ i)) + ) + in + Format.fprintf f "[|%t|]" (aux 0) -let error pr x = - eprintf "%a@." (Locality.print_annot pr) x +let error pr x = eprintf "%a@." (Loc.print_annoted pr) x let list_to_string pr_sep pr_el () l = let rec aux () = function - | [] -> "" - | [el] -> pr_el () el - | h :: t -> sprintf "%a%t%a" pr_el h pr_sep aux t - in aux () l + | [] -> "" + | [ el ] -> pr_el () el + | h :: t -> sprintf "%a%t%a" pr_el h pr_sep aux t + in + aux () l let set_to_string elements pr_sep pr_el () set = list_to_string pr_sep pr_el () (elements set) diff --git a/core/dataStructures/pp.mli b/core/dataStructures/pp.mli index e10f4a5772..d764f1f44a 100644 --- a/core/dataStructures/pp.mli +++ b/core/dataStructures/pp.mli @@ -10,23 +10,50 @@ open Format val listi : ?trailing:(formatter -> unit) -> - (formatter -> unit) -> (int -> formatter -> 'a -> unit) -> - formatter -> 'a list -> unit + (formatter -> unit) -> + (int -> formatter -> 'a -> unit) -> + formatter -> + 'a list -> + unit + val list : ?trailing:(formatter -> unit) -> - (formatter -> unit) -> (formatter -> 'a -> unit) -> - formatter -> 'a list -> unit + (formatter -> unit) -> + (formatter -> 'a -> unit) -> + formatter -> + 'a list -> + unit + val set : ?trailing:(formatter -> unit) -> - ('b -> 'a list) -> (formatter -> unit) -> (formatter -> 'a -> unit) -> - formatter -> 'b -> unit -val hashtbl : (formatter -> unit) -> (formatter -> 'a * 'b -> unit) -> - formatter -> ('a,'b) Hashtbl.t -> unit - -val option : ?with_space:bool -> - (formatter -> 'a -> unit) -> formatter -> 'a option -> unit -val pair : (formatter -> 'a -> unit) -> (formatter -> 'b -> unit) -> - formatter -> 'a * 'b -> unit + ('b -> 'a list) -> + (formatter -> unit) -> + (formatter -> 'a -> unit) -> + formatter -> + 'b -> + unit + +val hashtbl : + (formatter -> unit) -> + (formatter -> 'a * 'b -> unit) -> + formatter -> + ('a, 'b) Hashtbl.t -> + unit + +val option : + ?with_space:bool -> + (formatter -> 'a -> unit) -> + formatter -> + 'a option -> + unit + +val pair : + (formatter -> 'a -> unit) -> + (formatter -> 'b -> unit) -> + formatter -> + 'a * 'b -> + unit + val bottom : formatter -> unit val nu : formatter -> unit val empty_set : formatter -> unit @@ -37,18 +64,26 @@ val dot : formatter -> unit val space : formatter -> unit val cut : formatter -> unit val empty : formatter -> unit - val unit : formatter -> unit -> unit val array : ?trailing:(formatter -> unit) -> - (formatter -> unit) -> (int -> formatter -> 'a -> unit) -> - formatter -> 'a array -> unit + (formatter -> unit) -> + (int -> formatter -> 'a -> unit) -> + formatter -> + 'a array -> + unit + val plain_array : (formatter -> 'a -> unit) -> formatter -> 'a array -> unit +val error : (formatter -> 'a -> unit) -> 'a Loc.annoted -> unit -val error : (formatter -> 'a -> unit) -> 'a Locality.annot -> unit +val list_to_string : + (unit -> string) -> (unit -> 'a -> string) -> unit -> 'a list -> string -val list_to_string : (unit -> string) -> - (unit -> 'a -> string) -> unit -> 'a list -> string -val set_to_string : ('b -> 'a list) -> (unit -> string) -> - (unit -> 'a -> string) -> unit -> 'b -> string +val set_to_string : + ('b -> 'a list) -> + (unit -> string) -> + (unit -> 'a -> string) -> + unit -> + 'b -> + string diff --git a/core/dataStructures/pp_html.ml b/core/dataStructures/pp_html.ml index 44d65dc380..591f3073e4 100644 --- a/core/dataStructures/pp_html.ml +++ b/core/dataStructures/pp_html.ml @@ -8,16 +8,18 @@ let graph_page title ?subtitle deps header core f = let dependency f t = - Format.fprintf f "" t in + Format.fprintf f "" t + in let () = Format.fprintf f "@[@,@,@," in let () = Format.fprintf f "@[@,@," in let () = Format.fprintf f "%t@," title in let () = Pp.list ~trailing:Pp.space Pp.space dependency f deps in let () = Format.fprintf f "%t@]@,@," header in let () = Format.fprintf f "@[@,
    @," in - let () = Format.fprintf - f "

    @[%t%t@]

    @," title - (fun f -> match subtitle with - | None -> () - | Some t -> Format.fprintf f "@,%t" t) in + let () = + Format.fprintf f "

    @[%t%t@]

    @," title (fun f -> + match subtitle with + | None -> () + | Some t -> Format.fprintf f "@,%t" t) + in Format.fprintf f "%t@,
    @]@,@,@]@." core diff --git a/core/dataStructures/pp_html.mli b/core/dataStructures/pp_html.mli index c01d0e96a3..19b77887da 100644 --- a/core/dataStructures/pp_html.mli +++ b/core/dataStructures/pp_html.mli @@ -7,7 +7,11 @@ (******************************************************************************) val graph_page : - (Format.formatter -> unit) -> ?subtitle:(Format.formatter -> unit) -> - string list -> (Format.formatter -> unit) -> (Format.formatter -> unit) -> - Format.formatter -> unit - (** [graph_page title deps header core f] *) + (Format.formatter -> unit) -> + ?subtitle:(Format.formatter -> unit) -> + string list -> + (Format.formatter -> unit) -> + (Format.formatter -> unit) -> + Format.formatter -> + unit +(** [graph_page title deps header core f] *) diff --git a/core/dataStructures/random_tree.ml b/core/dataStructures/random_tree.ml index 34cbcfbb90..6b97cc9c48 100644 --- a/core/dataStructures/random_tree.ml +++ b/core/dataStructures/random_tree.ml @@ -7,24 +7,24 @@ (******************************************************************************) type tree = { - mask: (int, int) Hashtbl.t ; - unmask: (int, int) Hashtbl.t ; - mutable new_mask : int ; - mutable inf_list : Mods.IntSet.t ; + mask: (int, int) Hashtbl.t; + unmask: (int, int) Hashtbl.t; + mutable new_mask: int; + mutable inf_list: Mods.IntSet.t; size: int; - weight_of_nodes: float array ; - weight_of_subtrees: float array ; - unbalanced_events_by_layer: int list array ; + weight_of_nodes: float array; + weight_of_subtrees: float array; + unbalanced_events_by_layer: int list array; unbalanced_events: bool array; - layer: int array ; - mutable consistent: bool + layer: int array; + mutable consistent: bool; } let mask t i = try Hashtbl.find t.mask i with Not_found -> let m = t.new_mask in - let () = t.new_mask <- m+1 in + let () = t.new_mask <- m + 1 in let () = Hashtbl.replace t.mask i m in let () = Hashtbl.replace t.unmask m i in m @@ -33,36 +33,40 @@ let unmask t m = try Hashtbl.find t.unmask m with Not_found -> invalid_arg "Random_tree: incoherent hash" -let is_infinite i t = let i = mask t i in Mods.IntSet.mem i t.inf_list +let is_infinite i t = + let i = mask t i in + Mods.IntSet.mem i t.inf_list let find i t = - let i = mask t i in t.weight_of_nodes.(i) - -let copy t = { - mask = Hashtbl.copy t.mask ; - unmask = Hashtbl.copy t.unmask ; - new_mask = t.new_mask ; - size = t.size; - (* total = t.total ;*) - weight_of_nodes = Array.copy t.weight_of_nodes ; - weight_of_subtrees = Array.copy t.weight_of_subtrees ; - layer = Array.copy t.layer; - consistent = t.consistent ; - unbalanced_events_by_layer = Array.copy t.unbalanced_events_by_layer ; - unbalanced_events = Array.copy t.unbalanced_events ; - inf_list = Mods.IntSet.empty -} + let i = mask t i in + t.weight_of_nodes.(i) -let copy_vect_in t t1 = - Array.iteri (fun i a -> t1.(i) <- a) t +let copy t = + { + mask = Hashtbl.copy t.mask; + unmask = Hashtbl.copy t.unmask; + new_mask = t.new_mask; + size = t.size; + (* total = t.total ;*) + weight_of_nodes = Array.copy t.weight_of_nodes; + weight_of_subtrees = Array.copy t.weight_of_subtrees; + layer = Array.copy t.layer; + consistent = t.consistent; + unbalanced_events_by_layer = Array.copy t.unbalanced_events_by_layer; + unbalanced_events = Array.copy t.unbalanced_events; + inf_list = Mods.IntSet.empty; + } + +let copy_vect_in t t1 = Array.iteri (fun i a -> t1.(i) <- a) t let copy_in t1 t2 = let () = copy_vect_in t1.weight_of_nodes t2.weight_of_nodes in let () = copy_vect_in t1.weight_of_subtrees t2.weight_of_subtrees in let () = copy_vect_in t1.layer t2.layer in let () = copy_vect_in t1.unbalanced_events t2.unbalanced_events in - let () = copy_vect_in t1.unbalanced_events_by_layer - t2.unbalanced_events_by_layer in + let () = + copy_vect_in t1.unbalanced_events_by_layer t2.unbalanced_events_by_layer + in let () = t2.consistent <- t1.consistent in t2 @@ -70,38 +74,53 @@ let is_root i = i = 1 let declare_unbalanced i t = let () = - if not t.unbalanced_events.(i) then + if not t.unbalanced_events.(i) then ( let l = t.layer.(i) in let () = t.unbalanced_events.(i) <- true in - t.unbalanced_events_by_layer.(l) <- - i :: (t.unbalanced_events_by_layer.(l)) + t.unbalanced_events_by_layer.(l) <- i :: t.unbalanced_events_by_layer.(l) + ) in t.consistent <- false let update_structure t = - if t.consistent then t - else + if t.consistent then + t + else ( let n_layer = t.layer.(t.size) in let update_structure_aux i = - let () = t.weight_of_subtrees.(i) <- - t.weight_of_nodes.(i) - +. (if 2*i > t.size then 0. else t.weight_of_subtrees.(2*i)) - +. (if 2*i+1 > t.size then 0. else t.weight_of_subtrees.(2*i+1)) in + let () = + t.weight_of_subtrees.(i) <- + (t.weight_of_nodes.(i) + +. (if 2 * i > t.size then + 0. + else + t.weight_of_subtrees.(2 * i)) + +. + if (2 * i) + 1 > t.size then + 0. + else + t.weight_of_subtrees.((2 * i) + 1)) + in let () = t.unbalanced_events.(i) <- false in - if not (is_root i) then + if not (is_root i) then ( let father = i / 2 in - declare_unbalanced father t in + declare_unbalanced father t + ) + in let rec aux k = - if k = 0 then () - else + if k = 0 then + () + else ( let l = t.unbalanced_events_by_layer.(k) in let () = t.unbalanced_events_by_layer.(k) <- [] in let () = List.iter update_structure_aux l in aux (k - 1) + ) in let () = aux n_layer in let () = t.consistent <- true in t + ) let create n = let t_node = Array.make (n + 1) 0. in @@ -111,92 +130,129 @@ let create n = let rec aux k current_layer layer_end = if k <= n then if k > layer_end then - aux k (current_layer + 1) (2 * layer_end + 1) - else + aux k (current_layer + 1) ((2 * layer_end) + 1) + else ( let () = layer.(k) <- current_layer in aux (k + 1) current_layer layer_end - in aux 1 1 1 in + ) + in + aux 1 1 1 + in let unbalanced_events_by_layer = Array.make (layer.(n) + 1) [] in let unbalanced_events = Array.make (n + 1) false in - { size = n; + { + size = n; (* total = 0.;*) - new_mask = 1 ; - mask = Hashtbl.create (n+1) ; - unmask = Hashtbl.create (n+1) ; - inf_list = Mods.IntSet.empty ; + new_mask = 1; + mask = Hashtbl.create (n + 1); + unmask = Hashtbl.create (n + 1); + inf_list = Mods.IntSet.empty; consistent = true; weight_of_nodes = t_node; weight_of_subtrees = t_subtree; - unbalanced_events_by_layer = unbalanced_events_by_layer; - unbalanced_events = unbalanced_events; - layer = layer } + unbalanced_events_by_layer; + unbalanced_events; + layer; + } let add i w t = let i = mask t i in - if w < 0. then failwith "Negative value forbidden in Random_tree" - else + if w < 0. then + failwith "Negative value forbidden in Random_tree" + else ( let w = - if w = infinity then - let () = t.inf_list <- Mods.IntSet.add i t.inf_list in 0. - else - let () = t.inf_list <- Mods.IntSet.remove i t.inf_list in w in + if w = infinity then ( + let () = t.inf_list <- Mods.IntSet.add i t.inf_list in + 0. + ) else ( + let () = t.inf_list <- Mods.IntSet.remove i t.inf_list in + w + ) + in (* let total = t.total -. t.weight_of_nodes.(i) +. w in*) let () = t.weight_of_nodes.(i) <- w in let () = declare_unbalanced i t in - () (*t.total <- (max 0.0 total) (*not satisfactory*)*) + () (*t.total <- (max 0.0 total) (*not satisfactory*)*) + ) let total t = - if Mods.IntSet.is_empty t.inf_list then + if Mods.IntSet.is_empty t.inf_list then ( let t = update_structure t in - if t.size = 0 then 0. else t.weight_of_subtrees.(1) - else + if t.size = 0 then + 0. + else + t.weight_of_subtrees.(1) + ) else infinity let random rs t = match Mods.IntSet.random rs t.inf_list with - | Some x -> (unmask t x,infinity) + | Some x -> unmask t x, infinity | None -> let t = update_structure t in let a = total t in - if a <= 0. then raise Not_found - else + if a <= 0. then + raise Not_found + else ( let r = Random.State.float rs a in let rec find i r = let node = t.weight_of_nodes.(i) in - if r < node then (i,node) - else if 2 * i > t.size then raise Not_found - else - let r'= r -.node in + if r < node then + i, node + else if 2 * i > t.size then + raise Not_found + else ( + let r' = r -. node in let lson = 2 * i in - let rson = 2 * i + 1 in + let rson = (2 * i) + 1 in let left = t.weight_of_subtrees.(lson) in - if r'< left then find lson r' + if r' < left then + find lson r' + else if rson > t.size then + raise Not_found else - if rson > t.size then raise Not_found - else find rson (r'-.left) + find rson (r' -. left) + ) in - let rep,w = find 1 r in - (unmask t rep,w) + let rep, w = find 1 r in + unmask t rep, w + ) (* TODO - weight_of_subtrees: float array ; - unbalanced_events_by_layer: int list array ; + weight_of_subtrees: float array ; + unbalanced_events_by_layer: int list array ; *) let debug_print f t = let () = - Format.fprintf f "@[%sconsistent:@ [" (if t.consistent then "" else "un") in + Format.fprintf f "@[%sconsistent:@ [" + (if t.consistent then + "" + else + "un") + in let () = Hashtbl.iter (fun i k -> - let bal = if t.unbalanced_events.(k) then "!" else "" in - let inv = - if Hashtbl.find t.mask k = i then "" else " not involutive" in - let inf = - match classify_float t.weight_of_nodes.(k) with - | FP_infinite when Mods.IntSet.mem k t.inf_list -> "" - | FP_infinite -> " not in inf_list" - | _ when not (Mods.IntSet.mem k t.inf_list) -> "" - | (FP_normal | FP_zero | FP_nan | FP_subnormal) -> " in inf_list" in - Format.fprintf f "%s%i:%f%s%s,@," bal i t.weight_of_nodes.(k) inf inv) - t.unmask in + let bal = + if t.unbalanced_events.(k) then + "!" + else + "" + in + let inv = + if Hashtbl.find t.mask k = i then + "" + else + " not involutive" + in + let inf = + match classify_float t.weight_of_nodes.(k) with + | FP_infinite when Mods.IntSet.mem k t.inf_list -> "" + | FP_infinite -> " not in inf_list" + | _ when not (Mods.IntSet.mem k t.inf_list) -> "" + | FP_normal | FP_zero | FP_nan | FP_subnormal -> " in inf_list" + in + Format.fprintf f "%s%i:%f%s%s,@," bal i t.weight_of_nodes.(k) inf inv) + t.unmask + in Format.fprintf f "]@]" diff --git a/core/dataStructures/random_tree.mli b/core/dataStructures/random_tree.mli index 148c8aa760..bc5e6fdd9a 100644 --- a/core/dataStructures/random_tree.mli +++ b/core/dataStructures/random_tree.mli @@ -7,12 +7,13 @@ (******************************************************************************) type tree -val create: int -> tree -val total: tree -> float -val copy: tree -> tree -val copy_in: tree -> tree -> tree -val add: int -> float -> tree -> unit -val random: Random.State.t -> tree -> int * float + +val create : int -> tree +val total : tree -> float +val copy : tree -> tree +val copy_in : tree -> tree -> tree +val add : int -> float -> tree -> unit +val random : Random.State.t -> tree -> int * float val find : int -> tree -> float val is_infinite : int -> tree -> bool val debug_print : Format.formatter -> tree -> unit diff --git a/core/dataStructures/renaming.ml b/core/dataStructures/renaming.ml index 3237c2b688..d164db007b 100644 --- a/core/dataStructures/renaming.ml +++ b/core/dataStructures/renaming.ml @@ -11,19 +11,21 @@ exception NotBijective exception Clashing let special_val = max_int + type t = { mutable immediate: int array; - mutable delayed: (t*t) option; - mutable is_identity:bool; - mutable dsts:Mods.IntSet.t + mutable delayed: (t * t) option; + mutable is_identity: bool; + mutable dsts: Mods.IntSet.t; } -let empty () = { - immediate = [||]; - delayed = None; - is_identity=true; - dsts = Mods.IntSet.empty -} +let empty () = + { + immediate = [||]; + delayed = None; + is_identity = true; + dsts = Mods.IntSet.empty; + } let dummy = empty () @@ -31,78 +33,114 @@ let identity l = let max = List.fold_left max 0 l in let immediate = Array.make (succ max) special_val in let () = List.iter (fun x -> immediate.(x) <- x) l in - {immediate; delayed = None; is_identity = true; - dsts = - List.fold_left (fun out x -> Mods.IntSet.add x out) Mods.IntSet.empty l} + { + immediate; + delayed = None; + is_identity = true; + dsts = + List.fold_left (fun out x -> Mods.IntSet.add x out) Mods.IntSet.empty l; + } + let is_identity i = i.is_identity let rec compute k i = let v = i.immediate.(k) in - if v <> special_val then v else + if v <> special_val then + v + else ( match i.delayed with | None -> special_val - | Some (x,y) -> - if k >= Array.length x.immediate then special_val - else + | Some (x, y) -> + if k >= Array.length x.immediate then + special_val + else ( let v' = compute k x in - if v' = special_val then special_val else + if v' = special_val then + special_val + else ( let v'' = compute v' y in - let o = if v'' = special_val then v' else v'' in + let o = + if v'' = special_val then + v' + else + v'' + in let () = i.immediate.(k) <- o in o + ) + ) + ) let force i = - if i.delayed <> None then + if i.delayed <> None then ( let () = Array.iteri (fun k _ -> ignore (compute k i)) i.immediate in i.delayed <- None + ) let to_list i = let () = force i in Tools.array_fold_lefti - (fun i acc v -> if v <> special_val then (i,v)::acc else acc) + (fun i acc v -> + if v <> special_val then + (i, v) :: acc + else + acc) [] i.immediate |> List.rev let image i = i.dsts let unsafe_functionnal_add x y i = - let l = max (Array.length i.immediate) (x+1) in + let l = max (Array.length i.immediate) (x + 1) in let immediate = Array.make l special_val in let () = Array.blit i.immediate 0 immediate 0 (Array.length i.immediate) in - let () = immediate.(x) <- y in { - immediate; delayed = i.delayed; - is_identity = i.is_identity && x==y ; - dsts = Mods.IntSet.add y i.dsts + let () = immediate.(x) <- y in + { + immediate; + delayed = i.delayed; + is_identity = i.is_identity && x == y; + dsts = Mods.IntSet.add y i.dsts; } -let add ~debugMode x y i = + +let add ~debug_mode x y i = let not_ok = - debugMode && - x < Array.length i.immediate && i.immediate.(x) <> special_val in - if not_ok then raise Clashing else + debug_mode && x < Array.length i.immediate && i.immediate.(x) <> special_val + in + if not_ok then + raise Clashing + else ( let i' = unsafe_functionnal_add x y i in - if i.dsts == i'.dsts then None else Some i' + if i.dsts == i'.dsts then + None + else + Some i' + ) let unsafe_imperative_add x y i = let () = let l = Array.length i.immediate in - if x >= l then + if x >= l then ( let immediate = Array.make (succ x) special_val in let () = Array.blit i.immediate 0 immediate 0 l in let () = immediate.(x) <- y in i.immediate <- immediate - else - i.immediate.(x) <- y in - let () = i.is_identity <- i.is_identity && x==y in + ) else + i.immediate.(x) <- y + in + let () = i.is_identity <- i.is_identity && x == y in i.dsts <- Mods.IntSet.add y i.dsts -let imperative_add ~debugMode x y i = +let imperative_add ~debug_mode x y i = let not_ok = - debugMode && - x < Array.length i.immediate && i.immediate.(x) <> special_val in - if not_ok then raise Clashing else + debug_mode && x < Array.length i.immediate && i.immediate.(x) <> special_val + in + if not_ok then + raise Clashing + else ( let origin = i.dsts in let () = unsafe_imperative_add x y i in not (i.dsts == origin) + ) let rec cyclic_permutation_from_identity max id subst pre = function | _ when pre = id -> unsafe_imperative_add pre max subst @@ -110,6 +148,7 @@ let rec cyclic_permutation_from_identity max id subst pre = function | h :: t -> let () = unsafe_imperative_add pre h subst in cyclic_permutation_from_identity max id subst h t + let cyclic_permutation_from_list ~stop_at = function | [] -> failwith "Renaming.cyclic_permutation_from_list" | h :: t -> @@ -118,66 +157,93 @@ let cyclic_permutation_from_list ~stop_at = function out let mem x i = x < Array.length i.immediate && compute x i <> special_val + let fold f i acc = let () = force i in Tools.array_fold_lefti (fun i acc v -> - if v = special_val then acc else f i v acc) - acc - i.immediate + if v = special_val then + acc + else + f i v acc) + acc i.immediate -let apply ~debugMode i x = - if not i.is_identity || debugMode then +let apply ~debug_mode i x = + if (not i.is_identity) || debug_mode then ( let c = compute x i in - if c = special_val then raise Undefined else c - else x - -let compose ~debugMode extensible i i' = - if not i.is_identity || extensible || debugMode then { - immediate = Array.make (Array.length i.immediate) special_val; - delayed = Some (i,i'); - is_identity = i.is_identity && i'.is_identity; - dsts = - Mods.IntSet.fold - (fun v' set -> - let v'' = compute v' i' in - Mods.IntSet.add v'' set) - i.dsts - Mods.IntSet.empty - } -(* let sigma,is_id = - Mods.IntMap.fold (fun x y (out,is_id) -> - match Mods.IntMap.find_option y i'.sigma with - | Some z -> (Mods.IntMap.add x z out,is_id && x==z) - | None -> (out,is_id && x==y) - ) i.sigma (i.sigma,true) - in - {sigma=sigma ; is_identity=is_id ; dsts = i'.dsts} -*) else i' + if c = special_val then + raise Undefined + else + c + ) else + x -let inverse i = - if i.is_identity then i +let compose ~debug_mode extensible i i' = + if (not i.is_identity) || extensible || debug_mode then + { + immediate = Array.make (Array.length i.immediate) special_val; + delayed = Some (i, i'); + is_identity = i.is_identity && i'.is_identity; + dsts = + Mods.IntSet.fold + (fun v' set -> + let v'' = compute v' i' in + Mods.IntSet.add v'' set) + i.dsts Mods.IntSet.empty; + } + (* let sigma,is_id = + Mods.IntMap.fold (fun x y (out,is_id) -> + match Mods.IntMap.find_option y i'.sigma with + | Some z -> (Mods.IntMap.add x z out,is_id && x==z) + | None -> (out,is_id && x==y) + ) i.sigma (i.sigma,true) + in + {sigma=sigma ; is_identity=is_id ; dsts = i'.dsts} + *) else + i' + +let inverse i = + if i.is_identity then + i + else ( let out = empty () in let () = force i in let () = - Array.iteri (fun x y -> + Array.iteri + (fun x y -> if y <> special_val then - if y < Array.length out.immediate && out.immediate.(y) <> special_val - then raise NotBijective - else unsafe_imperative_add y x out) i.immediate in + if + y < Array.length out.immediate && out.immediate.(y) <> special_val + then + raise NotBijective + else + unsafe_imperative_add y x out) + i.immediate + in out + ) let compare i i' = - let () = force i in let () = force i' in + let () = force i in + let () = force i' in Tools.array_compare Mods.int_compare i.immediate i'.immediate -let equal i i' = (compare i i') = 0 + +let equal i i' = compare i i' = 0 + let min_elt i = let l = Array.length i.immediate in let rec aux_min_elt k = - if k >= l then None else + if k >= l then + None + else ( let o = compute k i in - if o = special_val then aux_min_elt (succ k) else Some (k,o) in + if o = special_val then + aux_min_elt (succ k) + else + Some (k, o) + ) + in aux_min_elt 0 let print f i = @@ -185,42 +251,55 @@ let print f i = ignore (Tools.array_fold_lefti (fun src b dst -> - if src <> dst && dst <> special_val then - let () = - Format.fprintf f "%t%i->%i" (if b then Pp.comma else Pp.empty) - src dst in - true - else b - ) false i.immediate) + if src <> dst && dst <> special_val then ( + let () = + Format.fprintf f "%t%i->%i" + (if b then + Pp.comma + else + Pp.empty) + src dst + in + true + ) else + b) + false i.immediate) let print_full f i = let () = force i in - Format.fprintf - f "@[(%a)@]" - (Pp.array Pp.comma - (fun src f dst -> - if dst <> special_val then - if src<>dst then Format.fprintf f "%i->%i" src dst - else Format.pp_print_int f src)) i.immediate + Format.fprintf f "@[(%a)@]" + (Pp.array Pp.comma (fun src f dst -> + if dst <> special_val then + if src <> dst then + Format.fprintf f "%i->%i" src dst + else + Format.pp_print_int f src)) + i.immediate let to_yojson i = let () = force i in `List (Tools.array_fold_lefti (fun src acc dst -> - if dst <> special_val then `List [`Int src; `Int dst] :: acc else acc) + if dst <> special_val then + `List [ `Int src; `Int dst ] :: acc + else + acc) [] i.immediate) let of_yojson = function | `List l -> let out = empty () in let () = - List.iter (function + List.iter + (function | `List [ `Int src; `Int dst ] as x -> - if not (imperative_add ~debugMode:false src dst out) then - raise (Yojson.Basic.Util.Type_error ("Incorrect renaming item",x)) + if not (imperative_add ~debug_mode:false src dst out) then + raise + (Yojson.Basic.Util.Type_error ("Incorrect renaming item", x)) | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect renaming item",x)) - ) l in + raise (Yojson.Basic.Util.Type_error ("Incorrect renaming item", x))) + l + in out - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect renaming",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect renaming", x)) diff --git a/core/dataStructures/renaming.mli b/core/dataStructures/renaming.mli index 465d0bfca0..0bd1cc95fa 100644 --- a/core/dataStructures/renaming.mli +++ b/core/dataStructures/renaming.mli @@ -18,27 +18,27 @@ val dummy : t val empty : unit -> t val is_identity : t -> bool val identity : int list -> t - val image : t -> Mods.IntSet.t val cyclic_permutation_from_list : stop_at:int -> int list -> t (** very specific use case for Connected_component.remove_ag_cc *) -val imperative_add : debugMode:bool -> int -> int -> t -> bool +val imperative_add : debug_mode:bool -> int -> int -> t -> bool (** @raise Clashing in debug mode @return if the addition preserves injectivity *) -val add : debugMode:bool -> int -> int -> t -> t option +val add : debug_mode:bool -> int -> int -> t -> t option (** @raise Clashing in debug mode @return [None] if the addition would break injectivity *) -val compose : debugMode:bool -> bool -> t -> t -> t +val compose : debug_mode:bool -> bool -> t -> t -> t (** @raise Undefined *) -val apply : debugMode:bool -> t -> int -> int +val apply : debug_mode:bool -> t -> int -> int (** @raise Undefined *) val mem : int -> t -> bool + val inverse : t -> t (** @raise NotBijective *) @@ -46,12 +46,11 @@ val compare : t -> t -> int val equal : t -> t -> bool val min_elt : t -> (int * int) option val fold : (int -> int -> 'a -> 'a) -> t -> 'a -> 'a -val to_list : t -> (int*int) list +val to_list : t -> (int * int) list val print : Format.formatter -> t -> unit (** prints only non identity points *) val print_full : Format.formatter -> t -> unit - val to_yojson : t -> Yojson.Basic.t val of_yojson : Yojson.Basic.t -> t diff --git a/core/dataStructures/result_util.ml b/core/dataStructures/result_util.ml index af2e3c622a..03a021ec61 100644 --- a/core/dataStructures/result_util.ml +++ b/core/dataStructures/result_util.ml @@ -7,20 +7,25 @@ (******************************************************************************) type status = - [ `OK | `Accepted | `Created | - `Bad_request | `Conflict | `Not_found | `Request_timeout ] + [ `OK + | `Accepted + | `Created + | `Bad_request + | `Conflict + | `Not_found + | `Request_timeout ] (** The subset of [Cohttp.Code.status] we need *) type message = { - severity : Logs.level; - text : string ; (*should be an algebraic type*) - range : Locality.t option; + severity: Logs.level; + text: string; (*should be an algebraic type*) + range: Loc.t option; } -type ('a,'b) t = { - value : ('a,'b) Result.result; - status : status; - messages : message list; +type ('a, 'b) t = { + value: ('a, 'b) Result.result; + status: status; + messages: message list; } let write_severity ob x = @@ -33,7 +38,7 @@ let read_severity p lb = | Result.Ok (Some x) -> x | Result.Ok None -> raise (Yojson.Json_error "Message of no severity") | Result.Error (`Msg x) -> - raise (Yojson.Json_error ("While reading severity: "^x)) + raise (Yojson.Json_error ("While reading severity: " ^ x)) let write_status ob = function | `OK -> Buffer.add_string ob "200" @@ -53,39 +58,47 @@ let read_status p lb = | 409 -> `Conflict | 404 -> `Not_found | 408 -> `Request_timeout - | x -> raise (Yojson.Json_error - ("Status "^string_of_int x^" is out of the scope of Kappa")) + | x -> + raise + (Yojson.Json_error + ("Status " ^ string_of_int x ^ " is out of the scope of Kappa")) let write_message ob { severity; text; range } = let () = Buffer.add_char ob '{' in let () = JsonUtil.write_field "severity" write_severity ob severity in let () = JsonUtil.write_comma ob in let () = JsonUtil.write_field "text" Yojson.Basic.write_string ob text in - let () = match range with + let () = + match range with | None -> () | Some r -> let () = JsonUtil.write_comma ob in - JsonUtil.write_field "range" Locality.write_range ob r in + JsonUtil.write_field "range" Loc.write_range ob r + in Buffer.add_char ob '}' let read_message p lb = - let (severity,text,range) = + let severity, text, range = Yojson.Basic.read_fields - (fun (s,t,r) key p lb -> - if key = "severity" then (read_severity p lb,t,r) - else if key = "text" then (s,Yojson.Basic.read_string p lb,r) - else if key = "range" then (s,t,Some (Locality.read_range p lb)) - else raise (Yojson.Json_error ("No field "^key^" expected in message"))) - (Logs.App,"",None) p lb in + (fun (s, t, r) key p lb -> + if key = "severity" then + read_severity p lb, t, r + else if key = "text" then + s, Yojson.Basic.read_string p lb, r + else if key = "range" then + s, t, Some (Loc.read_range p lb) + else + raise (Yojson.Json_error ("No field " ^ key ^ " expected in message"))) + (Logs.App, "", None) p lb + in { severity; text; range } let print_message f { range; text; _ } = match range with - | Some range -> - Locality.print_annot Format.pp_print_string f (text,range) + | Some range -> Loc.print_annoted Format.pp_print_string f (text, range) | None -> Format.pp_print_string f text -let write_t write__ok write__error = fun ob -> function +let write_t write__ok write__error ob = function | { value = Result.Ok x; status; messages } -> Buffer.add_string ob "[\"Ok\","; write__ok ob x; @@ -102,47 +115,51 @@ let write_t write__ok write__error = fun ob -> function Buffer.add_char ob ','; JsonUtil.write_list write_message ob messages; Buffer.add_char ob ']' + let string_of_t write__ok write__error ?(len = 1024) x = let ob = Buffer.create len in write_t write__ok write__error ob x; Buffer.contents ob let read_t_content f p lb = - let v = f p lb in - let () = JsonUtil.read_between_spaces - Yojson.Basic.read_comma p lb in + let v = f p lb in + let () = JsonUtil.read_between_spaces Yojson.Basic.read_comma p lb in let s = read_status p lb in - let () = JsonUtil.read_between_spaces - Yojson.Basic.read_comma p lb in - (v,s,Yojson.Basic.read_list read_message p lb) + let () = JsonUtil.read_between_spaces Yojson.Basic.read_comma p lb in + v, s, Yojson.Basic.read_list read_message p lb -let read_t read__ok read__error = fun p lb -> +let read_t read__ok read__error p lb = let aux_read_t closing p lb = Yojson.Basic.read_space p lb; - let out = Yojson.Basic.map_ident p + let out = + Yojson.Basic.map_ident p (fun s pos len -> - Yojson.Basic.read_space p lb; - Yojson.Basic.read_comma p lb; - Yojson.Basic.read_space p lb; - match String.sub s pos len with - | "Ok" -> - let (v,status,messages) = read_t_content read__ok p lb in - { value = Result.Ok v; status; messages } - | "Error" -> - let (v,status,messages) = read_t_content read__error p lb in - { value = Result.Error v; status; messages } - | x -> raise (Yojson.Json_error ("Field \""^x^ - "\" does not belong to the result type")) - ) lb in + Yojson.Basic.read_space p lb; + Yojson.Basic.read_comma p lb; + Yojson.Basic.read_space p lb; + match String.sub s pos len with + | "Ok" -> + let v, status, messages = read_t_content read__ok p lb in + { value = Result.Ok v; status; messages } + | "Error" -> + let v, status, messages = read_t_content read__error p lb in + { value = Result.Error v; status; messages } + | x -> + raise + (Yojson.Json_error + ("Field \"" ^ x ^ "\" does not belong to the result type"))) + lb + in Yojson.Basic.read_space p lb; closing p lb; Yojson.Basic.read_space p lb; - out in + out + in match Yojson.Basic.start_any_variant p lb with | `Edgy_bracket -> aux_read_t Yojson.Basic.read_gt p lb - | `Double_quote -> - raise (Yojson.Json_error "Not of result type") + | `Double_quote -> raise (Yojson.Json_error "Not of result type") | `Square_bracket -> aux_read_t Yojson.Basic.read_rbr p lb + let t_of_string read__ok read__error s = read_t read__ok read__error (Yojson.Safe.init_lexer ()) (Lexing.from_string s) @@ -150,46 +167,50 @@ let lift ?(ok_status = `OK) ?(error_status = `Bad_request) = function | Result.Ok _ as value -> { value; status = ok_status; messages = [] } | Result.Error _ as value -> { value; status = error_status; messages = [] } -let fold - ~(ok:'ok -> 'a) - ~(error:'error -> 'a) : ('ok,'error) t -> 'a - = +let fold ~(ok : 'ok -> 'a) ~(error : 'error -> 'a) : ('ok, 'error) t -> 'a = function | { value = Result.Ok o; _ } -> ok o | { value = Result.Error e; _ } -> error e -let bind: - type ok a err. ?overwrite_status:status -> ?error_status: status -> - (ok -> (a,err) Result.result) -> (ok,err) t -> (a,err) t = - fun ?overwrite_status ?(error_status = `Bad_request) ok -> function - | { value = Result.Error _; _ } as e -> e - | { value = Result.Ok o; status; messages } -> - match ok o with - | Result.Error _ as value -> { value; status = error_status; messages } - | Result.Ok _ as value -> match overwrite_status with - | None -> { value; status; messages } - | Some status -> { value; status; messages } - -let map: type ok a err. (ok -> a) -> (ok,err) t -> (a,err) t = - fun ok -> function - | { value = Result.Ok o; status; messages } -> - { value = Result.Ok (ok o); status; messages } - | { value = Result.Error _; _ } as e -> e - -let map2: - type a b ok err. (a -> b -> ok) -> (a,err) t -> (b,err) t -> (ok,err) t = - fun f a b -> match a,b with - | { value = Result.Ok a; messages; _ }, - { value = Result.Ok b; status; messages = m' } -> { - value = Result.Ok (f a b); - status; - messages = List.rev_append (List.rev m') messages; - } - | { value = Result.Error _; _ } as e, _ -> e +let bind : + type ok a err. + ?overwrite_status:status -> + ?error_status:status -> + (ok -> (a, err) Result.result) -> + (ok, err) t -> + (a, err) t = + fun ?overwrite_status ?(error_status = `Bad_request) ok -> function + | { value = Result.Error _; _ } as e -> e + | { value = Result.Ok o; status; messages } -> + (match ok o with + | Result.Error _ as value -> { value; status = error_status; messages } + | Result.Ok _ as value -> + (match overwrite_status with + | None -> { value; status; messages } + | Some status -> { value; status; messages })) + +let map : type ok a err. (ok -> a) -> (ok, err) t -> (a, err) t = + fun ok -> function + | { value = Result.Ok o; status; messages } -> + { value = Result.Ok (ok o); status; messages } + | { value = Result.Error _; _ } as e -> e + +let map2 : + type a b ok err. (a -> b -> ok) -> (a, err) t -> (b, err) t -> (ok, err) t = + fun f a b -> + match a, b with + | ( { value = Result.Ok a; messages; _ }, + { value = Result.Ok b; status; messages = m' } ) -> + { + value = Result.Ok (f a b); + status; + messages = List.rev_append (List.rev m') messages; + } + | ({ value = Result.Error _; _ } as e), _ -> e | { value = Result.Ok _; _ }, ({ value = Result.Error _; _ } as e) -> e -let error ?(status=`Bad_request) (error:'error ) : ('ok,'error) t = - { value = Result.Error error; status; messages = []; } +let error ?(status = `Bad_request) (error : 'error) : ('ok, 'error) t = + { value = Result.Error error; status; messages = [] } -let ok ?(status=`OK) (ok : 'ok) : ('ok,'error) t = - { value = Result.Ok ok; status; messages = []; } +let ok ?(status = `OK) (ok : 'ok) : ('ok, 'error) t = + { value = Result.Ok ok; status; messages = [] } diff --git a/core/dataStructures/result_util.mli b/core/dataStructures/result_util.mli index 3c039c6778..e28c9f903b 100644 --- a/core/dataStructures/result_util.mli +++ b/core/dataStructures/result_util.mli @@ -7,38 +7,45 @@ (******************************************************************************) type status = - [ `OK | `Accepted | `Created | - `Bad_request | `Conflict | `Not_found | `Request_timeout ] + [ `OK + | `Accepted + | `Created + | `Bad_request + | `Conflict + | `Not_found + | `Request_timeout ] (** The subset of [Cohttp.Code.status] we need *) type message = { - severity : Logs.level ; - text : string ; (*should be an algebraic type*) - range : Locality.t option; + severity: Logs.level; + text: string; (*should be an algebraic type*) + range: Loc.t option; } -type ('a,'b) t = { - value : ('a,'b) Result.result; - status : status; - messages : message list; +type ('a, 'b) t = { + value: ('a, 'b) Result.result; + status: status; + messages: message list; } val write_message : Buffer.t -> message -> unit - val read_message : Yojson.Safe.lexer_state -> Lexing.lexbuf -> message - val print_message : Format.formatter -> message -> unit val write_t : (Buffer.t -> 'ok -> unit) -> (Buffer.t -> 'error -> unit) -> - Buffer.t -> ('ok, 'error) t -> unit + Buffer.t -> + ('ok, 'error) t -> + unit (** Output a JSON value of type {!t}. *) val string_of_t : (Buffer.t -> 'ok -> unit) -> (Buffer.t -> 'error -> unit) -> - ?len:int -> ('ok, 'error) t -> string + ?len:int -> + ('ok, 'error) t -> + string (** Serialize a value of type {!t} into a JSON string. @param len specifies the initial length of the buffer used internally. Default: 1024. *) @@ -46,24 +53,37 @@ val string_of_t : val read_t : (Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'ok) -> (Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'error) -> - Yojson.Safe.lexer_state -> Lexing.lexbuf -> ('ok, 'error) t + Yojson.Safe.lexer_state -> + Lexing.lexbuf -> + ('ok, 'error) t (** Input JSON data of type {!t}. *) val t_of_string : (Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'ok) -> (Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'error) -> - string -> ('ok, 'error) t + string -> + ('ok, 'error) t (** Deserialize JSON data of type {!t}. *) val lift : - ?ok_status:status -> ?error_status:status -> - ('a, 'b) Result.result -> ('a, 'b) t + ?ok_status:status -> + ?error_status:status -> + ('a, 'b) Result.result -> + ('a, 'b) t + val fold : ok:('ok -> 'a) -> error:('error -> 'a) -> ('ok, 'error) t -> 'a + val bind : - ?overwrite_status:status -> ?error_status: status -> - ('ok -> ('a, 'error) Result.result) -> ('ok, 'error) t -> ('a, 'error) t + ?overwrite_status:status -> + ?error_status:status -> + ('ok -> ('a, 'error) Result.result) -> + ('ok, 'error) t -> + ('a, 'error) t + val map : ('ok -> 'a) -> ('ok, 'error) t -> ('a, 'error) t + val map2 : ('a -> 'b -> 'ok) -> ('a, 'error) t -> ('b, 'error) t -> ('ok, 'error) t + val error : ?status:status -> 'error -> ('ok, 'error) t val ok : ?status:status -> 'ok -> ('ok, 'error) t diff --git a/core/dataStructures/setMap.ml b/core/dataStructures/setMap.ml index c76781046d..916479f503 100644 --- a/core/dataStructures/setMap.ml +++ b/core/dataStructures/setMap.ml @@ -6,252 +6,357 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -module type OrderedType = -sig +module type OrderedType = sig type t + val compare : t -> t -> int val print : Format.formatter -> t -> unit end -type ('parameters,'error,'a) with_log_wrap = +type ('parameters, 'error, 'a) with_log_wrap = ('parameters -> 'error -> string -> string option -> exn -> 'error) -> - 'parameters -> 'error -> 'a + 'parameters -> + 'error -> + 'a -module type Set = -sig +module type Set = sig type elt type t - val empty: t - val is_empty: t -> bool - val singleton: elt -> t - val is_singleton: t -> bool - - val add: elt -> t -> t - val add_with_logs: ('parameters,'error,elt -> t -> 'error * t) with_log_wrap - val remove: elt -> t -> t - val add_while_testing_freshness: - ('parameters,'error,elt -> t -> 'error * bool * t) with_log_wrap - val remove_while_testing_existence: - ('parameters,'error,elt -> t -> 'error * bool * t) with_log_wrap - val remove_with_logs: - ('parameters,'error,elt -> t -> 'error * t) with_log_wrap - val split: elt -> t -> (t * bool * t) - val union: t -> t -> t - val disjoint_union: t -> t -> t option - val inter: t -> t -> t - val minus: t -> t -> t + val empty : t + val is_empty : t -> bool + val singleton : elt -> t + val is_singleton : t -> bool + val add : elt -> t -> t + + val add_with_logs : + ('parameters, 'error, elt -> t -> 'error * t) with_log_wrap + + val remove : elt -> t -> t + + val add_while_testing_freshness : + ('parameters, 'error, elt -> t -> 'error * bool * t) with_log_wrap + + val remove_while_testing_existence : + ('parameters, 'error, elt -> t -> 'error * bool * t) with_log_wrap + + val remove_with_logs : + ('parameters, 'error, elt -> t -> 'error * t) with_log_wrap + + val split : elt -> t -> t * bool * t + val union : t -> t -> t + val disjoint_union : t -> t -> t option + val inter : t -> t -> t + + val minus : t -> t -> t (** [minus a b] contains elements of [a] that are not in [b] *) - val diff: t -> t -> t + val diff : t -> t -> t (** [diff a b] = [minus (union a b) (inter a b)] *) - val minus_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val union_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val disjoint_union_with_logs: - ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val inter_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val diff_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap - (* val split_with_logs: - ('parameters,'error,elt -> t -> 'error * ( t * bool * t)) with_log_wrap *) + val minus_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap - val size: t -> int + val union_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap + + val disjoint_union_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap - val mem: elt -> t -> bool - val exists: (elt -> bool) -> t -> bool - val filter: (elt -> bool) -> t -> t - val filter_with_logs: - ('parameters,'error,(elt -> bool) -> t -> 'error * t) with_log_wrap - val for_all: (elt -> bool) -> t -> bool - val partition: (elt -> bool) -> t -> t * t - val partition_with_logs: - ('parameters,'error,(elt -> bool) -> t -> 'error * t * t) with_log_wrap + val inter_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap - val compare: t -> t -> int - val equal: t -> t -> bool + val diff_with_logs : ('parameters, 'error, t -> t -> 'error * t) with_log_wrap + (* val split_with_logs: + ('parameters,'error,elt -> t -> 'error * ( t * bool * t)) with_log_wrap *) - val subset: t -> t -> bool + val size : t -> int + val mem : elt -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t - val iter: (elt -> unit) -> t -> unit + val filter_with_logs : + ('parameters, 'error, (elt -> bool) -> t -> 'error * t) with_log_wrap - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - val fold_inv: (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val partition : (elt -> bool) -> t -> t * t - val elements: t -> elt list - val print: Format.formatter -> t -> unit + val partition_with_logs : + ('parameters, 'error, (elt -> bool) -> t -> 'error * t * t) with_log_wrap - val choose: t -> elt option - val random: Random.State.t -> t -> elt option - val min_elt: t -> elt option - val max_elt: t -> elt option + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val fold_inv : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val elements : t -> elt list + val print : Format.formatter -> t -> unit + val choose : t -> elt option + val random : Random.State.t -> t -> elt option + val min_elt : t -> elt option + val max_elt : t -> elt option end -module type Map = -sig +module type Map = sig type elt type set type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val size: 'a t -> int - val root: 'a t -> (elt * 'a) option - val max_key: 'a t -> elt option - - val add: elt -> 'a -> 'a t -> 'a t - val remove: elt -> 'a t -> 'a t - val add_while_testing_freshness: - ('parameters,'error, - elt -> 'a -> 'a t -> 'error * bool * 'a t) with_log_wrap - val remove_while_testing_existence: - ('parameters,'error,elt -> 'a t -> 'error * bool * 'a t) with_log_wrap - - val pop: elt -> 'a t -> ('a option * 'a t) - val merge: 'a t -> 'a t -> 'a t - val min_elt: 'a t -> (elt * 'a) option - val find_option: elt -> 'a t -> 'a option - val find_default: 'a -> elt -> 'a t -> 'a - val find_option_with_logs: - ('parameters,'error,elt -> 'a t -> 'error * 'a option) with_log_wrap - val find_default_with_logs: - ('parameters,'error,'a -> elt -> 'a t -> 'error * 'a) with_log_wrap - val mem: elt -> 'a t -> bool - val diff: 'a t -> 'a t -> 'a t * 'a t - val union: 'a t -> 'a t -> 'a t - val update: 'a t -> 'a t -> 'a t - val diff_pred: ('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t * 'a t - val add_with_logs: - ('parameters,'error,elt -> 'a -> 'a t -> 'error * 'a t) with_log_wrap - val remove_with_logs: - ('parameters,'error,elt -> 'a t -> 'error * 'a t) with_log_wrap - - val join_with_logs: - ('parameters,'error, - 'a t -> elt -> 'a -> 'a t -> 'error * 'a t) with_log_wrap - val split_with_logs: - ('parameters,'error, - elt -> 'a t -> 'error * ('a t * 'a option * 'a t)) with_log_wrap - val update_with_logs: - ('parameters,'error,'a t -> 'a t -> 'error * 'a t) with_log_wrap - val map2_with_logs: - ('parameters,'error, - ('parameters -> 'error -> 'a -> 'error * 'c) -> - ('parameters -> 'error -> 'b -> 'error * 'c) -> - ('parameters -> 'error -> 'a -> 'b -> 'error * 'c) -> - 'a t -> 'b t -> 'error * 'c t) with_log_wrap - val map2z_with_logs: - ('parameters,'error, - ('parameters -> 'error -> 'a -> 'a -> 'error * 'a) -> - 'a t -> 'a t -> 'error * 'a t) with_log_wrap - val fold2z_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> ('error * 'c)) -> - 'a t -> 'b t -> 'c -> 'error * 'c) with_log_wrap - val fold2_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'c -> 'error * 'c) -> - ('parameters -> 'error -> elt -> 'b -> 'c -> 'error * 'c) -> - ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> - 'a t -> 'b t -> 'c -> 'error * 'c) with_log_wrap - val fold2_sparse_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> ('error * 'c)) -> - 'a t -> 'b t -> 'c -> 'error * 'c) with_log_wrap - val iter2_sparse_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'b -> 'error) -> - 'a t -> 'b t -> 'error) with_log_wrap - val diff_with_logs: - ('parameters,'error,'a t -> 'a t -> 'error * 'a t * 'a t) with_log_wrap - - val diff_pred_with_logs: - ('parameters,'error, - ('a -> 'a -> bool) -> 'a t -> 'a t -> 'error * 'a t * 'a t) with_log_wrap + val empty : 'a t + val is_empty : 'a t -> bool + val size : 'a t -> int + val root : 'a t -> (elt * 'a) option + val max_key : 'a t -> elt option + val add : elt -> 'a -> 'a t -> 'a t + val remove : elt -> 'a t -> 'a t + + val add_while_testing_freshness : + ( 'parameters, + 'error, + elt -> 'a -> 'a t -> 'error * bool * 'a t ) + with_log_wrap + + val remove_while_testing_existence : + ('parameters, 'error, elt -> 'a t -> 'error * bool * 'a t) with_log_wrap + + val pop : elt -> 'a t -> 'a option * 'a t + val merge : 'a t -> 'a t -> 'a t + val min_elt : 'a t -> (elt * 'a) option + val find_option : elt -> 'a t -> 'a option + val find_default : 'a -> elt -> 'a t -> 'a + + val find_option_with_logs : + ('parameters, 'error, elt -> 'a t -> 'error * 'a option) with_log_wrap + + val find_default_with_logs : + ('parameters, 'error, 'a -> elt -> 'a t -> 'error * 'a) with_log_wrap + + val mem : elt -> 'a t -> bool + val diff : 'a t -> 'a t -> 'a t * 'a t + val union : 'a t -> 'a t -> 'a t + val update : 'a t -> 'a t -> 'a t + val diff_pred : ('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t * 'a t + + val add_with_logs : + ('parameters, 'error, elt -> 'a -> 'a t -> 'error * 'a t) with_log_wrap + + val remove_with_logs : + ('parameters, 'error, elt -> 'a t -> 'error * 'a t) with_log_wrap + + val join_with_logs : + ( 'parameters, + 'error, + 'a t -> elt -> 'a -> 'a t -> 'error * 'a t ) + with_log_wrap + + val split_with_logs : + ( 'parameters, + 'error, + elt -> 'a t -> 'error * ('a t * 'a option * 'a t) ) + with_log_wrap + + val update_with_logs : + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t) with_log_wrap + + val map2_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> 'a -> 'error * 'c) -> + ('parameters -> 'error -> 'b -> 'error * 'c) -> + ('parameters -> 'error -> 'a -> 'b -> 'error * 'c) -> + 'a t -> + 'b t -> + 'error * 'c t ) + with_log_wrap + + val map2z_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> 'a -> 'a -> 'error * 'a) -> + 'a t -> + 'a t -> + 'error * 'a t ) + with_log_wrap + + val fold2z_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'error * 'c ) + with_log_wrap + + val fold2_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'c -> 'error * 'c) -> + ('parameters -> 'error -> elt -> 'b -> 'c -> 'error * 'c) -> + ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'error * 'c ) + with_log_wrap + + val fold2_sparse_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'error * 'c ) + with_log_wrap + + val iter2_sparse_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'b -> 'error) -> + 'a t -> + 'b t -> + 'error ) + with_log_wrap + + val diff_with_logs : + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t * 'a t) with_log_wrap + + val diff_pred_with_logs : + ( 'parameters, + 'error, + ('a -> 'a -> bool) -> 'a t -> 'a t -> 'error * 'a t * 'a t ) + with_log_wrap + val merge_with_logs : - ('parameters,'error,'a t -> 'a t -> 'error * 'a t) with_log_wrap + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t) with_log_wrap + val union_with_logs : - ('parameters,'error,'a t -> 'a t -> 'error * 'a t) with_log_wrap - val fold_restriction_with_logs: - ('parameters,'error, - (elt -> 'a -> ('error * 'b) -> ('error* 'b)) -> - set -> 'a t -> 'b -> 'error * 'b) with_log_wrap - - val fold_restriction_with_missing_associations_with_logs: - ('parameters,'error, - (elt -> 'a -> ('error * 'b) -> ('error* 'b)) -> - (elt -> ('error * 'b) -> ('error * 'b)) -> - set -> 'a t -> 'b -> 'error * 'b) with_log_wrap - - val iter: (elt -> 'a -> unit) -> 'a t -> unit - val fold: (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val fold_with_interruption: (elt -> 'a -> 'b -> ('b,'c) Stop.stop) -> 'a t -> 'b -> ('b,'c) Stop.stop - val monadic_fold2: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> 'c -> ('method_handler * 'c)) -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'c -> ('method_handler * 'c)) -> - ('parameters -> 'method_handler -> - elt -> 'b -> 'c -> ('method_handler * 'c)) -> - 'a t -> 'b t -> 'c -> ('method_handler * 'c) - val monadic_fold2_sparse: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> 'c -> ('method_handler * 'c)) -> - 'a t -> 'b t -> 'c -> ('method_handler * 'c) - val monadic_iter2_sparse: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> 'method_handler) -> - 'a t -> 'b t -> 'method_handler - val monadic_fold_restriction: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> ('method_handler * 'b)) -> - set -> 'a t -> 'b -> 'method_handler * 'b - - val mapi: (elt -> 'a -> 'b) -> 'a t -> 'b t - val map: ('a -> 'b) -> 'a t -> 'b t - val map2: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t - - val for_all: (elt -> 'a -> bool) -> 'a t -> bool - val filter_one: (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t) with_log_wrap + + val fold_restriction_with_logs : + ( 'parameters, + 'error, + (elt -> 'a -> 'error * 'b -> 'error * 'b) -> + set -> + 'a t -> + 'b -> + 'error * 'b ) + with_log_wrap + + val fold_restriction_with_missing_associations_with_logs : + ( 'parameters, + 'error, + (elt -> 'a -> 'error * 'b -> 'error * 'b) -> + (elt -> 'error * 'b -> 'error * 'b) -> + set -> + 'a t -> + 'b -> + 'error * 'b ) + with_log_wrap + + val iter : (elt -> 'a -> unit) -> 'a t -> unit + val fold : (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_with_interruption : + (elt -> 'a -> 'b -> ('b, 'c) Stop.stop) -> 'a t -> 'b -> ('b, 'c) Stop.stop + + val monadic_fold2 : + 'parameters -> + 'method_handler -> + ('parameters -> + 'method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + 'method_handler * 'c) -> + ('parameters -> 'method_handler -> elt -> 'a -> 'c -> 'method_handler * 'c) -> + ('parameters -> 'method_handler -> elt -> 'b -> 'c -> 'method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'method_handler * 'c + + val monadic_fold2_sparse : + 'parameters -> + 'method_handler -> + ('parameters -> + 'method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + 'method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'method_handler * 'c + + val monadic_iter2_sparse : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt -> 'a -> 'b -> 'method_handler) -> + 'a t -> + 'b t -> + 'method_handler + + val monadic_fold_restriction : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt -> 'a -> 'b -> 'method_handler * 'b) -> + set -> + 'a t -> + 'b -> + 'method_handler * 'b + + val mapi : (elt -> 'a -> 'b) -> 'a t -> 'b t + val map : ('a -> 'b) -> 'a t -> 'b t + val map2 : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val for_all : (elt -> 'a -> bool) -> 'a t -> bool + val filter_one : (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val bindings : 'a t -> (elt * 'a) list - val print: + + val print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - val of_json: - ?lab_key:string -> ?lab_value:string -> ?error_msg:string -> + val of_json : + ?lab_key:string -> + ?lab_value:string -> + ?error_msg:string -> (Yojson.Basic.t -> elt) -> (Yojson.Basic.t -> 'value) -> - Yojson.Basic.t -> 'value t + Yojson.Basic.t -> + 'value t - val to_json: - ?lab_key:string -> ?lab_value:string -> + val to_json : + ?lab_key:string -> + ?lab_value:string -> (elt -> Yojson.Basic.t) -> ('value -> Yojson.Basic.t) -> - 'value t -> Yojson.Basic.t + 'value t -> + Yojson.Basic.t end module type S = sig type elt + module Set : Set with type elt = elt module Map : Map with type elt = elt and type set = Set.t end exception DeadCodeIsNotDead of string -module Make(Ord:OrderedType): S with type elt = Ord.t = -struct +module Make (Ord : OrderedType) : S with type elt = Ord.t = struct type elt = Ord.t - module Set = - struct + module Set = struct type elt = Ord.t - module Private : - sig + + module Private : sig type t = private Empty | Node of t * elt * t * int * int val empty : t @@ -260,165 +365,200 @@ struct val node : t -> elt -> t -> t end = struct type t = Empty | Node of t * elt * t * int * int + let empty = Empty + let height = function | Empty -> 0 - | Node(_,_,_,h,_) -> h + | Node (_, _, _, h, _) -> h + let size = function | Empty -> 0 - | Node(_,_,_,_,s) -> s + | Node (_, _, _, _, s) -> s let node left value right = let hl = height left in let hr = height right in - Node(left,value,right,(if hl > hr then hl else hr)+1, - size left + size right + 1) + Node + ( left, + value, + right, + (if hl > hr then + hl + else + hr) + + 1, + size left + size right + 1 ) end type t = Private.t + let empty = Private.empty let height = Private.height let size = Private.size let node = Private.node - let is_empty = function Private.Empty -> true | Private.Node _ -> false + let is_empty = function + | Private.Empty -> true + | Private.Node _ -> false + let singleton value = node empty value empty + let is_singleton set = match set with - Private.Empty -> false - | Private.Node (set1,_,set2,_,_) -> is_empty set1 && is_empty set2 + | Private.Empty -> false + | Private.Node (set1, _, set2, _, _) -> is_empty set1 && is_empty set2 let balance left value right = let height_left = height left in let height_right = height right in - if height_left > height_right + 2 then + if height_left > height_right + 2 then ( match left with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 222") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 222") (* height_left > height_right + 2 >= 2 *) - | Private.Node(leftleft,leftvalue,leftright,_,_) -> + | Private.Node (leftleft, leftvalue, leftright, _, _) -> if height leftleft >= height leftright then node leftleft leftvalue (node leftright value right) - else + else ( match leftright with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 229") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 229") (* 0 <= height leftleft < height leftright *) - | Private.Node - (leftrightleft,leftrightvalue,leftrightright,_,_) -> + | Private.Node (leftrightleft, leftrightvalue, leftrightright, _, _) + -> node (node leftleft leftvalue leftrightleft) leftrightvalue (node leftrightright value right) - else if height_right > height_left + 2 then + ) + ) else if height_right > height_left + 2 then ( match right with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 238") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 238") (* height_right > height_left + 2 >= 2 *) - | Private.Node(rightleft,rightvalue,rightright,_,_) -> + | Private.Node (rightleft, rightvalue, rightright, _, _) -> if height rightright >= height rightleft then node (node left value rightleft) rightvalue rightright - else + else ( match rightleft with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 245") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 245") (* 0 <= height rightright < height rightleft *) - | Private.Node - (rightleftleft,rightleftvalue,rightleftright,_,_) -> + | Private.Node (rightleftleft, rightleftvalue, rightleftright, _, _) + -> node (node left value rightleftleft) rightleftvalue (node rightleftright rightvalue rightright) - else node left value right + ) + ) else + node left value right let balance_with_logs warn parameters error left value right = - try error,balance left value right + try error, balance left value right with DeadCodeIsNotDead loc -> let error = - warn - parameters error "setMap.ml" - (Some (loc^" Set invariant is broken, keep on with unbalanced set")) + warn parameters error "setMap.ml" + (Some (loc ^ " Set invariant is broken, keep on with unbalanced set")) (Failure "Set_and_Map.SET.balance") - in error,node left value right + in + error, node left value right (** Beware some code relies on the invariant [add x s == s] iff [mem x s] *) let rec add x = function | Private.Empty -> singleton x - | Private.Node(l, v, r, _,_) as t -> + | Private.Node (l, v, r, _, _) as t -> let c = Ord.compare x v in - if c = 0 then t else - if c < 0 - then let o = add x l in if o == l then t else balance o v r - else let o = add x r in if o == r then t else balance l v o + if c = 0 then + t + else if c < 0 then ( + let o = add x l in + if o == l then + t + else + balance o v r + ) else ( + let o = add x r in + if o == r then + t + else + balance l v o + ) let rec add_while_testing_freshness warn parameters error new_val set = match set with | Private.Empty -> error, true, singleton new_val - | Private.Node(left,value_set,right,_,_) -> + | Private.Node (left, value_set, right, _, _) -> let c = Ord.compare new_val value_set in - if c = 0 then error,false,set - else if c<0 then + if c = 0 then + error, false, set + else if c < 0 then ( let error, bool, left' = - add_while_testing_freshness warn parameters error new_val left in + add_while_testing_freshness warn parameters error new_val left + in let error, set = - balance_with_logs warn parameters error left' value_set right in - error,bool,set - else + balance_with_logs warn parameters error left' value_set right + in + error, bool, set + ) else ( let error, bool, right' = - add_while_testing_freshness warn parameters error new_val right in + add_while_testing_freshness warn parameters error new_val right + in let error, set = - balance_with_logs warn parameters error left value_set right' in + balance_with_logs warn parameters error left value_set right' + in error, bool, set + ) let add_with_logs warn parameters error new_value set = let error, bool, set = - add_while_testing_freshness warn parameters error new_value set in + add_while_testing_freshness warn parameters error new_value set + in let error = if bool then error else - warn - parameters error "setMap.ml" - (Some ("SetMap line 300"^" an already elt has been added to a set")) + warn parameters error "setMap.ml" + (Some ("SetMap line 300" ^ " an already elt has been added to a set")) (Failure "Set_and_Map.SET.add") in error, set let add_even_if_it_exists warn parameters error new_value set = - let error,_,set = - add_while_testing_freshness warn parameters error new_value set in - error,set + let error, _, set = + add_while_testing_freshness warn parameters error new_value set + in + error, set let rec join left value right = - match left,right with - | Private.Empty,_ -> add value right - | _,Private.Empty -> add value left - | Private.Node(leftleft,leftvalue,leftright,leftheight,_), - Private.Node(rightleft,rightvalue,rightright,rightheight,_) -> - if leftheight > rightheight + 2 then + match left, right with + | Private.Empty, _ -> add value right + | _, Private.Empty -> add value left + | ( Private.Node (leftleft, leftvalue, leftright, leftheight, _), + Private.Node (rightleft, rightvalue, rightright, rightheight, _) ) -> + if leftheight > rightheight + 2 then ( let right' = join leftright value right in balance leftleft leftvalue right' - else if rightheight > leftheight +2 then + ) else if rightheight > leftheight + 2 then ( let left' = join left value rightleft in balance left' rightvalue rightright - else node left value right + ) else + node left value right let rec safe_extract_min_elt left value right = match left with - | Private.Empty -> value,right - | Private.Node (leftleft,leftvalue,leftright,_,_) -> - let min,left' = - safe_extract_min_elt leftleft leftvalue leftright in - min,balance left' value right + | Private.Empty -> value, right + | Private.Node (leftleft, leftvalue, leftright, _, _) -> + let min, left' = safe_extract_min_elt leftleft leftvalue leftright in + min, balance left' value right - let rec min_elt_with_logs warn parameters error set = + let rec min_elt_with_logs warn parameters error set = match set with | Private.Empty -> - let error = warn parameters error "setMap.ml" - (Some "min_elt_with_logs, line 303") Not_found in - error,None - | Private.Node(Private.Empty,v,_,_,_) -> error,Some v - | Private.Node(left,_,_,_,_) -> + let error = + warn parameters error "setMap.ml" (Some "min_elt_with_logs, line 303") + Not_found + in + error, None + | Private.Node (Private.Empty, v, _, _, _) -> error, Some v + | Private.Node (left, _, _, _, _) -> min_elt_with_logs warn parameters error left let rec remove_min_elt_with_logs warn parameters error set = @@ -426,291 +566,341 @@ struct | Private.Empty -> let error = warn parameters error "setMap.ml" - (Some "remove_min_elt_with_logs, line 311") Not_found in - error,empty - | Private.Node(Private.Empty,_,right,_,_) -> error,right - | Private.Node(left,value,right,_,_) -> + (Some "remove_min_elt_with_logs, line 311") Not_found + in + error, empty + | Private.Node (Private.Empty, _, right, _, _) -> error, right + | Private.Node (left, value, right, _, _) -> let error, left' = - remove_min_elt_with_logs warn parameters error left in + remove_min_elt_with_logs warn parameters error left + in balance_with_logs warn parameters error left' value right let merge set1 set2 = - match set1,set2 with - | Private.Empty,_ -> set2 - | _,Private.Empty -> set1 - | Private.Node _, Private.Node (left2,value2,right2,_,_) -> - let min2,set2' = safe_extract_min_elt left2 value2 right2 in + match set1, set2 with + | Private.Empty, _ -> set2 + | _, Private.Empty -> set1 + | Private.Node _, Private.Node (left2, value2, right2, _, _) -> + let min2, set2' = safe_extract_min_elt left2 value2 right2 in balance set1 min2 set2' let merge_with_logs warn parameters error set1 set2 = - match set1,set2 with - | Private.Empty,_ -> error,set2 - | _,Private.Empty -> error,set1 + match set1, set2 with + | Private.Empty, _ -> error, set2 + | _, Private.Empty -> error, set1 | Private.Node _, Private.Node _ -> - let error,left2 = - remove_min_elt_with_logs warn parameters error set2 in - let error,elt_opt = min_elt_with_logs warn parameters error set2 in - match elt_opt with + let error, left2 = + remove_min_elt_with_logs warn parameters error set2 + in + let error, elt_opt = min_elt_with_logs warn parameters error set2 in + (match elt_opt with | None -> - let error = warn parameters error "setMap.ml" - (Some "merge_with_logs,line 339") Not_found in - error,set1 - | Some elt -> - balance_with_logs warn parameters error set1 elt left2 + let error = + warn parameters error "setMap.ml" (Some "merge_with_logs,line 339") + Not_found + in + error, set1 + | Some elt -> balance_with_logs warn parameters error set1 elt left2) let rec join_with_logs warn parameters error left value right = - match left,right with - | Private.Empty,_ -> add_with_logs warn parameters error value right - | _,Private.Empty -> add_with_logs warn parameters error value left - | Private.Node(leftleft,leftvalue,leftright,leftheight,_), - Private.Node(rightleft,rightvalue,rightright,rightheight,_) -> - if leftheight > rightheight + 2 then + match left, right with + | Private.Empty, _ -> add_with_logs warn parameters error value right + | _, Private.Empty -> add_with_logs warn parameters error value left + | ( Private.Node (leftleft, leftvalue, leftright, leftheight, _), + Private.Node (rightleft, rightvalue, rightright, rightheight, _) ) -> + if leftheight > rightheight + 2 then ( let error, right' = - join_with_logs warn parameters error leftright value right in + join_with_logs warn parameters error leftright value right + in balance_with_logs warn parameters error leftleft leftvalue right' - else if rightheight > leftheight +2 then + ) else if rightheight > leftheight + 2 then ( let error, left' = - join_with_logs warn parameters error left value rightleft in + join_with_logs warn parameters error left value rightleft + in balance_with_logs warn parameters error left' rightvalue rightright - else - error,node left value right + ) else + error, node left value right let concat set1 set2 = - match set1,set2 with - | Private.Empty,_ -> set2 - | _,Private.Empty -> set1 - | Private.Node _, Private.Node (left2,value2,right2,_,_) -> - let min2,set2' = safe_extract_min_elt left2 value2 right2 in + match set1, set2 with + | Private.Empty, _ -> set2 + | _, Private.Empty -> set1 + | Private.Node _, Private.Node (left2, value2, right2, _, _) -> + let min2, set2' = safe_extract_min_elt left2 value2 right2 in join set1 min2 set2' let concat_with_logs warn parameters error set1 set2 = - match set1,set2 with - | Private.Empty,_ -> error,set2 - | _,Private.Empty -> error,set1 + match set1, set2 with + | Private.Empty, _ -> error, set2 + | _, Private.Empty -> error, set1 | Private.Node _, Private.Node _ -> - let error,left2 = - remove_min_elt_with_logs warn parameters error set2 in - let error,elt_opt = - min_elt_with_logs warn parameters error set2 in - match elt_opt with + let error, left2 = + remove_min_elt_with_logs warn parameters error set2 + in + let error, elt_opt = min_elt_with_logs warn parameters error set2 in + (match elt_opt with | None -> - let error = warn parameters error "setMap.ml" - (Some "concat_with_logs,line 390") Not_found in - error,set1 - | Some elt -> join_with_logs warn parameters error set1 elt left2 + let error = + warn parameters error "setMap.ml" (Some "concat_with_logs,line 390") + Not_found + in + error, set1 + | Some elt -> join_with_logs warn parameters error set1 elt left2) let rec split_with_logs warn parameters error split_val set = match set with - | Private.Empty -> error,(empty,false,empty) - | Private.Node(left,set_val,right,_,_) -> + | Private.Empty -> error, (empty, false, empty) + | Private.Node (left, set_val, right, _, _) -> let c = Ord.compare split_val set_val in - if c=0 then error,(left,true,right) - else if c<0 then - let error,(leftleft,bool,rightleft) = - split_with_logs warn parameters error split_val left in - let error,rightright = - join_with_logs warn parameters error rightleft set_val right in - error,(leftleft,bool,rightright) - else - let error,(leftright,bool,rightright) = - split_with_logs warn parameters error split_val right in - let error,leftleft = - join_with_logs warn parameters error left set_val leftright in - error,(leftleft,bool,rightright) + if c = 0 then + error, (left, true, right) + else if c < 0 then ( + let error, (leftleft, bool, rightleft) = + split_with_logs warn parameters error split_val left + in + let error, rightright = + join_with_logs warn parameters error rightleft set_val right + in + error, (leftleft, bool, rightright) + ) else ( + let error, (leftright, bool, rightright) = + split_with_logs warn parameters error split_val right + in + let error, leftleft = + join_with_logs warn parameters error left set_val leftright + in + error, (leftleft, bool, rightright) + ) let rec remove value = function | Private.Empty as set -> set - | Private.Node(left,value_set,right,_,_) as set -> + | Private.Node (left, value_set, right, _, _) as set -> let c = Ord.compare value value_set in - if c = 0 then merge left right - else if c < 0 then + if c = 0 then + merge left right + else if c < 0 then ( let left' = remove value left in - if left == left' then set else balance left' value_set right - else + if left == left' then + set + else + balance left' value_set right + ) else ( let right' = remove value right in - if right == right' then set else balance left value_set right' + if right == right' then + set + else + balance left value_set right' + ) let rec remove_while_testing_existence warn parameters error value = function | Private.Empty as set -> error, false, set - | Private.Node(left,value_set,right,_,_) as set -> + | Private.Node (left, value_set, right, _, _) as set -> let c = Ord.compare value value_set in - if c = 0 then - let error,set = - merge_with_logs warn parameters error left right in + if c = 0 then ( + let error, set = merge_with_logs warn parameters error left right in error, true, set - else if c < 0 then - let error, bool, left' = remove_while_testing_existence - warn parameters error value left in - if left == left' then + ) else if c < 0 then ( + let error, bool, left' = + remove_while_testing_existence warn parameters error value left + in + if left == left' then ( let error = - if bool - then - warn parameters error "setMap.ml" - (Some "SetMap line 454") + if bool then + warn parameters error "setMap.ml" (Some "SetMap line 454") (failwith "Invariant is broken") - else error + else + error in error, bool, set - else - let error,set = - balance_with_logs - warn parameters error left' value_set right in + ) else ( + let error, set = + balance_with_logs warn parameters error left' value_set right + in error, bool, set - else - let error, bool, right' = remove_while_testing_existence - warn parameters error value right in - if right == right' then + ) + ) else ( + let error, bool, right' = + remove_while_testing_existence warn parameters error value right + in + if right == right' then ( let error = - if bool - then - warn parameters error "setMap.ml" - (Some "SetMap line 467") Not_found - else error + if bool then + warn parameters error "setMap.ml" (Some "SetMap line 467") + Not_found + else + error in error, bool, set - else - let error,set = - balance_with_logs - warn parameters error left value_set right' in + ) else ( + let error, set = + balance_with_logs warn parameters error left value_set right' + in error, bool, set + ) + ) let remove_with_logs warn parameters error value set = let error, bool, set = - remove_while_testing_existence warn parameters error value set in - if bool then error,set + remove_while_testing_existence warn parameters error value set + in + if bool then + error, set else - warn - parameters error "setMap.ml" - (Some ("SetMap line 481"^"Attempt to remove an elt that does not exist")) - Not_found, - set + ( warn parameters error "setMap.ml" + (Some + ("SetMap line 481" + ^ "Attempt to remove an elt that does not exist")) + Not_found, + set ) let rec split split_value set = match set with - | Private.Empty -> (empty,false,empty) - | Private.Node(left,set_value,right,_,_) -> + | Private.Empty -> empty, false, empty + | Private.Node (left, set_value, right, _, _) -> let c = Ord.compare split_value set_value in - if c=0 then (left,true,right) - else if c<0 then - let (leftleft,bool,rightleft) = split split_value left in + if c = 0 then + left, true, right + else if c < 0 then ( + let leftleft, bool, rightleft = split split_value left in let rightright = join rightleft set_value right in - (leftleft,bool,rightright) - else - let (leftright,bool,rightright) = split split_value right in + leftleft, bool, rightright + ) else ( + let leftright, bool, rightright = split split_value right in let leftleft = join left set_value leftright in - (leftleft,bool,rightright) + leftleft, bool, rightright + ) let rec union set1 set2 = - match set1,set2 with - | Private.Empty,_ -> set2 - | _,Private.Empty -> set1 - | Private.Node(left1,value1,right1,height1,_), - Private.Node(left2,value2,right2,height2,_) -> + match set1, set2 with + | Private.Empty, _ -> set2 + | _, Private.Empty -> set1 + | ( Private.Node (left1, value1, right1, height1, _), + Private.Node (left2, value2, right2, height2, _) ) -> if height1 > height2 then - if height2 = 1 then add value2 set1 - else - let (left2,_,right2) = split value1 set2 in + if height2 = 1 then + add value2 set1 + else ( + let left2, _, right2 = split value1 set2 in let left' = union left1 left2 in let right' = union right1 right2 in join left' value1 right' - else - if height1 = 1 then add value1 set2 - else - let (left1,_,right1) = split value2 set1 in + ) + else if height1 = 1 then + add value1 set2 + else ( + let left1, _, right1 = split value2 set1 in let left' = union left1 left2 in let right' = union right1 right2 in join left' value2 right' + ) let rec disjoint_union set1 set2 = - match set1,set2 with - | Private.Empty,_ -> Some set2 - | _,Private.Empty -> Some set1 - | Private.Node(left1,value1,right1,height1,_), - Private.Node(left2,value2,right2,height2,_) -> + match set1, set2 with + | Private.Empty, _ -> Some set2 + | _, Private.Empty -> Some set1 + | ( Private.Node (left1, value1, right1, height1, _), + Private.Node (left2, value2, right2, height2, _) ) -> if height1 > height2 then - if height2 = 1 then + if height2 = 1 then ( let out = add value2 set1 in - if out == set1 then None else Some out - else - let (left2,_,right2) = split value1 set2 in - match disjoint_union left1 left2, - disjoint_union right1 right2 with + if out == set1 then + None + else + Some out + ) else ( + let left2, _, right2 = split value1 set2 in + match disjoint_union left1 left2, disjoint_union right1 right2 with | Some left', Some right' -> Some (join left' value1 right') | _, _ -> None - else - if height1 = 1 then + ) + else if height1 = 1 then ( let out = add value1 set2 in - if set2 == out then None else Some out - else - let (left1,_,right1) = split value2 set1 in - match disjoint_union left1 left2, - disjoint_union right1 right2 with + if set2 == out then + None + else + Some out + ) else ( + let left1, _, right1 = split value2 set1 in + match disjoint_union left1 left2, disjoint_union right1 right2 with | Some left', Some right' -> Some (join left' value2 right') | _, _ -> None + ) let rec union_gen add_gen warn parameters error set1 set2 = - match set1,set2 with - | Private.Empty,_ -> error,set2 - | _,Private.Empty -> error,set1 - | Private.Node(left1,value1,right1,height1,_), - Private.Node(left2,value2,right2,height2,_) -> + match set1, set2 with + | Private.Empty, _ -> error, set2 + | _, Private.Empty -> error, set1 + | ( Private.Node (left1, value1, right1, height1, _), + Private.Node (left2, value2, right2, height2, _) ) -> if height1 > height2 then - if height2 = 1 then add_gen warn parameters error value2 set1 - else - let error,(left2,_,right2) = - split_with_logs warn parameters error value1 set2 in - let error,left' = - union_gen add_gen warn parameters error left1 left2 in + if height2 = 1 then + add_gen warn parameters error value2 set1 + else ( + let error, (left2, _, right2) = + split_with_logs warn parameters error value1 set2 + in + let error, left' = + union_gen add_gen warn parameters error left1 left2 + in let error, right' = - union_gen add_gen warn parameters error right1 right2 in + union_gen add_gen warn parameters error right1 right2 + in join_with_logs warn parameters error left' value1 right' - else - if height1 = 1 then add_gen warn parameters error value1 set2 - else - let error,(left1,_,right1) = - split_with_logs warn parameters error value2 set1 in - let error,left' = - union_gen add_gen warn parameters error left1 left2 in - let error,right' = - union_gen add_gen warn parameters error right1 right2 in + ) + else if height1 = 1 then + add_gen warn parameters error value1 set2 + else ( + let error, (left1, _, right1) = + split_with_logs warn parameters error value2 set1 + in + let error, left' = + union_gen add_gen warn parameters error left1 left2 + in + let error, right' = + union_gen add_gen warn parameters error right1 right2 + in join_with_logs warn parameters error left' value2 right' + ) - let union_with_logs w p e s s' = - union_gen add_even_if_it_exists w p e s s' - let disjoint_union_with_logs w p e s s' = - union_gen add_with_logs w p e s s' + let union_with_logs w p e s s' = union_gen add_even_if_it_exists w p e s s' + let disjoint_union_with_logs w p e s s' = union_gen add_with_logs w p e s s' - let suture (left1,value1,right1) (left2,bool,right2) f = + let suture (left1, value1, right1) (left2, bool, right2) f = let left' = f left1 left2 in let right' = f right1 right2 in - if bool then join left' value1 right' else concat left' right' + if bool then + join left' value1 right' + else + concat left' right' - let suture_not (left1,value1,right1) (left2,bool,right2) f = + let suture_not (left1, value1, right1) (left2, bool, right2) f = let left' = f left1 left2 in let right' = f right1 right2 in - if bool then concat left' right' else join left' value1 right' + if bool then + concat left' right' + else + join left' value1 right' let rec inter set1 set2 = - match set1,set2 with - | Private.Empty,_ - | _,Private.Empty -> empty - | Private.Node(left1,value1,right1,_,_),_ -> + match set1, set2 with + | Private.Empty, _ | _, Private.Empty -> empty + | Private.Node (left1, value1, right1, _, _), _ -> let triple2 = split value1 set2 in - suture (left1,value1,right1) triple2 inter + suture (left1, value1, right1) triple2 inter - let suture_with_logs - warn parameters error (left1,value1,right1) (left2,bool,right2) f = - let error ,left' = f warn parameters error left1 left2 in + let suture_with_logs warn parameters error (left1, value1, right1) + (left2, bool, right2) f = + let error, left' = f warn parameters error left1 left2 in let error, right' = f warn parameters error right1 right2 in if bool then join_with_logs warn parameters error left' value1 right' else concat_with_logs warn parameters error left' right' - let suture_not_with_logs - warn parameters error (left1,value1,right1) (left2,bool,right2) f = - let error ,left' = f warn parameters error left1 left2 in + let suture_not_with_logs warn parameters error (left1, value1, right1) + (left2, bool, right2) f = + let error, left' = f warn parameters error left1 left2 in let error, right' = f warn parameters error right1 right2 in if bool then concat_with_logs warn parameters error left' right' @@ -718,122 +908,146 @@ struct join_with_logs warn parameters error left' value1 right' let rec inter_with_logs warn parameters error set1 set2 = - match set1,set2 with - | Private.Empty,_ - | _,Private.Empty -> error,empty - | Private.Node(left1,value1,right1,_,_),_ -> - let mh',triple2 = - split_with_logs warn parameters error value1 set2 in - suture_with_logs - warn parameters mh' (left1,value1,right1) triple2 inter_with_logs + match set1, set2 with + | Private.Empty, _ | _, Private.Empty -> error, empty + | Private.Node (left1, value1, right1, _, _), _ -> + let mh', triple2 = split_with_logs warn parameters error value1 set2 in + suture_with_logs warn parameters mh' (left1, value1, right1) triple2 + inter_with_logs let rec diff set1 set2 = - match set1,set2 with - | Private.Empty,_ -> set2 - | _,Private.Empty -> set1 - | Private.Node(left1,value1,right1,_,_),_ -> + match set1, set2 with + | Private.Empty, _ -> set2 + | _, Private.Empty -> set1 + | Private.Node (left1, value1, right1, _, _), _ -> let triple2 = split value1 set2 in - suture_not (left1,value1,right1) triple2 diff + suture_not (left1, value1, right1) triple2 diff let rec diff_with_logs warn parameters error set1 set2 = - match set1,set2 with - | Private.Empty,_ -> error,empty - | _,Private.Empty -> error,set1 - | Private.Node(left1,value1,right1,_,_),_ -> - let error,triple2 = - split_with_logs warn parameters error value1 set2 in - suture_not_with_logs - warn parameters error (left1,value1,right1) triple2 diff_with_logs + match set1, set2 with + | Private.Empty, _ -> error, empty + | _, Private.Empty -> error, set1 + | Private.Node (left1, value1, right1, _, _), _ -> + let error, triple2 = + split_with_logs warn parameters error value1 set2 + in + suture_not_with_logs warn parameters error (left1, value1, right1) + triple2 diff_with_logs let rec minus set1 set2 = - match set1,set2 with - | Private.Empty,_ -> empty - | _,Private.Empty -> set1 - | Private.Node(left1,value1,right1,_,_),_ -> + match set1, set2 with + | Private.Empty, _ -> empty + | _, Private.Empty -> set1 + | Private.Node (left1, value1, right1, _, _), _ -> let triple2 = split value1 set2 in - suture_not (left1,value1,right1) triple2 minus + suture_not (left1, value1, right1) triple2 minus let rec minus_with_logs warn parameters error set1 set2 = - match set1,set2 with - | Private.Empty,_ -> error,empty - | _,Private.Empty -> error,set1 - | Private.Node(left1,value1,right1,_,_),_ -> - let error,triple2 = - split_with_logs warn parameters error value1 set2 in - suture_not_with_logs - warn parameters error (left1,value1,right1) triple2 minus_with_logs + match set1, set2 with + | Private.Empty, _ -> error, empty + | _, Private.Empty -> error, set1 + | Private.Node (left1, value1, right1, _, _), _ -> + let error, triple2 = + split_with_logs warn parameters error value1 set2 + in + suture_not_with_logs warn parameters error (left1, value1, right1) + triple2 minus_with_logs let rec mem searched_value = function | Private.Empty -> false - | Private.Node(left,set_value,right,_,_) -> + | Private.Node (left, set_value, right, _, _) -> let c = Ord.compare searched_value set_value in - c==0 || mem searched_value (if c < 0 then left else right) + c == 0 + || mem searched_value + (if c < 0 then + left + else + right) let filter p set = let rec filt accu = function | Private.Empty -> accu - | Private.Node(left,value,right,_,_) -> - filt (filt (if p value then add value accu else accu) left) right - in filt empty set + | Private.Node (left, value, right, _, _) -> + filt + (filt + (if p value then + add value accu + else + accu) + left) + right + in + filt empty set let filter_with_logs warn parameters error p set = let rec filt accu set = match set with | Private.Empty -> accu - | Private.Node(left,value,right,_,_) -> - let error,list = accu in - filt (filt (if p value - then add_with_logs warn parameters error value list - else accu) left) right in - filt (error,empty) set + | Private.Node (left, value, right, _, _) -> + let error, list = accu in + filt + (filt + (if p value then + add_with_logs warn parameters error value list + else + accu) + left) + right + in + filt (error, empty) set let partition p set = - let rec part (t,f as accu) = function + let rec part ((t, f) as accu) = function | Private.Empty -> accu - | Private.Node(left,value,right,_,_) -> + | Private.Node (left, value, right, _, _) -> part (part - (if p value then add value t,f else t,add value f) + (if p value then + add value t, f + else + t, add value f) left) right - in part (empty,empty) set + in + part (empty, empty) set let partition_with_logs warn parameters error p set = - let rec part (rh,t,f as accu) set = + let rec part ((rh, t, f) as accu) set = match set with | Private.Empty -> accu - | Private.Node(left,value,right,_,_) -> + | Private.Node (left, value, right, _, _) -> part (part - begin - if p value then - let a,b = add_with_logs warn parameters rh value t - in a,b,f - else - let a,c = add_with_logs warn parameters rh value f in - a,t,c - end + (if p value then ( + let a, b = add_with_logs warn parameters rh value t in + a, b, f + ) else ( + let a, c = add_with_logs warn parameters rh value f in + a, t, c + )) left) right in - part (error,empty,empty) set + part (error, empty, empty) set type enumeration = End | More of elt * t * enumeration let rec cons_enum enum = function | Private.Empty -> enum - | Private.Node(left,value,right,_,_) -> - cons_enum (More(value,right,enum)) left + | Private.Node (left, value, right, _, _) -> + cons_enum (More (value, right, enum)) left let rec compare_aux e1 e2 = - match e1,e2 with - | End,End -> 0 - | End,_ -> -1 - | _ , End -> 1 - | More(v1,r1,e1),More(v2,r2,e2) -> + match e1, e2 with + | End, End -> 0 + | End, _ -> -1 + | _, End -> 1 + | More (v1, r1, e1), More (v2, r2, e2) -> let c = Ord.compare v1 v2 in - if c<>0 then c - else compare_aux (cons_enum e1 r1) (cons_enum e2 r2) + if c <> 0 then + c + else + compare_aux (cons_enum e1 r1) (cons_enum e2 r2) let compare set1 set2 = compare_aux (cons_enum End set1) (cons_enum End set2) @@ -841,13 +1055,13 @@ struct let equal set1 set2 = compare set1 set2 == 0 let rec subset set1 set2 = - match set1,set2 with - | Private.Empty,_ -> true - | _,Private.Empty -> false - | Private.Node(left1,value1,right1,_,_), - Private.Node(left2,value2,right2,_,_) -> + match set1, set2 with + | Private.Empty, _ -> true + | _, Private.Empty -> false + | ( Private.Node (left1, value1, right1, _, _), + Private.Node (left2, value2, right2, _, _) ) -> let c = Ord.compare value1 value2 in - if c=0 then + if c = 0 then subset left1 left2 && subset right1 right2 else if c < 0 then subset (node left1 value1 empty) left2 && subset right1 set2 @@ -856,48 +1070,51 @@ struct let rec iter f = function | Private.Empty -> () - | Private.Node(left,value,right,_,_) -> - let () = iter f left in let () = f value in iter f right + | Private.Node (left, value, right, _, _) -> + let () = iter f left in + let () = f value in + iter f right let rec fold f set accu = match set with | Private.Empty -> accu - | Private.Node(left,value,right,_,_) -> + | Private.Node (left, value, right, _, _) -> fold f right (f value (fold f left accu)) let rec fold_inv f s accu = match s with - Private.Empty -> accu - | Private.Node(l, v, r, _,_) -> fold_inv f l (f v (fold_inv f r accu)) + | Private.Empty -> accu + | Private.Node (l, v, r, _, _) -> fold_inv f l (f v (fold_inv f r accu)) let rec for_all p = function | Private.Empty -> true - | Private.Node(left,value,right,_,_) -> + | Private.Node (left, value, right, _, _) -> p value && for_all p left && for_all p right let rec exists p = function | Private.Empty -> false - | Private.Node(left,value,right,_,_) -> + | Private.Node (left, value, right, _, _) -> p value || exists p left || exists p right let elements set = let rec elements_aux accu = function | Private.Empty -> accu - | Private.Node(left,value,right,_,_) -> - elements_aux (value::(elements_aux accu right)) left - in elements_aux [] set + | Private.Node (left, value, right, _, _) -> + elements_aux (value :: elements_aux accu right) left + in + elements_aux [] set let rec aux_print f = function | Private.Empty -> () - | Private.Node (Private.Empty,key,Private.Empty,_,_) -> + | Private.Node (Private.Empty, key, Private.Empty, _, _) -> Format.fprintf f "@[%a@]" Ord.print key - | Private.Node (Private.Empty,key,right,_,_) -> + | Private.Node (Private.Empty, key, right, _, _) -> Format.fprintf f "@[%a@],@ %a" Ord.print key aux_print right - | Private.Node (left,key,Private.Empty,_,_) -> + | Private.Node (left, key, Private.Empty, _, _) -> Format.fprintf f "%a,@ @[%a@]" aux_print left Ord.print key - | Private.Node (left,key,right,_,_) -> - Format.fprintf f "%a,@ @[%a@],@ %a" - aux_print left Ord.print key aux_print right + | Private.Node (left, key, right, _, _) -> + Format.fprintf f "%a,@ @[%a@],@ %a" aux_print left Ord.print key + aux_print right let print f = function | Private.Empty -> Format.pp_print_string f "\xE2\x88\x85" @@ -905,61 +1122,69 @@ struct let rec min_elt = function | Private.Empty -> None - | Private.Node(Private.Empty,v,_,_,_) -> Some v - | Private.Node(left,_,_,_,_) -> min_elt left + | Private.Node (Private.Empty, v, _, _, _) -> Some v + | Private.Node (left, _, _, _, _) -> min_elt left + let rec max_elt = function | Private.Empty -> None - | Private.Node(_,v,Private.Empty,_,_) -> Some v - | Private.Node(_,_,right,_,_) -> max_elt right + | Private.Node (_, v, Private.Empty, _, _) -> Some v + | Private.Node (_, _, right, _, _) -> max_elt right + let choose = function | Private.Empty -> None - | Private.Node (_,v,_,_,_) -> Some v + | Private.Node (_, v, _, _, _) -> Some v let rec find_acc aim_acc = function - Private.Empty -> None - | Private.Node(l,key,r,_,acc) -> - if aim_acc >= acc then None - else + | Private.Empty -> None + | Private.Node (l, key, r, _, acc) -> + if aim_acc >= acc then + None + else ( let acc_l = size l in let acc_r = size r in - if acc_l > aim_acc then find_acc aim_acc l - else if (acc_r + acc_l) > aim_acc - then find_acc (aim_acc - acc_l) r - else Some key - - (* let rec find_acc k m = *) - (* match m with *) - (* Private.Empty -> None *) - (* | Private.Node (l, key, r, _, _) -> *) - (* let s = size l in *) - (* if k < s then find_acc k l *) - (* else if k = s then Some key *) - (* else find_acc (k - s - 1) r *) + if acc_l > aim_acc then + find_acc aim_acc l + else if acc_r + acc_l > aim_acc then + find_acc (aim_acc - acc_l) r + else + Some key + ) + + (* let rec find_acc k m = + match m with + | Private.Empty -> None + | Private.Node (l, key, r, _, _) -> + let s = size l in + if k < s then find_acc k l + else if k = s then Some key + else find_acc (k - s - 1) r *) let random rs m = let s = size m in - if s = 0 then None else find_acc (Random.State.int rs (size m)) m - - (* let add = Lift_error_logs.lift_generic_binary_for_KaSim add_with_logs - let split = Lift_error_logs.lift_generic_binary_for_KaSim split_with_logs - let remove = Lift_error_logs.lift_generic_binary_for_KaSim remove_with_logs - let union = Lift_error_logs.lift_generic_binary_for_KaSim union_with_logs - let inter = Lift_error_logs.lift_generic_binary_for_KaSim inter_with_logs - let diff = Lift_error_logs.lift_generic_binary_for_KaSim diff_with_logs - let minus = Lift_error_logs.lift_generic_binary_for_KaSim minus_with_logs - let filter = Lift_error_logs.lift_generic_binary_for_KaSim filter_with_logs - let partition = Lift_error_logs.lift_generic_binary_binary_for_KaSim partition_with_logs + if s = 0 then + None + else + find_acc (Random.State.int rs (size m)) m + + (* let add = Lift_error_logs.lift_generic_binary_for_KaSim add_with_logs + let split = Lift_error_logs.lift_generic_binary_for_KaSim split_with_logs + let remove = Lift_error_logs.lift_generic_binary_for_KaSim remove_with_logs + let union = Lift_error_logs.lift_generic_binary_for_KaSim union_with_logs + let inter = Lift_error_logs.lift_generic_binary_for_KaSim inter_with_logs + let diff = Lift_error_logs.lift_generic_binary_for_KaSim diff_with_logs + let minus = Lift_error_logs.lift_generic_binary_for_KaSim minus_with_logs + let filter = Lift_error_logs.lift_generic_binary_for_KaSim filter_with_logs + let partition = Lift_error_logs.lift_generic_binary_binary_for_KaSim partition_with_logs *) end (**************************************************************************) (* Map implementation*) - module Map = - struct + module Map = struct type elt = Ord.t - module Private : - sig + + module Private : sig type +'data t = private | Empty | Node of 'data t * elt * 'data * 'data t * int * int @@ -974,20 +1199,34 @@ struct | Node of 'data t * elt * 'data * 'data t * int * int let empty = Empty + let height = function | Empty -> 0 - | Node(_,_,_,_,h,_) -> h + | Node (_, _, _, _, h, _) -> h + let size = function | Empty -> 0 - | Node(_,_,_,_,_,s) -> s - let node left key0 data right = + | Node (_, _, _, _, _, s) -> s + + let node left key0 data right = let hl = height left in let hr = height right in - Node (left,key0,data,right, 1 + (if hl > hr then hl else hr), - 1 + size left + size right) + Node + ( left, + key0, + data, + right, + (1 + + + if hl > hr then + hl + else + hr), + 1 + size left + size right ) end type +'a t = 'a Private.t + let empty = Private.empty let height = Private.height let size = Private.size @@ -995,739 +1234,821 @@ struct type set = Set.t - let is_empty = function Private.Empty -> true | Private.Node _ -> false + let is_empty = function + | Private.Empty -> true + | Private.Node _ -> false let root = function | Private.Empty -> None - | Private.Node (_,x,d,_,_,_) -> Some (x,d) + | Private.Node (_, x, d, _, _, _) -> Some (x, d) let rec max_key = function | Private.Empty -> None - | Private.Node (_,k,_,Private.Empty,_,_) -> Some k - | Private.Node (_,_,_,m,_,_) -> max_key m + | Private.Node (_, k, _, Private.Empty, _, _) -> Some k + | Private.Node (_, _, _, m, _, _) -> max_key m let balance left key data right = let height_left = height left in let height_right = height right in - if height_left > height_right + 2 then + if height_left > height_right + 2 then ( match left with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 828") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 828") (* height_left > height_right + 2 >= 2 *) - | Private.Node (left0,key0,data0,right0,_,_) -> + | Private.Node (left0, key0, data0, right0, _, _) -> if height left0 >= height right0 then node left0 key0 data0 (node right0 key data right) - else + else ( match right0 with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 835") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 835") (* 0 <= height left0 < height right0 *) - | Private.Node (left1,key1,data1,right1,_,_) -> - node (node left0 key0 data0 left1) + | Private.Node (left1, key1, data1, right1, _, _) -> + node + (node left0 key0 data0 left1) key1 data1 (node right1 key data right) - else - if height_right > height_left + 2 then + ) + ) else if height_right > height_left + 2 then ( match right with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 844") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 844") (* height_right > height_left + 2 >= 2 *) - | Private.Node (left0,key0,data0,right0,_,_) -> + | Private.Node (left0, key0, data0, right0, _, _) -> if height right0 >= height left0 then node (node left key data left0) key0 data0 right0 - else + else ( match left0 with - | Private.Empty -> - raise (DeadCodeIsNotDead "SetMap line 851") + | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 851") (* 0 <= height right0 < height left0 *) - | Private.Node (left1,key1,data1,right1,_,_) -> - node (node left key data left1) - key1 data1 + | Private.Node (left1, key1, data1, right1, _, _) -> + node (node left key data left1) key1 data1 (node right1 key0 data0 right0) - else node left key data right + ) + ) else + node left key data right let balance_with_logs warn parameters error left key data right = - try error,balance left key data right + try error, balance left key data right with DeadCodeIsNotDead loc -> let error = - warn - parameters error "setMap.ml" - (Some (loc^" Map invariant is broken, keep on with unbalanced map")) + warn parameters error "setMap.ml" + (Some (loc ^ " Map invariant is broken, keep on with unbalanced map")) (Failure "Set_and_Map.Map.balance") - in error,node left key data right + in + error, node left key data right let rec add key data = function | Private.Empty -> node empty key data empty - | Private.Node (left,key_map,data_map,right,_,_) -> + | Private.Node (left, key_map, data_map, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then node left key_map data right + if cmp = 0 then + node left key_map data right else if cmp < 0 then balance (add key data left) key_map data_map right - else balance left key_map data_map (add key data right) + else + balance left key_map data_map (add key data right) - let rec add_while_testing_freshness warn parameter error key data = - function - | Private.Empty -> - error, true, node empty key data empty - | Private.Node (left,key_map,data_map,right,_,_) -> + let rec add_while_testing_freshness warn parameter error key data = function + | Private.Empty -> error, true, node empty key data empty + | Private.Node (left, key_map, data_map, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then error, false, node left key_map data right - else if cmp < 0 then + if cmp = 0 then + error, false, node left key_map data right + else if cmp < 0 then ( let error, bool, left' = - add_while_testing_freshness - warn parameter error key data left in + add_while_testing_freshness warn parameter error key data left + in let error, map = - balance_with_logs - warn parameter error left' key_map data_map right in + balance_with_logs warn parameter error left' key_map data_map right + in error, bool, map - else + ) else ( let error, bool, right' = - add_while_testing_freshness - warn parameter error key data right in + add_while_testing_freshness warn parameter error key data right + in let error, map = - balance_with_logs - warn parameter error left key_map data_map right' in + balance_with_logs warn parameter error left key_map data_map right' + in error, bool, map + ) let add_with_logs warn parameter error key data map = let error, bool, map = - add_while_testing_freshness warn parameter error key data map in - if bool - then + add_while_testing_freshness warn parameter error key data map + in + if bool then error, map - else - let a,b,_,_ = __POS__ in - warn - parameter error "setMap.ml " - (Some (a^" line: "^(string_of_int b)^": Attempt to add an association over a former one in a map")) - (Failure "Set_and_Map.Map.add"), - map + else ( + let a, b, _, _ = __POS__ in + ( warn parameter error "setMap.ml " + (Some + (a ^ " line: " ^ string_of_int b + ^ ": Attempt to add an association over a former one in a map")) + (Failure "Set_and_Map.Map.add"), + map ) + ) let rec extract_min_binding map key data map' = match map with - | Private.Empty -> (key,data),map' - | Private.Node (left2,key2,data2,right2,_,_) -> + | Private.Empty -> (key, data), map' + | Private.Node (left2, key2, data2, right2, _, _) -> let min, left' = extract_min_binding left2 key2 data2 right2 in - min,balance left' key data map' + min, balance left' key data map' - let rec extract_min_binding_with_logs - warn parameters error map key data map' = + let rec extract_min_binding_with_logs warn parameters error map key data + map' = match map with - | Private.Empty -> error,((key,data),map') - | Private.Node (left2,key2,data2,right2,_,_) -> - let error,(min, left') = - extract_min_binding_with_logs - warn parameters error left2 key2 data2 right2 in - error,(min,balance left' key data map') + | Private.Empty -> error, ((key, data), map') + | Private.Node (left2, key2, data2, right2, _, _) -> + let error, (min, left') = + extract_min_binding_with_logs warn parameters error left2 key2 data2 + right2 + in + error, (min, balance left' key data map') let merge map1 map2 = match map1 with | Private.Empty -> map2 | Private.Node _ -> - match map2 with + (match map2 with | Private.Empty -> map1 - | Private.Node(left2,key2,data2,right2,_,_) -> - let (key3,data3), left' = - extract_min_binding left2 key2 data2 right2 in - balance map1 key3 data3 left' + | Private.Node (left2, key2, data2, right2, _, _) -> + let (key3, data3), left' = + extract_min_binding left2 key2 data2 right2 + in + balance map1 key3 data3 left') let merge_with_logs warn parameters error map1 map2 = match map1 with - | Private.Empty -> error,map2 + | Private.Empty -> error, map2 | Private.Node _ -> - match map2 with - | Private.Empty -> error,map1 - | Private.Node(left2,key2,data2,right2,_,_) -> - let error,((key3,data3), left') = - extract_min_binding_with_logs - warn parameters error left2 key2 data2 right2 in - balance_with_logs warn parameters error map1 key3 data3 left' + (match map2 with + | Private.Empty -> error, map1 + | Private.Node (left2, key2, data2, right2, _, _) -> + let error, ((key3, data3), left') = + extract_min_binding_with_logs warn parameters error left2 key2 data2 + right2 + in + balance_with_logs warn parameters error map1 key3 data3 left') let rec remove key = function | Private.Empty -> empty - | Private.Node (left,key_map,data,right,_,_) -> + | Private.Node (left, key_map, data, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then merge left right - else if cmp < 0 then balance (remove key left) key_map data right - else balance left key_map data (remove key right) + if cmp = 0 then + merge left right + else if cmp < 0 then + balance (remove key left) key_map data right + else + balance left key_map data (remove key right) let rec remove_while_testing_existence warn parameters error key map = match map with - | Private.Empty -> - error, false, empty - | Private.Node (left,key_map,data,right,_,_) -> + | Private.Empty -> error, false, empty + | Private.Node (left, key_map, data, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then - let error, map = - merge_with_logs warn parameters error left right in + if cmp = 0 then ( + let error, map = merge_with_logs warn parameters error left right in error, true, map - else if cmp < 0 then + ) else if cmp < 0 then ( let error, bool, left' = - remove_while_testing_existence - warn parameters error key left in - begin - if left' == left then - let error = - if bool then - warn parameters error "setMap.ml" - (Some "SetMap line 961") - (failwith "Invariant is broken") - else error in - error, bool, map - else - let error, map = - balance_with_logs - warn parameters error left' key_map data right in - error, bool, map - end - else + remove_while_testing_existence warn parameters error key left + in + if left' == left then ( + let error = + if bool then + warn parameters error "setMap.ml" (Some "SetMap line 961") + (failwith "Invariant is broken") + else + error + in + error, bool, map + ) else ( + let error, map = + balance_with_logs warn parameters error left' key_map data right + in + error, bool, map + ) + ) else ( let error, bool, right' = - remove_while_testing_existence - warn parameters error key right in - begin - if right' == right - then - let error = - if bool then - warn parameters error "setMap.ml" - (Some "SetMap line 978") - (failwith "Invariant is broken") - else error in - error, bool, map - else - let error, map = - balance_with_logs - warn parameters error left key_map data right' in - error, bool, map - end + remove_while_testing_existence warn parameters error key right + in + if right' == right then ( + let error = + if bool then + warn parameters error "setMap.ml" (Some "SetMap line 978") + (failwith "Invariant is broken") + else + error + in + error, bool, map + ) else ( + let error, map = + balance_with_logs warn parameters error left key_map data right' + in + error, bool, map + ) + ) let remove_with_logs warn parameters error key map = - let error, bool,map = - remove_while_testing_existence warn parameters error key map in - if bool then error, map + let error, bool, map = + remove_while_testing_existence warn parameters error key map + in + if bool then + error, map else - warn - parameters error "setMap.ml" - (Some ("SetMap line 994"^"Try to remove an association that is not defined in Map.remove")) - (failwith "Try to remove an association that is not defined in Map.remove"), - map + ( warn parameters error "setMap.ml" + (Some + ("SetMap line 994" + ^ "Try to remove an association that is not defined in Map.remove" + )) + (failwith + "Try to remove an association that is not defined in Map.remove"), + map ) let rec pop x = function - | Private.Empty as m -> (None, m) - | Private.Node(l, v, d, r, _,_) as m -> + | Private.Empty as m -> None, m + | Private.Node (l, v, d, r, _, _) as m -> let c = Ord.compare x v in if c = 0 then - (Some d,merge l r) - else if c < 0 then + Some d, merge l r + else if c < 0 then ( match pop x l with - | None as o, _ -> (o, m) - | Some _ as o, t -> (o, balance t v d r) - else + | (None as o), _ -> o, m + | (Some _ as o), t -> o, balance t v d r + ) else ( match pop x r with - | None as o, _ -> (o, m) - | Some _ as o, t -> (o, balance l v d t) + | (None as o), _ -> o, m + | (Some _ as o), t -> o, balance l v d t + ) let rec join left key value right = match balance left key value right with | Private.Empty -> raise (DeadCodeIsNotDead "SetMap line 1013") (* By case analysis *) - | Private.Node (left2,key2,data2,right2,_,_) as map2 -> + | Private.Node (left2, key2, data2, right2, _, _) as map2 -> let h = height left2 - height right2 in - if h > 2 || h< -2 then join left2 key2 data2 right2 else map2 + if h > 2 || h < -2 then + join left2 key2 data2 right2 + else + map2 let rec join_with_logs warn parameters error left key value right = - match balance_with_logs - warn parameters error left key value right with - | error,Private.Empty -> + match balance_with_logs warn parameters error left key value right with + | error, Private.Empty -> let error = - warn - parameters error "setMap.ml" - (Some "Map.join_with_logs, line 986, the output of balance should not be empty") - (failwith "the output of balance should not be empty") in - error,empty - | error,(Private.Node (left2,key2,data2,right2,_,_) as map2) -> + warn parameters error "setMap.ml" + (Some + "Map.join_with_logs, line 986, the output of balance should not \ + be empty") + (failwith "the output of balance should not be empty") + in + error, empty + | error, (Private.Node (left2, key2, data2, right2, _, _) as map2) -> let h = height left2 - height right2 in - if h > 2 || h< -2 - then join_with_logs warn parameters error left2 key2 data2 right2 - else error,map2 + if h > 2 || h < -2 then + join_with_logs warn parameters error left2 key2 data2 right2 + else + error, map2 let rec split value = function - | Private.Empty -> (empty,None,empty) - | Private.Node (left1,key1,data1,right1,_,_) -> + | Private.Empty -> empty, None, empty + | Private.Node (left1, key1, data1, right1, _, _) -> let cmp = Ord.compare value key1 in - if cmp = 0 then (left1,Some data1,right1) - else if cmp < 0 then - let (left2,data2,right2) = split value left1 in + if cmp = 0 then + left1, Some data1, right1 + else if cmp < 0 then ( + let left2, data2, right2 = split value left1 in let right2' = join right2 key1 data1 right1 in - (left2,data2,right2') - else - let (left2,data2,right2) = split value right1 in + left2, data2, right2' + ) else ( + let left2, data2, right2 = split value right1 in let left2' = join left1 key1 data1 left2 in - (left2',data2,right2) + left2', data2, right2 + ) let rec split_with_logs warn parameters error value map = match map with - | Private.Empty -> error,(empty,None,empty) - | Private.Node (left1,key1,data1,right1,_,_) -> + | Private.Empty -> error, (empty, None, empty) + | Private.Node (left1, key1, data1, right1, _, _) -> let cmp = Ord.compare value key1 in if cmp = 0 then - error,(left1,Some data1,right1) - else if cmp < 0 then - let error,(left2,data2,right2) = - split_with_logs warn parameters error value left1 in - let error,right2' = - join_with_logs - warn parameters error right2 key1 data1 right1 in - error,(left2,data2,right2') - else - let error,(left2,data2,right2) = - split_with_logs warn parameters error value right1 in - let error,left2' = - join_with_logs warn parameters error left1 key1 data1 left2 in - error,(left2',data2,right2) + error, (left1, Some data1, right1) + else if cmp < 0 then ( + let error, (left2, data2, right2) = + split_with_logs warn parameters error value left1 + in + let error, right2' = + join_with_logs warn parameters error right2 key1 data1 right1 + in + error, (left2, data2, right2') + ) else ( + let error, (left2, data2, right2) = + split_with_logs warn parameters error value right1 + in + let error, left2' = + join_with_logs warn parameters error left1 key1 data1 left2 + in + error, (left2', data2, right2) + ) let rec diff map1 map2 = match map1 with - | Private.Empty -> empty,map2 - | Private.Node(left1,key1,data1,right1,_,_) -> - let left2,data2,right2 = split key1 map2 in - let oleft1,oleft2 = diff left1 left2 in - let oright1,oright2 = diff right1 right2 in - match data2 with - | Some x when x = data1 -> - merge oleft1 oright1, merge oleft2 oright2 - | Some data2 -> + | Private.Empty -> empty, map2 + | Private.Node (left1, key1, data1, right1, _, _) -> + let left2, data2, right2 = split key1 map2 in + let oleft1, oleft2 = diff left1 left2 in + let oright1, oright2 = diff right1 right2 in + (match data2 with + | Some x when x = data1 -> merge oleft1 oright1, merge oleft2 oright2 + | Some data2 -> join oleft1 key1 data1 oright1, join oleft2 key1 data2 oright2 - | None -> - join oleft1 key1 data1 oright1, merge oleft2 oright2 + | None -> join oleft1 key1 data1 oright1, merge oleft2 oright2) let rec union map1 map2 = match map1, map2 with | Private.Empty, _ -> map2 | _, Private.Empty -> map1 - | Private.Node (left1, value1, data1, right1, height1,_), - Private.Node (left2, value2, data2, right2, height2,_) -> - if height1 >= height2 then + | ( Private.Node (left1, value1, data1, right1, height1, _), + Private.Node (left2, value2, data2, right2, height2, _) ) -> + if height1 >= height2 then ( let left2, op_data2, right2 = split value1 map2 in - join (union left1 left2) - value1 (match op_data2 with None -> data1 | Some d2 -> d2) + join (union left1 left2) value1 + (match op_data2 with + | None -> data1 + | Some d2 -> d2) (union right1 right2) - else + ) else ( let left1, op_data1, right1 = split value2 map1 in - join (union left1 left2) - value1 (match op_data1 with None -> data2 | Some d1 -> d1) + join (union left1 left2) value1 + (match op_data1 with + | None -> data2 + | Some d1 -> d1) (union right1 right2) + ) let rec union_with_logs warn parameters error map1 map2 = match map1, map2 with | Private.Empty, _ -> error, map2 | _, Private.Empty -> error, map1 - | Private.Node (left1, value1, data1, right1, height1,_), - Private.Node (left2, value2, data2, right2, height2,_) -> - if height1 >= height2 then + | ( Private.Node (left1, value1, data1, right1, height1, _), + Private.Node (left2, value2, data2, right2, height2, _) ) -> + if height1 >= height2 then ( let error, (left2, op_data2, right2) = - split_with_logs warn parameters error value1 map2 in + split_with_logs warn parameters error value1 map2 + in let error, left' = - union_with_logs warn parameters error left1 left2 in + union_with_logs warn parameters error left1 left2 + in let error, right' = - union_with_logs warn parameters error right1 right2 in + union_with_logs warn parameters error right1 right2 + in join_with_logs warn parameters error left' value1 (match op_data2 with - | None -> data1 - | Some d2 -> d2 - ) right' - else + | None -> data1 + | Some d2 -> d2) + right' + ) else ( let error, (left1, op_data1, right1) = - split_with_logs warn parameters error value2 map1 in + split_with_logs warn parameters error value2 map1 + in let error, left' = - union_with_logs warn parameters error left1 left2 in + union_with_logs warn parameters error left1 left2 + in let error, right' = - union_with_logs warn parameters error right1 right2 in + union_with_logs warn parameters error right1 right2 + in join_with_logs warn parameters error left' value1 (match op_data1 with - | None -> data2 - | Some d1 -> d1) right' + | None -> data2 + | Some d1 -> d1) + right' + ) let rec update map1 map2 = - if map1==map2 then map2 - else + if map1 == map2 then + map2 + else ( match map1 with | Private.Empty -> map2 - | Private.Node(left1,key1,data1,right1,_,_) -> - let left2,data2,right2 = split key1 map2 in - join (update left1 left2) - key1 (match data2 with None -> data1 | Some d2 -> d2) + | Private.Node (left1, key1, data1, right1, _, _) -> + let left2, data2, right2 = split key1 map2 in + join (update left1 left2) key1 + (match data2 with + | None -> data1 + | Some d2 -> d2) (update right1 right2) + ) let rec update_with_logs warn parameters error map1 map2 = - if map1==map2 then error,map2 - else + if map1 == map2 then + error, map2 + else ( match map1 with - | Private.Empty -> error,map2 - | Private.Node(left1,key1,data1,right1,_,_) -> - let error,(left2,data2,right2) = - split_with_logs warn parameters error key1 map2 in + | Private.Empty -> error, map2 + | Private.Node (left1, key1, data1, right1, _, _) -> + let error, (left2, data2, right2) = + split_with_logs warn parameters error key1 map2 + in let error, left' = - update_with_logs warn parameters error left1 left2 in + update_with_logs warn parameters error left1 left2 + in let error, right' = - update_with_logs warn parameters error right1 right2 in + update_with_logs warn parameters error right1 right2 + in join_with_logs warn parameters error left' key1 (match data2 with - None -> data1 - | Some d2 -> d2) + | None -> data1 + | Some d2 -> d2) right' + ) let rec diff_pred pred map1 map2 = match map1 with - | Private.Empty -> empty,map2 - | Private.Node(left1,key1,data1,right1,_,_) -> - let left2,data2,right2 = split key1 map2 in - let oleft1,oleft2 = diff_pred pred left1 left2 in - let oright1,oright2 = diff_pred pred right1 right2 in - match data2 with - | Some x when pred x data1 -> - merge oleft1 oright1, merge oleft2 oright2 - | Some data2 -> + | Private.Empty -> empty, map2 + | Private.Node (left1, key1, data1, right1, _, _) -> + let left2, data2, right2 = split key1 map2 in + let oleft1, oleft2 = diff_pred pred left1 left2 in + let oright1, oright2 = diff_pred pred right1 right2 in + (match data2 with + | Some x when pred x data1 -> merge oleft1 oright1, merge oleft2 oright2 + | Some data2 -> join oleft1 key1 data1 oright1, join oleft2 key1 data2 oright2 - | None -> - join oleft1 key1 data1 oright1, merge oleft2 oright2 + | None -> join oleft1 key1 data1 oright1, merge oleft2 oright2) let rec min_elt = function | Private.Empty -> None - | Private.Node(Private.Empty,key,data,_,_,_) -> Some (key,data) - | Private.Node(left,_,_,_,_,_) -> min_elt left + | Private.Node (Private.Empty, key, data, _, _, _) -> Some (key, data) + | Private.Node (left, _, _, _, _, _) -> min_elt left let rec find_option key = function | Private.Empty -> None - | Private.Node (left,key_map,data,right,_,_) -> + | Private.Node (left, key_map, data, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then Some data - else find_option key (if cmp<0 then left else right) + if cmp = 0 then + Some data + else + find_option key + (if cmp < 0 then + left + else + right) let rec find_default d key = function | Private.Empty -> d - | Private.Node (left,key_map,data,right,_,_) -> + | Private.Node (left, key_map, data, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then data - else find_default d key (if cmp<0 then left else right) + if cmp = 0 then + data + else + find_default d key + (if cmp < 0 then + left + else + right) let rec find_option_with_logs warn parameter error key = function | Private.Empty -> let error = - warn parameter error "setMap.ml" (Some "line 659") Not_found in - error,None - | Private.Node (left,key_map,data,right,_,_) -> + warn parameter error "setMap.ml" (Some "line 659") Not_found + in + error, None + | Private.Node (left, key_map, data, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then (error,Some data) - else find_option_with_logs - warn parameter error key (if cmp<0 then left else right) - + if cmp = 0 then + error, Some data + else + find_option_with_logs warn parameter error key + (if cmp < 0 then + left + else + right) let rec find_default_with_logs warn parameter error d key = function | Private.Empty -> let error = - warn parameter error "setMap.ml" (Some "line 669") Not_found in - error,d - | Private.Node (left,key_map,data,right,_,_) -> + warn parameter error "setMap.ml" (Some "line 669") Not_found + in + error, d + | Private.Node (left, key_map, data, right, _, _) -> let cmp = Ord.compare key key_map in - if cmp = 0 then error,data - else find_default_with_logs - warn parameter error d key (if cmp<0 then left else right) + if cmp = 0 then + error, data + else + find_default_with_logs warn parameter error d key + (if cmp < 0 then + left + else + right) let rec mem key = function | Private.Empty -> false - | Private.Node (left,key_map,_,right,_,_) -> + | Private.Node (left, key_map, _, right, _, _) -> let cmp = Ord.compare key key_map in - cmp == 0 || - if cmp>0 then mem key right else mem key left + cmp == 0 + || + if cmp > 0 then + mem key right + else + mem key left let rec filter_one p = function | Private.Empty -> None - | Private.Node(left,key,value,right,_,_) -> - if p key value then Some (key,value) - else match filter_one p left with + | Private.Node (left, key, value, right, _, _) -> + if p key value then + Some (key, value) + else ( + match filter_one p left with | None -> filter_one p right | out -> out + ) let rec iter f = function | Private.Empty -> () - | Private.Node(left,key,data,right,_,_) -> - let () = iter f left in let () = f key data in iter f right + | Private.Node (left, key, data, right, _, _) -> + let () = iter f left in + let () = f key data in + iter f right let rec fold f map value = match map with | Private.Empty -> value - | Private.Node(left,key,data,right,_,_) -> + | Private.Node (left, key, data, right, _, _) -> fold f right (f key data (fold f left value)) let rec fold_with_interruption f map value = match map with - | Private.Empty -> false,Stop.success value - | Private.Node(left,key,data,right,_,_) -> + | Private.Empty -> false, Stop.success value + | Private.Node (left, key, data, right, _, _) -> let outputl = fold_with_interruption f left value in - let interrupted,value = outputl in - if interrupted then outputl + let interrupted, value = outputl in + if interrupted then + outputl else Stop.success_or_stop (fun value -> - let val_opt = - try - Some (f key data value) - with Sys.Break -> None - in - match - val_opt - with - | None -> (true,Stop.success value) - | Some v -> - Stop.success_or_stop - (fun v -> - fold_with_interruption f right v ) - (fun v -> false,Stop.stop v) - v) - (fun x -> false,Stop.stop x) + let val_opt = + try Some (f key data value) with Sys.Break -> None + in + match val_opt with + | None -> true, Stop.success value + | Some v -> + Stop.success_or_stop + (fun v -> fold_with_interruption f right v) + (fun v -> false, Stop.stop v) + v) + (fun x -> false, Stop.stop x) value - let fold_with_interruption f map value = snd (fold_with_interruption f map value) + let fold_with_interruption f map value = + snd (fold_with_interruption f map value) let rec monadic_fold param err f map value = match map with - | Private.Empty -> err,value - | Private.Node(left,key,data,right,_,_) -> - let err',value' = monadic_fold param err f left value in - let err'',value'' = f param err' key data value' in + | Private.Empty -> err, value + | Private.Node (left, key, data, right, _, _) -> + let err', value' = monadic_fold param err f left value in + let err'', value'' = f param err' key data value' in monadic_fold param err'' f right value'' let rec monadic_fold2 parameters rh f g h map1 map2 res = - match map1,map2 with - | Private.Empty,Private.Empty -> rh,res - | Private.Empty , _ -> monadic_fold parameters rh h map2 res - | _ , Private.Empty -> monadic_fold parameters rh g map1 res - | Private.Node(left1,key1,data1,right1,_,_),_ -> - let (left2,data2,right2) = split key1 map2 in - match data2 with + match map1, map2 with + | Private.Empty, Private.Empty -> rh, res + | Private.Empty, _ -> monadic_fold parameters rh h map2 res + | _, Private.Empty -> monadic_fold parameters rh g map1 res + | Private.Node (left1, key1, data1, right1, _, _), _ -> + let left2, data2, right2 = split key1 map2 in + (match data2 with | None -> - let rh', res' = - monadic_fold2 parameters rh f g h left1 left2 res in - let rh'',res'' = g parameters rh' key1 data1 res' in + let rh', res' = monadic_fold2 parameters rh f g h left1 left2 res in + let rh'', res'' = g parameters rh' key1 data1 res' in monadic_fold2 parameters rh'' f g h right1 right2 res'' | Some data2 -> - let rh', res' = - monadic_fold2 parameters rh f g h left1 left2 res in - let rh'',res'' = f parameters rh' key1 data1 data2 res' in - monadic_fold2 parameters rh'' f g h right1 right2 res'' + let rh', res' = monadic_fold2 parameters rh f g h left1 left2 res in + let rh'', res'' = f parameters rh' key1 data1 data2 res' in + monadic_fold2 parameters rh'' f g h right1 right2 res'') let monadic_fold2_sparse parameters rh f map1 map2 res = - let id _ x _ _ y = (x,y) in + let id _ x _ _ y = x, y in monadic_fold2 parameters rh f id id map1 map2 res let monadic_iter2_sparse parameters rh f map1 map2 = - let error,() = - monadic_fold2_sparse - parameters rh - (fun p e k a b () -> (f p e k a b,())) map1 map2 () in + let error, () = + monadic_fold2_sparse parameters rh + (fun p e k a b () -> f p e k a b, ()) + map1 map2 () + in error let rec monadic_fold_restriction parameters rh f set map res = match set with - | Set.Private.Empty -> rh,res - | Set.Private.Node(left1,key1,right1,_,_) -> - let left2,data2,right2 = split key1 map in - match data2 with + | Set.Private.Empty -> rh, res + | Set.Private.Node (left1, key1, right1, _, _) -> + let left2, data2, right2 = split key1 map in + (match data2 with | None -> let rh', res' = - monadic_fold_restriction parameters rh f left1 left2 res in + monadic_fold_restriction parameters rh f left1 left2 res + in monadic_fold_restriction parameters rh' f right1 right2 res' | Some data2 -> let rh', res' = - monadic_fold_restriction parameters rh f left1 left2 res in - let rh'',res'' = f parameters rh' key1 data2 res' in - monadic_fold_restriction parameters rh'' f right1 right2 res'' + monadic_fold_restriction parameters rh f left1 left2 res + in + let rh'', res'' = f parameters rh' key1 data2 res' in + monadic_fold_restriction parameters rh'' f right1 right2 res'') let rec mapi f = function | Private.Empty -> empty - | Private.Node(left,key,data,right,_,_) -> + | Private.Node (left, key, data, right, _, _) -> node (mapi f left) key (f key data) (mapi f right) let map f s = mapi (fun _ x -> f x) s let rec map_with_logs warn parameters errors f map = - match - map - with - | Private.Empty -> errors,empty - | Private.Node(left,key,data,right,_,_) -> - let errors,left' = map_with_logs warn parameters errors f left in - let errors,data' = f parameters errors data in - let error,right' = map_with_logs warn parameters errors f right in - error,node left' key data' right' + match map with + | Private.Empty -> errors, empty + | Private.Node (left, key, data, right, _, _) -> + let errors, left' = map_with_logs warn parameters errors f left in + let errors, data' = f parameters errors data in + let error, right' = map_with_logs warn parameters errors f right in + error, node left' key data' right' let rec map2 f map map' = match map with | Private.Empty -> map' - | Private.Node(left1,key1,data1,right1,_,_) -> - let left2,data2,right2 = split key1 map' in - join (map2 f left1 left2) - key1 (match data2 with None -> data1 | Some d2 -> f data1 d2) + | Private.Node (left1, key1, data1, right1, _, _) -> + let left2, data2, right2 = split key1 map' in + join (map2 f left1 left2) key1 + (match data2 with + | None -> data1 + | Some d2 -> f data1 d2) (map2 f right1 right2) let rec map2_with_logs warn parameters errors f g h map1 map2 = match map1 with | Private.Empty -> - begin - match map2 with - | Private.Empty -> errors,empty - | Private.Node (_) -> - map_with_logs warn parameters errors g map2 - end - | Private.Node(left1,key1,data1,right1,_,_) -> - let errors,(left2,data2,right2) = - split_with_logs warn parameters errors key1 map2 in + (match map2 with + | Private.Empty -> errors, empty + | Private.Node _ -> map_with_logs warn parameters errors g map2) + | Private.Node (left1, key1, data1, right1, _, _) -> + let errors, (left2, data2, right2) = + split_with_logs warn parameters errors key1 map2 + in let errors, left' = - map2_with_logs warn parameters errors f g h left1 left2 in + map2_with_logs warn parameters errors f g h left1 left2 + in let error, right' = - map2_with_logs warn parameters errors f g h right1 right2 in + map2_with_logs warn parameters errors f g h right1 right2 + in let error, data' = - begin - match data2 - with - | None -> f parameters error data1 - | Some d2 -> h parameters errors data1 d2 - end + match data2 with + | None -> f parameters error data1 + | Some d2 -> h parameters errors data1 d2 in join_with_logs warn parameters error left' key1 data' right' let map2z_with_logs warn parameters errors = - map2_with_logs - warn parameters errors + map2_with_logs warn parameters errors (fun parameters error a -> - let error = - warn parameters error "setMap.ml" - (Some "line 1248, incompatible maps in map2z_safe") - Not_found in - error,a) + let error = + warn parameters error "setMap.ml" + (Some "line 1248, incompatible maps in map2z_safe") Not_found + in + error, a) (fun parameters error a -> - let error = - warn parameters error "setMap.ml" - (Some "line 1251, incompatible maps in map2z_safe") - Not_found in - error,a) + let error = + warn parameters error "setMap.ml" + (Some "line 1251, incompatible maps in map2z_safe") Not_found + in + error, a) let rec fold2_with_logs warn parameters error f g h map1 map2 res = - match map1,map2 with - | Private.Empty,Private.Empty -> error,res - | Private.Empty , _ -> monadic_fold parameters error g map2 res - | _ , Private.Empty -> monadic_fold parameters error f map1 res - | Private.Node(left1,key1,data1,right1,_,_),_ -> - let error,(left2,data2,right2) = - split_with_logs warn parameters error key1 map2 in - match data2 with + match map1, map2 with + | Private.Empty, Private.Empty -> error, res + | Private.Empty, _ -> monadic_fold parameters error g map2 res + | _, Private.Empty -> monadic_fold parameters error f map1 res + | Private.Node (left1, key1, data1, right1, _, _), _ -> + let error, (left2, data2, right2) = + split_with_logs warn parameters error key1 map2 + in + (match data2 with | None -> let error, res' = - fold2_with_logs warn parameters error f g h left1 left2 res in + fold2_with_logs warn parameters error f g h left1 left2 res + in let error, res'' = f parameters error key1 data1 res' in - fold2_with_logs - warn parameters error f g h right1 right2 res'' + fold2_with_logs warn parameters error f g h right1 right2 res'' | Some data2 -> let error, res' = - fold2_with_logs warn parameters error f g h left1 left2 res in - let error,res'' = - h parameters error (key1:elt) data1 data2 res' in - fold2_with_logs - warn parameters error f g h right1 right2 res'' + fold2_with_logs warn parameters error f g h left1 left2 res + in + let error, res'' = h parameters error (key1 : elt) data1 data2 res' in + fold2_with_logs warn parameters error f g h right1 right2 res'') let fold2z_with_logs warn parameters error = - fold2_with_logs - warn parameters error + fold2_with_logs warn parameters error (fun parameters error _ _ a -> - let error = - warn parameters error "setMap.ml" - (Some "line 1248, incompatible maps in fold2z_safe") - Not_found in - error,a) + let error = + warn parameters error "setMap.ml" + (Some "line 1248, incompatible maps in fold2z_safe") Not_found + in + error, a) (fun parameters error _ _ a -> - let error = - warn parameters error "setMap.ml" - (Some "line 1251, incompatible maps in fold2z_safe") - Not_found in - error,a) + let error = + warn parameters error "setMap.ml" + (Some "line 1251, incompatible maps in fold2z_safe") Not_found + in + error, a) let rec fold2_sparse_with_logs warn parameters error f map1 map2 res = - match map1,map2 with - | Private.Empty , _ - | _ , Private.Empty -> (error,res) - | Private.Node(left1,key1,data1,right1,_,_),_ -> - let error,(left2,data2,right2) = - split_with_logs warn parameters error key1 map2 in - match data2 with + match map1, map2 with + | Private.Empty, _ | _, Private.Empty -> error, res + | Private.Node (left1, key1, data1, right1, _, _), _ -> + let error, (left2, data2, right2) = + split_with_logs warn parameters error key1 map2 + in + (match data2 with | None -> - let error, res' = fold2_sparse_with_logs - warn parameters error f left1 left2 res in - fold2_sparse_with_logs - warn parameters error f right1 right2 res' + let error, res' = + fold2_sparse_with_logs warn parameters error f left1 left2 res + in + fold2_sparse_with_logs warn parameters error f right1 right2 res' | Some data2 -> - let error, res' = fold2_sparse_with_logs - warn parameters error f left1 left2 res in - let error,res'' = f parameters error key1 data1 data2 res' in - fold2_sparse_with_logs - warn parameters error f right1 right2 res'' + let error, res' = + fold2_sparse_with_logs warn parameters error f left1 left2 res + in + let error, res'' = f parameters error key1 data1 data2 res' in + fold2_sparse_with_logs warn parameters error f right1 right2 res'') let iter2_sparse_with_logs warn parameters error f map1 map2 = - let error,_ = - fold2_sparse_with_logs - warn parameters error - (fun par err a b c _ -> f par err a b c,()) map1 map2 () - in error + let error, _ = + fold2_sparse_with_logs warn parameters error + (fun par err a b c _ -> f par err a b c, ()) + map1 map2 () + in + error let rec for_all p = function | Private.Empty -> true - | Private.Node(left,key,data,right,_,_) -> + | Private.Node (left, key, data, right, _, _) -> p key data && for_all p right && for_all p left type 'a enumeration = End | More of elt * 'a * 'a t * 'a enumeration let rec cons_enum m e = match m with - Private.Empty -> e - | Private.Node(l, v, d, r, _,_) -> cons_enum l (More(v, d, r, e)) + | Private.Empty -> e + | Private.Node (l, v, d, r, _, _) -> cons_enum l (More (v, d, r, e)) let compare cmp m1 m2 = let rec compare_aux e1 e2 = - match (e1, e2) with - (End, End) -> 0 - | (End, _) -> - 1 - | (_, End) -> 1 - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + match e1, e2 with + | End, End -> 0 + | End, _ -> -1 + | _, End -> 1 + | More (v1, d1, r1, e1), More (v2, d2, r2, e2) -> let c = Ord.compare v1 v2 in - if c <> 0 then c else + if c <> 0 then + c + else ( let c = cmp d1 d2 in - if c <> 0 then c else + if c <> 0 then + c + else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) - in compare_aux (cons_enum m1 End) (cons_enum m2 End) + ) + in + compare_aux (cons_enum m1 End) (cons_enum m2 End) let equal cmp m1 m2 = - compare (fun x y -> if cmp x y then 0 else 1) m1 m2 == 0 + compare + (fun x y -> + if cmp x y then + 0 + else + 1) + m1 m2 + == 0 let rec bindings_aux accu = function | Private.Empty -> accu - | Private.Node (l, v, d, r, _,_) -> + | Private.Node (l, v, d, r, _, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let rec aux_print pr f = function | Private.Empty -> () - | Private.Node (Private.Empty,key,data,Private.Empty,_,_) -> + | Private.Node (Private.Empty, key, data, Private.Empty, _, _) -> Format.fprintf f "@[%a->@,%a@]" Ord.print key pr data - | Private.Node (Private.Empty,key,data,right,_,_) -> - Format.fprintf f "@[%a->%a@],@ %a" - Ord.print key pr data (aux_print pr) right - | Private.Node (left,key,data,Private.Empty,_,_) -> - Format.fprintf f "%a,@ @[%a->%a@]" - (aux_print pr) left Ord.print key pr data - | Private.Node (left,key,data,right,_,_) -> - Format.fprintf f "%a,@ @[%a->%a@],@ %a" - (aux_print pr) left Ord.print key pr data (aux_print pr) right + | Private.Node (Private.Empty, key, data, right, _, _) -> + Format.fprintf f "@[%a->%a@],@ %a" Ord.print key pr data (aux_print pr) + right + | Private.Node (left, key, data, Private.Empty, _, _) -> + Format.fprintf f "%a,@ @[%a->%a@]" (aux_print pr) left Ord.print key pr + data + | Private.Node (left, key, data, right, _, _) -> + Format.fprintf f "%a,@ @[%a->%a@],@ %a" (aux_print pr) left Ord.print + key pr data (aux_print pr) right let print pr f = function | Private.Empty -> Format.pp_print_string f "\xE2\x88\x85" @@ -1735,102 +2056,120 @@ struct let rec diff_with_logs warn parameters error map1 map2 = match map1 with - | Private.Empty -> error,empty,map2 - | Private.Node (left1,key1,data1,right1,_,_) -> - let error,(left2,data2,right2) = - split_with_logs warn parameters error key1 map2 in - let error,oleft1,oleft2 = - diff_with_logs warn parameters error left1 left2 in - let error,oright1,oright2 = - diff_with_logs warn parameters error right1 right2 in - match data2 with + | Private.Empty -> error, empty, map2 + | Private.Node (left1, key1, data1, right1, _, _) -> + let error, (left2, data2, right2) = + split_with_logs warn parameters error key1 map2 + in + let error, oleft1, oleft2 = + diff_with_logs warn parameters error left1 left2 + in + let error, oright1, oright2 = + diff_with_logs warn parameters error right1 right2 + in + (match data2 with | Some x when x = data1 -> - let error,o1 = - merge_with_logs warn parameters error oleft1 oright1 in - let error,o2 = - merge_with_logs warn parameters error oleft2 oright2 in - error,o1,o2 - | Some data2 -> - let error,o1 = - join_with_logs - warn parameters error oleft1 key1 data1 oright1 in - let error,o2 = - join_with_logs - warn parameters error oleft2 key1 data2 oright2 in - error,o1,o2 + let error, o1 = + merge_with_logs warn parameters error oleft1 oright1 + in + let error, o2 = + merge_with_logs warn parameters error oleft2 oright2 + in + error, o1, o2 + | Some data2 -> + let error, o1 = + join_with_logs warn parameters error oleft1 key1 data1 oright1 + in + let error, o2 = + join_with_logs warn parameters error oleft2 key1 data2 oright2 + in + error, o1, o2 | None -> - let error,o1 = - join_with_logs - warn parameters error oleft1 key1 data1 oright1 in - let error,o2 = - merge_with_logs warn parameters error oleft2 oright2 in - error,o1,o2 + let error, o1 = + join_with_logs warn parameters error oleft1 key1 data1 oright1 + in + let error, o2 = + merge_with_logs warn parameters error oleft2 oright2 + in + error, o1, o2) let rec diff_pred_with_logs warn parameters error pred map1 map2 = match map1 with - | Private.Empty -> error,empty,map2 - | Private.Node(left1,key1,data1,right1,_,_) -> - let error,(left2,data2,right2) = - split_with_logs warn parameters error key1 map2 in - let error,oleft1,oleft2 = - diff_pred_with_logs warn parameters error pred left1 left2 in - let error,oright1,oright2 = - diff_pred_with_logs warn parameters error pred right1 right2 in - match data2 with + | Private.Empty -> error, empty, map2 + | Private.Node (left1, key1, data1, right1, _, _) -> + let error, (left2, data2, right2) = + split_with_logs warn parameters error key1 map2 + in + let error, oleft1, oleft2 = + diff_pred_with_logs warn parameters error pred left1 left2 + in + let error, oright1, oright2 = + diff_pred_with_logs warn parameters error pred right1 right2 + in + (match data2 with | Some x when pred x data1 -> - let error,o1 = - merge_with_logs warn parameters error oleft1 oright1 in - let error,o2 = - merge_with_logs warn parameters error oleft2 oright2 in - error,o1,o2 - | Some data2 -> - let error,o1 = - join_with_logs - warn parameters error oleft1 key1 data1 oright1 in - let error,o2 = - join_with_logs - warn parameters error oleft2 key1 data2 oright2 in - error,o1,o2 + let error, o1 = + merge_with_logs warn parameters error oleft1 oright1 + in + let error, o2 = + merge_with_logs warn parameters error oleft2 oright2 + in + error, o1, o2 + | Some data2 -> + let error, o1 = + join_with_logs warn parameters error oleft1 key1 data1 oright1 + in + let error, o2 = + join_with_logs warn parameters error oleft2 key1 data2 oright2 + in + error, o1, o2 | None -> - let error,o1 = - join_with_logs - warn parameters error oleft1 key1 data1 oright1 in - let error,o2 = - merge_with_logs warn parameters error oleft2 oright2 in - error,o1,o2 - - let rec fold_restriction_with_missing_associations_with_logs warn parameters error f g set map res = - match set,map with - | Set.Private.Empty,_ -> error,res - | Set.Private.Node(left1,key1,right1,_,_),_ -> - let error,(left2,data2,right2) = - split_with_logs warn parameters error key1 map in - match data2 with + let error, o1 = + join_with_logs warn parameters error oleft1 key1 data1 oright1 + in + let error, o2 = + merge_with_logs warn parameters error oleft2 oright2 + in + error, o1, o2) + + let rec fold_restriction_with_missing_associations_with_logs warn parameters + error f g set map res = + match set, map with + | Set.Private.Empty, _ -> error, res + | Set.Private.Node (left1, key1, right1, _, _), _ -> + let error, (left2, data2, right2) = + split_with_logs warn parameters error key1 map + in + (match data2 with | None -> - let error, res' = fold_restriction_with_missing_associations_with_logs warn parameters error f g left1 left2 res in - let error, res'' = g key1 (error,res') in - fold_restriction_with_missing_associations_with_logs - warn parameters error f g right1 right2 res'' + let error, res' = + fold_restriction_with_missing_associations_with_logs warn parameters + error f g left1 left2 res + in + let error, res'' = g key1 (error, res') in + fold_restriction_with_missing_associations_with_logs warn parameters + error f g right1 right2 res'' | Some data2 -> - let error, res' = fold_restriction_with_missing_associations_with_logs warn parameters error f g left1 left2 res in - let error,res'' = f key1 data2 (error,res') in - fold_restriction_with_missing_associations_with_logs - warn parameters error f g right1 right2 res'' - - let fold_restriction_with_logs warn parameters error f set map res = fold_restriction_with_missing_associations_with_logs warn parameters error f (fun _ x -> x) set map res - - let to_json - ?lab_key:(lab_key="key") ?lab_value:(lab_value="value") = + let error, res' = + fold_restriction_with_missing_associations_with_logs warn parameters + error f g left1 left2 res + in + let error, res'' = f key1 data2 (error, res') in + fold_restriction_with_missing_associations_with_logs warn parameters + error f g right1 right2 res'') + + let fold_restriction_with_logs warn parameters error f set map res = + fold_restriction_with_missing_associations_with_logs warn parameters error + f + (fun _ x -> x) + set map res + + let to_json ?(lab_key = "key") ?(lab_value = "value") = JsonUtil.of_map ~lab_key ~lab_value ~fold - - let of_json - ?lab_key:(lab_key="key") - ?lab_value:(lab_value="value") - ?error_msg:(error_msg=JsonUtil.build_msg "map") = - JsonUtil.to_map ~lab_key ~lab_value ~error_msg - ~add ~empty - + let of_json ?(lab_key = "key") ?(lab_value = "value") + ?(error_msg = JsonUtil.build_msg "map") = + JsonUtil.to_map ~lab_key ~lab_value ~error_msg ~add ~empty end end @@ -1842,33 +2181,43 @@ module type Projection = sig type set_a type set_b - val proj_map: (elt_a -> elt_b) -> 'b -> ('b -> 'a -> 'b) -> 'a map_a -> 'b map_b - val proj_map_monadic: - 'parameters -> 'method_handler -> (elt_a -> elt_b) -> 'b -> + val proj_map : + (elt_a -> elt_b) -> 'b -> ('b -> 'a -> 'b) -> 'a map_a -> 'b map_b + + val proj_map_monadic : + 'parameters -> + 'method_handler -> + (elt_a -> elt_b) -> + 'b -> ('parameters -> 'method_handler -> 'b -> 'a -> 'method_handler * 'b) -> - 'a map_a -> 'method_handler * 'b map_b + 'a map_a -> + 'method_handler * 'b map_b - val proj_set: - (elt_a -> elt_b) -> set_a -> set_b + val proj_set : (elt_a -> elt_b) -> set_a -> set_b - val proj_set_monadic: - 'parameters -> 'method_handler -> ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> set_a -> 'method_handler * set_b + val proj_set_monadic : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> + set_a -> + 'method_handler * set_b + val partition_set : (elt_a -> elt_b) -> set_a -> set_a map_b - val partition_set: - (elt_a -> elt_b) -> set_a -> set_a map_b - val partition_set_monadic: - 'parameters -> 'method_handler -> ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> set_a -> + val partition_set_monadic : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> + set_a -> 'method_handler * set_a map_b - end -module Proj(A:S)(B:S) = -struct - module MA=A.Map - module MB=B.Map - module SA=A.Set - module SB=B.Set +module Proj (A : S) (B : S) = struct + module MA = A.Map + module MB = B.Map + module SA = A.Set + module SB = B.Set + type elt_a = MA.elt type elt_b = MB.elt type set_a = SA.t @@ -1879,56 +2228,49 @@ struct let proj_map f identity_elt merge map = MA.fold (fun key_a data_a map_b -> - let key_b = f key_a in - MB.add key_b - (merge (MB.find_default identity_elt key_b map_b) data_a) map_b) - map - MB.empty + let key_b = f key_a in + MB.add key_b + (merge (MB.find_default identity_elt key_b map_b) data_a) + map_b) + map MB.empty - let proj_map_monadic parameter handler f identity_elt monadic_merge map = + let proj_map_monadic parameter handler f identity_elt monadic_merge map = MA.fold - (fun key_a data_a (handler,map_b) -> - let key_b = f key_a in - let handler,data' = - monadic_merge - parameter - handler - (MB.find_default identity_elt key_b map_b) - data_a in - handler,MB.add key_b data' map_b) - map - (handler,MB.empty) - - let proj_set f set_a = - SA.fold - (fun key_a -> - SB.add (f key_a)) - set_a SB.empty + (fun key_a data_a (handler, map_b) -> + let key_b = f key_a in + let handler, data' = + monadic_merge parameter handler + (MB.find_default identity_elt key_b map_b) + data_a + in + handler, MB.add key_b data' map_b) + map (handler, MB.empty) + + let proj_set f set_a = SA.fold (fun key_a -> SB.add (f key_a)) set_a SB.empty let proj_set_monadic parameter handler f set_a = SA.fold (fun key_a (handler, set_b) -> - let handler, key_b = f parameter handler key_a in - handler, SB.add key_b set_b) - set_a - (handler,SB.empty) + let handler, key_b = f parameter handler key_a in + handler, SB.add key_b set_b) + set_a (handler, SB.empty) let partition_set f set_a = SA.fold (fun key_a map_b -> - let key_b = f key_a in - MB.add key_b (SA.add key_a (MB.find_default SA.empty key_b map_b)) map_b) - set_a - MB.empty + let key_b = f key_a in + MB.add key_b (SA.add key_a (MB.find_default SA.empty key_b map_b)) map_b) + set_a MB.empty let partition_set_monadic parameter handler f set_a = SA.fold - (fun key_a (handler, map_b) -> - let handler, key_b = f parameter handler key_a in - handler, MB.add key_b (SA.add key_a (MB.find_default SA.empty key_b map_b)) map_b) - set_a - (handler, MB.empty) - + (fun key_a (handler, map_b) -> + let handler, key_b = f parameter handler key_a in + ( handler, + MB.add key_b + (SA.add key_a (MB.find_default SA.empty key_b map_b)) + map_b )) + set_a (handler, MB.empty) end (* todo: add the following test to the sanity tests *) @@ -1985,21 +2327,31 @@ module type Projection2 = sig type 'a map_a type 'a map_b type 'a map_c - val proj2: - (elt_a -> elt_b) -> (elt_a -> elt_c) -> - 'b -> ('b -> 'a -> 'b) -> 'a map_a -> 'b map_c map_b - val proj2_monadic: - 'parameters -> 'method_handler -> (elt_a -> elt_b) -> (elt_a -> elt_c) -> + + val proj2 : + (elt_a -> elt_b) -> + (elt_a -> elt_c) -> + 'b -> + ('b -> 'a -> 'b) -> + 'a map_a -> + 'b map_c map_b + + val proj2_monadic : + 'parameters -> + 'method_handler -> + (elt_a -> elt_b) -> + (elt_a -> elt_c) -> 'b -> ('parameters -> 'method_handler -> 'b -> 'a -> 'method_handler * 'b) -> - 'a map_a -> 'method_handler * 'b map_c map_b + 'a map_a -> + 'method_handler * 'b map_c map_b end -module Proj2(A:S)(B:S)(C:S) = -struct - module MA=A.Map - module MB=B.Map - module MC=C.Map +module Proj2 (A : S) (B : S) (C : S) = struct + module MA = A.Map + module MB = B.Map + module MC = C.Map + type elt_a = MA.elt type elt_b = MB.elt type elt_c = MC.elt @@ -2010,36 +2362,29 @@ struct let proj2 f g identity_elt merge map = MA.fold (fun key_a data_a map_b -> - let key_b = f key_a in - let key_c = g key_a in - let submap = MB.find_default MC.empty key_b map_b in - let submap = - MC.add - key_c - (merge - (MC.find_default - identity_elt - key_c - submap) data_a) - submap - in - MB.add key_b submap map_b) - map - MB.empty + let key_b = f key_a in + let key_c = g key_a in + let submap = MB.find_default MC.empty key_b map_b in + let submap = + MC.add key_c + (merge (MC.find_default identity_elt key_c submap) data_a) + submap + in + MB.add key_b submap map_b) + map MB.empty let proj2_monadic parameter handler f g identity_elt merge map = MA.fold - (fun key_a data_a (handler,map_b) -> - let key_b = f key_a in - let key_c = g key_a in - let submap = MB.find_default MC.empty key_b map_b in - let handler,data' = - merge parameter handler - (MC.find_default identity_elt key_c submap) - data_a - in - let submap = MC.add key_c data' submap in - handler,MB.add key_b submap map_b) - map - (handler,MB.empty) + (fun key_a data_a (handler, map_b) -> + let key_b = f key_a in + let key_c = g key_a in + let submap = MB.find_default MC.empty key_b map_b in + let handler, data' = + merge parameter handler + (MC.find_default identity_elt key_c submap) + data_a + in + let submap = MC.add key_c data' submap in + handler, MB.add key_b submap map_b) + map (handler, MB.empty) end diff --git a/core/dataStructures/setMap.mli b/core/dataStructures/setMap.mli index 3cd399f091..12c9cdac01 100644 --- a/core/dataStructures/setMap.mli +++ b/core/dataStructures/setMap.mli @@ -11,246 +11,348 @@ Purely functionnal. Functions without _with_logs do NOT raise any exception.*) -module type OrderedType = -sig +module type OrderedType = sig type t + val compare : t -> t -> int val print : Format.formatter -> t -> unit end -type ('parameters,'error,'a) with_log_wrap = +type ('parameters, 'error, 'a) with_log_wrap = ('parameters -> 'error -> string -> string option -> exn -> 'error) -> - 'parameters -> 'error -> 'a + 'parameters -> + 'error -> + 'a -module type Set = -sig +module type Set = sig type elt type t - val empty: t - val is_empty: t -> bool - val singleton: elt -> t - val is_singleton: t -> bool - - val add: elt -> t -> t - val add_with_logs: ('parameters,'error,elt -> t -> 'error * t) with_log_wrap - val remove: elt -> t -> t - val add_while_testing_freshness: - ('parameters,'error,elt -> t -> 'error * bool * t) with_log_wrap - val remove_while_testing_existence: - ('parameters,'error,elt -> t -> 'error * bool * t) with_log_wrap - val remove_with_logs: - ('parameters,'error,elt -> t -> 'error * t) with_log_wrap - val split: elt -> t -> (t * bool * t) - val union: t -> t -> t - val disjoint_union: t -> t -> t option - val inter: t -> t -> t - val minus: t -> t -> t + val empty : t + val is_empty : t -> bool + val singleton : elt -> t + val is_singleton : t -> bool + val add : elt -> t -> t + + val add_with_logs : + ('parameters, 'error, elt -> t -> 'error * t) with_log_wrap + + val remove : elt -> t -> t + + val add_while_testing_freshness : + ('parameters, 'error, elt -> t -> 'error * bool * t) with_log_wrap + + val remove_while_testing_existence : + ('parameters, 'error, elt -> t -> 'error * bool * t) with_log_wrap + + val remove_with_logs : + ('parameters, 'error, elt -> t -> 'error * t) with_log_wrap + + val split : elt -> t -> t * bool * t + val union : t -> t -> t + val disjoint_union : t -> t -> t option + val inter : t -> t -> t + + val minus : t -> t -> t (** [minus a b] contains elements of [a] that are not in [b] *) - val diff: t -> t -> t + val diff : t -> t -> t (** [diff a b] = [minus (union a b) (inter a b)] *) - val minus_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val union_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val disjoint_union_with_logs: - ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val inter_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap - val diff_with_logs: ('parameters,'error,t -> t -> 'error * t) with_log_wrap + val minus_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap - val size: t -> int + val union_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap - val mem: elt -> t -> bool - val exists: (elt -> bool) -> t -> bool - val filter: (elt -> bool) -> t -> t - val filter_with_logs: - ('parameters,'error,(elt -> bool) -> t -> 'error * t) with_log_wrap - val for_all: (elt -> bool) -> t -> bool - val partition: (elt -> bool) -> t -> t * t - val partition_with_logs: - ('parameters,'error,(elt -> bool) -> t -> 'error * t * t) with_log_wrap + val disjoint_union_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap - val compare: t -> t -> int - val equal: t -> t -> bool + val inter_with_logs : + ('parameters, 'error, t -> t -> 'error * t) with_log_wrap + val diff_with_logs : ('parameters, 'error, t -> t -> 'error * t) with_log_wrap + val size : t -> int + val mem : elt -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t - val subset: t -> t -> bool - val iter: (elt -> unit) -> t -> unit + val filter_with_logs : + ('parameters, 'error, (elt -> bool) -> t -> 'error * t) with_log_wrap - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - val fold_inv: (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val partition : (elt -> bool) -> t -> t * t - val elements: t -> elt list - val print: Format.formatter -> t -> unit + val partition_with_logs : + ('parameters, 'error, (elt -> bool) -> t -> 'error * t * t) with_log_wrap - val choose: t -> elt option - val random: Random.State.t -> t -> elt option - val min_elt: t -> elt option - val max_elt: t -> elt option + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val fold_inv : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val elements : t -> elt list + val print : Format.formatter -> t -> unit + val choose : t -> elt option + val random : Random.State.t -> t -> elt option + val min_elt : t -> elt option + val max_elt : t -> elt option end -module type Map = -sig +module type Map = sig type elt type set type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val size: 'a t -> int - val root: 'a t -> (elt * 'a) option - val max_key: 'a t -> elt option - - val add: elt -> 'a -> 'a t -> 'a t - val remove: elt -> 'a t -> 'a t - val add_while_testing_freshness: - ('parameters,'error, - elt -> 'a -> 'a t -> 'error * bool * 'a t) with_log_wrap - val remove_while_testing_existence: - ('parameters,'error,elt -> 'a t -> 'error * bool * 'a t) with_log_wrap - - val pop: elt -> 'a t -> ('a option * 'a t) - val merge: 'a t -> 'a t -> 'a t - val min_elt: 'a t -> (elt * 'a) option - val find_option: elt -> 'a t -> 'a option - val find_default: 'a -> elt -> 'a t -> 'a - val find_option_with_logs: - ('parameters,'error,elt -> 'a t -> 'error * 'a option) with_log_wrap - val find_default_with_logs: - ('parameters,'error,'a -> elt -> 'a t -> 'error * 'a) with_log_wrap - val mem: elt -> 'a t -> bool - val diff: 'a t -> 'a t -> 'a t * 'a t - val union: 'a t -> 'a t -> 'a t - val update: 'a t -> 'a t -> 'a t - val diff_pred: ('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t * 'a t - val add_with_logs: - ('parameters,'error,elt -> 'a -> 'a t -> 'error * 'a t) with_log_wrap - val remove_with_logs: - ('parameters,'error,elt -> 'a t -> 'error * 'a t) with_log_wrap - - val join_with_logs: - ('parameters,'error, - 'a t -> elt -> 'a -> 'a t -> 'error * 'a t) with_log_wrap - val split_with_logs: - ('parameters,'error, - elt -> 'a t -> 'error * ('a t * 'a option * 'a t)) with_log_wrap - val update_with_logs: - ('parameters,'error,'a t -> 'a t -> 'error * 'a t) with_log_wrap - val map2_with_logs: - ('parameters,'error, - ('parameters -> 'error -> 'a -> 'error * 'c) -> - ('parameters -> 'error -> 'b -> 'error * 'c) -> - ('parameters -> 'error -> 'a -> 'b -> 'error * 'c) -> - 'a t -> 'b t -> 'error * 'c t) with_log_wrap - val map2z_with_logs: - ('parameters,'error, - ('parameters -> 'error -> 'a -> 'a -> 'error * 'a) -> - 'a t -> 'a t -> 'error * 'a t) with_log_wrap - val fold2z_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> ('error * 'c)) -> - 'a t -> 'b t -> 'c -> 'error * 'c) with_log_wrap - val fold2_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'c -> 'error * 'c) -> - ('parameters -> 'error -> elt -> 'b -> 'c -> 'error * 'c) -> - ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> - 'a t -> 'b t -> 'c -> 'error * 'c) with_log_wrap - val fold2_sparse_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> ('error * 'c)) -> - 'a t -> 'b t -> 'c -> 'error * 'c) with_log_wrap - val iter2_sparse_with_logs: - ('parameters,'error, - ('parameters -> 'error -> elt -> 'a -> 'b -> 'error) -> - 'a t -> 'b t -> 'error) with_log_wrap - val diff_with_logs: - ('parameters,'error,'a t -> 'a t -> 'error * 'a t * 'a t) with_log_wrap - - val diff_pred_with_logs: - ('parameters,'error, - ('a -> 'a -> bool) -> 'a t -> 'a t -> 'error * 'a t * 'a t) with_log_wrap + val empty : 'a t + val is_empty : 'a t -> bool + val size : 'a t -> int + val root : 'a t -> (elt * 'a) option + val max_key : 'a t -> elt option + val add : elt -> 'a -> 'a t -> 'a t + val remove : elt -> 'a t -> 'a t + + val add_while_testing_freshness : + ( 'parameters, + 'error, + elt -> 'a -> 'a t -> 'error * bool * 'a t ) + with_log_wrap + + val remove_while_testing_existence : + ('parameters, 'error, elt -> 'a t -> 'error * bool * 'a t) with_log_wrap + + val pop : elt -> 'a t -> 'a option * 'a t + val merge : 'a t -> 'a t -> 'a t + val min_elt : 'a t -> (elt * 'a) option + val find_option : elt -> 'a t -> 'a option + val find_default : 'a -> elt -> 'a t -> 'a + + val find_option_with_logs : + ('parameters, 'error, elt -> 'a t -> 'error * 'a option) with_log_wrap + + val find_default_with_logs : + ('parameters, 'error, 'a -> elt -> 'a t -> 'error * 'a) with_log_wrap + + val mem : elt -> 'a t -> bool + val diff : 'a t -> 'a t -> 'a t * 'a t + val union : 'a t -> 'a t -> 'a t + val update : 'a t -> 'a t -> 'a t + val diff_pred : ('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t * 'a t + + val add_with_logs : + ('parameters, 'error, elt -> 'a -> 'a t -> 'error * 'a t) with_log_wrap + + val remove_with_logs : + ('parameters, 'error, elt -> 'a t -> 'error * 'a t) with_log_wrap + + val join_with_logs : + ( 'parameters, + 'error, + 'a t -> elt -> 'a -> 'a t -> 'error * 'a t ) + with_log_wrap + + val split_with_logs : + ( 'parameters, + 'error, + elt -> 'a t -> 'error * ('a t * 'a option * 'a t) ) + with_log_wrap + + val update_with_logs : + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t) with_log_wrap + + val map2_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> 'a -> 'error * 'c) -> + ('parameters -> 'error -> 'b -> 'error * 'c) -> + ('parameters -> 'error -> 'a -> 'b -> 'error * 'c) -> + 'a t -> + 'b t -> + 'error * 'c t ) + with_log_wrap + + val map2z_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> 'a -> 'a -> 'error * 'a) -> + 'a t -> + 'a t -> + 'error * 'a t ) + with_log_wrap + + val fold2z_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'error * 'c ) + with_log_wrap + + val fold2_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'c -> 'error * 'c) -> + ('parameters -> 'error -> elt -> 'b -> 'c -> 'error * 'c) -> + ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'error * 'c ) + with_log_wrap + + val fold2_sparse_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'b -> 'c -> 'error * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'error * 'c ) + with_log_wrap + + val iter2_sparse_with_logs : + ( 'parameters, + 'error, + ('parameters -> 'error -> elt -> 'a -> 'b -> 'error) -> + 'a t -> + 'b t -> + 'error ) + with_log_wrap + + val diff_with_logs : + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t * 'a t) with_log_wrap + + val diff_pred_with_logs : + ( 'parameters, + 'error, + ('a -> 'a -> bool) -> 'a t -> 'a t -> 'error * 'a t * 'a t ) + with_log_wrap + val merge_with_logs : - ('parameters,'error,'a t -> 'a t -> 'error * 'a t) with_log_wrap + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t) with_log_wrap + val union_with_logs : - ('parameters,'error,'a t -> 'a t -> 'error * 'a t) with_log_wrap - val fold_restriction_with_logs: - ('parameters,'error, - (elt -> 'a -> ('error * 'b) -> ('error* 'b)) -> - set -> 'a t -> 'b -> 'error * 'b) with_log_wrap - val fold_restriction_with_missing_associations_with_logs: - ('parameters,'error, - (elt -> 'a -> ('error * 'b) -> ('error* 'b)) -> - (elt -> ('error * 'b) -> ('error * 'b)) -> - set -> 'a t -> 'b -> 'error * 'b) with_log_wrap - - - val iter: (elt -> 'a -> unit) -> 'a t -> unit - val fold: (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val fold_with_interruption: (elt -> 'a -> 'b -> ('b,'c) Stop.stop) -> 'a t -> 'b -> ('b,'c) Stop.stop - - val monadic_fold2: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> 'c -> ('method_handler * 'c)) -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'c -> ('method_handler * 'c)) -> - ('parameters -> 'method_handler -> - elt -> 'b -> 'c -> ('method_handler * 'c)) -> - 'a t -> 'b t -> 'c -> ('method_handler * 'c) - val monadic_fold2_sparse: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> 'c -> ('method_handler * 'c)) -> - 'a t -> 'b t -> 'c -> ('method_handler * 'c) - val monadic_iter2_sparse: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> 'method_handler) -> - 'a t -> 'b t -> 'method_handler - val monadic_fold_restriction: - 'parameters -> 'method_handler -> - ('parameters -> 'method_handler -> - elt -> 'a -> 'b -> ('method_handler * 'b)) -> - set -> 'a t -> 'b -> 'method_handler * 'b - - val mapi: (elt -> 'a -> 'b) -> 'a t -> 'b t - val map: ('a -> 'b) -> 'a t -> 'b t - val map2: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t - - val for_all: (elt -> 'a -> bool) -> 'a t -> bool - - val filter_one: (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option + ('parameters, 'error, 'a t -> 'a t -> 'error * 'a t) with_log_wrap + + val fold_restriction_with_logs : + ( 'parameters, + 'error, + (elt -> 'a -> 'error * 'b -> 'error * 'b) -> + set -> + 'a t -> + 'b -> + 'error * 'b ) + with_log_wrap + + val fold_restriction_with_missing_associations_with_logs : + ( 'parameters, + 'error, + (elt -> 'a -> 'error * 'b -> 'error * 'b) -> + (elt -> 'error * 'b -> 'error * 'b) -> + set -> + 'a t -> + 'b -> + 'error * 'b ) + with_log_wrap + + val iter : (elt -> 'a -> unit) -> 'a t -> unit + val fold : (elt -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_with_interruption : + (elt -> 'a -> 'b -> ('b, 'c) Stop.stop) -> 'a t -> 'b -> ('b, 'c) Stop.stop + + val monadic_fold2 : + 'parameters -> + 'method_handler -> + ('parameters -> + 'method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + 'method_handler * 'c) -> + ('parameters -> 'method_handler -> elt -> 'a -> 'c -> 'method_handler * 'c) -> + ('parameters -> 'method_handler -> elt -> 'b -> 'c -> 'method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'method_handler * 'c + + val monadic_fold2_sparse : + 'parameters -> + 'method_handler -> + ('parameters -> + 'method_handler -> + elt -> + 'a -> + 'b -> + 'c -> + 'method_handler * 'c) -> + 'a t -> + 'b t -> + 'c -> + 'method_handler * 'c + + val monadic_iter2_sparse : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt -> 'a -> 'b -> 'method_handler) -> + 'a t -> + 'b t -> + 'method_handler + + val monadic_fold_restriction : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt -> 'a -> 'b -> 'method_handler * 'b) -> + set -> + 'a t -> + 'b -> + 'method_handler * 'b + + val mapi : (elt -> 'a -> 'b) -> 'a t -> 'b t + val map : ('a -> 'b) -> 'a t -> 'b t + val map2 : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val for_all : (elt -> 'a -> bool) -> 'a t -> bool + val filter_one : (elt -> 'a -> bool) -> 'a t -> (elt * 'a) option (* returns an element that respects the predicate (if any) *) - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val bindings : 'a t -> (elt * 'a) list - val print: - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - - val of_json: - ?lab_key:string -> ?lab_value:string -> ?error_msg:string -> - (Yojson.Basic.t -> elt) -> - (Yojson.Basic.t -> 'value) -> - Yojson.Basic.t -> 'value t - - val to_json: - ?lab_key:string -> ?lab_value:string -> - (elt -> Yojson.Basic.t) -> - ('value -> Yojson.Basic.t) -> - 'value t -> Yojson.Basic.t + val print : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + val of_json : + ?lab_key:string -> + ?lab_value:string -> + ?error_msg:string -> + (Yojson.Basic.t -> elt) -> + (Yojson.Basic.t -> 'value) -> + Yojson.Basic.t -> + 'value t + + val to_json : + ?lab_key:string -> + ?lab_value:string -> + (elt -> Yojson.Basic.t) -> + ('value -> Yojson.Basic.t) -> + 'value t -> + Yojson.Basic.t end module type S = sig type elt + module Set : Set with type elt = elt module Map : Map with type elt = elt and type set = Set.t end -module Make(Ord:OrderedType): S with type elt = Ord.t +module Make (Ord : OrderedType) : S with type elt = Ord.t module type Projection = sig type elt_a @@ -260,36 +362,48 @@ module type Projection = sig type set_a type set_b + val proj_map : + (elt_a -> elt_b) -> 'b -> ('b -> 'a -> 'b) -> 'a map_a -> 'b map_b (** proj_map f init merge map is a map mapping each element b to the result of the itteration of the function merge over the image in map of the element a in f such that f(a)=b, starting with the element init. *) - val proj_map: (elt_a -> elt_b) -> 'b -> ('b -> 'a -> 'b) -> 'a map_a -> 'b map_b - val proj_map_monadic: - 'parameters -> 'method_handler -> (elt_a -> elt_b) -> 'b -> + + val proj_map_monadic : + 'parameters -> + 'method_handler -> + (elt_a -> elt_b) -> + 'b -> ('parameters -> 'method_handler -> 'b -> 'a -> 'method_handler * 'b) -> - 'a map_a -> 'method_handler * 'b map_b + 'a map_a -> + 'method_handler * 'b map_b + val proj_set : (elt_a -> elt_b) -> set_a -> set_b (** proj_set f set is the set \{f(a) | a\in S\} *) - val proj_set: - (elt_a -> elt_b) -> set_a -> set_b - - val proj_set_monadic: - 'parameters -> 'method_handler -> ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> set_a -> 'method_handler * set_b + val proj_set_monadic : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> + set_a -> + 'method_handler * set_b + val partition_set : (elt_a -> elt_b) -> set_a -> set_a map_b (** partition_set f set is the map mapping any element b with an antecedent for f in the set set, into the set of its antecedents, ie to the set \{a\in set | f(a)=b\}. *) - val partition_set: - (elt_a -> elt_b) -> set_a -> set_a map_b - val partition_set_monadic: - 'parameters -> 'method_handler -> ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> set_a -> - 'method_handler * set_a map_b - + val partition_set_monadic : + 'parameters -> + 'method_handler -> + ('parameters -> 'method_handler -> elt_a -> 'method_handler * elt_b) -> + set_a -> + 'method_handler * set_a map_b end -module Proj(A:S)(B:S): Projection with - type elt_a = A.elt and type elt_b = B.elt and -type 'a map_a = 'a A.Map.t and type 'a map_b = 'a B.Map.t +module Proj (A : S) (B : S) : + Projection + with type elt_a = A.elt + and type elt_b = B.elt + and type 'a map_a = 'a A.Map.t + and type 'a map_b = 'a B.Map.t module type Projection2 = sig type elt_a @@ -298,17 +412,31 @@ module type Projection2 = sig type 'a map_a type 'a map_b type 'a map_c - val proj2: - (elt_a -> elt_b) -> (elt_a -> elt_c) -> - 'b -> ('b -> 'a -> 'b) -> 'a map_a -> 'b map_c map_b - val proj2_monadic: - 'parameters -> 'method_handler -> (elt_a -> elt_b) -> (elt_a -> elt_c) -> + + val proj2 : + (elt_a -> elt_b) -> + (elt_a -> elt_c) -> + 'b -> + ('b -> 'a -> 'b) -> + 'a map_a -> + 'b map_c map_b + + val proj2_monadic : + 'parameters -> + 'method_handler -> + (elt_a -> elt_b) -> + (elt_a -> elt_c) -> 'b -> ('parameters -> 'method_handler -> 'b -> 'a -> 'method_handler * 'b) -> - 'a map_a -> 'method_handler * 'b map_c map_b + 'a map_a -> + 'method_handler * 'b map_c map_b end -module Proj2(A:S)(B:S)(C:S): Projection2 with - type elt_a = A.elt and type elt_b = B.elt and -type 'a map_a = 'a A.Map.t and type 'a map_b = 'a B.Map.t and -type elt_c = C.elt and type 'a map_c = 'a C.Map.t +module Proj2 (A : S) (B : S) (C : S) : + Projection2 + with type elt_a = A.elt + and type elt_b = B.elt + and type 'a map_a = 'a A.Map.t + and type 'a map_b = 'a B.Map.t + and type elt_c = C.elt + and type 'a map_c = 'a C.Map.t diff --git a/core/dataStructures/stop.ml b/core/dataStructures/stop.ml index 373fc0bc1c..545dc09f25 100644 --- a/core/dataStructures/stop.ml +++ b/core/dataStructures/stop.ml @@ -6,16 +6,12 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type ('a,'b) stop = - Stop of 'b - | Success of 'a +type ('a, 'b) stop = Stop of 'b | Success of 'a let success a = Success a let stop a = Stop a let success_or_stop f g x = - match x - with + match x with | Success a -> f a - | Stop a -> g a - + | Stop a -> g a diff --git a/core/dataStructures/stop.mli b/core/dataStructures/stop.mli index 0e21e47649..bac79ed825 100644 --- a/core/dataStructures/stop.mli +++ b/core/dataStructures/stop.mli @@ -1,9 +1,5 @@ -type ('a,'b) stop +type ('a, 'b) stop -val success: 'a -> ('a,'b) stop -val stop: 'b -> ('a,'b) stop - -val success_or_stop: -('a -> 'c) -> -('b -> 'c) -> -('a,'b) stop -> 'c +val success : 'a -> ('a, 'b) stop +val stop : 'b -> ('a, 'b) stop +val success_or_stop : ('a -> 'c) -> ('b -> 'c) -> ('a, 'b) stop -> 'c diff --git a/core/dataStructures/tools.ml b/core/dataStructures/tools.ml index 74271bcec5..5342e6f5f5 100644 --- a/core/dataStructures/tools.ml +++ b/core/dataStructures/tools.ml @@ -9,24 +9,26 @@ let float_is_zero x = match classify_float x with | FP_zero -> true - | FP_normal | FP_subnormal |FP_infinite | FP_nan -> false + | FP_normal | FP_subnormal | FP_infinite | FP_nan -> false let pow i j = let () = assert (0 <= j) in let rec aux i k accu = - if k=0 then accu - else if k land 1 = 0 - then - aux i (k/2) accu*accu + if k = 0 then + accu + else if k land 1 = 0 then + aux i (k / 2) accu * accu else - aux i (k/2) (i*accu*accu) + aux i (k / 2) (i * accu * accu) in aux i j 1 let fact i = let rec aux i accu = - if i<2 then accu - else aux (i-1) (i*accu) + if i < 2 then + accu + else + aux (i - 1) (i * accu) in aux i 1 @@ -34,56 +36,56 @@ let get_product_image_occ start combine f l = let l = List.sort compare l in let rec aux l old occ accu = match l with - | h::t when h=old -> aux t old (1+occ) accu + | h :: t when h = old -> aux t old (1 + occ) accu | _ -> - begin - let accu = combine accu (f occ) in - match l with - | h::t -> aux t h 1 accu - | [] -> accu - end - in match l with + let accu = combine accu (f occ) in + (match l with + | h :: t -> aux t h 1 accu + | [] -> accu) + in + match l with | [] -> 1 - | h::t -> aux t h 1 start + | h :: t -> aux t h 1 start let get_product_image_occ_2 start combine f l1 l2 = let l1 = List.sort compare l1 in let l2 = List.sort compare l2 in let count_head_and_get_tail l = match l with - | [] -> [],0 - | h::t -> + | [] -> [], 0 + | h :: t -> let rec aux l h occ = match l with - | [] -> [],occ - | h'::t when h=h' -> aux t h (occ+1) - | _ -> l,occ + | [] -> [], occ + | h' :: t when h = h' -> aux t h (occ + 1) + | _ -> l, occ in aux t h 1 in let rec aux l1 l2 accu = - match l1,l2 with - | h1::_,h2::_ when h1=h2 -> - let l1,occ1 = count_head_and_get_tail l1 in - let l2,occ2 = count_head_and_get_tail l2 in + match l1, l2 with + | h1 :: _, h2 :: _ when h1 = h2 -> + let l1, occ1 = count_head_and_get_tail l1 in + let l2, occ2 = count_head_and_get_tail l2 in aux l1 l2 (combine accu (f occ1 occ2)) - | h1::_,h2::_ when compare h1 h2 < 0 -> - let l1,occ1 = count_head_and_get_tail l1 in + | h1 :: _, h2 :: _ when compare h1 h2 < 0 -> + let l1, occ1 = count_head_and_get_tail l1 in aux l1 l2 (combine accu (f occ1 0)) - | _::_,_::_ -> - let l2,occ2 = count_head_and_get_tail l2 in - aux l1 l2 (combine accu (f 0 occ2)) - | [],_ | _,[] -> accu - in - aux l1 l2 start + | _ :: _, _ :: _ -> + let l2, occ2 = count_head_and_get_tail l2 in + aux l1 l2 (combine accu (f 0 occ2)) + | [], _ | _, [] -> accu + in + aux l1 l2 start let div2 x = Int64.div x (Int64.add Int64.one Int64.one) + let pow64 x n = assert (n >= Int64.zero); let rec aux k accu = - if k=Int64.zero then accu - else if Int64.logand k Int64.one = Int64.zero - then + if k = Int64.zero then + accu + else if Int64.logand k Int64.one = Int64.zero then aux (div2 k) (Int64.mul accu accu) else aux (div2 k) (Int64.mul x (Int64.mul accu accu)) @@ -91,48 +93,56 @@ let pow64 x n = aux n Int64.one let cantor_pairing x y = - let s = x + y in (succ s * s)/2 + y + let s = x + y in + (succ s * s / 2) + y let read_input () = let rec parse acc input = match Stream.next input with | '\n' -> acc - | c -> parse (Printf.sprintf "%s%c" acc c) input in + | c -> parse (Printf.sprintf "%s%c" acc c) input + in try let user_input = Stream.of_channel stdin in parse "" user_input - with - | Stream.Failure -> invalid_arg "Tools.Read_input: cannot read stream" + with Stream.Failure -> invalid_arg "Tools.Read_input: cannot read stream" let not_an_id s = - (String.length s = 0) || + String.length s = 0 + || let i = int_of_char s.[0] in - (i < 65 || i > 122 || (i > 90 && (i <> 95 || String.length s = 1) && i < 97)) || + (i < 65 || i > 122 || (i > 90 && (i <> 95 || String.length s = 1) && i < 97)) + || try String.iter (fun c -> - let i = int_of_char c in - if i < 48 || i > 122 || - (i > 57 && (i < 65 || (i > 90 && i <> 95 && i < 97))) - then raise Not_found) + let i = int_of_char c in + if + i < 48 || i > 122 + || (i > 57 && (i < 65 || (i > 90 && i <> 95 && i < 97))) + then + raise Not_found) s; false with Not_found -> true let array_fold_left_mapi f x a = let y = ref x in - let o = Array.init (Array.length a) - (fun i -> let (y',out) = f i !y a.(i) in + let o = + Array.init (Array.length a) (fun i -> + let y', out = f i !y a.(i) in let () = y := y' in - out) in - (!y,o) + out) + in + !y, o let array_map_of_list = let rec fill f i v = function | [] -> () | x :: l -> Array.unsafe_set v i (f x); - fill f (succ i) v l in + fill f (succ i) v l + in fun f -> function | [] -> [||] | x :: l -> @@ -143,10 +153,11 @@ let array_map_of_list = let array_rev_of_list = let rec fill out i = function - | [] -> assert (i= -1) + | [] -> assert (i = -1) | h' :: t' -> let () = Array.unsafe_set out i h' in - fill out (pred i) t' in + fill out (pred i) t' + in function | [] -> [||] | h :: t -> @@ -157,10 +168,11 @@ let array_rev_of_list = let array_rev_map_of_list = let rec fill f out i = function - | [] -> assert (i= -1) + | [] -> assert (i = -1) | h' :: t' -> let () = Array.unsafe_set out i (f h') in - fill f out (pred i) t' in + fill f out (pred i) t' + in fun f -> function | [] -> [||] | h :: t -> @@ -175,186 +187,279 @@ let array_fold_lefti f x a = !y let rec aux_fold_righti i f a x = - if i < 0 then x else + if i < 0 then + x + else aux_fold_righti (pred i) f a (f i a.(i) x) -let array_fold_righti f a x = - aux_fold_righti (Array.length a - 1) f a x -let array_fold_left2i f x a1 a2 = +let array_fold_righti f a x = aux_fold_righti (Array.length a - 1) f a x + +let array_fold_left2i f x a1 a2 = let l = Array.length a1 in - if l <> Array.length a2 then raise (Invalid_argument "array_fold_left2i") - else array_fold_lefti (fun i x e -> f i x e a2.(i)) x a1 + if l <> Array.length a2 then + raise (Invalid_argument "array_fold_left2i") + else + array_fold_lefti (fun i x e -> f i x e a2.(i)) x a1 let array_filter f a = - array_fold_lefti (fun i acc x -> if f i x then i :: acc else acc) [] a + array_fold_lefti + (fun i acc x -> + if f i x then + i :: acc + else + acc) + [] a let array_min_equal_not_null l1 l2 = - if Array.length l1 <> Array.length l2 then None - else + if Array.length l1 <> Array.length l2 then + None + else ( let rec f j = - if j = Array.length l1 then Some ([],[]) - else - let (nb1,ag1) = l1.(j) in - let (nb2,ag2) = l2.(j) in - if nb1 <> nb2 then None - else if nb1 = 0 then f (succ j) - else + if j = Array.length l1 then + Some ([], []) + else ( + let nb1, ag1 = l1.(j) in + let nb2, ag2 = l2.(j) in + if nb1 <> nb2 then + None + else if nb1 = 0 then + f (succ j) + else ( let rec aux i va out = - if i = Array.length l1 then Some out - else - let (nb1,ag1) = l1.(i) in - let (nb2,ag2) = l2.(i) in - if nb1 <> nb2 then None - else if nb1 > 0 && nb1 < va then aux (succ i) nb1 (ag1,ag2) - else aux (succ i) va out in - aux (succ j) nb1 (ag1,ag2) in + if i = Array.length l1 then + Some out + else ( + let nb1, ag1 = l1.(i) in + let nb2, ag2 = l2.(i) in + if nb1 <> nb2 then + None + else if nb1 > 0 && nb1 < va then + aux (succ i) nb1 (ag1, ag2) + else + aux (succ i) va out + ) + in + aux (succ j) nb1 (ag1, ag2) + ) + ) + in f 0 + ) let array_compare compare a b = - let l = Array.length a in let l' = Array.length b in + let l = Array.length a in + let l' = Array.length b in let d = Stdlib.compare l l' in let rec aux_array_compare k = - if k >= l then 0 else + if k >= l then + 0 + else ( let o = compare a.(k) b.(k) in - if o <> 0 then o else aux_array_compare (succ k) in - if d <> 0 then d else aux_array_compare 0 + if o <> 0 then + o + else + aux_array_compare (succ k) + ) + in + if d <> 0 then + d + else + aux_array_compare 0 let iteri f i = - let rec aux j = if j < i then let () = f j in aux (succ j) in + let rec aux j = + if j < i then ( + let () = f j in + aux (succ j) + ) + in aux 0 let rec recti f x i = - if 0 < i then let i' = pred i in recti f (f x i') i' else x - -let min_pos_int_not_zero (keya,dataa) (keyb,datab) = - if keya = 0 then keyb,datab - else if keyb = 0 then keya,dataa - else if compare keya keyb > 0 then keyb,datab - else keya,dataa + if 0 < i then ( + let i' = pred i in + recti f (f x i') i' + ) else + x + +let min_pos_int_not_zero (keya, dataa) (keyb, datab) = + if keya = 0 then + keyb, datab + else if keyb = 0 then + keya, dataa + else if compare keya keyb > 0 then + keyb, datab + else + keya, dataa -let max_pos_int_not_zero (keya,dataa) (keyb,datab) = - if compare keya keyb > 0 then keya,dataa else keyb,datab +let max_pos_int_not_zero (keya, dataa) (keyb, datab) = + if compare keya keyb > 0 then + keya, dataa + else + keyb, datab -let fold_over_permutations - f l accu = +let fold_over_permutations f l accu = let rec aux to_do discarded permutation accu = - match to_do,discarded - with - | [],[] -> f permutation accu - | [],_::_ -> accu - | h::t,_ -> - let to_do1 = - List.fold_left - (fun list a -> a::list) - t discarded - in - let accu = aux to_do1 [] (h::permutation) accu in - let accu = aux t (h::discarded) permutation accu in + match to_do, discarded with + | [], [] -> f permutation accu + | [], _ :: _ -> accu + | h :: t, _ -> + let to_do1 = List.fold_left (fun list a -> a :: list) t discarded in + let accu = aux to_do1 [] (h :: permutation) accu in + let accu = aux t (h :: discarded) permutation accu in accu in aux l [] [] accu let gcd_2 a b = let rec aux a b = - if b = 0 then a - else aux b (a mod b) + if b = 0 then + a + else + aux b (a mod b) in let a = abs a in let b = abs b in - if a < b then aux b a - else aux a b + if a < b then + aux b a + else + aux a b + +let lcm_2 a b = abs a * abs b / gcd_2 a b -let lcm_2 a b = (abs a)*(abs b)/(gcd_2 a b) let lcm list = match list with | [] -> 0 - | h::t -> - List.fold_left lcm_2 h t + | h :: t -> List.fold_left lcm_2 h t let get_interval_list p i j = let add current output = match current with | None -> output - | Some p -> p::output + | Some p -> p :: output in let insert k current = match current with - | None -> Some (k,k) - | Some (_,j) -> Some (k,j) + | None -> Some (k, k) + | Some (_, j) -> Some (k, j) in let rec aux p k current output = - if k (s,None) + String.sub s 0 index, Some (String.sub s (index + 1) (length - index - 1)) + with Not_found -> s, None let smash_duplicate_in_ordered_list p l = - - let () = Format.fprintf Format.std_formatter "DUPL \n" in + let () = Format.fprintf Format.std_formatter "DUPL \n" in let rec aux tail nocc current accu = match tail with - | [] -> (current,nocc)::accu - | (h,n)::t when p h current = 0 -> + | [] -> (current, nocc) :: accu + | (h, n) :: t when p h current = 0 -> (*let () = Format.fprintf Format.std_formatter "DUPL %i\n" (n+nocc) in*) - aux t (n+nocc) current accu - | (h,n)::t -> aux t n h ((current,nocc)::accu) + aux t (n + nocc) current accu + | (h, n) :: t -> aux t n h ((current, nocc) :: accu) in - match (List.rev l) with + match List.rev l with | [] -> [] - | (h,n)::t -> aux t n h [] + | (h, n) :: t -> aux t n h [] let chop_suffix_or_extension name ext = - if Filename.check_suffix name ext - then Filename.chop_suffix name ext - else Filename.remove_extension name + if Filename.check_suffix name ext then + Filename.chop_suffix name ext + else + Filename.remove_extension name let find_available_name ~already_there name ~facultative ~ext = - let ext = match ext with Some e -> e | None -> Filename.extension name in + let ext = + match ext with + | Some e -> e + | None -> Filename.extension name + in let base = chop_suffix_or_extension name ext in - if already_there (base^ext) then - let base' = if facultative <> "" then base^"_"^facultative else base in - if already_there (base'^ext) then + if already_there (base ^ ext) then ( + let base' = + if facultative <> "" then + base ^ "_" ^ facultative + else + base + in + if already_there (base' ^ ext) then ( let v = ref 0 in let () = - while already_there (base'^"~"^(string_of_int !v)^ext) - do incr v; done - in base'^"~"^(string_of_int !v)^ext - else base'^ext - else base^ext + while already_there (base' ^ "~" ^ string_of_int !v ^ ext) do + incr v + done + in + base' ^ "~" ^ string_of_int !v ^ ext + ) else + base' ^ ext + ) else + base ^ ext let default_message_delimter : char = '\x1e' (* "\t" *) let get_ref ref = let i = !ref in - let () = ref := i+1 in + let () = ref := i + 1 in i let remove_double_elements l = let l = List.sort compare l in let rec aux l accu old = - match - l, old - with + match l, old with | [], _ -> accu - | h::t, Some h' when h=h' -> aux t accu old - | h::t, (None | Some _) -> aux t (h::accu) (Some h) + | h :: t, Some h' when h = h' -> aux t accu old + | h :: t, (None | Some _) -> aux t (h :: accu) (Some h) in aux l [] None + +let from_n_to_0 n = + let rec aux k acc = + if k > n then + acc + else + aux (k + 1) (k :: acc) + in + aux 0 [] + +let clear a = Array.iteri (fun i _ -> a.(i) <- []) a + +let sort_by_priority f n = + let a = Array.make (n + 1) [] in + let keys = from_n_to_0 n in + let sort l = + let rec aux l = + match l with + | [] -> () + | h :: t -> + let k = f h in + let () = a.(k) <- h :: a.(k) in + aux t + in + let () = aux l in + let output = + List.fold_left + (fun list key -> + List.fold_left (fun list elt -> elt :: list) list a.(key)) + [] keys + in + let () = clear a in + output + in + sort diff --git a/core/dataStructures/tools.mli b/core/dataStructures/tools.mli index 4cb40e1b71..6ffac6f883 100644 --- a/core/dataStructures/tools.mli +++ b/core/dataStructures/tools.mli @@ -11,6 +11,7 @@ (** {5 Combinators on primitive types} *) val iteri : (int -> unit) -> int -> unit + val recti : ('a -> int -> 'a) -> 'a -> int -> 'a (** [recti f x n] = f (f (f .. (f (f x 0) 1) ..) (n-1) *) @@ -18,15 +19,16 @@ val array_compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int val array_map_of_list : ('a -> 'b) -> 'a list -> 'b array val array_rev_map_of_list : ('a -> 'b) -> 'a list -> 'b array val array_rev_of_list : 'a list -> 'a array -val array_fold_lefti : - (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a -val array_fold_righti : - (int -> 'a -> 'b -> 'b) -> 'a array -> 'b -> 'b +val array_fold_lefti : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a +val array_fold_righti : (int -> 'a -> 'b -> 'b) -> 'a array -> 'b -> 'b val array_filter : (int -> 'a -> bool) -> 'a array -> int list + val array_fold_left_mapi : (int -> 'a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + val array_fold_left2i : (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a + val array_min_equal_not_null : (int * 'a list) array -> (int * 'b list) array -> ('a list * 'b list) option @@ -37,47 +39,38 @@ val pow : int -> int -> int val pow64 : Int64.t -> Int64.t -> Int64.t val not_an_id : string -> bool val read_input : unit -> string -val min_pos_int_not_zero: (int*'a) -> (int*'a) -> (int*'a) -val max_pos_int_not_zero: (int*'a) -> (int*'a) -> (int*'a) - -val fold_over_permutations: (int list -> 'a -> 'a) -> int list -> 'a -> 'a - -val gcd_2: int -> int -> int -val lcm: int list -> int +val min_pos_int_not_zero : int * 'a -> int * 'a -> int * 'a +val max_pos_int_not_zero : int * 'a -> int * 'a -> int * 'a +val fold_over_permutations : (int list -> 'a -> 'a) -> int list -> 'a -> 'a +val gcd_2 : int -> int -> int +val lcm : int list -> int +val fact : int -> int +val cantor_pairing : int -> int -> int -val fact: int -> int -val cantor_pairing: int -> int -> int +val get_product_image_occ : + int -> (int -> int -> int) -> (int -> int) -> 'a list -> int -val get_product_image_occ: - int -> - (int -> int -> int) -> - (int -> int) -> - 'a list -> - int - -val get_product_image_occ_2: - int -> - (int -> int -> int) -> - (int -> int -> int) -> - 'a list -> 'a list -> - int - -val get_interval_list: (int -> bool) -> int -> int -> (int * int) list +val get_product_image_occ_2 : + int -> (int -> int -> int) -> (int -> int -> int) -> 'a list -> 'a list -> int +val get_interval_list : (int -> bool) -> int -> int -> (int * int) list val string_split_on_char : char -> string -> string * string option -val lowercase: string -> string -val capitalize: string -> string -val smash_duplicate_in_ordered_list: +val lowercase : string -> string +val capitalize : string -> string + +val smash_duplicate_in_ordered_list : ('a -> 'a -> int) -> ('a * int) list -> ('a * int) list val chop_suffix_or_extension : string -> string -> string val find_available_name : already_there:(string -> bool) -> - string -> facultative:string -> ext:string option -> string + string -> + facultative:string -> + ext:string option -> + string val default_message_delimter : char - -val get_ref: int ref -> int - -val remove_double_elements: 'a list -> 'a list +val get_ref : int ref -> int +val remove_double_elements : 'a list -> 'a list +val sort_by_priority : ('a -> int) -> int -> 'a list -> 'a list diff --git a/core/dataStructures/valMap.ml b/core/dataStructures/valMap.ml index 04f8956674..8b4bc4ca86 100644 --- a/core/dataStructures/valMap.ml +++ b/core/dataStructures/valMap.ml @@ -7,149 +7,169 @@ (******************************************************************************) type key = int - -type t = - | Empty - | Node of t * key * t * int * Int64.t - (*Node(left,key,right,height,acc)*) +type t = Empty | Node of t * key * t * int * Int64.t +(*Node(left,key,right,height,acc)*) let height = function | Empty -> 0 - | Node(_,_,_,h,_) -> h + | Node (_, _, _, h, _) -> h let accval = function | Empty -> 0L - | Node(_,_,_,_,acc) -> acc + | Node (_, _, _, _, acc) -> acc let total = accval let weight = function | Empty -> 0L - | Node(l,_,r,_,acc) -> Int64.sub (Int64.sub acc (accval l)) (accval r) + | Node (l, _, r, _, acc) -> Int64.sub (Int64.sub acc (accval l)) (accval r) let rec print f = function | Empty -> Pp.empty_set f - | Node (l,k,r,_,acc) as x -> - Format.fprintf f "@[<%d,%Li(%Li)>@,[%a@,|%a@,]" - k acc (weight x) print l print r + | Node (l, k, r, _, acc) as x -> + Format.fprintf f "@[<%d,%Li(%Li)>@,[%a@,|%a@,]" k acc (weight x) + print l print r let create l key acc r = - let hl = height l in let hr = height r in - Node(l, key, r, succ (min hl hr), acc) + let hl = height l in + let hr = height r in + Node (l, key, r, succ (min hl hr), acc) let bal l x w r = - let hl = height l in let hr = height r in - if hl > hr + 2 then - begin - match l with - | Empty -> invalid_arg "Val_map.bal" - | Node(ll, lv, lr, _,acc_l) -> - let acc_r = accval r in - if height ll >= height lr then + let hl = height l in + let hr = height r in + if hl > hr + 2 then ( + match l with + | Empty -> invalid_arg "Val_map.bal" + | Node (ll, lv, lr, _, acc_l) -> + let acc_r = accval r in + if height ll >= height lr then + create ll lv + (Int64.add (Int64.add acc_l w) acc_r) + (create lr x (Int64.add (Int64.add w (accval lr)) acc_r) r) + else ( + match lr with + | Empty -> invalid_arg "Val_map.bal" + | Node (lrl, lrv, lrr, _, _) -> + let acc_lrr = accval lrr in create - ll lv (Int64.add (Int64.add acc_l w) acc_r) - (create lr x (Int64.add (Int64.add w (accval lr)) acc_r) r) - else - begin - match lr with - Empty -> invalid_arg "Val_map.bal" - | Node(lrl, lrv, lrr, _,_)-> - let acc_lrr = accval lrr in - create - (create ll lv (Int64.sub acc_l acc_lrr) lrl) - lrv (Int64.add (Int64.add acc_l w) acc_r) - (create lrr x (Int64.add (Int64.add acc_lrr w) acc_r) r) - end - end - else - if hr > hl + 2 then - begin - match r with - | Empty -> invalid_arg "Val_map.bal" - | Node(rl, rv, rr, _,acc_r) -> - let acc_l = accval l in - if height rr >= height rl then + (create ll lv (Int64.sub acc_l acc_lrr) lrl) + lrv + (Int64.add (Int64.add acc_l w) acc_r) + (create lrr x (Int64.add (Int64.add acc_lrr w) acc_r) r) + ) + ) else if hr > hl + 2 then ( + match r with + | Empty -> invalid_arg "Val_map.bal" + | Node (rl, rv, rr, _, acc_r) -> + let acc_l = accval l in + if height rr >= height rl then + create + (create l x (Int64.add (Int64.add acc_l w) (accval rl)) rl) + rv + (Int64.add (Int64.add acc_l w) acc_r) + rr + else ( + match rl with + | Empty -> invalid_arg "Val_map.bal" + | Node (rll, rlv, rlr, _, _) -> + let acc_rll = accval rll in create - (create l x (Int64.add (Int64.add acc_l w) (accval rl)) rl) - rv (Int64.add (Int64.add acc_l w) acc_r) rr - else - begin - match rl with - | Empty -> invalid_arg "Val_map.bal" - | Node(rll, rlv, rlr, _,_) -> - let acc_rll = accval rll in - create - (create l x (Int64.add (Int64.add acc_l w) acc_rll) rll) - rlv (Int64.add (Int64.add acc_l w) acc_r) - (create rlr rv (Int64.sub acc_r acc_rll) rr) - end - end - else - let acc_l = accval l in let acc_r = accval r in + (create l x (Int64.add (Int64.add acc_l w) acc_rll) rll) + rlv + (Int64.add (Int64.add acc_l w) acc_r) + (create rlr rv (Int64.sub acc_r acc_rll) rr) + ) + ) else ( + let acc_l = accval l in + let acc_r = accval r in create l x (Int64.add (Int64.add acc_l w) acc_r) r + ) let empty = Empty -let is_empty = function Empty -> true | Node _ -> false + +let is_empty = function + | Empty -> true + | Node _ -> false let rec add key weight = function - | Empty -> Node(Empty,key, Empty,1,Int64.of_int weight) - | Node(l, key', r, h,acc) -> + | Empty -> Node (Empty, key, Empty, 1, Int64.of_int weight) + | Node (l, key', r, h, acc) -> if key = key' then - Node(l, key, r, h, - Int64.add (Int64.add (Int64.of_int weight) (accval l)) (accval r)) - else + Node + ( l, + key, + r, + h, + Int64.add (Int64.add (Int64.of_int weight) (accval l)) (accval r) ) + else ( let weight' = Int64.sub (Int64.sub acc (accval l)) (accval r) in if key < key' then bal (add key weight l) key' weight' r else bal l key' weight' (add key weight r) + ) let rec find_acc aim_acc = function | Empty -> raise Not_found - | Node(l,key,r,_,acc) -> - if aim_acc >= acc then raise Not_found - else - let acc_l = accval l in let acc_r = accval r in - if acc_l > aim_acc then find_acc aim_acc l + | Node (l, key, r, _, acc) -> + if aim_acc >= acc then + raise Not_found + else ( + let acc_l = accval l in + let acc_r = accval r in + if acc_l > aim_acc then + find_acc aim_acc l + else if Int64.add acc_r acc_l > aim_acc then + find_acc (Int64.sub aim_acc acc_l) r else - if Int64.add acc_r acc_l > aim_acc - then find_acc (Int64.sub aim_acc acc_l) r - else key + key + ) let rec mem key = function | Empty -> false - | Node(l, key', r,_,_) -> + | Node (l, key', r, _, _) -> let c = Mods.int_compare key key' in - c = 0 || (mem key (if c < 0 then l else r)) + c = 0 + || mem key + (if c < 0 then + l + else + r) let rec min_binding = function | Empty -> raise Not_found - | Node(Empty, x, r,_,acc) -> (x, Int64.sub acc (accval r)) - | Node(l, _, _, _,_) -> min_binding l + | Node (Empty, x, r, _, acc) -> x, Int64.sub acc (accval r) + | Node (l, _, _, _, _) -> min_binding l let rec remove_min_binding = function | Empty -> invalid_arg "Val_map.remove_min_elt" - | Node(Empty, _, r, _,_) -> r - | Node(l, x, r, _,acc) -> + | Node (Empty, _, r, _, _) -> r + | Node (l, x, r, _, acc) -> let weight = Int64.sub (Int64.sub acc (accval l)) (accval r) in bal (remove_min_binding l) x weight r let merge t1 t2 = - match (t1, t2) with - | (Empty, t) -> t - | (t, Empty) -> t - | (Node _, Node _) -> - let (x, w) = min_binding t2 in + match t1, t2 with + | Empty, t -> t + | t, Empty -> t + | Node _, Node _ -> + let x, w = min_binding t2 in bal t1 x w (remove_min_binding t2) let rec remove x = function | Empty -> Empty - | Node(l, v, r,_,acc) -> + | Node (l, v, r, _, acc) -> let c = compare x v in - if c = 0 then merge l r else + if c = 0 then + merge l r + else ( let weight = Int64.sub (Int64.sub acc (accval l)) (accval r) in - if c < 0 then bal (remove x l) v weight r - else bal l v weight (remove x r) + if c < 0 then + bal (remove x l) v weight r + else + bal l v weight (remove x r) + ) (* let rec iter f = function | Empty -> () @@ -166,5 +186,4 @@ let random state m = try let r = Random.State.int64 state (accval m) in find_acc r m - with - | Invalid_argument _ -> invalid_arg "Val_map.random_val" + with Invalid_argument _ -> invalid_arg "Val_map.random_val" diff --git a/core/dataStructures/valMap.mli b/core/dataStructures/valMap.mli index d36e073a8a..8a38e1654e 100644 --- a/core/dataStructures/valMap.mli +++ b/core/dataStructures/valMap.mli @@ -11,9 +11,9 @@ type t val print : Format.formatter -> t -> unit val random : Random.State.t -> t -> key -val empty: t -val is_empty: t -> bool -val add: key -> int -> t -> t -val mem: key -> t -> bool +val empty : t +val is_empty : t -> bool +val add : key -> int -> t -> t +val mem : key -> t -> bool val remove : key -> t -> t val total : t -> Int64.t diff --git a/core/error_handlers/dune b/core/error_handlers/dune index 44bf7f4272..b0d549556e 100644 --- a/core/error_handlers/dune +++ b/core/error_handlers/dune @@ -1,7 +1,16 @@ (library - (name kappa_errors) - (libraries yojson result kappa-library.generic kappa_logging kappa_parameters) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_logging - -open Kappa_parameters ))) + (name kappa_errors) + (libraries + yojson + result + kappa-library.generic + kappa_logging + kappa_parameters) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_logging + -open + Kappa_parameters))) diff --git a/core/error_handlers/exception.ml b/core/error_handlers/exception.ml index 807298289c..cf49557b35 100644 --- a/core/error_handlers/exception.ml +++ b/core/error_handlers/exception.ml @@ -12,14 +12,19 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type method_handler = Exception_without_parameter.method_handler + let empty_error_handler = Exception_without_parameter.empty_error_handler let is_empty_error_handler = Exception_without_parameter.is_empty_error_handler let safe_warn parameters _error_handler file_name message exn _default = - let uncaught = Exception_without_parameter.build_uncaught_exception ?file_name ?message exn in - let stringlist = Exception_without_parameter.stringlist_of_uncaught uncaught [Remanent_parameters.get_prefix parameters] in + let uncaught = + Exception_without_parameter.build_uncaught_exception ?file_name ?message exn + in + let stringlist = + Exception_without_parameter.stringlist_of_uncaught uncaught + [ Remanent_parameters.get_prefix parameters ] + in let _ = List.iter (Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s") @@ -28,99 +33,157 @@ let safe_warn parameters _error_handler file_name message exn _default = let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in raise (Exception_without_parameter.Uncaught_exception uncaught) -let unsafe_warn _parameters error_handler file_name message exn default = - let uncaught = Exception_without_parameter.build_uncaught_exception ?file_name ?message exn in - Exception_without_parameter.add_uncaught_error uncaught error_handler, default () +let unsafe_warn _parameters error_handler ?to_ui file_name message exn default = + let uncaught = + Exception_without_parameter.build_uncaught_exception ?file_name ?message exn + in + ( Exception_without_parameter.add_uncaught_error uncaught ?to_ui error_handler, + default () ) -let warn_aux parameters error_handler file message exn default = - let error,dft = - if Remanent_parameters.get_unsafe parameters - then unsafe_warn parameters error_handler file message exn default - else safe_warn parameters error_handler file message exn default +let warn_aux parameters error_handler ?to_ui file message exn default = + let error, dft = + if Remanent_parameters.get_unsafe parameters then + unsafe_warn parameters error_handler ?to_ui file message exn default + else + safe_warn parameters error_handler file message exn default in let () = Remanent_parameters.save_error_list parameters error in - error,dft + error, dft -let warn_with_exn parameters error_handler (file,line,_,_) ?message:(message="") ?pos:(pos=None) exn default = - let liaison = if message = "" && pos = None then "" else ": " in +let warn_with_exn parameters error_handler ?to_ui (file, line, _, _) + ?(message = "") ?(pos = None) exn default = + let liaison = + if message = "" && pos = None then + "" + else + ": " + in let pos = match pos with | None -> "" - | Some s -> ", "^Locality.to_string s + | Some s -> ", " ^ Loc.to_string s in - warn_aux - parameters error_handler - (Some file) (Some ("line "^(string_of_int line)^pos^liaison^message)) + warn_aux parameters error_handler ?to_ui (Some file) + (Some ("line " ^ string_of_int line ^ pos ^ liaison ^ message)) exn default -let warn parameters error_handler file_line ?message:(message="") ?pos exn default = - warn_with_exn parameters error_handler file_line ~message ~pos exn (fun () -> default) +let warn parameters error_handler ?to_ui file_line ?(message = "") ?pos exn + default = + warn_with_exn parameters error_handler ?to_ui file_line ~message ~pos exn + (fun () -> default) let print_for_KaSim parameters handlers = let parameters = Remanent_parameters.update_prefix parameters "error: " in let _ = List.iter (fun caught -> - let stringlist = (Remanent_parameters.get_prefix parameters)::(Exception_without_parameter.stringlist_of_caught caught []) in - let _ = List.iter - (Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s") stringlist - in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - ()) - (List.rev (Exception_without_parameter.get_caught_exception_list handlers)) + let stringlist = + Remanent_parameters.get_prefix parameters + :: Exception_without_parameter.stringlist_of_caught caught [] + in + let _ = + List.iter + (Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s") + stringlist + in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + ()) + (List.rev + (Exception_without_parameter.get_caught_exception_list handlers)) in let _ = List.iter (fun uncaught -> - let stringlist = (Remanent_parameters.get_prefix parameters)::(Exception_without_parameter.stringlist_of_uncaught uncaught []) in - let _ = List.iter (Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s") stringlist in - let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in - ()) - (List.rev (Exception_without_parameter.get_uncaught_exception_list handlers)) + let stringlist = + Remanent_parameters.get_prefix parameters + :: Exception_without_parameter.stringlist_of_uncaught uncaught [] + in + let _ = + List.iter + (Loggers.fprintf (Remanent_parameters.get_logger parameters) "%s") + stringlist + in + let _ = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in + ()) + (List.rev + (Exception_without_parameter.get_uncaught_exception_list handlers)) in () let print parameters handlers = if Exception_without_parameter.get_caught_exception_list handlers = [] - && - Exception_without_parameter.get_uncaught_exception_list handlers = [] - then - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%sexecution finished without any exception" (Remanent_parameters.get_prefix parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + && Exception_without_parameter.get_uncaught_exception_list handlers = [] + then ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sexecution finished without any exception" + (Remanent_parameters.get_prefix parameters) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in () - else - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%sSome exceptions have been raised" (Remanent_parameters.get_prefix parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + ) else ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sSome exceptions have been raised" + (Remanent_parameters.get_prefix parameters) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in print_for_KaSim parameters handlers + ) let print_errors_light_for_kasim parameters handlers = - if Exception_without_parameter.get_caught_exception_list handlers = [] - && - Exception_without_parameter.get_uncaught_exception_list handlers = [] + if + Exception_without_parameter.get_caught_exception_list handlers = [] + && Exception_without_parameter.get_uncaught_exception_list handlers = [] then () - else - let () = Loggers.fprintf (Remanent_parameters.get_logger parameters) "%sSome exceptions have been raised during the static analysis, please analyse your file with KaSa" (Remanent_parameters.get_prefix parameters) in - let () = Loggers.print_newline (Remanent_parameters.get_logger parameters) in + else ( + let () = + Loggers.fprintf + (Remanent_parameters.get_logger parameters) + "%sSome exceptions have been raised during the static analysis, please \ + analyse your file with KaSa" + (Remanent_parameters.get_prefix parameters) + in + let () = + Loggers.print_newline (Remanent_parameters.get_logger parameters) + in () + ) -let wrap = - (fun parameters error string string_opt exn -> - fst (warn_aux parameters error (Some string) string_opt exn (fun () -> ()))) +let wrap parameters error string string_opt exn = + fst (warn_aux parameters error (Some string) string_opt exn (fun () -> ())) let _lift_error_logs_for_KaSa f = - f - (fun parameters error string string_opt exn -> - fst (warn_aux parameters error (Some string) - string_opt exn (fun () -> ()))) + f (fun parameters error string string_opt exn -> + fst + (warn_aux parameters error (Some string) string_opt exn (fun () -> ()))) let check_point - (warn:Remanent_parameters_sig.parameters -> method_handler -> 'a -> ?message:string -> ?pos:Locality.t -> - exn -> unit -> method_handler * unit) - parameter error error' s ?message ?pos exn = - if error==error' - then error - else - let error,() = warn parameter error' s ?message ?pos exn () in + (warn : + Remanent_parameters_sig.parameters -> + method_handler -> + ?to_ui:bool -> + 'a -> + ?message:string -> + ?pos:Loc.t -> + exn -> + unit -> + method_handler * unit) parameter error error' s ?to_ui ?message ?pos exn = + if error == error' then + error + else ( + let error, () = warn parameter error' ?to_ui s ?message ?pos exn () in error + ) diff --git a/core/error_handlers/exception.mli b/core/error_handlers/exception.mli index bfd76c7334..c0f9ad7853 100644 --- a/core/error_handlers/exception.mli +++ b/core/error_handlers/exception.mli @@ -6,24 +6,59 @@ val empty_error_handler : method_handler val is_empty_error_handler : method_handler -> bool val warn_with_exn : - Remanent_parameters_sig.parameters -> method_handler -> - string * int * int * int -> ?message:string -> ?pos:Locality.t option -> - exn -> (unit -> 'a) -> method_handler * 'a + Remanent_parameters_sig.parameters -> + method_handler -> + ?to_ui:bool -> + string * int * int * int -> + ?message:string -> + ?pos:Loc.t option -> + exn -> + (unit -> 'a) -> + method_handler * 'a val warn : - Remanent_parameters_sig.parameters -> method_handler -> - string * int * int * int -> ?message:string -> ?pos:Locality.t -> - exn -> 'a -> method_handler * 'a + Remanent_parameters_sig.parameters -> + method_handler -> + ?to_ui:bool -> + string * int * int * int -> + ?message:string -> + ?pos:Loc.t -> + exn -> + 'a -> + method_handler * 'a val print : Remanent_parameters_sig.parameters -> method_handler -> unit -val print_errors_light_for_kasim : Remanent_parameters_sig.parameters -> method_handler -> unit -val print_for_KaSim : Remanent_parameters_sig.parameters -> method_handler -> unit -val wrap : Remanent_parameters_sig.parameters -> - method_handler -> string -> string option -> exn -> method_handler +val print_errors_light_for_kasim : + Remanent_parameters_sig.parameters -> method_handler -> unit + +val print_for_KaSim : + Remanent_parameters_sig.parameters -> method_handler -> unit + +val wrap : + Remanent_parameters_sig.parameters -> + method_handler -> + string -> + string option -> + exn -> + method_handler val check_point : - (Remanent_parameters_sig.parameters -> method_handler -> 'a -> ?message:string -> ?pos:Locality.t -> - exn -> unit -> method_handler * unit) -> - Remanent_parameters_sig.parameters -> method_handler -> method_handler -> - 'a -> ?message:string -> ?pos:Locality.t -> exn -> method_handler + (Remanent_parameters_sig.parameters -> + method_handler -> + ?to_ui:bool -> + 'a -> + ?message:string -> + ?pos:Loc.t -> + exn -> + unit -> + method_handler * unit) -> + Remanent_parameters_sig.parameters -> + method_handler -> + method_handler -> + 'a -> + ?to_ui:bool -> + ?message:string -> + ?pos:Loc.t -> + exn -> + method_handler diff --git a/core/error_handlers/lift_error_logs.ml b/core/error_handlers/lift_error_logs.ml index 9c3a26670f..97dc48308e 100644 --- a/core/error_handlers/lift_error_logs.ml +++ b/core/error_handlers/lift_error_logs.ml @@ -1,44 +1,54 @@ (** Time-stamp: *) let for_KaSim f = f (fun _ _ _ _ _ -> ()) () () -let lift_generic_binary_for_KaSim f = - (fun a b -> snd (for_KaSim f a b)) -let lift_generic_binary_binary_for_KaSim f = - (fun a b -> let _,b,c = for_KaSim f a b in b,c) -let lift_generic_ternary_for_KaSim f = - (fun a b c -> snd (for_KaSim f a b c)) +let lift_generic_binary_for_KaSim f a b = snd (for_KaSim f a b) + +let lift_generic_binary_binary_for_KaSim f a b = + let _, b, c = for_KaSim f a b in + b, c + +let lift_generic_ternary_for_KaSim f a b c = snd (for_KaSim f a b c) let lift_gen_unary dump f a = - let parameters = Remanent_parameters.dummy_parameters - ~called_from:Remanent_parameters_sig.KaSa () in + let parameters = + Remanent_parameters.dummy_parameters + ~called_from:Remanent_parameters_sig.KaSa () + in let error = Exception.empty_error_handler in - let error,output = f parameters error a in + let error, output = f parameters error a in let _ = dump parameters error in output let lift_gen_binary dump f a b = - let parameters = Remanent_parameters.dummy_parameters - ~called_from:Remanent_parameters_sig.KaSa () in + let parameters = + Remanent_parameters.dummy_parameters + ~called_from:Remanent_parameters_sig.KaSa () + in let error = Exception.empty_error_handler in - let error,output = f parameters error a b in + let error, output = f parameters error a b in let _ = dump parameters error in output + let lift_gen_ternary dump f a b c = - let parameters = Remanent_parameters.dummy_parameters - ~called_from:Remanent_parameters_sig.KaSa () in + let parameters = + Remanent_parameters.dummy_parameters + ~called_from:Remanent_parameters_sig.KaSa () + in let error = Exception.empty_error_handler in - let error,output = f parameters error a b c in + let error, output = f parameters error a b c in let _ = dump parameters error in output let lift_with_on_the_fly_logging_unary f a = lift_gen_unary Exception.print f a -let lift_with_on_the_fly_logging_binary f a b = lift_gen_binary Exception.print f a b +let lift_with_on_the_fly_logging_binary f a b = + lift_gen_binary Exception.print f a b -let lift_with_on_the_fly_logging_ternary f a b c = lift_gen_binary Exception.print f a b c +let lift_with_on_the_fly_logging_ternary f a b c = + lift_gen_binary Exception.print f a b c let lift_without_logging_unary f a = lift_gen_unary (fun _ _ -> ()) f a - let lift_without_logging_binary f a b = lift_gen_binary (fun _ _ _ -> ()) f a b -let lift_without_logging_ternary f a b c = lift_gen_ternary (fun _ _ _ _ -> ()) f a b c +let lift_without_logging_ternary f a b c = + lift_gen_ternary (fun _ _ _ _ -> ()) f a b c diff --git a/core/grammar/ast.ml b/core/grammar/ast.ml index a2934f3583..bdb032a33a 100644 --- a/core/grammar/ast.ml +++ b/core/grammar/ast.ml @@ -9,191 +9,194 @@ type syntax_version = V3 | V4 let merge_version a b = - match a,b with + match a, b with | V4, _ | _, V4 -> V4 | V3, V3 -> V3 -type internal = string option Locality.annot list +type internal = string option Loc.annoted list type port = { - port_nme:string Locality.annot; - port_int:internal; - port_int_mod: string Locality.annot option; - port_lnk:(string Locality.annot,unit) LKappa.link Locality.annot list; - port_lnk_mod: int Locality.annot option option; + port_name: string Loc.annoted; + port_int: internal; + port_int_mod: string Loc.annoted option; + port_link: (string Loc.annoted, unit) LKappa.link Loc.annoted list; + port_link_mod: int Loc.annoted option option; } -type counter_test = CEQ of int | CGTE of int | CVAR of string +(* TODO change name, CVAR is not a test? *) +(* TODO discriminate between counter definition and counter test ? *) +(* TODO: change this to CTYPE = CTEST (CTESTTYPE * int) | CVAR string? *) + +type counter_test = CEQ of int | CGTE of int | CLTE of int | CVAR of string type counter = { - count_nme: string Locality.annot; - count_test: counter_test Locality.annot option; - count_delta: int Locality.annot; + counter_name: string Loc.annoted; + counter_test: counter_test Loc.annoted option; + (** In a rule: what test is done, in an agent declaration: the min value, in an init declaration: the init value, None if absent *) + counter_delta: int Loc.annoted; + (** In a rule: change in counter value, in an agent declaration: max value of the counter, 0 if absent *) } +(** Counter syntax from AST, present in 3 contexts with different meanings: agent definition, species init declaration, rule *) -type site = - | Port of port - | Counter of counter - -type agent_mod = Erase | Create +type site = Port of port | Counter of counter +type agent_mod = NoMod | Erase | Create type agent = - | Present of string Locality.annot * site list * agent_mod option - | Absent of Locality.t + | Present of string Loc.annoted * site list * agent_mod + | Absent of Loc.t +(* TODO: document why list list *) type mixture = agent list list type edit_notation = { mix: mixture; - delta_token: ((mixture,string) Alg_expr.e Locality.annot - * string Locality.annot) list; + delta_token: + ((mixture, string) Alg_expr.e Loc.annoted * string Loc.annoted) list; } type arrow_notation = { - lhs: mixture ; - rm_token: ((mixture,string) Alg_expr.e Locality.annot - * string Locality.annot) list ; - rhs: mixture ; - add_token: ((mixture,string) Alg_expr.e Locality.annot - * string Locality.annot) list; + lhs: mixture; + rm_token: + ((mixture, string) Alg_expr.e Loc.annoted * string Loc.annoted) list; + rhs: mixture; + add_token: + ((mixture, string) Alg_expr.e Loc.annoted * string Loc.annoted) list; } type rule_content = Edit of edit_notation | Arrow of arrow_notation type rule = { rewrite: rule_content; - bidirectional:bool ; - k_def: (mixture,string) Alg_expr.e Locality.annot ; + bidirectional: bool; + k_def: (mixture, string) Alg_expr.e Loc.annoted; k_un: - ((mixture,string) Alg_expr.e Locality.annot * - (mixture,string) Alg_expr.e Locality.annot option) option; + ((mixture, string) Alg_expr.e Loc.annoted + * (mixture, string) Alg_expr.e Loc.annoted option) + option; (*k_1:radius_opt*) - k_op: (mixture,string) Alg_expr.e Locality.annot option ; + k_op: (mixture, string) Alg_expr.e Loc.annoted option; k_op_un: - ((mixture,string) Alg_expr.e Locality.annot * - (mixture,string) Alg_expr.e Locality.annot option) option; - (*rate for backward rule*) + ((mixture, string) Alg_expr.e Loc.annoted + * (mixture, string) Alg_expr.e Loc.annoted option) + option; + (*rate for backward rule*) } -let flip_label str = str^"_op" +let flip_label str = str ^ "_op" -type ('pattern,'mixture,'id,'rule) modif_expr = - | APPLY of - (('pattern,'id) Alg_expr.e Locality.annot * 'rule Locality.annot) - | UPDATE of - ('id Locality.annot * - ('pattern,'id) Alg_expr.e Locality.annot) - | STOP of ('pattern,'id) Alg_expr.e Primitives.print_expr list - | SNAPSHOT of bool * ('pattern,'id) Alg_expr.e Primitives.print_expr list +type ('pattern, 'mixture, 'id, 'rule) modif_expr = + | APPLY of (('pattern, 'id) Alg_expr.e Loc.annoted * 'rule Loc.annoted) + | UPDATE of ('id Loc.annoted * ('pattern, 'id) Alg_expr.e Loc.annoted) + | STOP of ('pattern, 'id) Alg_expr.e Primitives.print_expr list + | SNAPSHOT of bool * ('pattern, 'id) Alg_expr.e Primitives.print_expr list | PRINT of - (('pattern,'id) Alg_expr.e Primitives.print_expr list) * - (('pattern,'id) Alg_expr.e Primitives.print_expr list) + ('pattern, 'id) Alg_expr.e Primitives.print_expr list + * ('pattern, 'id) Alg_expr.e Primitives.print_expr list | PLOTENTRY - | CFLOWLABEL of (bool * string Locality.annot) - | CFLOWMIX of (bool * 'pattern Locality.annot) + | CFLOWLABEL of (bool * string Loc.annoted) + | CFLOWMIX of (bool * 'pattern Loc.annoted) | DIN of - Primitives.din_kind * ('pattern,'id) Alg_expr.e Primitives.print_expr list - | DINOFF of ('pattern,'id) Alg_expr.e Primitives.print_expr list + Primitives.din_kind + * ('pattern, 'id) Alg_expr.e Primitives.print_expr list + | DINOFF of ('pattern, 'id) Alg_expr.e Primitives.print_expr list | SPECIES_OF of - bool * ('pattern,'id) Alg_expr.e Primitives.print_expr list - * 'pattern Locality.annot - -type ('pattern,'mixture,'id,'rule) perturbation = - (Nbr.t option * - ('pattern,'id) Alg_expr.bool Locality.annot option * - (('pattern,'mixture,'id,'rule) modif_expr list) * - ('pattern,'id) Alg_expr.bool Locality.annot option) Locality.annot - -type configuration = string Locality.annot * (string Locality.annot list) - -type ('pattern,'id) variable_def = - string Locality.annot * ('pattern,'id) Alg_expr.e Locality.annot - -type ('mixture,'id) init_t = - | INIT_MIX of 'mixture Locality.annot - | INIT_TOK of 'id Locality.annot list - -type ('pattern,'mixture,'id) init_statment = - (* string Locality.annot option * (*volume*)*) - ('pattern,'id) Alg_expr.e Locality.annot * ('mixture,'id) init_t - -type ('agent,'pattern,'mixture,'id,'rule) instruction = - | SIG of 'agent - | TOKENSIG of string Locality.annot - | VOLSIG of string * float * string (* type, volume, parameter*) - | INIT of ('pattern,'mixture,'id) init_statment + bool + * ('pattern, 'id) Alg_expr.e Primitives.print_expr list + * 'pattern Loc.annoted + +type ('pattern, 'mixture, 'id, 'rule) perturbation = + (Nbr.t option + * ('pattern, 'id) Alg_expr.bool Loc.annoted option + * ('pattern, 'mixture, 'id, 'rule) modif_expr list + * ('pattern, 'id) Alg_expr.bool Loc.annoted option) + Loc.annoted + +type configuration = string Loc.annoted * string Loc.annoted list + +type ('pattern, 'id) variable_def = + string Loc.annoted * ('pattern, 'id) Alg_expr.e Loc.annoted + +type ('mixture, 'id) init_t = + | INIT_MIX of 'mixture Loc.annoted + | INIT_TOK of 'id Loc.annoted list + +type ('pattern, 'mixture, 'id) init_statement = + (* string Loc.annoted option * (*volume*)*) + ('pattern, 'id) Alg_expr.e Loc.annoted * ('mixture, 'id) init_t + +type ('agent, 'pattern, 'mixture, 'id, 'rule) instruction = + | SIG of 'agent + | TOKENSIG of string Loc.annoted + | VOLSIG of string * float * string (* type, volume, parameter*) + | INIT of ('pattern, 'mixture, 'id) init_statement (*volume, init, position *) - | DECLARE of ('pattern,'id) variable_def - | OBS of ('pattern,'id) variable_def (*for backward compatibility*) - | PLOT of ('pattern,'id) Alg_expr.e Locality.annot - | PERT of ('pattern,'mixture,'id,'rule) perturbation - | CONFIG of configuration - | RULE of (string Locality.annot option * 'rule Locality.annot) - -type ('pattern,'mixture,'id,'rule) command = - | RUN of ('pattern,'id) Alg_expr.bool Locality.annot - | MODIFY of ('pattern,'mixture,'id,'rule) modif_expr list + | DECLARE of ('pattern, 'id) variable_def + | OBS of ('pattern, 'id) variable_def (*for backward compatibility*) + | PLOT of ('pattern, 'id) Alg_expr.e Loc.annoted + | PERT of ('pattern, 'mixture, 'id, 'rule) perturbation + | CONFIG of configuration + | RULE of (string Loc.annoted option * 'rule Loc.annoted) + +type ('pattern, 'mixture, 'id, 'rule) command = + | RUN of ('pattern, 'id) Alg_expr.bool Loc.annoted + | MODIFY of ('pattern, 'mixture, 'id, 'rule) modif_expr list | QUIT -type ('agent,'pattern,'mixture,'id,'rule) compil = - { - filenames : string list; - variables : - ('pattern,'id) variable_def list; - (*pattern declaration for reusing as variable in perturbations - or kinetic rate*) - signatures : - 'agent list; (*agent signature declaration*) - rules : - (string Locality.annot option * 'rule Locality.annot) list; - (*rules (possibly named)*) - observables : - ('pattern,'id) Alg_expr.e Locality.annot list; - (*list of patterns to plot*) - init : ('pattern,'mixture,'id) init_statment list; - (*initial graph declaration*) - perturbations : - ('pattern,'mixture,'id,'rule) perturbation list; - configurations : - configuration list; - tokens : - string Locality.annot list; - volumes : - (string * float * string) list - } +type ('agent, 'pattern, 'mixture, 'id, 'rule) compil = { + filenames: string list; + variables: ('pattern, 'id) variable_def list; + (** pattern declaration for reusing as variable in perturbations + or kinetic rate *) + signatures: 'agent list; (** agent signature declaration *) + rules: (string Loc.annoted option * 'rule Loc.annoted) list; + (** rules (possibly named): [name_option * rule_definition] *) + observables: ('pattern, 'id) Alg_expr.e Loc.annoted list; + (** list of patterns to plot *) + init: ('pattern, 'mixture, 'id) init_statement list; + (** initial graph declaration *) + perturbations: ('pattern, 'mixture, 'id, 'rule) perturbation list; + configurations: configuration list; + tokens: string Loc.annoted list; + volumes: (string * float * string) list; +} -type parsing_compil = (agent,mixture,mixture,string,rule) compil -type parsing_instruction = (agent,mixture,mixture,string,rule) instruction +type parsing_compil = (agent, mixture, mixture, string, rule) compil +type parsing_instruction = (agent, mixture, mixture, string, rule) instruction let no_more_site_on_right error left right = List.for_all (function | Counter _ -> true | Port p -> - List.exists (function + List.exists + (function | Counter _ -> false - | Port p' -> fst p.port_nme = fst p'.port_nme) left - || let () = - if error then - raise (ExceptionDefn.Malformed_Decl - ("Site '"^fst p.port_nme^ - "' was not mentionned in the left-hand side.", - snd p.port_nme)) - in false) + | Port p' -> fst p.port_name = fst p'.port_name) + left + || + let () = + if error then + raise + (ExceptionDefn.Malformed_Decl + ( "Site '" ^ fst p.port_name + ^ "' was not mentionned in the left-hand side.", + snd p.port_name )) + in + false) right let empty_compil = { - filenames = []; - variables = []; - signatures = []; - rules = []; - init = []; - observables = []; - perturbations = []; + filenames = []; + variables = []; + signatures = []; + rules = []; + init = []; + observables = []; + perturbations = []; configurations = []; - tokens = []; - volumes = [] + tokens = []; + volumes = []; } (* @@ -211,17 +214,18 @@ let empty_compil = let print_ast_link mod_l f l = if l <> [] || mod_l <> None then Format.fprintf f "[%a%a]" - (Pp.list Pp.space - (fun f (x,_) -> LKappa.print_link - (fun _ f (x,_) -> Format.pp_print_string f x) - (fun f (x,_) -> Format.pp_print_string f x) - (fun _ () -> ()) f x)) + (Pp.list Pp.space (fun f (x, _) -> + LKappa.print_link + (fun _ f (x, _) -> Format.pp_print_string f x) + (fun f (x, _) -> Format.pp_print_string f x) + (fun _ () -> ()) + f x)) l - (Pp.option ~with_space:false - (fun f x -> Format.fprintf f "/%a" - ((fun f -> function - | Some (l,_)-> Format.pp_print_int f l - | None -> Format.pp_print_string f ".")) + (Pp.option ~with_space:false (fun f x -> + Format.fprintf f "/%a" + (fun f -> function + | Some (l, _) -> Format.pp_print_int f l + | None -> Format.pp_print_string f ".") x)) mod_l @@ -229,528 +233,626 @@ let print_ast_internal mod_i f l = if l <> [] || mod_i <> None then Format.fprintf f "{%a%a}" (Pp.list Pp.space (fun f -> function - | Some x,_ -> Format.pp_print_string f x - | None, _ -> Format.pp_print_string f "#")) + | Some x, _ -> Format.pp_print_string f x + | None, _ -> Format.pp_print_string f "#")) l - (Pp.option ~with_space:false - (fun f (i,_) -> Format.fprintf f "/%s" i)) + (Pp.option ~with_space:false (fun f (i, _) -> Format.fprintf f "/%s" i)) mod_i let print_ast_port f p = - Format.fprintf f "%s%a%a" (fst p.port_nme) - (print_ast_internal p.port_int_mod) p.port_int - (print_ast_link p.port_lnk_mod) p.port_lnk + Format.fprintf f "%s%a%a" (fst p.port_name) + (print_ast_internal p.port_int_mod) + p.port_int + (print_ast_link p.port_link_mod) + p.port_link let print_counter_test f = function | CEQ x, _ -> Format.fprintf f "=%i" x | CGTE x, _ -> Format.fprintf f ">=%i" x - | CVAR x, _ -> Format.fprintf f "=%s" x + | CLTE x, _ -> Format.fprintf f "<=%i" x + | CVAR x, _ -> Format.fprintf f "=%s" x -let print_counter_delta test f (delta,_) = +let print_counter_delta test f (delta, _) = if delta <> 0 then Format.fprintf f "%a+=%d" (Pp.option ~with_space:false (fun f _ -> Format.pp_print_string f "/")) - test - delta + test delta let print_counter f c = - Format.fprintf f "%s{%a%a}" (fst c.count_nme) - (Pp.option ~with_space:false print_counter_test) c.count_test - (print_counter_delta c.count_test) c.count_delta + Format.fprintf f "%s{%a%a}" (fst c.counter_name) + (Pp.option ~with_space:false print_counter_test) + c.counter_test + (print_counter_delta c.counter_test) + c.counter_delta let print_ast_site f = function | Port p -> print_ast_port f p | Counter c -> print_counter f c let string_annot_to_json filenames = - Locality.annot_to_yojson ~filenames JsonUtil.of_string -let string_annot_of_json filenames = - Locality.annot_of_yojson - ~filenames (JsonUtil.to_string ?error_msg:None) + Loc.yojson_of_annoted ~filenames JsonUtil.of_string + +let string_annoted_of_json filenames = + Loc.annoted_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) let string_option_annot_to_json filenames = - Locality.annot_to_yojson - ~filenames (JsonUtil.of_option JsonUtil.of_string) -let string_option_annot_of_json filenames = - Locality.annot_of_yojson - ~filenames (JsonUtil.to_option (JsonUtil.to_string ?error_msg:None)) + Loc.yojson_of_annoted ~filenames (JsonUtil.of_option JsonUtil.of_string) + +let string_option_annoted_of_json filenames = + Loc.annoted_of_yojson ~filenames + (JsonUtil.to_option (JsonUtil.to_string ?error_msg:None)) let counter_test_to_json = function | CEQ x -> `Assoc [ "test", `String "eq"; "val", `Int x ] | CGTE x -> `Assoc [ "test", `String "gte"; "val", `Int x ] + | CLTE x -> `Assoc [ "test", `String "lte"; "val", `Int x ] | CVAR x -> `Assoc [ "test", `String "eq"; "val", `String x ] + let counter_test_of_json = function - | `Assoc [ "test", `String "eq"; "val", `Int x ] - | `Assoc [ "val", `Int x; "test", `String "eq" ] -> CEQ x - | `Assoc [ "val", `Int x; "test", `String "gte" ] - | `Assoc [ "test", `String "gte"; "val", `Int x ] -> CGTE x - | `Assoc [ "test", `String "eq"; "val", `String x ] - | `Assoc [ "val", `String x; "test", `String "eq" ] -> CVAR x - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect counter test",x)) + | `Assoc [ ("test", `String "eq"); ("val", `Int x) ] + | `Assoc [ ("val", `Int x); ("test", `String "eq") ] -> + CEQ x + | `Assoc [ ("val", `Int x); ("test", `String "gte") ] + | `Assoc [ ("test", `String "gte"); ("val", `Int x) ] -> + CGTE x + | `Assoc [ ("val", `Int x); ("test", `String "gle") ] + | `Assoc [ ("test", `String "gle"); ("val", `Int x) ] -> + CLTE x + | `Assoc [ ("test", `String "eq"); ("val", `String x) ] + | `Assoc [ ("val", `String x); ("test", `String "eq") ] -> + CVAR x + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect counter test", x)) let port_to_json filenames p = - let mod_l = JsonUtil.of_option - (function - | None -> `String "FREE" - | Some x -> - Locality.annot_to_yojson ~filenames JsonUtil.of_int x) in - let mod_i =JsonUtil.of_option - (Locality.annot_to_yojson ~filenames JsonUtil.of_string) in - JsonUtil.smart_assoc [ - "port_nme", string_annot_to_json filenames p.port_nme; - "port_int", JsonUtil.smart_assoc [ - "state", JsonUtil.of_list - (string_option_annot_to_json filenames) p.port_int; - "mod", mod_i p.port_int_mod]; - "port_lnk", JsonUtil.smart_assoc [ - "state", JsonUtil.of_list - (Locality.annot_to_yojson ~filenames - (LKappa.link_to_json - (fun _ -> string_annot_to_json filenames) - (string_annot_to_json filenames) (fun ()->[]))) - p.port_lnk; - "mod", mod_l p.port_lnk_mod] - ] + let mod_l = + JsonUtil.of_option (function + | None -> `String "FREE" + | Some x -> Loc.yojson_of_annoted ~filenames JsonUtil.of_int x) + in + let mod_i = + JsonUtil.of_option (Loc.yojson_of_annoted ~filenames JsonUtil.of_string) + in + JsonUtil.smart_assoc + [ + "port_name", string_annot_to_json filenames p.port_name; + ( "port_int", + JsonUtil.smart_assoc + [ + ( "state", + JsonUtil.of_list + (string_option_annot_to_json filenames) + p.port_int ); + "mod", mod_i p.port_int_mod; + ] ); + ( "port_link", + JsonUtil.smart_assoc + [ + ( "state", + JsonUtil.of_list + (Loc.yojson_of_annoted ~filenames + (LKappa.link_to_json + (fun _ -> string_annot_to_json filenames) + (string_annot_to_json filenames) + (fun () -> []))) + p.port_link ); + "mod", mod_l p.port_link_mod; + ] ); + ] + let build_port_of_json filenames n i l = - let mod_l = JsonUtil.to_option - (function - | `String "FREE" -> None - | x -> - Some - (Locality.annot_of_yojson - ~filenames (JsonUtil.to_int ?error_msg:None) x)) in - let mod_i = JsonUtil.to_option - (Locality.annot_of_yojson - ~filenames (JsonUtil.to_string ?error_msg:None)) in - let port_int,port_int_mod = + let mod_l = + JsonUtil.to_option (function + | `String "FREE" -> None + | x -> + Some + (Loc.annoted_of_yojson ~filenames (JsonUtil.to_int ?error_msg:None) x)) + in + let mod_i = + JsonUtil.to_option + (Loc.annoted_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None)) + in + let port_int, port_int_mod = match i with - | `Assoc [] | `Null -> ([],None) - | `Assoc [ "state", i ] -> - (JsonUtil.to_list (string_option_annot_of_json filenames) i, None) - | `Assoc [ "mod", m ] -> ([], mod_i m) - | `Assoc [ "state", i; "mod", m ] - | `Assoc [ "mod", m; "state", i ] -> - (JsonUtil.to_list (string_option_annot_of_json filenames) i, mod_i m) - | _-> raise (Yojson.Basic.Util.Type_error ("Not internal states",i)) in - let port_lnk,port_lnk_mod = + | `Assoc [] | `Null -> [], None + | `Assoc [ ("state", i) ] -> + JsonUtil.to_list (string_option_annoted_of_json filenames) i, None + | `Assoc [ ("mod", m) ] -> [], mod_i m + | `Assoc [ ("state", i); ("mod", m) ] | `Assoc [ ("mod", m); ("state", i) ] + -> + JsonUtil.to_list (string_option_annoted_of_json filenames) i, mod_i m + | _ -> raise (Yojson.Basic.Util.Type_error ("Not internal states", i)) + in + let port_link, port_link_mod = match l with - | `Assoc [] | `Null -> ([],None) - | `Assoc [ "state", l ] -> - (JsonUtil.to_list - (Locality.annot_of_yojson - ~filenames - (LKappa.link_of_json - (fun _ -> string_annot_of_json filenames) - (string_annot_of_json filenames) - (fun _ -> ()))) l,None) - | `Assoc [ "mod", m ] -> ([],mod_l m) - | `Assoc [ "state", l; "mod", m ] - | `Assoc [ "mod", m; "state", l ] -> - (JsonUtil.to_list - (Locality.annot_of_yojson - ~filenames - (LKappa.link_of_json - (fun _ -> string_annot_of_json filenames) - (string_annot_of_json filenames) - (fun _ -> ()))) l,mod_l m) - | _ -> raise (Yojson.Basic.Util.Type_error ("Not link states",i)) in + | `Assoc [] | `Null -> [], None + | `Assoc [ ("state", l) ] -> + ( JsonUtil.to_list + (Loc.annoted_of_yojson ~filenames + (LKappa.link_of_json + (fun _ -> string_annoted_of_json filenames) + (string_annoted_of_json filenames) + (fun _ -> ()))) + l, + None ) + | `Assoc [ ("mod", m) ] -> [], mod_l m + | `Assoc [ ("state", l); ("mod", m) ] | `Assoc [ ("mod", m); ("state", l) ] + -> + ( JsonUtil.to_list + (Loc.annoted_of_yojson ~filenames + (LKappa.link_of_json + (fun _ -> string_annoted_of_json filenames) + (string_annoted_of_json filenames) + (fun _ -> ()))) + l, + mod_l m ) + | _ -> raise (Yojson.Basic.Util.Type_error ("Not link states", i)) + in Port - { port_nme = string_annot_of_json filenames n; - port_int; port_int_mod; - port_lnk; port_lnk_mod; + { + port_name = string_annoted_of_json filenames n; + port_int; + port_int_mod; + port_link; + port_link_mod; } let site_of_json filenames = function - | `Assoc [ "count_nme", n; "count_test", t; "count_delta", d ] | - `Assoc [ "count_nme", n; "count_delta", d; "count_test", t ] | - `Assoc [ "count_test", t; "count_nme", n; "count_delta", d ] | - `Assoc [ "count_test", t; "count_delta", d; "count_nme", n ] | - `Assoc [ "count_delta", d; "count_nme", n; "count_test", t ] | - `Assoc [ "count_delta", d; "count_test", t; "count_nme", n ] -> - Counter { - count_nme = - Locality.annot_of_yojson ~filenames Yojson.Basic.Util.to_string n; - count_test = JsonUtil.to_option - (Locality.annot_of_yojson ~filenames counter_test_of_json) t; - count_delta = - Locality.annot_of_yojson ~filenames Yojson.Basic.Util.to_int d; - } - | `Assoc [ "port_nme", n; "port_int", i; "port_lnk", l ] | - `Assoc [ "port_nme", n; "port_lnk", l; "port_int", i ] | - `Assoc [ "port_int", i; "port_nme", n; "port_lnk", l ] | - `Assoc [ "port_lnk", l; "port_nme", n; "port_int", i ] | - `Assoc [ "port_int", i; "port_lnk", l; "port_nme", n ] | - `Assoc [ "port_lnk", l; "port_int", i; "port_nme", n ] -> + | `Assoc [ ("counter_name", n); ("counter_test", t); ("counter_delta", d) ] + | `Assoc [ ("counter_name", n); ("counter_delta", d); ("counter_test", t) ] + | `Assoc [ ("counter_test", t); ("counter_name", n); ("counter_delta", d) ] + | `Assoc [ ("counter_test", t); ("counter_delta", d); ("counter_name", n) ] + | `Assoc [ ("counter_delta", d); ("counter_name", n); ("counter_test", t) ] + | `Assoc [ ("counter_delta", d); ("counter_test", t); ("counter_name", n) ] -> + Counter + { + counter_name = + Loc.annoted_of_yojson ~filenames Yojson.Basic.Util.to_string n; + counter_test = + JsonUtil.to_option + (Loc.annoted_of_yojson ~filenames counter_test_of_json) + t; + counter_delta = + Loc.annoted_of_yojson ~filenames Yojson.Basic.Util.to_int d; + } + | `Assoc [ ("port_name", n); ("port_int", i); ("port_link", l) ] + | `Assoc [ ("port_name", n); ("port_link", l); ("port_int", i) ] + | `Assoc [ ("port_int", i); ("port_name", n); ("port_link", l) ] + | `Assoc [ ("port_link", l); ("port_name", n); ("port_int", i) ] + | `Assoc [ ("port_int", i); ("port_link", l); ("port_name", n) ] + | `Assoc [ ("port_link", l); ("port_int", i); ("port_name", n) ] -> build_port_of_json filenames n i l - | `Assoc [ "port_nme", n; "port_int", i ] | - `Assoc [ "port_int", i; "port_nme", n ] -> + | `Assoc [ ("port_name", n); ("port_int", i) ] + | `Assoc [ ("port_int", i); ("port_name", n) ] -> build_port_of_json filenames n i `Null - | `Assoc [ "port_nme", n; "port_lnk", l ] | - `Assoc [ "port_lnk", l; "port_nme", n ] -> + | `Assoc [ ("port_name", n); ("port_link", l) ] + | `Assoc [ ("port_link", l); ("port_name", n) ] -> build_port_of_json filenames n `Null l - | `Assoc [ "port_nme", n ] -> build_port_of_json filenames n `Null `Null - | x -> raise (Yojson.Basic.Util.Type_error ("Not an AST agent",x)) + | `Assoc [ ("port_name", n) ] -> build_port_of_json filenames n `Null `Null + | x -> raise (Yojson.Basic.Util.Type_error ("Not an AST agent", x)) let site_to_json filenames = function | Port p -> port_to_json filenames p | Counter c -> - `Assoc [ - "count_nme", - Locality.annot_to_yojson ~filenames JsonUtil.of_string c.count_nme; - "count_test", JsonUtil.of_option - (Locality.annot_to_yojson ~filenames counter_test_to_json) c.count_test; - "count_delta", - Locality.annot_to_yojson ~filenames JsonUtil.of_int c.count_delta - ] + `Assoc + [ + ( "counter_name", + Loc.yojson_of_annoted ~filenames JsonUtil.of_string c.counter_name ); + ( "counter_test", + JsonUtil.of_option + (Loc.yojson_of_annoted ~filenames counter_test_to_json) + c.counter_test ); + ( "counter_delta", + Loc.yojson_of_annoted ~filenames JsonUtil.of_int c.counter_delta ); + ] let print_agent_mod f = function | Create -> Format.pp_print_string f "+" | Erase -> Format.pp_print_string f "-" + | NoMod -> Format.pp_print_string f "" let print_ast_agent f = function | Absent _ -> Format.pp_print_string f "." - | Present ((ag_na,_),l,m) -> - Format.fprintf f "%s(%a)%a" - ag_na - (Pp.list (fun f -> Format.fprintf f " ") print_ast_site) l - (Pp.option ~with_space:false print_agent_mod) m + | Present ((agent_name, _), l, m) -> + Format.fprintf f "%s(%a)%a" agent_name + (Pp.list (fun f -> Format.fprintf f " ") print_ast_site) + l print_agent_mod m let agent_mod_to_yojson = function | Create -> `String "created" | Erase -> `String "erase" + | NoMod -> `String "no_mod" let agent_mod_of_yojson = function | `String "created" -> Create | `String "erase" -> Erase + | `String "no_mod" -> NoMod | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect agent modification",x)) + raise (Yojson.Basic.Util.Type_error ("Incorrect agent modification", x)) let agent_to_json filenames = function | Absent _ -> `Null - | Present (na,l,m) -> + | Present (na, l, m) -> JsonUtil.smart_assoc - [ "name", Locality.annot_to_yojson ~filenames JsonUtil.of_string na; + [ + "name", Loc.yojson_of_annoted ~filenames JsonUtil.of_string na; "sig", JsonUtil.of_list (site_to_json filenames) l; - "mod", (JsonUtil.of_option agent_mod_to_yojson) m] + "mod", agent_mod_to_yojson m; + ] let agent_of_json filenames = function - | `Null -> Absent Locality.dummy - | `Assoc [ "name", n; "sig", s; "mod", m ] - | `Assoc [ "sig", s; "name", n; "mod", m ] - | `Assoc [ "name", n; "mod", m; "sig", s ] - | `Assoc [ "sig", s; "mod", m; "name", n ] - | `Assoc [ "mod", m; "name", n; "sig", s ] - | `Assoc [ "mod", m; "sig", s; "name", n ] -> + | `Null -> Absent Loc.dummy + | `Assoc [ ("name", n); ("sig", s); ("mod", m) ] + | `Assoc [ ("sig", s); ("name", n); ("mod", m) ] + | `Assoc [ ("name", n); ("mod", m); ("sig", s) ] + | `Assoc [ ("sig", s); ("mod", m); ("name", n) ] + | `Assoc [ ("mod", m); ("name", n); ("sig", s) ] + | `Assoc [ ("mod", m); ("sig", s); ("name", n) ] -> Present - (Locality.annot_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, - JsonUtil.to_list (site_of_json filenames) s, - (JsonUtil.to_option agent_mod_of_yojson) m) - | `Assoc [ "name", n; "mod", m ] - | `Assoc [ "mod", m; "name", n ] -> + ( Loc.annoted_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, + JsonUtil.to_list (site_of_json filenames) s, + agent_mod_of_yojson m ) + | `Assoc [ ("name", n); ("mod", m) ] | `Assoc [ ("mod", m); ("name", n) ] -> Present - (Locality.annot_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, - [], (JsonUtil.to_option agent_mod_of_yojson) m) - | `Assoc [ "name", n; "sig", s ] - | `Assoc [ "sig", s; "name", n ] -> + ( Loc.annoted_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, + [], + agent_mod_of_yojson m ) + | `Assoc [ ("name", n); ("sig", s) ] | `Assoc [ ("sig", s); ("name", n) ] -> Present - (Locality.annot_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, - JsonUtil.to_list (site_of_json filenames) s, None) - | `Assoc [ "name", n ] -> + ( Loc.annoted_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, + JsonUtil.to_list (site_of_json filenames) s, + NoMod ) + | `Assoc [ ("name", n) ] -> Present - (Locality.annot_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, - [],None) - | x -> raise (Yojson.Basic.Util.Type_error ("Not an AST agent",x)) + ( Loc.annoted_of_yojson ~filenames (JsonUtil.to_string ?error_msg:None) n, + [], + NoMod ) + | x -> raise (Yojson.Basic.Util.Type_error ("Not an AST agent", x)) let print_ast_mix = - Pp.list - (fun f -> Format.fprintf f "\\@ ") - (Pp.list Pp.comma print_ast_agent) + Pp.list (fun f -> Format.fprintf f "\\@ ") (Pp.list Pp.comma print_ast_agent) let to_erased_mixture = List.map (List.map (function - | Absent pos -> Absent pos - | Present (n,s,_) -> Present (n,s,Some Erase))) + | Absent pos -> Absent pos + | Present (n, s, _) -> Present (n, s, Erase))) let to_created_mixture = List.map (List.map (function - | Absent pos -> Absent pos - | Present (n,s,_) -> Present (n,s,Some Create))) + | Absent pos -> Absent pos + | Present (n, s, _) -> Present (n, s, Create))) let to_dummy_user_link = function - | [] | [ LKappa.LNK_ANY, _ ] -> User_graph.WHATEVER - | [ LKappa.ANY_FREE, _ ] -> User_graph.LINKS [] - | [ LKappa.LNK_VALUE (x, _), _ ] -> User_graph.LINKS [ ((-1,-1),x)] - | [ LKappa.LNK_FREE, _ ] -> User_graph.LINKS [] - | [ LKappa.LNK_SOME, _ ] -> User_graph.SOME - | [ LKappa.LNK_TYPE ((ty,_), (si,_)), _ ] -> User_graph.TYPE (ty,si) + | [] | [ (LKappa.LNK_ANY, _) ] -> User_graph.WHATEVER + | [ (LKappa.ANY_FREE, _) ] -> User_graph.LINKS [] + | [ (LKappa.LNK_VALUE (x, _), _) ] -> User_graph.LINKS [ (-1, -1), x ] + | [ (LKappa.LNK_FREE, _) ] -> User_graph.LINKS [] + | [ (LKappa.LNK_SOME, _) ] -> User_graph.SOME + | [ (LKappa.LNK_TYPE ((ty, _), (si, _)), _) ] -> User_graph.TYPE (ty, si) | _ :: _ :: _ -> assert false (* TODO *) let to_dummy_user_internal = function | [] -> Some [] | [ (None, _) ] -> None - | [ (Some st, _) ] -> Some [st] + | [ (Some st, _) ] -> Some [ st ] | _ :: _ :: _ as l -> Some (List_util.map_option fst l) let to_dummy_user_site = function - | Port { port_nme; port_int; port_int_mod = _; port_lnk; port_lnk_mod = _} -> { - User_graph.site_name = fst port_nme; - User_graph.site_type = User_graph.Port { - User_graph.port_links = to_dummy_user_link port_lnk; - User_graph.port_states = to_dummy_user_internal port_int; - }; + | Port { port_name; port_int; port_int_mod = _; port_link; port_link_mod = _ } + -> + { + User_graph.site_name = fst port_name; + User_graph.site_type = + User_graph.Port + { + User_graph.port_links = to_dummy_user_link port_link; + User_graph.port_states = to_dummy_user_internal port_int; + }; } - | Counter { count_nme; count_test = _; count_delta = _ } -> { - User_graph.site_name = fst count_nme; - User_graph.site_type = User_graph.Counter (-1); (* TODO *) + | Counter { counter_name; counter_test = _; counter_delta = _ } -> + { + User_graph.site_name = fst counter_name; + User_graph.site_type = User_graph.Counter (-1); + (* TODO *) } let to_dummy_user_agent = function | Absent _ -> None - | Present ((na,_),s,_mods) -> Some { - User_graph.node_type = na; - User_graph.node_id = None; - User_graph.node_sites = Tools.array_map_of_list to_dummy_user_site s; - } - -let setup_link m ((line,row),site) va = + | Present ((na, _), s, _mods) -> + Some + { + User_graph.node_type = na; + User_graph.node_id = None; + User_graph.node_sites = Tools.array_map_of_list to_dummy_user_site s; + } + +let setup_link m ((line, row), site) va = match m.(line).(row) with | None -> () - | Some { User_graph.node_sites ; _ } -> + | Some { User_graph.node_sites; _ } -> let s = node_sites.(site) in - match s.User_graph.site_type with + (match s.User_graph.site_type with | User_graph.Counter _ -> () | User_graph.Port p -> node_sites.(site) <- { User_graph.site_name = s.User_graph.site_name; - User_graph.site_type = User_graph.Port { - User_graph.port_links = User_graph.LINKS [va]; - User_graph.port_states = p.User_graph.port_states; - } - } + User_graph.site_type = + User_graph.Port + { + User_graph.port_links = User_graph.LINKS [ va ]; + User_graph.port_states = p.User_graph.port_states; + }; + }) let mixture_to_user_graph m = let out = - Tools.array_map_of_list (Tools.array_map_of_list to_dummy_user_agent) m in + Tools.array_map_of_list (Tools.array_map_of_list to_dummy_user_agent) m + in let acc = Tools.array_fold_lefti (fun line -> - Tools.array_fold_lefti - (fun row acc -> function - | None -> acc - | Some { User_graph.node_sites ; _ } -> - Tools.array_fold_lefti - (fun site acc -> function - | { User_graph.site_type = User_graph.Port - { User_graph.port_links = User_graph.LINKS [];_};_} -> - acc - | { User_graph.site_type = User_graph.Port - { User_graph.port_links = User_graph.LINKS (_::_::_);_};_} -> - assert false - | { User_graph.site_type = User_graph.Port - { User_graph.port_links = ( User_graph.WHATEVER - | User_graph.SOME - | User_graph.TYPE (_, _));_};_} -> acc - | { User_graph.site_type = User_graph.Counter _;_} -> acc - | { User_graph.site_type = User_graph.Port - { User_graph.port_links = User_graph.LINKS [_,id];_};_} -> - match Mods.IntMap.pop id acc with - | (None, acc') -> Mods.IntMap.add id ((line,row),site) acc' - | (Some va, acc') -> - let va' = ((line,row),site) in - let () = setup_link out va va' in - let () = setup_link out va' va in - acc') - acc node_sites)) - Mods.IntMap.empty - out in + Tools.array_fold_lefti (fun row acc -> function + | None -> acc + | Some { User_graph.node_sites; _ } -> + Tools.array_fold_lefti + (fun site acc -> function + | { + User_graph.site_type = + User_graph.Port + { User_graph.port_links = User_graph.LINKS []; _ }; + _; + } -> + acc + | { + User_graph.site_type = + User_graph.Port + { + User_graph.port_links = User_graph.LINKS (_ :: _ :: _); + _; + }; + _; + } -> + assert false + | { + User_graph.site_type = + User_graph.Port + { + User_graph.port_links = + ( User_graph.WHATEVER | User_graph.SOME + | User_graph.TYPE (_, _) ); + _; + }; + _; + } -> + acc + | { User_graph.site_type = User_graph.Counter _; _ } -> acc + | { + User_graph.site_type = + User_graph.Port + { + User_graph.port_links = User_graph.LINKS [ (_, id) ]; + _; + }; + _; + } -> + (match Mods.IntMap.pop id acc with + | None, acc' -> Mods.IntMap.add id ((line, row), site) acc' + | Some va, acc' -> + let va' = (line, row), site in + let () = setup_link out va va' in + let () = setup_link out va' va in + acc')) + acc node_sites)) + Mods.IntMap.empty out + in let () = assert (Mods.IntMap.is_empty acc) in out let init_to_json ~filenames f_mix f_var = function | INIT_MIX m -> - `List [`String "mixture"; Locality.annot_to_yojson ~filenames f_mix m ] + `List [ `String "mixture"; Loc.yojson_of_annoted ~filenames f_mix m ] | INIT_TOK t -> - `List [`String "token"; - JsonUtil.of_list (Locality.annot_to_yojson ~filenames f_var) t ] + `List + [ + `String "token"; + JsonUtil.of_list (Loc.yojson_of_annoted ~filenames f_var) t; + ] let init_of_json ~filenames f_mix f_var = function - | `List [`String "mixture"; m ] -> - INIT_MIX (Locality.annot_of_yojson ~filenames f_mix m) - | `List [`String "token"; t ] -> - INIT_TOK (JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "INIT_TOK") - (Locality.annot_of_yojson ~filenames f_var) t) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid Ast init statement",x)) - -let print_tok pr_mix pr_tok pr_var f ((nb,_),(n,_)) = + | `List [ `String "mixture"; m ] -> + INIT_MIX (Loc.annoted_of_yojson ~filenames f_mix m) + | `List [ `String "token"; t ] -> + INIT_TOK + (JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "INIT_TOK") + (Loc.annoted_of_yojson ~filenames f_var) + t) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid Ast init statement", x)) + +let print_tok pr_mix pr_tok pr_var f ((nb, _), (n, _)) = Format.fprintf f "%a %a" (Alg_expr.print pr_mix pr_tok pr_var) nb pr_tok n + let print_one_size tk f mix = - Format.fprintf - f "%a%t%a" print_ast_mix mix - (fun f -> match tk with [] -> () | _::_ -> Format.pp_print_string f " | ") + Format.fprintf f "%a%t%a" print_ast_mix mix + (fun f -> + match tk with + | [] -> () + | _ :: _ -> Format.pp_print_string f " | ") (Pp.list (fun f -> Format.pp_print_string f " + ") (print_tok (fun f m -> Format.fprintf f "|%a|" print_ast_mix m) - Format.pp_print_string (fun f x -> Format.fprintf f "'%s'" x))) + Format.pp_print_string + (fun f x -> Format.fprintf f "'%s'" x))) tk -let print_arrow f bidir = - Format.pp_print_string f (if bidir then "<->" else "->") -let print_raw_rate pr_mix pr_tok pr_var op f (def,_) = - Format.fprintf - f "%a%t" (Alg_expr.print pr_mix pr_tok pr_var) def - (fun f -> - match op with - None -> () - | Some (d,_) -> - Format.fprintf f ", %a" (Alg_expr.print pr_mix pr_tok pr_var) d) +let print_arrow f bidir = + Format.pp_print_string f + (if bidir then + "<->" + else + "->") + +let print_raw_rate pr_mix pr_tok pr_var op f (def, _) = + Format.fprintf f "%a%t" (Alg_expr.print pr_mix pr_tok pr_var) def (fun f -> + match op with + | None -> () + | Some (d, _) -> + Format.fprintf f ", %a" (Alg_expr.print pr_mix pr_tok pr_var) d) let print_ast_alg_expr = Alg_expr.print (fun f m -> Format.fprintf f "|%a|" print_ast_mix m) - Format.pp_print_string (fun f x -> Format.fprintf f "'%s'" x) + Format.pp_print_string + (fun f x -> Format.fprintf f "'%s'" x) let print_rates_one_dir un f def = - Format.fprintf - f "%a%t" + Format.fprintf f "%a%t" (print_raw_rate (fun f m -> Format.fprintf f "|%a|" print_ast_mix m) - Format.pp_print_string (fun f x -> Format.fprintf f "'%s'" x) None) + Format.pp_print_string + (fun f x -> Format.fprintf f "'%s'" x) + None) def (fun f -> - match un with - None -> () - | Some ((d,_),max_dist) -> - Format.fprintf - f " {%a%t}" print_ast_alg_expr d - (fun f -> - Pp.option - (fun f (md,_) -> Format.fprintf f ":%a" print_ast_alg_expr md) - f max_dist)) + match un with + | None -> () + | Some ((d, _), max_dist) -> + Format.fprintf f " {%a%t}" print_ast_alg_expr d (fun f -> + Pp.option + (fun f (md, _) -> Format.fprintf f ":%a" print_ast_alg_expr md) + f max_dist)) let print_rule_content ~bidirectional f = function - | Edit r -> - Format.fprintf f "@[%a @]" - (print_one_size r.delta_token) r.mix + | Edit r -> Format.fprintf f "@[%a @]" (print_one_size r.delta_token) r.mix | Arrow r -> Format.fprintf f "@[%a %a@ %a@]" - (print_one_size r.rm_token) r.lhs - print_arrow bidirectional - (print_one_size r.add_token) r.rhs + (print_one_size r.rm_token) + r.lhs print_arrow bidirectional + (print_one_size r.add_token) + r.rhs let print_ast_rule f r = - Format.fprintf - f "@[%a @@ %a%t@]" + Format.fprintf f "@[%a @@ %a%t@]" (print_rule_content ~bidirectional:r.bidirectional) r.rewrite - (print_rates_one_dir r.k_un) r.k_def - (fun f -> - match r.k_op, r.k_op_un with - | None,None -> () - | None,_ -> - Format.fprintf f " , %a" - (print_rates_one_dir r.k_op_un) - (Alg_expr.const Nbr.zero) - | Some a,_ -> - Format.fprintf f " , %a" - (print_rates_one_dir r.k_op_un) a) - -let print_configuration f ((n,_),l) = + (print_rates_one_dir r.k_un) r.k_def (fun f -> + match r.k_op, r.k_op_un with + | None, None -> () + | None, _ -> + Format.fprintf f " , %a" + (print_rates_one_dir r.k_op_un) + (Alg_expr.const Nbr.zero) + | Some a, _ -> Format.fprintf f " , %a" (print_rates_one_dir r.k_op_un) a) + +let print_configuration f ((n, _), l) = Format.fprintf f "@[%%def: \"%s\" @[%a@]@]" n - (Pp.list Pp.space (fun f (x,_) -> Format.fprintf f "\"%s\"" x)) l + (Pp.list Pp.space (fun f (x, _) -> Format.fprintf f "\"%s\"" x)) + l let print_init f = function - | (n,_), INIT_MIX (m,_) -> - Format.fprintf f "@[%%init: @[%a@]@ @[%a@]@]" - print_ast_alg_expr n print_ast_mix m - | (n,_), INIT_TOK t -> - Format.fprintf f "@[%%init: %a %a@]" - print_ast_alg_expr n - (Pp.list Pp.space (fun f (x,_) -> Format.pp_print_string f x)) t + | (n, _), INIT_MIX (m, _) -> + Format.fprintf f "@[%%init: @[%a@]@ @[%a@]@]" print_ast_alg_expr n + print_ast_mix m + | (n, _), INIT_TOK t -> + Format.fprintf f "@[%%init: %a %a@]" print_ast_alg_expr n + (Pp.list Pp.space (fun f (x, _) -> Format.pp_print_string f x)) + t let print_ast_bool_expr = Alg_expr.print_bool (fun f m -> Format.fprintf f "|%a|" print_ast_mix m) - Format.pp_print_string (fun f x -> Format.fprintf f "'%s'" x) + Format.pp_print_string + (fun f x -> Format.fprintf f "'%s'" x) let print_print_expr f = let aux f = function - | Primitives.Str_pexpr (str,_) -> Format.fprintf f "\"%s\"" str - | Primitives.Alg_pexpr (alg,_) -> print_ast_alg_expr f alg - in function - | [] -> () - | [ Primitives.Str_pexpr (str,_) ] -> Format.fprintf f " \"%s\"" str - | ([ Primitives.Alg_pexpr _ ] | _::_::_) as e -> - Format.fprintf f "@ (@[%a@])" (Pp.list (fun f -> Format.fprintf f ".") aux) e + | Primitives.Str_pexpr (str, _) -> Format.fprintf f "\"%s\"" str + | Primitives.Alg_pexpr (alg, _) -> print_ast_alg_expr f alg + in + function + | [] -> () + | [ Primitives.Str_pexpr (str, _) ] -> Format.fprintf f " \"%s\"" str + | ([ Primitives.Alg_pexpr _ ] | _ :: _ :: _) as e -> + Format.fprintf f "@ (@[%a@])" + (Pp.list (fun f -> Format.fprintf f ".") aux) + e let print_modif f = function - | APPLY ((n,_),(r,_)) -> + | APPLY ((n, _), (r, _)) -> Format.fprintf f "$APPLY @[%a@] @[%a@];" print_ast_alg_expr n - (print_rule_content ~bidirectional:false) r.rewrite - | UPDATE ((s,_),(n,_)) -> + (print_rule_content ~bidirectional:false) + r.rewrite + | UPDATE ((s, _), (n, _)) -> Format.fprintf f "$UPDATE '%s@' @[%a@];" s print_ast_alg_expr n | STOP p -> Format.fprintf f "$STOP%a;" print_print_expr p - | SNAPSHOT (raw,p) -> - Format.fprintf - f "$SNAPSHOT%a%t;" print_print_expr p (fun f -> if raw then Format.pp_print_string f " [true]") - | PRINT ([],x) -> - Format.fprintf f "$PRINTF%a" print_print_expr x - | PRINT (file,x) -> + | SNAPSHOT (raw, p) -> + Format.fprintf f "$SNAPSHOT%a%t;" print_print_expr p (fun f -> + if raw then Format.pp_print_string f " [true]") + | PRINT ([], x) -> Format.fprintf f "$PRINTF%a" print_print_expr x + | PRINT (file, x) -> Format.fprintf f "$PRINTF%a >%a" print_print_expr x print_print_expr file | PLOTENTRY -> Format.pp_print_string f "$PLOTNOW;" - | CFLOWLABEL (on,(s,_)) -> - Format.fprintf f "$TRACK '%s' %s;" s (if on then "[true]" else "[false]") - | CFLOWMIX (on,(p,_)) -> - Format.fprintf f "$TRACK @[%a@] %s;" - print_ast_mix p (if on then "[true]" else "[false]") - | DIN (k,p) -> - Format.fprintf - f "$DIN%a %t[true]" print_print_expr p - (fun f -> match k with - | Primitives.ABSOLUTE -> Format.fprintf f "\"absolute\" " - | Primitives.RELATIVE -> () - | Primitives.PROBABILITY -> Format.fprintf f "\"probability\" ") - | DINOFF p -> - Format.fprintf f "$DIN%a [false]" print_print_expr p - | SPECIES_OF (on,p,(m,_)) -> - Format.fprintf f "$SPECIES_OF @[%a@] %s >%a;" - print_ast_mix m - (if on then "[true]" else "[false]") print_print_expr p - -let print_perturbation f ((alarm,cond,modif,rep),_) = + | CFLOWLABEL (on, (s, _)) -> + Format.fprintf f "$TRACK '%s' %s;" s + (if on then + "[true]" + else + "[false]") + | CFLOWMIX (on, (p, _)) -> + Format.fprintf f "$TRACK @[%a@] %s;" print_ast_mix p + (if on then + "[true]" + else + "[false]") + | DIN (k, p) -> + Format.fprintf f "$DIN%a %t[true]" print_print_expr p (fun f -> + match k with + | Primitives.ABSOLUTE -> Format.fprintf f "\"absolute\" " + | Primitives.RELATIVE -> () + | Primitives.PROBABILITY -> Format.fprintf f "\"probability\" ") + | DINOFF p -> Format.fprintf f "$DIN%a [false]" print_print_expr p + | SPECIES_OF (on, p, (m, _)) -> + Format.fprintf f "$SPECIES_OF @[%a@] %s >%a;" print_ast_mix m + (if on then + "[true]" + else + "[false]") + print_print_expr p + +let print_perturbation f ((alarm, cond, modif, rep), _) = Format.fprintf f "@[%%mod:%a%a do@ @[%a@]%a@]" - (Pp.option (fun f i -> Format.fprintf f "alarm %a" Nbr.print i)) alarm - (Pp.option (fun f (r,_) -> Format.fprintf f "@[%a@]" print_ast_bool_expr r)) + (Pp.option (fun f i -> Format.fprintf f "alarm %a" Nbr.print i)) + alarm + (Pp.option (fun f (r, _) -> Format.fprintf f "@[%a@]" print_ast_bool_expr r)) cond (Pp.list Pp.space print_modif) modif - (Pp.option (fun f (r,_) -> + (Pp.option (fun f (r, _) -> Format.fprintf f "repeat @[%a@]" print_ast_bool_expr r)) rep let print_parsing_compil_kappa f c = Format.fprintf f "@[%a@,@,%a@,%a@,@,%a@,@,%a@,%a@,@,%a@,@,%a@]@." - (Pp.list Pp.space print_configuration) c.configurations + (Pp.list Pp.space print_configuration) + c.configurations (Pp.list Pp.space (fun f a -> Format.fprintf f "@[%%agent:@ @[%a@]@]" print_ast_agent a)) c.signatures - (Pp.list Pp.space (fun f (s,_) -> Format.fprintf f "%%token: %s" s)) + (Pp.list Pp.space (fun f (s, _) -> Format.fprintf f "%%token: %s" s)) c.tokens - (Pp.list Pp.space (fun f ((s,_),(a,_)) -> + (Pp.list Pp.space (fun f ((s, _), (a, _)) -> Format.fprintf f "@[%%var: '%s'@ @[%a@]@]" s print_ast_alg_expr a)) c.variables - (Pp.list Pp.space (fun f (a,_) -> - Format.fprintf f "@[%%plot:@ @[%a@]@]" - print_ast_alg_expr a)) + (Pp.list Pp.space (fun f (a, _) -> + Format.fprintf f "@[%%plot:@ @[%a@]@]" print_ast_alg_expr a)) c.observables - (Pp.list Pp.space (fun f (s,(r,_)) -> + (Pp.list Pp.space (fun f (s, (r, _)) -> Format.fprintf f "@[@[%a%a@]@]" - (Pp.option ~with_space:false - (fun f (s,_) -> Format.fprintf f "'%s'@ " s)) s - print_ast_rule r)) + (Pp.option ~with_space:false (fun f (s, _) -> + Format.fprintf f "'%s'@ " s)) + s print_ast_rule r)) c.rules (Pp.list Pp.space print_perturbation) c.perturbations @@ -758,24 +860,25 @@ let print_parsing_compil_kappa f c = c.init let arrow_notation_to_yojson filenames f_mix f_var r = - JsonUtil.smart_assoc [ - "lhs", f_mix r.lhs; - "rm_token", - JsonUtil.of_list - (JsonUtil.of_pair - (Locality.annot_to_yojson ~filenames - (Alg_expr.e_to_yojson ~filenames f_mix f_var)) - (string_annot_to_json filenames)) - r.rm_token; - "rhs", f_mix r.rhs; - "add_token", - JsonUtil.of_list - (JsonUtil.of_pair - (Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames f_mix f_var)) - (string_annot_to_json filenames)) - r.add_token; - ] + JsonUtil.smart_assoc + [ + "lhs", f_mix r.lhs; + ( "rm_token", + JsonUtil.of_list + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var)) + (string_annot_to_json filenames)) + r.rm_token ); + "rhs", f_mix r.rhs; + ( "add_token", + JsonUtil.of_list + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var)) + (string_annot_to_json filenames)) + r.add_token ); + ] let arrow_notation_of_yojson filenames f_mix f_var = function | `Assoc l as x when List.length l <= 4 -> @@ -784,38 +887,42 @@ let arrow_notation_of_yojson filenames f_mix f_var = function rm_token = JsonUtil.to_list (JsonUtil.to_pair - (Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var)) - (string_annot_of_json filenames)) + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var)) + (string_annoted_of_json filenames)) (Yojson.Basic.Util.member "rm_token" x); rhs = f_mix (Yojson.Basic.Util.member "rhs" x); add_token = JsonUtil.to_list (JsonUtil.to_pair - (Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var)) - (string_annot_of_json filenames)) + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var)) + (string_annoted_of_json filenames)) (Yojson.Basic.Util.member "add_token" x); } - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect AST arrow_notation",x)) + | x -> + raise (Yojson.Basic.Util.Type_error ("Incorrect AST arrow_notation", x)) let edit_notation_to_yojson filenames r = let mix_to_json = - JsonUtil.of_list (JsonUtil.of_list (agent_to_json filenames)) in - JsonUtil.smart_assoc [ - "mix", mix_to_json r.mix; - "delta_token", - JsonUtil.of_list - (JsonUtil.of_pair - (Locality.annot_to_yojson - ~filenames - (Alg_expr.e_to_yojson ~filenames mix_to_json JsonUtil.of_string)) - (string_annot_to_json filenames)) r.delta_token; - ] + JsonUtil.of_list (JsonUtil.of_list (agent_to_json filenames)) + in + JsonUtil.smart_assoc + [ + "mix", mix_to_json r.mix; + ( "delta_token", + JsonUtil.of_list + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames mix_to_json JsonUtil.of_string)) + (string_annot_to_json filenames)) + r.delta_token ); + ] let edit_notation_of_yojson filenames r = let mix_of_json = - JsonUtil.to_list (JsonUtil.to_list (agent_of_json filenames)) in + JsonUtil.to_list (JsonUtil.to_list (agent_of_json filenames)) + in match r with | `Assoc l as x when List.length l < 3 -> { @@ -823,475 +930,565 @@ let edit_notation_of_yojson filenames r = delta_token = JsonUtil.to_list (JsonUtil.to_pair - (Locality.annot_of_yojson ~filenames - (Alg_expr.e_of_yojson - ~filenames mix_of_json (JsonUtil.to_string ?error_msg:None))) - (string_annot_of_json filenames)) + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames mix_of_json + (JsonUtil.to_string ?error_msg:None))) + (string_annoted_of_json filenames)) (Yojson.Basic.Util.member "delta_token" x); } - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect AST edit_notation",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect AST edit_notation", x)) let rule_content_to_yojson filenames f_mix f_var = function - | Edit r -> `List [ `String "edit"; edit_notation_to_yojson filenames r] + | Edit r -> `List [ `String "edit"; edit_notation_to_yojson filenames r ] | Arrow r -> - `List [ `String "arrow"; arrow_notation_to_yojson filenames f_mix f_var r] + `List [ `String "arrow"; arrow_notation_to_yojson filenames f_mix f_var r ] let rule_content_of_yojson filenames f_mix f_var = function - | `List [ `String "edit"; r] -> Edit (edit_notation_of_yojson filenames r) - | `List [ `String "arrow"; r] -> + | `List [ `String "edit"; r ] -> Edit (edit_notation_of_yojson filenames r) + | `List [ `String "arrow"; r ] -> Arrow (arrow_notation_of_yojson filenames f_mix f_var r) - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect AST rule content",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect AST rule content", x)) let rule_to_json filenames f_mix f_var r = - JsonUtil.smart_assoc [ - "rewrite", rule_content_to_yojson filenames f_mix f_var r.rewrite; - "bidirectional", `Bool r.bidirectional; - "k_def", Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames f_mix f_var) r.k_def; - "k_un", - JsonUtil.of_option - (JsonUtil.of_pair - (Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames f_mix f_var)) - (JsonUtil.of_option (Locality.annot_to_yojson ~filenames - (Alg_expr.e_to_yojson ~filenames f_mix f_var)))) - r.k_un; - "k_op", - JsonUtil.of_option - (Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames f_mix f_var)) r.k_op; - "k_op_un", - JsonUtil.of_option - (JsonUtil.of_pair - (Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames f_mix f_var)) - (JsonUtil.of_option (Locality.annot_to_yojson ~filenames - (Alg_expr.e_to_yojson ~filenames f_mix f_var)))) - r.k_op_un; - ] + JsonUtil.smart_assoc + [ + "rewrite", rule_content_to_yojson filenames f_mix f_var r.rewrite; + "bidirectional", `Bool r.bidirectional; + ( "k_def", + Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var) + r.k_def ); + ( "k_un", + JsonUtil.of_option + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var)) + (JsonUtil.of_option + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var)))) + r.k_un ); + ( "k_op", + JsonUtil.of_option + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var)) + r.k_op ); + ( "k_op_un", + JsonUtil.of_option + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var)) + (JsonUtil.of_option + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var)))) + r.k_op_un ); + ] let rule_of_json filenames f_mix f_var = function | `Assoc l as x when List.length l <= 6 -> - begin - try - { - rewrite = - rule_content_of_yojson filenames f_mix f_var - (Yojson.Basic.Util.member "rewrite" x); - bidirectional = - Yojson.Basic.Util.to_bool - (Yojson.Basic.Util.member "bidirectional" x); - k_def = Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var) - (Yojson.Basic.Util.member "k_def" x); - k_un = - JsonUtil.to_option - (JsonUtil.to_pair - (Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var)) - (JsonUtil.to_option - (Locality.annot_of_yojson ~filenames - (Alg_expr.e_of_yojson ~filenames f_mix f_var)))) - (Yojson.Basic.Util.member "k_un" x); - k_op = JsonUtil.to_option - (Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var)) - (Yojson.Basic.Util.member "k_op" x); - k_op_un = - JsonUtil.to_option - (JsonUtil.to_pair - (Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var)) - (JsonUtil.to_option - (Locality.annot_of_yojson ~filenames - (Alg_expr.e_of_yojson ~filenames f_mix f_var)))) - (Yojson.Basic.Util.member "k_op_un" x); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Incorrect AST rule",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect AST rule",x)) + (try + { + rewrite = + rule_content_of_yojson filenames f_mix f_var + (Yojson.Basic.Util.member "rewrite" x); + bidirectional = + Yojson.Basic.Util.to_bool + (Yojson.Basic.Util.member "bidirectional" x); + k_def = + Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var) + (Yojson.Basic.Util.member "k_def" x); + k_un = + JsonUtil.to_option + (JsonUtil.to_pair + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var)) + (JsonUtil.to_option + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var)))) + (Yojson.Basic.Util.member "k_un" x); + k_op = + JsonUtil.to_option + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var)) + (Yojson.Basic.Util.member "k_op" x); + k_op_un = + JsonUtil.to_option + (JsonUtil.to_pair + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var)) + (JsonUtil.to_option + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var)))) + (Yojson.Basic.Util.member "k_op_un" x); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Incorrect AST rule", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect AST rule", x)) let modif_to_json filenames f_mix f_var = function - | APPLY (alg,r) -> - `List [ `String "APPLY"; - Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames f_mix f_var) alg; - Locality.annot_to_yojson - ~filenames (rule_to_json filenames f_mix f_var) r ] - | UPDATE (id,alg) -> - `List [ `String "UPDATE"; - Locality.annot_to_yojson ~filenames f_var id; - Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames f_mix f_var) alg ] + | APPLY (alg, r) -> + `List + [ + `String "APPLY"; + Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var) + alg; + Loc.yojson_of_annoted ~filenames (rule_to_json filenames f_mix f_var) r; + ] + | UPDATE (id, alg) -> + `List + [ + `String "UPDATE"; + Loc.yojson_of_annoted ~filenames f_var id; + Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var) + alg; + ] | STOP l -> - `List (`String "STOP" :: - List.map (Primitives.print_expr_to_yojson ~filenames f_mix f_var) l) - | SNAPSHOT (raw,l) -> - `List (`String (if raw then "RAW_SNAPSHOT" else "SNAPSHOT") :: - List.map (Primitives.print_expr_to_yojson ~filenames f_mix f_var) l) - | PRINT (file,expr) -> - `List [ `String "PRINT"; - JsonUtil.of_list - (Primitives.print_expr_to_yojson ~filenames f_mix f_var) file; - JsonUtil.of_list - (Primitives.print_expr_to_yojson ~filenames f_mix f_var) expr ] + `List + (`String "STOP" + :: List.map (Primitives.print_expr_to_yojson ~filenames f_mix f_var) l) + | SNAPSHOT (raw, l) -> + `List + (`String + (if raw then + "RAW_SNAPSHOT" + else + "SNAPSHOT") + :: List.map (Primitives.print_expr_to_yojson ~filenames f_mix f_var) l) + | PRINT (file, expr) -> + `List + [ + `String "PRINT"; + JsonUtil.of_list + (Primitives.print_expr_to_yojson ~filenames f_mix f_var) + file; + JsonUtil.of_list + (Primitives.print_expr_to_yojson ~filenames f_mix f_var) + expr; + ] | PLOTENTRY -> `String "PLOTENTRY" - | CFLOWLABEL (b,id) -> + | CFLOWLABEL (b, id) -> `List [ `String "CFLOWLABEL"; `Bool b; string_annot_to_json filenames id ] - | CFLOWMIX (b,m) -> - `List [ `String "CFLOW"; `Bool b; - Locality.annot_to_yojson ~filenames f_mix m ] - | DIN (b,file) -> - `List [ `String "DIN"; Primitives.din_kind_to_yojson b; - JsonUtil.of_list - (Primitives.print_expr_to_yojson ~filenames f_mix f_var) file] + | CFLOWMIX (b, m) -> + `List [ `String "CFLOW"; `Bool b; Loc.yojson_of_annoted ~filenames f_mix m ] + | DIN (b, file) -> + `List + [ + `String "DIN"; + Primitives.din_kind_to_yojson b; + JsonUtil.of_list + (Primitives.print_expr_to_yojson ~filenames f_mix f_var) + file; + ] | DINOFF file -> - `List (`String "DINOFF" :: - List.map - (Primitives.print_expr_to_yojson ~filenames f_mix f_var) file) - | SPECIES_OF (b,l,m) -> - `List [ `String "SPECIES_OF"; - `Bool b; - JsonUtil.of_list - (Primitives.print_expr_to_yojson ~filenames f_mix f_var) l; - Locality.annot_to_yojson ~filenames f_mix m ] + `List + (`String "DINOFF" + :: List.map (Primitives.print_expr_to_yojson ~filenames f_mix f_var) file + ) + | SPECIES_OF (b, l, m) -> + `List + [ + `String "SPECIES_OF"; + `Bool b; + JsonUtil.of_list + (Primitives.print_expr_to_yojson ~filenames f_mix f_var) + l; + Loc.yojson_of_annoted ~filenames f_mix m; + ] let modif_of_json filenames f_mix f_var = function | `List [ `String "APPLY"; alg; mix ] -> - APPLY - (Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var) alg, - Locality.annot_of_yojson - ~filenames (rule_of_json filenames f_mix f_var) mix) + APPLY + ( Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var) + alg, + Loc.annoted_of_yojson ~filenames + (rule_of_json filenames f_mix f_var) + mix ) | `List [ `String "UPDATE"; id; alg ] -> UPDATE - (Locality.annot_of_yojson ~filenames f_var id, - Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var) alg) + ( Loc.annoted_of_yojson ~filenames f_var id, + Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var) + alg ) | `List (`String "STOP" :: l) -> STOP (List.map (Primitives.print_expr_of_yojson ~filenames f_mix f_var) l) | `List (`String "SNAPSHOT" :: l) -> SNAPSHOT - (false,List.map (Primitives.print_expr_of_yojson ~filenames f_mix f_var) l) + ( false, + List.map (Primitives.print_expr_of_yojson ~filenames f_mix f_var) l ) | `List (`String "RAW_SNAPSHOT" :: l) -> SNAPSHOT - (true,List.map (Primitives.print_expr_of_yojson ~filenames f_mix f_var) l) + (true, List.map (Primitives.print_expr_of_yojson ~filenames f_mix f_var) l) | `List [ `String "PRINT"; file; expr ] -> - PRINT - (JsonUtil.to_list - (Primitives.print_expr_of_yojson ~filenames f_mix f_var) file, + PRINT + ( JsonUtil.to_list + (Primitives.print_expr_of_yojson ~filenames f_mix f_var) + file, JsonUtil.to_list - (Primitives.print_expr_of_yojson ~filenames f_mix f_var) expr) + (Primitives.print_expr_of_yojson ~filenames f_mix f_var) + expr ) | `String "PLOTENTRY" -> PLOTENTRY | `List [ `String "CFLOWLABEL"; `Bool b; id ] -> - CFLOWLABEL (b, string_annot_of_json filenames id) + CFLOWLABEL (b, string_annoted_of_json filenames id) | `List [ `String "CFLOW"; `Bool b; m ] -> - CFLOWMIX (b, Locality.annot_of_yojson ~filenames f_mix m) + CFLOWMIX (b, Loc.annoted_of_yojson ~filenames f_mix m) | `List [ `String "DIN"; b; file ] -> - DIN (Primitives.din_kind_of_yojson b, - JsonUtil.to_list - (Primitives.print_expr_of_yojson ~filenames f_mix f_var) file) + DIN + ( Primitives.din_kind_of_yojson b, + JsonUtil.to_list + (Primitives.print_expr_of_yojson ~filenames f_mix f_var) + file ) | `List (`String "DINOFF" :: file) -> - DINOFF (List.map - (Primitives.print_expr_of_yojson ~filenames f_mix f_var) file) + DINOFF + (List.map (Primitives.print_expr_of_yojson ~filenames f_mix f_var) file) | `List [ `String "SPECIES_OF"; `Bool b; file; m ] -> - SPECIES_OF - (b, + SPECIES_OF + ( b, JsonUtil.to_list - (Primitives.print_expr_of_yojson ~filenames f_mix f_var) file, - Locality.annot_of_yojson ~filenames f_mix m) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid modification",x)) + (Primitives.print_expr_of_yojson ~filenames f_mix f_var) + file, + Loc.annoted_of_yojson ~filenames f_mix m ) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid modification", x)) let merge_internal_mod acc = function | None -> acc - | Some (x,pos) -> + | Some (x, pos) -> let x_op = Some x in - if List.exists (fun (x',_) -> x_op = x') acc then acc else (x_op,pos)::acc + if List.exists (fun (x', _) -> x_op = x') acc then + acc + else + (x_op, pos) :: acc let merge_internals = - List.fold_left - (fun acc (x,_ as y) -> - if x = None || List.exists - (fun (x',_) -> - Option_util.equal (fun x x' -> String.compare x x' = 0) x x') acc - then acc else y::acc) + List.fold_left (fun acc ((x, _) as y) -> + if + x = None + || List.exists + (fun (x', _) -> + Option_util.equal (fun x x' -> String.compare x x' = 0) x x') + acc + then + acc + else + y :: acc) let rec merge_sites_counter c = function - | [] -> [Counter c] - | Counter c' :: _ as l when fst c.count_nme = fst c'.count_nme -> l - | (Port _ | Counter _ as h) :: t -> h :: merge_sites_counter c t + | [] -> [ Counter c ] + | Counter c' :: _ as l when fst c.counter_name = fst c'.counter_name -> l + | ((Port _ | Counter _) as h) :: t -> h :: merge_sites_counter c t + let rec merge_sites_port p = function - | [] -> [Port {p with port_lnk = []}] - | Port h :: t when fst p.port_nme = fst h.port_nme -> - Port {h with port_int = - merge_internal_mod - (merge_internals h.port_int p.port_int) p.port_int_mod}::t - | (Port _ | Counter _ as h) :: t -> h :: merge_sites_port p t + | [] -> [ Port { p with port_link = [] } ] + | Port h :: t when fst p.port_name = fst h.port_name -> + Port + { + h with + port_int = + merge_internal_mod + (merge_internals h.port_int p.port_int) + p.port_int_mod; + } + :: t + | ((Port _ | Counter _) as h) :: t -> h :: merge_sites_port p t + let merge_sites = - List.fold_left - (fun acc -> function - | Port p -> merge_sites_port p acc - | Counter c -> merge_sites_counter c acc) + List.fold_left (fun acc -> function + | Port p -> merge_sites_port p acc + | Counter c -> merge_sites_counter c acc) let merge_agents = List.fold_left - (List.fold_left - (fun acc -> function - | Absent _ -> acc - | Present ((na,_ as x),s,_) -> - let rec aux = function - | [] -> [Present - (x,List.map - (function - | Port p -> Port {p with port_lnk = []} - | Counter _ as x -> x) s,None)] - | Present ((na',_),s',_) :: t when String.compare na na' = 0 -> - Present (x,merge_sites s' s,None)::t - | (Present _ | Absent _ as h) :: t -> h :: aux t in - aux acc)) + (List.fold_left (fun acc -> function + | Absent _ -> acc + | Present (((na, _) as x), s, _) -> + let rec aux = function + | [] -> + [ + Present + ( x, + List.map + (function + | Port p -> Port { p with port_link = [] } + | Counter _ as x -> x) + s, + NoMod ); + ] + | Present ((na', _), s', _) :: t when String.compare na na' = 0 -> + Present (x, merge_sites s' s, NoMod) :: t + | ((Present _ | Absent _) as h) :: t -> h :: aux t + in + aux acc)) let merge_tokens = - List.fold_left - (fun acc (_,(na,_ as tok)) -> - let rec aux = function - | [] -> [ tok ] - | (na',_) :: _ as l when String.compare na na' = 0 -> l - | h :: t as l -> - let o = aux t in - if t == o then l else h::o in - aux acc) + List.fold_left (fun acc (_, ((na, _) as tok)) -> + let rec aux = function + | [] -> [ tok ] + | (na', _) :: _ as l when String.compare na na' = 0 -> l + | h :: t as l -> + let o = aux t in + if t == o then + l + else + h :: o + in + aux acc) let sig_from_inits = - List.fold_left - (fun (ags,toks) -> function - | _,INIT_MIX (m,_) -> (merge_agents ags m,toks) - | na,INIT_TOK l -> - (ags,merge_tokens toks (List.map (fun x -> (na,x)) l))) + List.fold_left (fun (ags, toks) -> function + | _, INIT_MIX (m, _) -> merge_agents ags m, toks + | na, INIT_TOK l -> ags, merge_tokens toks (List.map (fun x -> na, x) l)) -let sig_from_rule (ags,toks) r = +let sig_from_rule (ags, toks) r = match r.rewrite with - | Edit e -> (merge_agents ags e.mix, merge_tokens toks e.delta_token) + | Edit e -> merge_agents ags e.mix, merge_tokens toks e.delta_token | Arrow a -> - let (ags',toks') = + let ags', toks' = if r.bidirectional then - (merge_agents ags a.rhs, merge_tokens toks a.add_token) - else (ags,toks) in - (merge_agents ags' a.lhs, merge_tokens toks' a.rm_token) + merge_agents ags a.rhs, merge_tokens toks a.add_token + else + ags, toks + in + merge_agents ags' a.lhs, merge_tokens toks' a.rm_token -let sig_from_rules = - List.fold_left (fun p (_,(r,_)) -> sig_from_rule p r) +let sig_from_rules = List.fold_left (fun p (_, (r, _)) -> sig_from_rule p r) let sig_from_perts = - List.fold_left - (fun acc ((_,_,p,_),_) -> - List.fold_left - (fun p -> function - | APPLY (_,(r,_)) -> sig_from_rule p r - | (UPDATE _ | STOP _ | SNAPSHOT _ | PRINT _ | PLOTENTRY | - CFLOWLABEL _ | CFLOWMIX _ | DIN _ | DINOFF _ | SPECIES_OF _) -> - p) - acc p) - -let implicit_signature r = - let acc = sig_from_inits (r.signatures,r.tokens) r.init in + List.fold_left (fun acc ((_, _, p, _), _) -> + List.fold_left + (fun p -> function + | APPLY (_, (r, _)) -> sig_from_rule p r + | UPDATE _ | STOP _ | SNAPSHOT _ | PRINT _ | PLOTENTRY | CFLOWLABEL _ + | CFLOWMIX _ | DIN _ | DINOFF _ | SPECIES_OF _ -> + p) + acc p) + +let infer_agent_signatures r = + let acc = sig_from_inits (r.signatures, r.tokens) r.init in let acc' = sig_from_rules acc r.rules in - let ags,toks = sig_from_perts acc' r.perturbations in + let ags, toks = sig_from_perts acc' r.perturbations in { r with signatures = ags; tokens = toks } let split_mixture m = List.fold_right - (fun l (lhs,rhs) -> - let (ll,rr) = List.fold_right - (fun ag (lhs,rhs as pack) -> - match ag with - | Absent _ -> pack - | Present ((_,pos as na),intf,modif) -> - match modif with - | Some Create -> (Absent pos::lhs,Present (na,intf,None)::rhs) - | Some Erase -> (Present (na,intf,None)::lhs,Absent pos::rhs) - | None -> - let (intfl,intfr) = - List.fold_left - (fun (l,r) -> function - | Port p -> - (Port {port_nme = p.port_nme; - port_int = p.port_int; - port_int_mod = None; - port_lnk = p.port_lnk; - port_lnk_mod=None}::l, - Port {port_nme = p.port_nme; - port_int = - (match p.port_int_mod with - | None -> p.port_int - | Some (x,pos) -> [Some x,pos]); - port_int_mod = None; - port_lnk = - (match p.port_lnk_mod with - | None -> p.port_lnk - | Some None -> - [ Locality.dummy_annot LKappa.LNK_FREE ] - | Some (Some (i,pos))-> - [ LKappa.LNK_VALUE (i,()),pos ]); - port_lnk_mod=None}::r) - | Counter c -> - (Counter - {c with count_delta = Locality.dummy_annot 0}::l, - Counter {c with count_test = None}::r) - ) ([],[]) intf in - (Present (na,intfl,None)::lhs,Present (na,intfr,None)::rhs) - ) l ([],[]) in - (ll::lhs,rr::rhs)) - m ([],[]) + (fun l (lhs, rhs) -> + let ll, rr = + List.fold_right + (fun ag ((lhs, rhs) as pack) -> + match ag with + | Absent _ -> pack + | Present (((_, pos) as na), intf, modif) -> + (match modif with + | Create -> Absent pos :: lhs, Present (na, intf, NoMod) :: rhs + | Erase -> Present (na, intf, NoMod) :: lhs, Absent pos :: rhs + | NoMod -> + let intfl, intfr = + List.fold_left + (fun (l, r) -> function + | Port p -> + ( Port + { + port_name = p.port_name; + port_int = p.port_int; + port_int_mod = None; + port_link = p.port_link; + port_link_mod = None; + } + :: l, + Port + { + port_name = p.port_name; + port_int = + (match p.port_int_mod with + | None -> p.port_int + | Some (x, pos) -> [ Some x, pos ]); + port_int_mod = None; + port_link = + (match p.port_link_mod with + | None -> p.port_link + | Some None -> + [ Loc.annot_with_dummy LKappa.LNK_FREE ] + | Some (Some (i, pos)) -> + [ LKappa.LNK_VALUE (i, ()), pos ]); + port_link_mod = None; + } + :: r ) + | Counter c -> + ( Counter + { c with counter_delta = Loc.annot_with_dummy 0 } + :: l, + Counter { c with counter_test = None } :: r )) + ([], []) intf + in + ( Present (na, intfl, NoMod) :: lhs, + Present (na, intfr, NoMod) :: rhs ))) + l ([], []) + in + ll :: lhs, rr :: rhs) + m ([], []) let compil_to_json c = let files = - Array.of_list (Lexing.dummy_pos.Lexing.pos_fname::c.filenames) in - let filenames = + Array.of_list (Lexing.dummy_pos.Lexing.pos_fname :: c.filenames) + in + let filenames = Tools.array_fold_lefti (fun i map x -> Mods.StringMap.add x i map) - Mods.StringMap.empty files in + Mods.StringMap.empty files + in let mix_to_json = - JsonUtil.of_list (JsonUtil.of_list (agent_to_json filenames)) in + JsonUtil.of_list (JsonUtil.of_list (agent_to_json filenames)) + in let var_to_json = JsonUtil.of_string in `Assoc [ "filenames", JsonUtil.of_array JsonUtil.of_string files; - "signatures", - JsonUtil.of_list (agent_to_json filenames) c.signatures; + "signatures", JsonUtil.of_list (agent_to_json filenames) c.signatures; "tokens", JsonUtil.of_list (string_annot_to_json filenames) c.tokens; - "variables", JsonUtil.of_list - (JsonUtil.of_pair - (string_annot_to_json filenames) - (Locality.annot_to_yojson ~filenames - (Alg_expr.e_to_yojson ~filenames mix_to_json var_to_json))) - c.variables; - "rules", JsonUtil.of_list - (JsonUtil.of_pair - (JsonUtil.of_option (string_annot_to_json filenames)) - (Locality.annot_to_yojson ~filenames - (rule_to_json filenames mix_to_json var_to_json))) - c.rules; - "observables", - JsonUtil.of_list - (Locality.annot_to_yojson - ~filenames (Alg_expr.e_to_yojson ~filenames mix_to_json var_to_json)) - c.observables; - "init", - JsonUtil.of_list - (JsonUtil.of_pair - (Locality.annot_to_yojson ~filenames - (Alg_expr.e_to_yojson ~filenames mix_to_json var_to_json)) - (init_to_json ~filenames mix_to_json var_to_json)) - c.init; - "perturbations", JsonUtil.of_list - (Locality.annot_to_yojson ~filenames - (fun (alarm,pre,modif,post) -> - `List [ - JsonUtil.of_option Nbr.to_yojson alarm; - JsonUtil.of_option - (Locality.annot_to_yojson ~filenames - (Alg_expr.bool_to_yojson ~filenames mix_to_json var_to_json)) - pre; - JsonUtil.of_list - (modif_to_json filenames mix_to_json var_to_json) modif; - JsonUtil.of_option - (Locality.annot_to_yojson ~filenames - (Alg_expr.bool_to_yojson ~filenames mix_to_json var_to_json)) - post; - ])) c.perturbations; - "configurations", - JsonUtil.of_list - (JsonUtil.of_pair - (string_annot_to_json filenames) - (JsonUtil.of_list (string_annot_to_json filenames))) - c.configurations; + ( "variables", + JsonUtil.of_list + (JsonUtil.of_pair + (string_annot_to_json filenames) + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames mix_to_json var_to_json))) + c.variables ); + ( "rules", + JsonUtil.of_list + (JsonUtil.of_pair + (JsonUtil.of_option (string_annot_to_json filenames)) + (Loc.yojson_of_annoted ~filenames + (rule_to_json filenames mix_to_json var_to_json))) + c.rules ); + ( "observables", + JsonUtil.of_list + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames mix_to_json var_to_json)) + c.observables ); + ( "init", + JsonUtil.of_list + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames mix_to_json var_to_json)) + (init_to_json ~filenames mix_to_json var_to_json)) + c.init ); + ( "perturbations", + JsonUtil.of_list + (Loc.yojson_of_annoted ~filenames (fun (alarm, pre, modif, post) -> + `List + [ + JsonUtil.of_option Nbr.to_yojson alarm; + JsonUtil.of_option + (Loc.yojson_of_annoted ~filenames + (Alg_expr.bool_to_yojson ~filenames mix_to_json + var_to_json)) + pre; + JsonUtil.of_list + (modif_to_json filenames mix_to_json var_to_json) + modif; + JsonUtil.of_option + (Loc.yojson_of_annoted ~filenames + (Alg_expr.bool_to_yojson ~filenames mix_to_json + var_to_json)) + post; + ])) + c.perturbations ); + ( "configurations", + JsonUtil.of_list + (JsonUtil.of_pair + (string_annot_to_json filenames) + (JsonUtil.of_list (string_annot_to_json filenames))) + c.configurations ); ] let compil_of_json = function | `Assoc l as x when List.length l = 9 -> let var_of_json = JsonUtil.to_string ?error_msg:None in - begin - try - let filenames = - JsonUtil.to_array (JsonUtil.to_string ?error_msg:None) - (List.assoc "filenames" l) in - let mix_of_json = - JsonUtil.to_list (JsonUtil.to_list (agent_of_json filenames)) in - { - filenames = List.tl (Array.to_list filenames); - signatures = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST signature") - (agent_of_json filenames) - (List.assoc "signatures" l); - tokens = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST token sig") - (string_annot_of_json filenames) (List.assoc "tokens" l); - variables = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST variables") - (JsonUtil.to_pair - (string_annot_of_json filenames) - (Locality.annot_of_yojson ~filenames - (Alg_expr.e_of_yojson ~filenames mix_of_json var_of_json))) - (List.assoc "variables" l); - rules = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST rules") - (JsonUtil.to_pair - (JsonUtil.to_option (string_annot_of_json filenames)) - (Locality.annot_of_yojson ~filenames - (rule_of_json filenames mix_of_json var_of_json))) - (List.assoc "rules" l); - observables = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST observables") - (Locality.annot_of_yojson ~filenames - (Alg_expr.e_of_yojson ~filenames mix_of_json var_of_json)) - (List.assoc "observables" l); - init = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST init") - (JsonUtil.to_pair - (Locality.annot_of_yojson ~filenames - (Alg_expr.e_of_yojson ~filenames mix_of_json var_of_json)) - (init_of_json ~filenames mix_of_json var_of_json)) - (List.assoc "init" l); - perturbations = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST perturbations") - (Locality.annot_of_yojson - ~filenames - (function - | `List [alarm; pre; modif; post] -> - (JsonUtil.to_option Nbr.of_yojson alarm, - JsonUtil.to_option - (Locality.annot_of_yojson ~filenames - (Alg_expr.bool_of_yojson ~filenames mix_of_json var_of_json)) - pre, - JsonUtil.to_list - (modif_of_json filenames mix_of_json var_of_json) modif, - JsonUtil.to_option - (Locality.annot_of_yojson ~filenames - (Alg_expr.bool_of_yojson ~filenames mix_of_json var_of_json)) - post) - | x -> - raise - (Yojson.Basic.Util.Type_error ("Not a perturbation",x)) - )) - (List.assoc "perturbations" l); - configurations = - JsonUtil.to_list ~error_msg:(JsonUtil.build_msg "AST configuration") - (JsonUtil.to_pair - (string_annot_of_json filenames) - (JsonUtil.to_list (string_annot_of_json filenames))) - (List.assoc "configurations" l); - volumes = []; - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Incorrect AST",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect AST",x)) - -let write_parsing_compil b ast = - Yojson.Basic.write_json b (compil_to_json ast) - -let read_parsing_compil p lb = - compil_of_json (Yojson.Basic.read_json p lb) + (try + let filenames = + JsonUtil.to_array + (JsonUtil.to_string ?error_msg:None) + (List.assoc "filenames" l) + in + let mix_of_json = + JsonUtil.to_list (JsonUtil.to_list (agent_of_json filenames)) + in + { + filenames = List.tl (Array.to_list filenames); + signatures = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST signature") + (agent_of_json filenames) + (List.assoc "signatures" l); + tokens = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST token sig") + (string_annoted_of_json filenames) + (List.assoc "tokens" l); + variables = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST variables") + (JsonUtil.to_pair + (string_annoted_of_json filenames) + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames mix_of_json var_of_json))) + (List.assoc "variables" l); + rules = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST rules") + (JsonUtil.to_pair + (JsonUtil.to_option (string_annoted_of_json filenames)) + (Loc.annoted_of_yojson ~filenames + (rule_of_json filenames mix_of_json var_of_json))) + (List.assoc "rules" l); + observables = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST observables") + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames mix_of_json var_of_json)) + (List.assoc "observables" l); + init = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST init") + (JsonUtil.to_pair + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames mix_of_json var_of_json)) + (init_of_json ~filenames mix_of_json var_of_json)) + (List.assoc "init" l); + perturbations = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST perturbations") + (Loc.annoted_of_yojson ~filenames (function + | `List [ alarm; pre; modif; post ] -> + ( JsonUtil.to_option Nbr.of_yojson alarm, + JsonUtil.to_option + (Loc.annoted_of_yojson ~filenames + (Alg_expr.bool_of_yojson ~filenames mix_of_json + var_of_json)) + pre, + JsonUtil.to_list + (modif_of_json filenames mix_of_json var_of_json) + modif, + JsonUtil.to_option + (Loc.annoted_of_yojson ~filenames + (Alg_expr.bool_of_yojson ~filenames mix_of_json + var_of_json)) + post ) + | x -> + raise (Yojson.Basic.Util.Type_error ("Not a perturbation", x)))) + (List.assoc "perturbations" l); + configurations = + JsonUtil.to_list + ~error_msg:(JsonUtil.build_msg "AST configuration") + (JsonUtil.to_pair + (string_annoted_of_json filenames) + (JsonUtil.to_list (string_annoted_of_json filenames))) + (List.assoc "configurations" l); + volumes = []; + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Incorrect AST", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect AST", x)) + +let write_parsing_compil b ast = Yojson.Basic.write_json b (compil_to_json ast) +let read_parsing_compil p lb = compil_of_json (Yojson.Basic.read_json p lb) diff --git a/core/grammar/ast.mli b/core/grammar/ast.mli index 3f310d293e..f6358a70ad 100644 --- a/core/grammar/ast.mli +++ b/core/grammar/ast.mli @@ -11,33 +11,36 @@ type syntax_version = V3 | V4 val merge_version : syntax_version -> syntax_version -> syntax_version -type internal = string option Locality.annot list +type internal = string option Loc.annoted list type port = { - port_nme:string Locality.annot; - port_int:internal; - port_int_mod: string Locality.annot option; - port_lnk:(string Locality.annot,unit) LKappa.link Locality.annot list; - port_lnk_mod: int Locality.annot option option; + port_name: string Loc.annoted; + port_int: internal; + port_int_mod: string Loc.annoted option; + port_link: (string Loc.annoted, unit) LKappa.link Loc.annoted list; + port_link_mod: int Loc.annoted option option; } +(** Describe a port from an agent. [_int] references the internal state of the port, [_link], the possible links that can be made to this port, [_mod] to the changes in a rule that would be made to the state, used only in edit_notation *) -type counter_test = CEQ of int | CGTE of int | CVAR of string +(** What test is done by the counter expression + * - CEQ: If counter value is equal to the specified value + * - CGTE: If counter value is greater or equal to the specified value + * - CLTE: If counter value is less or equal to the specified value + * - CVAR: Not a test, but defines a variable to be used in the rule rates *) +type counter_test = CEQ of int | CGTE of int | CLTE of int | CVAR of string type counter = { - count_nme: string Locality.annot; - count_test: counter_test Locality.annot option; - count_delta: int Locality.annot; + counter_name: string Loc.annoted; + counter_test: counter_test Loc.annoted option; + counter_delta: int Loc.annoted; } -type site = - | Port of port - | Counter of counter - -type agent_mod = Erase | Create +type site = Port of port | Counter of counter +type agent_mod = NoMod | Erase | Create type agent = - | Present of string Locality.annot * site list * agent_mod option - | Absent of Locality.t + | Present of string Loc.annoted * site list * agent_mod + | Absent of Loc.t type mixture = agent list list @@ -45,146 +48,142 @@ val mixture_to_user_graph : mixture -> User_graph.connected_component type edit_notation = { mix: mixture; - delta_token: ((mixture,string) Alg_expr.e Locality.annot - * string Locality.annot) list; + delta_token: + ((mixture, string) Alg_expr.e Loc.annoted * string Loc.annoted) list; } type arrow_notation = { - lhs: mixture ; - rm_token: ((mixture,string) Alg_expr.e Locality.annot - * string Locality.annot) list ; - rhs: mixture ; - add_token: ((mixture,string) Alg_expr.e Locality.annot - * string Locality.annot) list; + lhs: mixture; + rm_token: + ((mixture, string) Alg_expr.e Loc.annoted * string Loc.annoted) list; + rhs: mixture; + add_token: + ((mixture, string) Alg_expr.e Loc.annoted * string Loc.annoted) list; } type rule_content = Edit of edit_notation | Arrow of arrow_notation type rule = { + (* TODO: is rewrite good naming ? *) rewrite: rule_content; - bidirectional:bool ; - k_def: (mixture,string) Alg_expr.e Locality.annot ; + bidirectional: bool; + (* rates *) + k_def: (mixture, string) Alg_expr.e Loc.annoted; k_un: - ((mixture,string) Alg_expr.e Locality.annot * - (mixture,string) Alg_expr.e Locality.annot option) option; + ((mixture, string) Alg_expr.e Loc.annoted + * (mixture, string) Alg_expr.e Loc.annoted option) + option; (*k_1:radius_opt*) - k_op: (mixture,string) Alg_expr.e Locality.annot option ; + k_op: (mixture, string) Alg_expr.e Loc.annoted option; k_op_un: - ((mixture,string) Alg_expr.e Locality.annot * - (mixture,string) Alg_expr.e Locality.annot option) option; - (*rate for backward rule*) + ((mixture, string) Alg_expr.e Loc.annoted + * (mixture, string) Alg_expr.e Loc.annoted option) + option; + (*rate for backward rule*) } val flip_label : string -> string -type ('pattern,'mixture,'id,'rule) modif_expr = - | APPLY of - (('pattern,'id) Alg_expr.e Locality.annot * 'rule Locality.annot) - | UPDATE of - ('id Locality.annot * ('pattern,'id) Alg_expr.e Locality.annot) +type ('pattern, 'mixture, 'id, 'rule) modif_expr = + | APPLY of (('pattern, 'id) Alg_expr.e Loc.annoted * 'rule Loc.annoted) + | UPDATE of ('id Loc.annoted * ('pattern, 'id) Alg_expr.e Loc.annoted) (*TODO: pause*) - | STOP of ('pattern,'id) Alg_expr.e Primitives.print_expr list - | SNAPSHOT of bool * ('pattern,'id) Alg_expr.e Primitives.print_expr list + | STOP of ('pattern, 'id) Alg_expr.e Primitives.print_expr list + | SNAPSHOT of bool * ('pattern, 'id) Alg_expr.e Primitives.print_expr list (*maybe later of mixture too*) | PRINT of - (('pattern,'id) Alg_expr.e Primitives.print_expr list) * - (('pattern,'id) Alg_expr.e Primitives.print_expr list) + ('pattern, 'id) Alg_expr.e Primitives.print_expr list + * ('pattern, 'id) Alg_expr.e Primitives.print_expr list | PLOTENTRY - | CFLOWLABEL of (bool * string Locality.annot) - | CFLOWMIX of (bool * 'pattern Locality.annot) + | CFLOWLABEL of (bool * string Loc.annoted) + | CFLOWMIX of (bool * 'pattern Loc.annoted) | DIN of - Primitives.din_kind * ('pattern,'id) Alg_expr.e Primitives.print_expr list - | DINOFF of ('pattern,'id) Alg_expr.e Primitives.print_expr list + Primitives.din_kind + * ('pattern, 'id) Alg_expr.e Primitives.print_expr list + | DINOFF of ('pattern, 'id) Alg_expr.e Primitives.print_expr list | SPECIES_OF of - bool * ('pattern,'id) Alg_expr.e Primitives.print_expr list - * 'pattern Locality.annot - -type ('pattern,'mixture,'id,'rule) perturbation = - (Nbr.t option * - ('pattern,'id) Alg_expr.bool Locality.annot option * - (('pattern,'mixture,'id,'rule) modif_expr list) * - ('pattern,'id) Alg_expr.bool Locality.annot option) - Locality.annot - -type configuration = string Locality.annot * (string Locality.annot list) - -type ('pattern,'id) variable_def = - string Locality.annot * ('pattern,'id) Alg_expr.e Locality.annot - -type ('mixture,'id) init_t = - | INIT_MIX of 'mixture Locality.annot - | INIT_TOK of 'id Locality.annot list - -type ('pattern,'mixture,'id) init_statment = - ('pattern,'id) Alg_expr.e Locality.annot * ('mixture,'id) init_t - -type ('agent,'pattern,'mixture,'id,'rule) instruction = - | SIG of 'agent - | TOKENSIG of string Locality.annot - | VOLSIG of string * float * string (* type, volume, parameter*) - | INIT of ('pattern,'mixture,'id) init_statment - | DECLARE of ('pattern,'id) variable_def - | OBS of ('pattern,'id) variable_def (*for backward compatibility*) - | PLOT of ('pattern,'id) Alg_expr.e Locality.annot - | PERT of ('pattern,'mixture,'id,'rule) perturbation - | CONFIG of configuration - | RULE of (string Locality.annot option * 'rule Locality.annot) - -type ('pattern,'mixture,'id,'rule) command = - | RUN of ('pattern,'id) Alg_expr.bool Locality.annot - | MODIFY of ('pattern,'mixture,'id,'rule) modif_expr list + bool + * ('pattern, 'id) Alg_expr.e Primitives.print_expr list + * 'pattern Loc.annoted + +type ('pattern, 'mixture, 'id, 'rule) perturbation = + (Nbr.t option + * ('pattern, 'id) Alg_expr.bool Loc.annoted option + * ('pattern, 'mixture, 'id, 'rule) modif_expr list + * ('pattern, 'id) Alg_expr.bool Loc.annoted option) + Loc.annoted + +type configuration = string Loc.annoted * string Loc.annoted list + +type ('pattern, 'id) variable_def = + string Loc.annoted * ('pattern, 'id) Alg_expr.e Loc.annoted + +type ('mixture, 'id) init_t = + | INIT_MIX of 'mixture Loc.annoted + | INIT_TOK of 'id Loc.annoted list + +type ('pattern, 'mixture, 'id) init_statement = + ('pattern, 'id) Alg_expr.e Loc.annoted * ('mixture, 'id) init_t + +type ('agent, 'pattern, 'mixture, 'id, 'rule) instruction = + | SIG of 'agent + | TOKENSIG of string Loc.annoted + | VOLSIG of string * float * string (** type, volume, parameter *) + | INIT of ('pattern, 'mixture, 'id) init_statement + | DECLARE of ('pattern, 'id) variable_def + | OBS of ('pattern, 'id) variable_def (*for backward compatibility*) + | PLOT of ('pattern, 'id) Alg_expr.e Loc.annoted + | PERT of ('pattern, 'mixture, 'id, 'rule) perturbation + | CONFIG of configuration + | RULE of (string Loc.annoted option * 'rule Loc.annoted) + +type ('pattern, 'mixture, 'id, 'rule) command = + | RUN of ('pattern, 'id) Alg_expr.bool Loc.annoted + | MODIFY of ('pattern, 'mixture, 'id, 'rule) modif_expr list | QUIT -type ('agent,'pattern,'mixture,'id,'rule) compil = - { - filenames : string list; - variables : - ('pattern,'id) variable_def list; - (*pattern declaration for reusing as variable in perturbations or kinetic rate*) - signatures : - 'agent list; (**agent signature declaration*) - rules : - (string Locality.annot option * 'rule Locality.annot) list; - (**rules (possibly named)*) - observables : ('pattern,'id) Alg_expr.e Locality.annot list; - (*list of patterns to plot*) - init : ('pattern,'mixture,'id) init_statment list; - (*initial graph declaration*) - perturbations : ('pattern,'mixture,'id,'rule) perturbation list; - configurations : configuration list; - tokens : string Locality.annot list; - volumes : (string * float * string) list - } - -type parsing_compil = (agent,mixture,mixture,string,rule) compil -type parsing_instruction = (agent,mixture,mixture,string,rule) instruction +type ('agent, 'pattern, 'mixture, 'id, 'rule) compil = { + filenames: string list; + variables: ('pattern, 'id) variable_def list; + (** pattern declaration for reusing as variable in perturbations or kinetic rate *) + signatures: 'agent list; (** agent signature declarations *) + rules: (string Loc.annoted option * 'rule Loc.annoted) list; + (**rules (possibly named)*) + observables: ('pattern, 'id) Alg_expr.e Loc.annoted list; + (** list of patterns to plot *) + init: ('pattern, 'mixture, 'id) init_statement list; + (** initial graph declaration *) + perturbations: ('pattern, 'mixture, 'id, 'rule) perturbation list; + configurations: configuration list; + tokens: string Loc.annoted list; + volumes: (string * float * string) list; +} + +type parsing_compil = (agent, mixture, mixture, string, rule) compil +type parsing_instruction = (agent, mixture, mixture, string, rule) instruction val empty_compil : parsing_compil - val no_more_site_on_right : bool -> site list -> site list -> bool -val split_mixture : mixture -> (mixture * mixture) +val split_mixture : mixture -> mixture * mixture (** @return (lhs,rhs) *) -val implicit_signature : parsing_compil -> parsing_compil -(** Infer agent signatures and tokens from init, rules and perturbations *) +val infer_agent_signatures : parsing_compil -> parsing_compil +(** Used when agent signatures is implicit: infer agent signatures and tokens from init, rules and perturbations *) (** {6 Printers} *) val print_counter : Format.formatter -> counter -> unit val print_ast_mix : Format.formatter -> mixture -> unit val print_ast_rule : Format.formatter -> rule -> unit + val print_rule_content : bidirectional:bool -> Format.formatter -> rule_content -> unit -val print_parsing_compil_kappa : - Format.formatter -> parsing_compil -> unit - +val print_parsing_compil_kappa : Format.formatter -> parsing_compil -> unit val to_erased_mixture : mixture -> mixture val to_created_mixture : mixture -> mixture - val compil_of_json : Yojson.Basic.t -> parsing_compil val compil_to_json : parsing_compil -> Yojson.Basic.t - val write_parsing_compil : Buffer.t -> parsing_compil -> unit val read_parsing_compil : Yojson.lexer_state -> Lexing.lexbuf -> parsing_compil diff --git a/core/grammar/counters_compiler.ml b/core/grammar/counters_compiler.ml index 296ed845c8..81253db9bc 100644 --- a/core/grammar/counters_compiler.ml +++ b/core/grammar/counters_compiler.ml @@ -6,739 +6,1069 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type 'a rule_agent_counters = { - ra : 'a; - ra_counters : (Ast.counter * LKappa.switching) option array; +type 'a with_agent_counters = { + agent: 'a; + counters: (Ast.counter * LKappa.switching) option array; } -let combinations ls1 ls2 = - if (ls1 = []) then List.fold_left (fun acc (b,ds) -> ([b],ds)::acc) [] ls2 +type rule_mixture_with_agent_counters = + LKappa.rule_agent with_agent_counters list + +type raw_mixture_with_agent_counters = + Raw_mixture.agent with_agent_counters list + +(** [combinations_of_var_setup ls1 ls2] + * Each element of [ls1] describes a setup of counter variables, with the first element of the tuple being the list of entities to be used in the model, where variables have been removed from counters, and the second one the mapping of variables to their values, that allows to know which instance of model entities would be chosen in this given setup. + * [ls2] adds a new entity with different kinds according to the variable values given in the list as second member of the tuple, which is then combined in this function with the other setups, combining the different variable values which those already defined. + * No check is done on the unicity of the described variables and their values *) +let combinations_of_var_setup (ls1 : ('a list * 'b list) list) + (ls2 : ('a * 'b list) list) : ('a list * 'b list) list = + if ls1 = [] then + List.fold_left (fun acc (b, ds) -> ([ b ], ds) :: acc) [] ls2 else List.fold_left - (fun acc (a,cs) -> - List.fold_left (fun acc' (b,ds) -> ((b::a),ds@cs)::acc') acc ls2) + (fun acc (a, cs) -> + List.fold_left (fun acc' (b, ds) -> (b :: a, ds @ cs) :: acc') acc ls2) [] ls1 -let update_rate counters (k,a) = +let update_rate counter_var_values (k, a) = let update_id s k = - let (a,_) = - List.partition (fun (s',_) -> (String.compare s s') = 0) counters in - match a with - | [(_,x)] -> Alg_expr.CONST (Nbr.I x) + let counters_matching_s, _ = + List.partition (fun (s', _) -> String.compare s s' = 0) counter_var_values + in + match counters_matching_s with + | [ (_, x) ] -> Alg_expr.CONST (Nbr.I x) | [] -> k - | _::_ -> raise (ExceptionDefn.Malformed_Decl - ("Counter variable "^s^" appears twice in rule", - Locality.dummy)) in - let rec update_bool k = match k with + | _ :: _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Counter variable " ^ s ^ " appears twice in rule", Loc.dummy)) + in + let rec update_bool_expr k = + match k with | Alg_expr.TRUE | Alg_expr.FALSE -> k - | Alg_expr.BIN_BOOL_OP (op,(k1,a1),(k2,a2)) -> - Alg_expr.BIN_BOOL_OP (op,((update_bool k1),a1),((update_bool k2),a2)) - | Alg_expr.UN_BOOL_OP (op,(k,a)) -> - Alg_expr.UN_BOOL_OP (op,(update_bool k,a)) - | Alg_expr.COMPARE_OP (op,(k1,a1),(k2,a2)) -> - Alg_expr.COMPARE_OP (op,((update_expr k1),a1),((update_expr k2),a2)) - and update_expr k = match k with - | Alg_expr.BIN_ALG_OP (op,(k1,a1),(k2,a2)) -> - Alg_expr.BIN_ALG_OP (op,((update_expr k1),a1),((update_expr k2),a2)) - | Alg_expr.UN_ALG_OP (op,(k1,a1)) -> - Alg_expr.UN_ALG_OP (op,((update_expr k1),a1)) - | Alg_expr.IF ((k1,a1),(k2,a2),(k3,a3)) -> - Alg_expr.IF - (((update_bool k1),a1),((update_expr k2),a2),((update_expr k3),a3)) - | Alg_expr.DIFF_TOKEN ((k1,a1),k2) -> - Alg_expr.DIFF_TOKEN (((update_expr k1),a1),k2) - | Alg_expr.DIFF_KAPPA_INSTANCE ((k,a),m) -> - Alg_expr.DIFF_KAPPA_INSTANCE (((update_expr k),a),m) - | Alg_expr.ALG_VAR id| Alg_expr.TOKEN_ID id -> - update_id id k - | Alg_expr.STATE_ALG_OP _| Alg_expr.CONST _| Alg_expr.KAPPA_INSTANCE _ -> k - in - ((update_expr k),a) - -let collect_ids expr_list expr2_list= + | Alg_expr.BIN_BOOL_OP (op, (k1, a1), (k2, a2)) -> + Alg_expr.BIN_BOOL_OP + (op, (update_bool_expr k1, a1), (update_bool_expr k2, a2)) + | Alg_expr.UN_BOOL_OP (op, (k, a)) -> + Alg_expr.UN_BOOL_OP (op, (update_bool_expr k, a)) + | Alg_expr.COMPARE_OP (op, (k1, a1), (k2, a2)) -> + Alg_expr.COMPARE_OP (op, (update_expr k1, a1), (update_expr k2, a2)) + and update_expr k = + match k with + | Alg_expr.BIN_ALG_OP (op, (k1, a1), (k2, a2)) -> + Alg_expr.BIN_ALG_OP (op, (update_expr k1, a1), (update_expr k2, a2)) + | Alg_expr.UN_ALG_OP (op, (k1, a1)) -> + Alg_expr.UN_ALG_OP (op, (update_expr k1, a1)) + | Alg_expr.IF ((k1, a1), (k2, a2), (k3, a3)) -> + Alg_expr.IF + ((update_bool_expr k1, a1), (update_expr k2, a2), (update_expr k3, a3)) + | Alg_expr.DIFF_TOKEN ((k1, a1), k2) -> + Alg_expr.DIFF_TOKEN ((update_expr k1, a1), k2) + | Alg_expr.DIFF_KAPPA_INSTANCE ((k, a), m) -> + Alg_expr.DIFF_KAPPA_INSTANCE ((update_expr k, a), m) + | Alg_expr.ALG_VAR id | Alg_expr.TOKEN_ID id -> update_id id k + | Alg_expr.STATE_ALG_OP _ | Alg_expr.CONST _ | Alg_expr.KAPPA_INSTANCE _ -> + k + in + update_expr k, a + +let collect_ids expr_list : Mods.StringSet.t = let rec aux_expr expr acc = match expr with - | Alg_expr.BIN_ALG_OP (_,(k1,_),(k2,_)) -> - aux_expr k2 (aux_expr k1 acc) - | Alg_expr.UN_ALG_OP (_,(k1,_)) - | Alg_expr.DIFF_TOKEN((k1,_),_) - | Alg_expr.DIFF_KAPPA_INSTANCE((k1,_),_)-> + | Alg_expr.BIN_ALG_OP (_, (k1, _), (k2, _)) -> aux_expr k2 (aux_expr k1 acc) + | Alg_expr.UN_ALG_OP (_, (k1, _)) + | Alg_expr.DIFF_TOKEN ((k1, _), _) + | Alg_expr.DIFF_KAPPA_INSTANCE ((k1, _), _) -> aux_expr k1 acc - | Alg_expr.IF ((k1,_),(k2,_),(k3,_)) -> + | Alg_expr.IF ((k1, _), (k2, _), (k3, _)) -> aux_expr k3 (aux_expr k2 (aux_bool k1 acc)) - | Alg_expr.ALG_VAR id| Alg_expr.TOKEN_ID id -> - aux_id id acc - | Alg_expr.STATE_ALG_OP _| Alg_expr.CONST _| Alg_expr.KAPPA_INSTANCE _ -> acc + | Alg_expr.ALG_VAR id | Alg_expr.TOKEN_ID id -> aux_id id acc + | Alg_expr.STATE_ALG_OP _ | Alg_expr.CONST _ | Alg_expr.KAPPA_INSTANCE _ -> + acc and aux_id id acc = Mods.StringSet.add id acc and aux_bool expr acc = match expr with | Alg_expr.TRUE | Alg_expr.FALSE -> acc - | Alg_expr.BIN_BOOL_OP (_,(k1,_),(k2,_)) -> aux_bool k2 (aux_bool k1 acc) - | Alg_expr.UN_BOOL_OP (_,(k,_)) -> aux_bool k acc - | Alg_expr.COMPARE_OP (_,(k1,_),(k2,_)) -> aux_expr k2 (aux_expr k1 acc) + | Alg_expr.BIN_BOOL_OP (_, (k1, _), (k2, _)) -> + aux_bool k2 (aux_bool k1 acc) + | Alg_expr.UN_BOOL_OP (_, (k, _)) -> aux_bool k acc + | Alg_expr.COMPARE_OP (_, (k1, _), (k2, _)) -> aux_expr k2 (aux_expr k1 acc) in List.fold_left - (fun acc expr2_opt -> - match expr2_opt with - | None -> acc - | Some ((expr1,_), None) -> aux_expr expr1 acc - | Some ((expr1,_),Some (expr2,_)) -> - aux_expr expr2 (aux_expr expr1 acc)) - (List.fold_left - (fun acc expr_opt -> - match expr_opt with - | None -> acc - | Some (expr,_) -> aux_expr expr acc) - Mods.StringSet.empty expr_list) - expr2_list - + (fun acc expr_opt -> + match expr_opt with + | None -> acc + | Some (expr, _) -> aux_expr expr acc) + Mods.StringSet.empty expr_list - -let name_match (s,_) (s',_) = (String.compare s s') = 0 +let name_match (s, _) (s', _) = String.compare s s' = 0 let prepare_agent rsites lsites = let rec prepare_site sites c = match sites with - | [] -> [Ast.Counter c] - | hd::tl -> - match hd with - Ast.Counter c' when (name_match c.Ast.count_nme c'.Ast.count_nme) -> - (Ast.Counter {c' with Ast.count_delta = c.Ast.count_delta})::tl - | Ast.Counter _ | Ast.Port _ -> hd::(prepare_site tl c) in + | [] -> [ Ast.Counter c ] + | hd :: tl -> + (match hd with + | Ast.Counter c' when name_match c.Ast.counter_name c'.Ast.counter_name -> + Ast.Counter { c' with Ast.counter_delta = c.Ast.counter_delta } :: tl + | Ast.Counter _ | Ast.Port _ -> hd :: prepare_site tl c) + in let counters = List.fold_left (fun acc' rsite -> - match rsite with Ast.Port _ -> acc' | Ast.Counter c -> c::acc') - [] rsites in + match rsite with + | Ast.Port _ -> acc' + | Ast.Counter c -> c :: acc') + [] rsites + in List.fold_left prepare_site lsites counters (* - add in the lhs : (i) counters only mentioned in the rhs and (ii) the deltas - syntactic checks of no test in rhs; no modif in lhs *) let prepare_counters rules = - let syntax sites f error = + let check_syntax sites f error = List.iter - (function Ast.Port _ -> () - | Ast.Counter c -> - if (f c) then - raise (ExceptionDefn.Malformed_Decl - ("Counter "^(fst c.Ast.count_nme)^error, - (snd c.Ast.count_nme)))) sites in - - let rec fold rhs lhs = match rhs,lhs with - | Ast.Present (rna,rsites,_)::r, Ast.Present (lna,lsites,b)::l-> - let () = syntax lsites (fun c -> not((fst c.Ast.count_delta)=0)) - " has a modif in the lhs"; - syntax rsites (fun c -> not(c.Ast.count_test=None)) - " has a test in the rhs" in - if String.compare (fst rna) (fst lna) = 0 then + (function + | Ast.Port _ -> () + | Ast.Counter c -> + if f c then + raise + (ExceptionDefn.Malformed_Decl + ( "Counter " ^ Loc.v c.Ast.counter_name ^ error, + Loc.get_annot c.Ast.counter_name ))) + sites + in + + let rec prepare_lhs_rule rhs lhs = + match rhs, lhs with + | Ast.Present (rna, rsites, _) :: r, Ast.Present (lna, lsites, b) :: l -> + check_syntax lsites + (fun c -> not (Loc.v c.counter_delta = 0)) + " has a modif in the lhs"; + check_syntax rsites + (fun c -> not (c.counter_test = None)) + " has a test in the rhs"; + if String.compare (Loc.v rna) (Loc.v lna) = 0 then ( let lsites' = prepare_agent rsites lsites in - Ast.Present (lna,lsites',b)::(fold r l) - else lhs (*TODO we stop our job here. LKappa_compiler will detect - later that there is a problem *) - | _::r, (Ast.Absent _ as lagent)::l -> + Ast.Present (lna, lsites', b) :: prepare_lhs_rule r l + ) else + lhs + (*TODO we stop our job here. LKappa_compiler will detect + later that there is a problem *) + | _ :: r, (Ast.Absent _ as lagent) :: l -> (*created agent*) (* TODO Maybe some syntax check on rhs are necessary here *) - lagent::fold r l - | Ast.Absent _::r, (Ast.Present (_,lsites,_) as lagent)::l -> + lagent :: prepare_lhs_rule r l + | Ast.Absent _ :: r, (Ast.Present (_, lsites, _) as lagent) :: l -> (*deleted agent*) - let () = syntax lsites (fun c -> not((fst c.Ast.count_delta)=0)) - " has a modif in the lhs" in - lagent::fold r l - | [], x -> x (* TODO x must be [] but it is for now LKappa_compiler - duty to complain *) - | _x, [] -> (*TODO let () = assert (_x = []) in*) [] in - - let aux r = match r.Ast.rewrite with - | Ast.Edit _ -> r - | Ast.Arrow a -> - {r with Ast.rewrite = - Ast.Arrow {a with - Ast.lhs = [fold (List.flatten a.Ast.rhs) (List.flatten a.Ast.lhs)]}} in - List.map (fun (s,(r,a)) -> (s,(aux r,a))) rules + check_syntax lsites + (fun c -> not (Loc.v c.Ast.counter_delta = 0)) + " has a modif in the lhs"; + lagent :: prepare_lhs_rule r l + | [], x -> + x + (* TODO x must be [] but it is for now LKappa_compiler + duty to complain *) + | _x, [] -> (*TODO let () = assert (_x = []) in*) [] + in + + let aux (rule : Ast.rule) : Ast.rule = + match rule.rewrite with + | Ast.Edit _ -> rule + | Ast.Arrow content -> + { + rule with + rewrite = + Ast.Arrow + { + content with + Ast.lhs = + [ + prepare_lhs_rule (List.flatten content.rhs) + (List.flatten content.lhs); + ]; + }; + } + in + List.map (fun (s, (r, a)) -> s, (aux r, a)) rules let counters_signature s agents = - match List.find (function - | Ast.Absent _ -> false - | Ast.Present (s',_,_) -> name_match s s') agents with + match + List.find + (function + | Ast.Absent _ -> false + | Ast.Present (s', _, _) -> name_match s s') + agents + with | Ast.Absent _ -> assert false - | Ast.Present (_,sites',_) -> + | Ast.Present (_, sites', _) -> List.fold_left - (fun acc s -> match s with - Ast.Counter c -> c::acc - | Ast.Port _ -> acc) [] sites' - -(* c': counter declaration, returns counter in rule*) -let enumerate_counter_tests x a ((delta,_) as count_delta) c' = - let (max,_) = c'.Ast.count_delta in - let min = - match c'.Ast.count_test with - None| Some (Ast.CGTE _,_)| Some (Ast.CVAR _,_) -> - raise - (ExceptionDefn.Malformed_Decl - ("Invalid counter signature - have to specify min bound", - (snd c'.Ast.count_nme))) - | Some (Ast.CEQ min,_) -> min in - - let rec enum v = - if (v>max) then [] + (fun acc s -> + match s with + | Ast.Counter c -> c :: acc + | Ast.Port _ -> acc) + [] sites' + +(** [split_cvar_counter_in_rules_per_value var_name annot counter_delta counter_def] translates a counter CVAR whose value acts upon the rate expression into a rule per possible value, that are selected by a CEQ expression. + * *) +let split_cvar_counter_in_rules_per_value (var_name : string) (annot : Loc.t) + (counter_delta : int Loc.annoted) (counter_def : Ast.counter) : + (Ast.site * (string * int) list) list = + let max_value : int = Loc.v counter_def.counter_delta in + let min_value : int = + match counter_def.counter_test with + | None | Some (Ast.CGTE _, _) | Some (Ast.CLTE _, _) | Some (Ast.CVAR _, _) + -> + raise + (ExceptionDefn.Malformed_Decl + ( "Invalid counter signature - have to specify min bound", + Loc.get_annot counter_def.counter_name )) + | Some (Ast.CEQ min_value, _) -> min_value + in + + (* Make CEQ counters with all possible values of variable *) + let rec make_ceq_counters_from_var_values (value : int) : + (Ast.site * (string * int) list) list = + if value > max_value then + [] + else if + value + Loc.v counter_delta <= max_value + && value + Loc.v counter_delta >= 0 + then + ( Ast.Counter + { + Ast.counter_name = counter_def.counter_name; + counter_test = Some (Ast.CEQ value, annot); + counter_delta; + }, + [ var_name, value ] ) + :: make_ceq_counters_from_var_values (value + 1) else - if (v+delta <= max)&&(v+delta >= 0) - then (Ast.Counter - {Ast.count_nme=c'.Ast.count_nme; - count_test = Some(Ast.CEQ v,a); - count_delta}, - [x,v])::(enum (v+1)) - else enum (v+1) in - enum min - -let enumerate rules f = - List.rev - (List.fold_left - (fun acc (s,(rc,_ as r)) -> - let enumerate_r = - if (match rc.Ast.rewrite with Ast.Edit _ -> false | Ast.Arrow a -> a.Ast.lhs = []) - then [(None,r)] - else - List.map - (fun (s',r') -> - match s,s' with - None, _ -> None,r' - | Some _, None -> s,r' - | Some (s1,a1), Some s2 -> Some (s1^"__"^s2,a1),r') (f r) in - enumerate_r@acc) [] rules) - -let remove_variable_in_counters ~warning rules signatures = - let counter_gte_delta c delta = - let count_delta = - {c with Ast.count_test=Some (Ast.CGTE (abs(delta)),Locality.dummy)} in - [(Ast.Counter count_delta,[])] in - let counter_gte_zero c = - [(Ast.Counter {c with Ast.count_test=Some (Ast.CGTE 0,Locality.dummy)}), []] - in - - let remove_var_site ids counters = - function - Ast.Port p -> [(Ast.Port p,[])] + make_ceq_counters_from_var_values (value + 1) + in + make_ceq_counters_from_var_values min_value + +let has_counters compil = + List.exists + (function + | Ast.Absent _ -> false + | Ast.Present (_, sites, _) -> + List.exists + (function + | Ast.Counter _ -> true + | Ast.Port _ -> false) + sites) + compil.Ast.signatures + +(** [split_counter_variables_into_separate_rules] ~warning rules signatures] replaces counters with CVAR contraints with counters with CEQ contraints in [rules], in lists with the variable values associated, so that in simulation, correct counter conditions are being selected. The main operation happens in [split_cvar_counter_in_rules_per_value] *) +let split_counter_variables_into_separate_rules ~warning rules signatures = + let split_for_each_counter_var_value_site ids counter_defs = function + | Ast.Port p -> [ Ast.Port p, [] ] | Ast.Counter c -> - let (delta,_) = c.Ast.count_delta in - match c.Ast.count_test with - | Some (Ast.CEQ v,_) -> - if (delta >0 || abs(delta) <= v) then [(Ast.Counter c,[])] - else - raise - (ExceptionDefn.Malformed_Decl - ("Counter "^(fst c.Ast.count_nme)^" becomes negative", - (snd c.Ast.count_nme))) - | Some (Ast.CGTE v,pos) -> - let () = if (v+delta <0) then - raise - (ExceptionDefn.Malformed_Decl - ("Counter "^(fst c.Ast.count_nme)^" becomes negative", - (snd c.Ast.count_nme))) in - let () = if (v=0) then - let error = "Counter "^(fst c.Ast.count_nme)^":>0 always holds" in - warning - ~pos (fun f -> Format.pp_print_string f error) in - [(Ast.Counter c,[])] - | Some (Ast.CVAR x,a) when Mods.StringSet.mem x ids -> - enumerate_counter_tests x a c.Ast.count_delta - (List.find - (fun c' -> name_match c.Ast.count_nme c'.Ast.count_nme) - counters) - | None | Some (Ast.CVAR _, _) -> - if (delta <0) then counter_gte_delta c delta else counter_gte_zero c - in - let rec remove_var_sites ids counters = function + let delta = Loc.v c.counter_delta in + (match c.counter_test with + | Some (Ast.CEQ value, _) -> + if delta > 0 || abs delta <= value then + [ Ast.Counter c, [] ] + else + raise + (ExceptionDefn.Malformed_Decl + ( "Counter " ^ Loc.v c.counter_name ^ " becomes negative", + Loc.get_annot c.counter_name )) + | Some (Ast.CLTE _value, _annot) -> + failwith "not implemented" (* TODO NOW *) + | Some (Ast.CGTE value, annot) -> + if value + delta < 0 then + raise + (ExceptionDefn.Malformed_Decl + ( "Counter " ^ Loc.v c.counter_name ^ " becomes negative", + Loc.get_annot c.counter_name )); + if value = 0 then ( + let error = "Counter " ^ Loc.v c.counter_name ^ ":>0 always holds" in + warning ~pos:annot (fun f -> Format.pp_print_string f error) + ); + [ Ast.Counter c, [] ] + | Some (Ast.CVAR var_name, annot) when Mods.StringSet.mem var_name ids -> + (* If the variable is present in an rate definition expression *) + let counter_def : Ast.counter = + List.find + (fun counter -> + name_match c.Ast.counter_name counter.Ast.counter_name) + counter_defs + in + + split_cvar_counter_in_rules_per_value var_name annot c.counter_delta + counter_def + | None | Some (Ast.CVAR _, _) -> + if delta < 0 then ( + let counter_delta : Ast.counter = + { c with counter_test = Some (Ast.CGTE (abs delta), Loc.dummy) } + in + [ Ast.Counter counter_delta, [] ] + ) else + [ + ( Ast.Counter { c with counter_test = Some (Ast.CGTE 0, Loc.dummy) }, + [] ); + ]) + in + + let rec split_for_each_counter_var_value_sites (ids : Mods.StringSet.t) + (counter_defs : Ast.counter list) : + Ast.site list -> (Ast.site list * (string * int) list) list = function | [] -> [] - | s::t -> - combinations - (remove_var_sites ids counters t) (remove_var_site ids counters s) in - let remove_var_agent ids = function - | Ast.Absent l -> [Ast.Absent l,[]] - | Ast.Present (s,sites,m) -> - let counters = counters_signature s signatures in - let enumerate_sites = remove_var_sites ids counters sites in + | s :: t -> + combinations_of_var_setup + (split_for_each_counter_var_value_sites ids counter_defs t) + (split_for_each_counter_var_value_site ids counter_defs s) + in + let split_for_each_counter_var_value_agent (ids : Mods.StringSet.t) : + Ast.agent -> (Ast.agent * (string * int) list) list = function + | Ast.Absent l -> [ Ast.Absent l, [] ] + | Ast.Present (agent_name, sites, modif) -> + let counter_defs = counters_signature agent_name signatures in + let sites_for_each_counter_var_values = + split_for_each_counter_var_value_sites ids counter_defs sites + in List.map - (fun (sites',c) -> (Ast.Present (s,sites',m),c)) enumerate_sites in - let rec remove_var_mixture ids = function + (fun (sites', var_values) -> + Ast.Present (agent_name, sites', modif), var_values) + sites_for_each_counter_var_values + in + let rec split_for_each_counter_var_value_mixture (ids : Mods.StringSet.t) : + Ast.agent list -> (Ast.agent list * (string * int) list) list = function | [] -> [] - | ag::t -> combinations - (remove_var_mixture ids t) - (remove_var_agent ids ag) in + | ast_agent :: t -> + combinations_of_var_setup + (split_for_each_counter_var_value_mixture ids t) + (split_for_each_counter_var_value_agent ids ast_agent) + in - let update_opt_rate counters = function + let update_opt_rate counter_var_values = function | None -> None - | Some r -> Some (update_rate counters r) in - let update_pair_rate counters = function + | Some r -> Some (update_rate counter_var_values r) + in + let update_pair_rate counter_var_values = function | None -> None - | Some (r1,r2) -> - Some ((update_rate counters r1),(update_opt_rate counters r2)) in - - let remove_var_rule (r,a) = - let mix = - match r.Ast.rewrite with - | Ast.Edit r -> r.Ast.mix - | Ast.Arrow r -> r.Ast.lhs in - let ids = - collect_ids - [Some r.Ast.k_def;r.Ast.k_op] - [r.Ast.k_un;r.Ast.k_op_un] in + | Some (r1, r2) -> + Some + ( update_rate counter_var_values r1, + update_opt_rate counter_var_values r2 ) + in + + (* TODO [split_for_each_counter_var_value_rule] rule evalues to a list of rules with their names *) + let split_for_each_counter_var_value_rule + (rule_name : string Loc.annoted option) + ((rule, annot) : Ast.rule Loc.annoted) : + (string Loc.annoted option * Ast.rule Loc.annoted) list = + let mix_lhs = + match rule.rewrite with + | Ast.Edit content -> content.mix + | Ast.Arrow content -> content.lhs + in + + (* Fetch ids from rule rates *) + let exprs_from_rates : + (Ast.mixture, string) Kappa_terms.Alg_expr.e Loc.annoted option list = + [ Some rule.k_def; rule.k_op ] + @ (match rule.k_un with + | None -> [] + | Some r_kun_rates -> [ Some (fst r_kun_rates); snd r_kun_rates ]) + @ + match rule.k_op_un with + | None -> [] + | Some r_k_op_un_rates -> + [ Some (fst r_k_op_un_rates); snd r_k_op_un_rates ] + in + let ids = collect_ids exprs_from_rates in + + let mixture_for_each_counter_var_value : + (Ast.agent list * (string * int) list) list = + split_for_each_counter_var_value_mixture ids (List.flatten mix_lhs) + in List.map - (fun (lhs,counters) -> - let k_def = update_rate counters r.Ast.k_def in - let k_un = update_pair_rate counters r.Ast.k_un in - let k_op = update_opt_rate counters r.Ast.k_op in - let k_op_un = update_pair_rate counters r.Ast.k_op_un in - let lhs = [lhs] in - let append = - if (counters = []) then None - else - Some (List.fold_left - (fun acc (_,i) -> (string_of_int i)^acc) "" counters) in - (append, - ({Ast.rewrite = (match r.Ast.rewrite with - | Ast.Edit e -> Ast.Edit {e with Ast.mix = lhs} - | Ast.Arrow a -> Ast.Arrow {a with Ast.lhs}); - Ast.bidirectional = r.Ast.bidirectional; - Ast.k_def; Ast.k_un; Ast.k_op; Ast.k_op_un},a))) - (remove_var_mixture ids (List.flatten mix)) in + (fun (lhs, counter_var_values) -> + (* Apply counter var values to rates *) + let k_def = update_rate counter_var_values rule.k_def in + let k_un = update_pair_rate counter_var_values rule.k_un in + let k_op = update_opt_rate counter_var_values rule.k_op in + let k_op_un = update_pair_rate counter_var_values rule.k_op_un in + let lhs = [ lhs ] in + let new_rule_name : string Loc.annoted option = + if counter_var_values = [] then + rule_name + else ( + (* Build counters_ids_as_string, that will be used to build new rule names *) + let counters_ids_as_string = + List.fold_left + (* TODO should we add a separator. maybe also add name of variable? *) + (fun acc (_, i) -> string_of_int i ^ acc) + "" counter_var_values + in + + match rule_name with + | None -> None (* No rule name, new rules will have no name too *) + | Some (rule_name_string, locality) -> + (* Make a new name for new rule including counter_var_values info *) + Some (rule_name_string ^ "__" ^ counters_ids_as_string, locality) + ) + in + + ( new_rule_name, + ( { + Ast.rewrite = + (match rule.rewrite with + | Ast.Edit content -> Ast.Edit { content with Ast.mix = lhs } + | Ast.Arrow content -> Ast.Arrow { content with Ast.lhs }); + bidirectional = rule.bidirectional; + k_def; + k_un; + k_op; + k_op_un; + }, + annot ) )) + mixture_for_each_counter_var_value + in + let rules = prepare_counters rules in - enumerate rules remove_var_rule + List.fold_left + (fun acc (rule_name, ((rule_content, _) as rule_annoted)) -> + let new_rules_from_rule = + if + (* Per counter syntax, these rules cannot contain counter vars that need to be considered when removing CVAR counter tests *) + match rule_content.Ast.rewrite with + | Ast.Edit _ -> false + | Ast.Arrow a -> a.lhs = [] + then + [ None, rule_annoted ] + else + split_for_each_counter_var_value_rule rule_name rule_annoted + in + new_rules_from_rule @ acc) + [] rules + (* TODO: is rev relevant here? *) + |> List.rev + +let split_counter_variables_into_separate_rules ~warning ~debug_mode + (compil : Ast.parsing_compil) = + let rules = + split_counter_variables_into_separate_rules ~warning compil.rules + compil.signatures + in + (* Debug printing *) + if debug_mode then ( + Format.printf "@.ast rules@."; + List.iter + (fun (s, (r, _)) -> + let label = + match s with + | None -> "" + | Some (l, _) -> l + in + Format.printf "@.%s = %a" label Ast.print_ast_rule r) + rules + ); + { compil with Ast.rules } -let with_counters c = - let with_counters_mix mix = - List.exists - (function - | Ast.Absent _ -> false - | Ast.Present (_,ls,_) -> - List.exists (function Ast.Counter _ -> true | Ast.Port _ -> false) ls) - mix in - with_counters_mix c.Ast.signatures - -let compile ~warning ~debugMode c = - if (with_counters c) then - let rules = - remove_variable_in_counters ~warning c.Ast.rules c.Ast.signatures in - let () = - if debugMode then - let () = Format.printf "@.ast rules@." in - List.iter (fun (s,(r,_)) -> - let label = match s with None -> "" | Some (l,_) -> l in - Format.printf "@.%s = %a" label Ast.print_ast_rule r) - rules in - ({c with Ast.rules},true) - else (c,false) - -let make_counter_agent sigs - (first,(dst,ra_erased)) (last,equal) i j pos created = - let (ra_type,arity,incr_b,incr_a) = Signature.incr_agent sigs in - let ra_ports = Array.make arity ((LKappa.LNK_FREE,pos), LKappa.Maintained) in +let make_counter_agent sigs (is_first, (dst, ra_erased)) (is_last, equal) i j + loc (created : bool) : LKappa.rule_agent = + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b, port_a = counter_agent_info.ports in + let ra_type = counter_agent_info.id in + + let ra_ports = + Array.make counter_agent_info.arity + ((LKappa.LNK_FREE, loc), LKappa.Maintained) + in let before_switch = - if first&&created then LKappa.Linked i else LKappa.Maintained in + if is_first && created then + LKappa.Linked i + else + LKappa.Maintained + in let before = - if first then LKappa.LNK_VALUE (i,dst), pos - else LKappa.LNK_VALUE (i,(ra_type,incr_a)), pos in - let () = ra_ports.(incr_b) <- before,before_switch in + if is_first then + LKappa.LNK_VALUE (i, dst), loc + else + LKappa.LNK_VALUE (i, (ra_type, port_a)), loc + in + let () = ra_ports.(port_b) <- before, before_switch in let after = - if (last&&equal) then LKappa.LNK_FREE, pos + if is_last && equal then + LKappa.LNK_FREE, loc + else if is_last then + LKappa.LNK_ANY, loc else - if last then LKappa.LNK_ANY, pos - else LKappa.LNK_VALUE (j,(ra_type,incr_b)), pos in - let () = ra_ports.(incr_a) <- (after,LKappa.Maintained) in - let ra_ints = Array.make arity LKappa.I_ANY in - {LKappa.ra_type; ra_erased; ra_ports; ra_ints; - ra_syntax = Some (Array.copy ra_ports,Array.copy ra_ints)} - -let raw_counter_agent - (first,first_lnk) (last,last_lnk) i j sigs equal = - let (incr_type,arity,incr_b,incr_a) = Signature.incr_agent sigs in - let ports = Array.make arity (Raw_mixture.FREE) in + LKappa.LNK_VALUE (j, (ra_type, port_b)), loc + in + let () = ra_ports.(port_a) <- after, LKappa.Maintained in + let ra_ints = Array.make counter_agent_info.arity LKappa.I_ANY in + { + LKappa.ra_type; + ra_erased; + ra_ports; + ra_ints; + ra_syntax = Some (Array.copy ra_ports, Array.copy ra_ints); + } + +let raw_counter_agent (is_first, first_link) (is_last, last_link) i j sigs equal + : Raw_mixture.agent = + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b, port_a = counter_agent_info.ports in + let ports = Array.make counter_agent_info.arity Raw_mixture.FREE in let internals = - Array.init arity - (fun i -> - Signature.default_internal_state incr_type i sigs) in - let before = if first then Raw_mixture.VAL first_lnk - else Raw_mixture.VAL i in - let () = ports.(incr_b) <- before in + Array.init counter_agent_info.arity (fun i -> + Signature.default_internal_state counter_agent_info.id i sigs) + in + let before = + if is_first then + Raw_mixture.VAL first_link + else + Raw_mixture.VAL i + in + let () = ports.(port_b) <- before in let after = - if (last&&equal) then Raw_mixture.FREE + if is_last && equal then + Raw_mixture.FREE + else if is_last then + Raw_mixture.VAL last_link else - if last then Raw_mixture.VAL last_lnk - else Raw_mixture.VAL j in - let () = ports.(incr_a) <- after in - { Raw_mixture.a_type = incr_type; - Raw_mixture.a_ports = ports; Raw_mixture.a_ints = internals; } - -let rec add_incr i first_lnk last_lnk delta equal sigs = - if (i=delta) then [] - else - let first = (i=0) in - let last = (i=(delta-1)) in + Raw_mixture.VAL j + in + let () = ports.(port_a) <- after in + { + Raw_mixture.a_type = counter_agent_info.id; + Raw_mixture.a_ports = ports; + Raw_mixture.a_ints = internals; + } + +let rec add_incr (i : int) (first_link : int) (last_link : int) (delta : int) + (equal : bool) (sigs : Signature.s) : Raw_mixture.agent list = + if i = delta then + [] + else ( + let is_first = i = 0 in + let is_last = i = delta - 1 in let raw_incr = - raw_counter_agent - (first,first_lnk) (last,last_lnk) - (first_lnk+i) (first_lnk+i+1) sigs equal in - raw_incr::(add_incr (i+1) first_lnk last_lnk delta equal sigs) + raw_counter_agent (is_first, first_link) (is_last, last_link) + (first_link + i) + (first_link + i + 1) + sigs equal + in + raw_incr :: add_incr (i + 1) first_link last_link delta equal sigs + ) -let rec link_incr sigs i nb ag_info equal lnk pos delta = - if (i=nb) then [] - else - let first = (i=0) in - let last = (i=(nb-1)) in +let rec link_incr (sigs : Signature.s) (i : int) (nb : int) + (ag_info : (int * int) * bool) (equal : bool) (link : int) (loc : Loc.t) + (delta : int) : LKappa.rule_mixture = + if i = nb then + [] + else ( + let is_first = i = 0 in + let is_last = i = nb - 1 in let ra_agent = - make_counter_agent sigs (first,ag_info) (last,equal) - (lnk+i) (lnk+i+1) pos (delta>0) in - ra_agent::(link_incr sigs (i+1) nb ag_info equal lnk pos delta) + make_counter_agent sigs (is_first, ag_info) (is_last, equal) (link + i) + (link + i + 1) + loc (delta > 0) + in + ra_agent :: link_incr sigs (i + 1) nb ag_info equal link loc delta + ) -let rec erase_incr sigs i incrs delta lnk = - let (_,_,incr_b,_) = Signature.incr_agent sigs in +let rec erase_incr (sigs : Signature.s) (i : int) (incrs : LKappa.rule_mixture) + (delta : int) (link : int) : LKappa.rule_mixture = + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b = fst counter_agent_info.ports in match incrs with - | hd::tl -> - if (i = abs(delta)) then - let (before,_) = hd.LKappa.ra_ports.(incr_b) in - let () = hd.LKappa.ra_ports.(incr_b) <- before, LKappa.Linked lnk in - hd::tl - else - let () = - Array.iteri - (fun i (a,_) -> hd.LKappa.ra_ports.(i) <- a,LKappa.Erased) hd.LKappa.ra_ports in - let ag = {hd with LKappa.ra_erased = true} in - ag::(erase_incr sigs (i+1) tl delta lnk) + | incr :: incr_s -> + if i = abs delta then ( + let before, _ = incr.LKappa.ra_ports.(port_b) in + incr.LKappa.ra_ports.(port_b) <- before, LKappa.Linked link; + incr :: incr_s + ) else ( + Array.iteri + (fun i (a, _) -> incr.LKappa.ra_ports.(i) <- a, LKappa.Erased) + incr.LKappa.ra_ports; + let rule_agent = { incr with LKappa.ra_erased = true } in + rule_agent :: erase_incr sigs (i + 1) incr_s delta link + ) | [] -> [] -let counter_becomes_port sigs ra p_id (delta,pos') pos equal test start_lnk_nb = - let (incr_type,_,incr_b,_) = Signature.incr_agent sigs in - let start_lnk_for_created = start_lnk_nb + test +1 in - let lnk_for_erased = start_lnk_nb + abs(delta) in - let ag_info = (p_id,ra.LKappa.ra_type),ra.LKappa.ra_erased in - - let test_incr = - link_incr sigs 0 (test+1) ag_info equal start_lnk_nb pos delta in - let adjust_delta = - if (delta<0) - then erase_incr sigs 0 test_incr delta lnk_for_erased - else test_incr in - let created = - if (delta>0) - then add_incr 0 start_lnk_for_created start_lnk_nb delta false sigs - else [] in - - let () = if (test + delta < 0) then - raise (ExceptionDefn.Internal_Error - ("Counter test should be greater then abs(delta)",pos')) in - let switch = - if (delta = 0) then LKappa.Maintained - else if (delta > 0) then LKappa.Linked start_lnk_for_created - else LKappa.Linked lnk_for_erased in - let p = (LKappa.LNK_VALUE (start_lnk_nb,(incr_b,incr_type)),pos),switch in - let () = ra.LKappa.ra_ports.(p_id) <- p in - (adjust_delta,created) - - -let pos_part i = - if i < 0 then 0 else i - -(* ag - agent with counters in a rule +(** Returns mixtures for agent with site changed from counter to port, as well as new [link_nb] after previous additions + * Used by [compile_counter_in_rule_agent]*) +let counter_becomes_port (sigs : Signature.s) (ra : LKappa.rule_agent) + (p_id : int) (counter : Ast.counter) (start_link_nb : int) : + (LKappa.rule_mixture * Raw_mixture.t) * int = + (* Returns positive part of value *) + let positive_part (i : int) : int = + if i < 0 then + 0 + else + i + in + + let loc : Loc.t = Loc.get_annot counter.Ast.counter_name in + let (delta, loc_delta) : int * Loc.t = counter.Ast.counter_delta in + let counter_test : Ast.counter_test Loc.annoted = + Option_util.unsome_or_raise + ~excep: + (ExceptionDefn.Internal_Error + ( "Counter " + ^ Loc.v counter.Ast.counter_name + ^ " should have a test by now", + loc )) + counter.Ast.counter_test + in + let (test, equal) : int * bool = + match Loc.v counter_test with + | Ast.CVAR _ -> + raise + (ExceptionDefn.Internal_Error + ( "Counter " + ^ Loc.v counter.Ast.counter_name + ^ " defines a variable, which should have been replaced by CEQ \ + conditions after rule splitting", + Loc.get_annot counter_test )) + | Ast.CEQ j -> j, true + | Ast.CGTE j -> j, false + | Ast.CLTE _j -> failwith "not implemented" (* TODO now *) + in + let start_link_for_created : int = start_link_nb + test + 1 in + let link_for_erased : int = start_link_nb + abs delta in + let ag_info : (int * int) * bool = + (p_id, ra.LKappa.ra_type), ra.LKappa.ra_erased + in + + let test_incr : LKappa.rule_mixture = + link_incr sigs 0 (test + 1) ag_info equal start_link_nb loc delta + in + let adjust_delta : LKappa.rule_mixture = + if delta < 0 then + erase_incr sigs 0 test_incr delta link_for_erased + else + test_incr + in + let created : Raw_mixture.t = + if delta > 0 then + add_incr 0 start_link_for_created start_link_nb delta false sigs + else + [] + in + + if test + delta < 0 then + raise + (ExceptionDefn.Internal_Error + ("Counter test should be greater then abs(delta)", loc_delta)); + + let switch : LKappa.switching = + if delta = 0 then + LKappa.Maintained + else if delta > 0 then + LKappa.Linked start_link_for_created + else + LKappa.Linked link_for_erased + in + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b : int = fst counter_agent_info.ports in + ra.LKappa.ra_ports.(p_id) <- + ( (LKappa.LNK_VALUE (start_link_nb, (port_b, counter_agent_info.id)), loc), + switch ); + let new_link_nb : int = start_link_nb + 1 + test + positive_part delta in + + (adjust_delta, created), new_link_nb + +(** Compiles the counter precondition in a left hand side mixture of a rule into a mixture which tests dummy positions + * rule_agent_ - agent with counters in a rule lnk_nb - the max link number used in the rule; - incr_info - info on the incr agent from the signature + sigs.counter_agent_info - info on the counter agent returns: agent with explicit counters; created incr agents; the next link number to use *) -let remove_counter_agent sigs ag lnk_nb = - let (incrs,lnk_nb') = +let compile_counter_in_rule_agent (sigs : Signature.s) + (rule_agent_ : LKappa.rule_agent with_agent_counters) (lnk_nb : int) : + LKappa.rule_mixture * Raw_mixture.t * int = + let (incrs, lnk_nb') : (LKappa.rule_mixture * Raw_mixture.t) list * int = Tools.array_fold_lefti - (fun id (acc_incrs,lnk_nb) -> function - | None -> (acc_incrs,lnk_nb) - | Some (counter,_) -> - let (s,pos) = counter.Ast.count_nme in - match (counter.Ast.count_test,counter.Ast.count_delta) with - | (None,_) -> - raise (ExceptionDefn.Internal_Error - ("Counter "^s^" should have a test by now",pos)) - | (Some (test,pos')), delta -> - match test with - | Ast.CEQ j -> - (counter_becomes_port - sigs ag.ra id delta pos true j lnk_nb)::acc_incrs, - lnk_nb+1+j+(pos_part (fst delta)) (* JF: link ids were colliding after counter decrementations -> I do not think that we should add delta when negative *) - | Ast.CGTE j -> - (counter_becomes_port - sigs ag.ra id delta pos false j lnk_nb)::acc_incrs, - lnk_nb+1+j+(pos_part (fst delta)) (* JF: link ids were colliding after counter decrementations -> I do not think that we should add delta when negative *) - | Ast.CVAR _ -> - raise (ExceptionDefn.Internal_Error - ("Counter "^s^" should not have a var by now",pos'))) - ([],lnk_nb) ag.ra_counters in - let (als,bls) = - List.fold_left (fun (als,bls) (a,b) -> a@als,b@bls) ([],[]) incrs in - (als,bls,lnk_nb') - -let remove_counter_created_agent sigs ag lnk_nb = - let raw_ag = ag.ra in - let ports = raw_ag.Raw_mixture.a_ports in + (fun id (acc_incrs, lnk_nb) -> function + | None -> acc_incrs, lnk_nb + | Some (counter, _) -> + let new_incrs, new_lnk_nb = + counter_becomes_port sigs rule_agent_.agent id counter lnk_nb + in + new_incrs :: acc_incrs, new_lnk_nb + (* JF: link ids were colliding after counter decrementations -> I do not think that we should add delta when negative *)) + ([], lnk_nb) rule_agent_.counters + in + let (als, bls) : LKappa.rule_mixture * Raw_mixture.t = + List.fold_left (fun (als, bls) (a, b) -> a @ als, b @ bls) ([], []) incrs + in + als, bls, lnk_nb' + +(** Compiles the counter value change in the right hand side of a rule into dummy chain changes *) +let compile_counter_in_raw_agent (sigs : Signature.s) + (raw_agent_ : Raw_mixture.agent with_agent_counters) (lnk_nb : int) : + Raw_mixture.agent list * int = + let raw_agent : Raw_mixture.agent = raw_agent_.agent in + let ports : Raw_mixture.link array = raw_agent.Raw_mixture.a_ports in Tools.array_fold_lefti - (fun p_id (acc,lnk) -> function - | None -> (acc,lnk) - | Some (c,_) -> - match c.Ast.count_test with - | None -> - let agent_name = - Format.asprintf "@[%a@]" - (Signature.print_agent sigs) raw_ag.Raw_mixture.a_type in - LKappa.not_enough_specified - ~status:"counter" ~side:"left" agent_name c.Ast.count_nme - | Some (test,_) -> - match test with - | Ast.CEQ j -> - let p = Raw_mixture.VAL lnk in - let () = ports.(p_id) <- p in - let incrs = add_incr 0 lnk (lnk+j) (j+1) true sigs in - (acc@incrs,(lnk+j+1)) - | Ast.CGTE _ | Ast.CVAR _ -> - let agent_name = - Format.asprintf "@[%a@]" - (Signature.print_agent sigs) raw_ag.Raw_mixture.a_type in - LKappa.not_enough_specified - ~status:"counter" ~side:"left" agent_name c.Ast.count_nme) - ([],lnk_nb) ag.ra_counters - -let raw_agent_with_counters ag = - Array.fold_left - (fun ok x -> x<>None||ok) - false ag.ra_counters - -let agent_with_counters ag sigs = - let sign = Signature.get sigs ag.LKappa.ra_type in - Signature.has_counter sign - -(* - adds increment agents to the rule_agent mixture + (fun p_id (acc, lnk_nb) -> function + | None -> acc, lnk_nb + | Some (c, _) -> + (match c.Ast.counter_test with + | None -> + let agent_name = + Format.asprintf "@[%a@]" + (Signature.print_agent sigs) + raw_agent.Raw_mixture.a_type + in + LKappa.raise_not_enough_specified ~status:"counter" ~side:"left" + agent_name c.Ast.counter_name + | Some (test, _) -> + (match test with + | Ast.CGTE _ | Ast.CLTE _ | Ast.CVAR _ -> + let agent_name = + Format.asprintf "@[%a@]" + (Signature.print_agent sigs) + raw_agent.Raw_mixture.a_type + in + LKappa.raise_not_enough_specified ~status:"counter" ~side:"left" + agent_name c.Ast.counter_name + | Ast.CEQ j -> + let p = Raw_mixture.VAL lnk_nb in + let () = ports.(p_id) <- p in + let incrs = add_incr 0 lnk_nb (lnk_nb + j) (j + 1) true sigs in + acc @ incrs, lnk_nb + j + 1))) + ([], lnk_nb) raw_agent_.counters + +let raw_agent_has_counters (ag_ : 'a with_agent_counters) : bool = + Array.fold_left (fun ok x -> x <> None || ok) false ag_.counters + +let rule_agent_has_counters (rule_agent : LKappa.rule_agent) + (sigs : Signature.s) : bool = + Signature.has_counter (Signature.get sigs rule_agent.ra_type) + +(** [compile_counter_in_rule sigs mix created] takes the intial mixture from a rule [mix], + * and the mixture obtained from the application of the rule [created], + * both with counter information, and returns two mixtures for a new rule without counters, having compiled the counter logic inside the rule. + * + * - adds increment agents to the rule_agent mixture - adds increment agents to the raw mixture - links the agents in the mixture(lhs,rhs,mix) or in the raw mixture(created) to the increments *) -let remove_counter_rule sigs mix created = - let with_counters = - List.exists (fun ag -> agent_with_counters ag.ra sigs) mix || - List.exists (fun ag -> raw_agent_with_counters ag) created in - if with_counters then - let lnk_nb = +let compile_counter_in_rule (sigs : Signature.s) + (mix : rule_mixture_with_agent_counters) + (created : raw_mixture_with_agent_counters) : + LKappa.rule_mixture * Raw_mixture.t = + let has_counters : bool = + List.exists + (fun rule_agent_ -> rule_agent_has_counters rule_agent_.agent sigs) + mix + || List.exists (fun raw_agent_ -> raw_agent_has_counters raw_agent_) created + in + if has_counters then ( + let lnk_nb : int = List.fold_left - (fun m ag -> max m (LKappa.max_link_id [ag.ra])) 0 mix in + (fun (m : int) rule_agent_ -> + max m (LKappa.max_link_id [ rule_agent_.agent ])) + 0 mix + in - let incrs,incrs_created,lnk_nb' = + let (incrs, incrs_created, lnk_nb') : + LKappa.rule_mixture * Raw_mixture.t * int = List.fold_left - (fun (a,b,lnk) ag -> - let (a',b',lnk') = remove_counter_agent sigs ag lnk in - a'@a,b'@b,lnk'+1) - ([],[],lnk_nb+1) mix in - let incrs_created',_ = + (fun (mix_incr, created_incr, lnk_nb) rule_agent_ -> + let mix_incr_new, created_incr_new, lnk_nb' = + compile_counter_in_rule_agent sigs rule_agent_ lnk_nb + in + mix_incr_new @ mix_incr, created_incr_new @ created_incr, lnk_nb' + 1) + ([], [], lnk_nb + 1) + mix + in + let incrs_created' : Raw_mixture.t = List.fold_left - (fun (acc,lnk) ag -> - let (a,lnk') = - remove_counter_created_agent sigs ag lnk in - (a@acc,lnk')) - ([],lnk_nb'+1) created in - - let rule_agent_mix = - List_util.rev_map_append (fun ag -> ag.ra) mix incrs in - let raw_mix = + (fun (created_incr, lnk_nb) raw_agent_ -> + let created_incr_new, lnk_nb'' = + compile_counter_in_raw_agent sigs raw_agent_ lnk_nb + in + created_incr_new @ created_incr, lnk_nb'') + ([], lnk_nb' + 1) + created + |> fst + (* We drop the lnk_nb as we don't need in the following *) + in + + (* Return initial mixtures with new agents in rule from counter compilation *) + let rule_agent_mix : LKappa.rule_mixture = + List_util.rev_map_append (fun rule_agent_ -> rule_agent_.agent) mix incrs + in + let raw_mix : Raw_mixture.t = List_util.rev_map_append - (fun ag -> ag.ra) created (incrs_created@incrs_created') in - (rule_agent_mix,raw_mix) - else (List.rev_map (fun ag -> ag.ra) (List.rev mix)), - (List.rev_map (fun ag -> ag.ra) (List.rev created)) + (fun raw_agent_ -> raw_agent_.agent) + created + (incrs_created @ incrs_created') + in + rule_agent_mix, raw_mix + ) else + ( List.rev_map (fun rule_agent_ -> rule_agent_.agent) (List.rev mix), + List.rev_map (fun raw_agent_ -> raw_agent_.agent) (List.rev created) ) -let agent_with_max_counter sigs c ((agent_name,_) as ag_ty) = - let (incr_type,_,incr_b,_) = Signature.incr_agent sigs in +let rule_agent_with_max_counter sigs c ((agent_name, _) as ag_ty) : + LKappa.rule_mixture = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in let ports = - Array.make arity (Locality.dummy_annot LKappa.LNK_ANY, LKappa.Maintained) in + Array.make arity (Loc.annot_with_dummy LKappa.LNK_ANY, LKappa.Maintained) + in let internals = Array.make arity LKappa.I_ANY in - let c_na = c.Ast.count_nme in + let c_na = c.Ast.counter_name in let c_id = Signature.num_of_site ~agent_name c_na sign in - let (max_val,pos) = c.Ast.count_delta in - let max_val' = max_val+1 in - let incrs = link_incr sigs 0 (max_val'+1) ((c_id,ag_id),false) false 1 pos (-1) in - let p = LKappa.LNK_VALUE (1,(incr_b,incr_type)),pos in - let () = ports.(c_id) <- p,LKappa.Maintained in - let ra = - { LKappa.ra_type = ag_id;ra_ports = ports;ra_ints = internals;ra_erased = false; - ra_syntax = Some (Array.copy ports, Array.copy internals);} in - ra::incrs + let max_val, loc = c.Ast.counter_delta in + let max_val' = max_val + 1 in + let incrs = + link_incr sigs 0 (max_val' + 1) ((c_id, ag_id), false) false 1 loc (-1) + in + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b = fst counter_agent_info.ports in + let p = LKappa.LNK_VALUE (1, (port_b, counter_agent_info.id)), loc in + ports.(c_id) <- p, LKappa.Maintained; + let ra : LKappa.rule_agent = + { + LKappa.ra_type = ag_id; + ra_ports = ports; + ra_ints = internals; + ra_erased = false; + ra_syntax = Some (Array.copy ports, Array.copy internals); + } + in + ra :: incrs let counter_perturbation sigs c ag_ty = - let filename = - [Primitives.Str_pexpr ("counter_perturbation.ka", snd c.Ast.count_nme) ] in + let annot = Loc.get_annot c.Ast.counter_name in + let filename = [ Primitives.Str_pexpr ("counter_perturbation.ka", annot) ] in let stop_message = - "Counter "^(fst c.Ast.count_nme)^" of agent "^(fst ag_ty)^" reached maximum" in - let mods = [ - Ast.PRINT ([],[ Primitives.Str_pexpr ("", snd c.Ast.count_nme) ]); - Ast.PRINT ([],[ Primitives.Str_pexpr (stop_message, snd c.Ast.count_nme) ]); - Ast.STOP filename] in + "Counter " ^ Loc.v c.Ast.counter_name ^ " of agent " ^ Loc.v ag_ty + ^ " reached maximum" + in + let mods = + [ + Ast.PRINT ([], [ Primitives.Str_pexpr ("", annot) ]); + Ast.PRINT ([], [ Primitives.Str_pexpr (stop_message, annot) ]); + Ast.STOP filename; + ] + in let val_of_counter = - Alg_expr.KAPPA_INSTANCE (agent_with_max_counter sigs c ag_ty) in + Alg_expr.KAPPA_INSTANCE (rule_agent_with_max_counter sigs c ag_ty) + in let pre = Alg_expr.COMPARE_OP - (Operator.EQUAL,(val_of_counter,snd c.Ast.count_nme), - (Alg_expr.CONST (Nbr.I 1),snd c.Ast.count_nme)) in - (None,Some (pre,snd ag_ty),mods,Some (Locality.dummy_annot Alg_expr.FALSE)) + ( Operator.EQUAL, + (val_of_counter, annot), + (Alg_expr.CONST (Nbr.I 1), annot) ) + in + ( None, + Some (pre, Loc.get_annot ag_ty), + mods, + Some (Loc.annot_with_dummy Alg_expr.FALSE) ) let counters_perturbations sigs ast_sigs = List.fold_left - (List.fold_left - (fun acc -> function - | Ast.Absent _ -> acc - | Ast.Present (ag_ty,sites,_) -> - List.fold_left - (fun acc' site -> - match site with - Ast.Port _ -> acc' - | Ast.Counter c -> - ((counter_perturbation sigs c ag_ty),(snd ag_ty))::acc') - acc sites)) + (List.fold_left (fun acc -> function + | Ast.Absent _ -> acc + | Ast.Present (ag_ty, sites, _) -> + List.fold_left + (fun acc' site -> + match site with + | Ast.Port _ -> acc' + | Ast.Counter c -> + (counter_perturbation sigs c ag_ty, Loc.get_annot ag_ty) :: acc') + acc sites)) [] ast_sigs let make_counter i name = - {Ast.count_nme = (name,Locality.dummy); - count_test = Some (Ast.CEQ i,Locality.dummy); count_delta =(0,Locality.dummy)} + { + Ast.counter_name = Loc.annot_with_dummy name; + counter_test = Some (Loc.annot_with_dummy (Ast.CEQ i)); + counter_delta = Loc.annot_with_dummy 0; + } let add_counter_to_contact_map sigs add_link_contact_map = - let (incr_id,_,incr_b,incr_a) = Signature.incr_agent sigs in - add_link_contact_map incr_id incr_a incr_id incr_b + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b, port_a = counter_agent_info.ports in + add_link_contact_map counter_agent_info.id port_a counter_agent_info.id port_b -let forbid_modification (delta,pos) = - if delta != 0 then LKappa.forbid_modification pos (Some delta) +let raise_if_modification (delta, loc) = + if delta != 0 then LKappa.raise_if_modification loc (Some delta) -let annotate_dropped_counters sign counts ra arity agent_name aux = +let annotate_dropped_counters sign ast_counters ra arity agent_name aux = let ra_counters = Array.make arity None in let _ = List.fold_left (fun pset c -> - let p_na = c.Ast.count_nme in - let p_id = Signature.num_of_site ~agent_name p_na sign in - let () = match Signature.counter_of_site p_id sign with - | None -> LKappa.counter_misused agent_name c.Ast.count_nme - | Some _ -> () in + let port_name = c.Ast.counter_name in + let p_id = Signature.num_of_site ~agent_name port_name sign in + let () = + match Signature.counter_of_site_id p_id sign with + | None -> LKappa.raise_counter_misused agent_name c.Ast.counter_name + | Some _ -> () + in let pset' = Mods.IntSet.add p_id pset in - let () = if pset == pset' then - LKappa.several_occurence_of_site agent_name c.Ast.count_nme in - let () = forbid_modification c.Ast.count_delta in - let () = match aux with | Some f -> f p_id | None -> () in - let () = ra_counters.(p_id) <- Some (c,LKappa.Erased) in pset') - Mods.IntSet.empty counts in - {ra; ra_counters;} - -let annotate_edit_counters - sigs (agent_name, _ as ag_ty) counts ra add_link_contact_map = + let () = + if pset == pset' then + LKappa.raise_several_occurence_of_site agent_name c.Ast.counter_name + in + let () = raise_if_modification c.Ast.counter_delta in + let () = + match aux with + | Some f -> f p_id + | None -> () + in + ra_counters.(p_id) <- Some (c, LKappa.Erased); + pset') + Mods.IntSet.empty ast_counters + in + { agent = ra; counters = ra_counters } + +let annotate_edit_counters sigs ((agent_name, _) as ag_ty) counters ra + add_link_contact_map = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in let ra_counters = Array.make arity None in let register_counter_modif c_id = - let (incr_id,_,incr_b,_) = Signature.incr_agent sigs in - add_link_contact_map ag_id c_id incr_id incr_b in + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b = fst counter_agent_info.ports in + add_link_contact_map ag_id c_id counter_agent_info.id port_b + in let _ = List.fold_left (fun pset c -> - let p_na = c.Ast.count_nme in - let p_id = Signature.num_of_site ~agent_name p_na sign in - let () = match Signature.counter_of_site p_id sign with - | None -> LKappa.counter_misused agent_name c.Ast.count_nme | Some _ -> () in + let port_name = c.Ast.counter_name in + let p_id = Signature.num_of_site ~agent_name port_name sign in + let () = + match Signature.counter_of_site_id p_id sign with + | None -> LKappa.raise_counter_misused agent_name c.Ast.counter_name + | Some _ -> () + in let pset' = Mods.IntSet.add p_id pset in - let () = if pset == pset' then - LKappa.several_occurence_of_site agent_name c.Ast.count_nme in + let () = + if pset == pset' then + LKappa.raise_several_occurence_of_site agent_name c.Ast.counter_name + in let () = register_counter_modif p_id in - let () = ra_counters.(p_id) <- Some (c,LKappa.Maintained) in pset') - Mods.IntSet.empty counts in - {ra; ra_counters;} + let () = ra_counters.(p_id) <- Some (c, LKappa.Maintained) in + pset') + Mods.IntSet.empty counters + in + { agent = ra; counters = ra_counters } -let annotate_counters_with_diff - sigs (agent_name, pos as ag_ty) lc rc ra add_link_contact_map = +let annotate_counters_with_diff sigs ((agent_name, loc) as ag_ty) lc rc ra + add_link_contact_map = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in let register_counter_modif c c_id = - let (incr_id,_,incr_b,_) = Signature.incr_agent sigs in - let () = add_link_contact_map ag_id c_id incr_id incr_b in - (c, LKappa.Maintained) in + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b = fst counter_agent_info.ports in + let () = add_link_contact_map ag_id c_id counter_agent_info.id port_b in + c, LKappa.Maintained + in let ra_counters = Array.make arity None in - let rc_r,_ = + let rc_r, _ = List.fold_left - (fun (rc,cset) c -> - let (na,_) as c_na = c.Ast.count_nme in - let c_id = Signature.num_of_site ~agent_name c_na sign in + (fun (rc, cset) c -> + let ((na, _) as counter_name) = c.Ast.counter_name in + let c_id = Signature.num_of_site ~agent_name counter_name sign in let cset' = Mods.IntSet.add c_id cset in - let () = if cset == cset' then - LKappa.several_occurence_of_site agent_name c_na in - let c',rc' = + let () = + if cset == cset' then + LKappa.raise_several_occurence_of_site agent_name counter_name + in + let c', rc' = List.partition - (fun p -> String.compare (fst p.Ast.count_nme) na = 0) rc in + (fun p -> String.compare (Loc.v p.Ast.counter_name) na = 0) + rc + in let c'' = match c' with - | _::[] | [] -> register_counter_modif c c_id - | _ :: _ -> LKappa.several_occurence_of_site agent_name c_na in + | _ :: [] | [] -> register_counter_modif c c_id + | _ :: _ -> + LKappa.raise_several_occurence_of_site agent_name counter_name + in let () = ra_counters.(c_id) <- Some c'' in - (rc',cset')) (rc,Mods.IntSet.empty) lc in - let _ = (* test if counter of rhs is in the signature *) + rc', cset') + (rc, Mods.IntSet.empty) lc + in + let _ = + (* test if counter of rhs is in the signature *) List.map - (fun c -> Signature.num_of_site ~agent_name (c.Ast.count_nme) sign) rc_r in - let () = - if not(rc =[]) && not(rc_r =[]) then - raise (ExceptionDefn.Internal_Error - ("Counters in "^agent_name^" should have tests by now",pos)) in - {ra; ra_counters;} - -let annotate_created_counters - sigs (agent_name,_ as ag_ty) counts add_link_contact_map ra = + (fun c -> Signature.num_of_site ~agent_name c.Ast.counter_name sign) + rc_r + in + if (not (rc = [])) && not (rc_r = []) then + raise + (ExceptionDefn.Internal_Error + ("Counters in " ^ agent_name ^ " should have tests by now", loc)); + { agent = ra; counters = ra_counters } +let annotate_created_counters sigs ((agent_name, _) as ag_ty) counters + add_link_contact_map ra = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in let ra_counters = Array.make arity None in - (* register all counters (specified or not) with min value *) - let () = - Array.iteri - (fun p_id _ -> - match Signature.counter_of_site p_id sign with - | Some (min,_) -> - begin - let c_name = Signature.site_of_num p_id sign in - try - let c = - List.find - (fun c' -> - (String.compare (fst c'.Ast.count_nme) c_name) = 0) counts in - ra_counters.(p_id) <- - Some - ({Ast.count_nme = c.Ast.count_nme; - Ast.count_test = c.Ast.count_test; - Ast.count_delta = (0,Locality.dummy)},LKappa.Maintained) - with Not_found -> - ra_counters.(p_id) <- - Some - ({Ast.count_nme = (c_name,Locality.dummy); - Ast.count_test = Some (Ast.CEQ min,Locality.dummy); - Ast.count_delta = (0,Locality.dummy)},LKappa.Maintained) - end - | None -> ()) ra_counters in - - let register_counter_modif c_id = - let (incr_id,_,incr_b,_) = Signature.incr_agent sigs in - add_link_contact_map ag_id c_id incr_id incr_b in - let _ = - List.fold_left - (fun pset c -> - let p_na = c.Ast.count_nme in - let p_id = Signature.num_of_site ~agent_name p_na sign in - let () = match Signature.counter_of_site p_id sign with - | None -> LKappa.counter_misused agent_name c.Ast.count_nme - | Some _ -> () in + (* register all counters (specified or not) with min value *) + Array.iteri + (fun p_id _ -> + match Signature.counter_of_site_id p_id sign with + | Some (min, _) -> + let c_name = Signature.site_of_num p_id sign in + (try + let c = + List.find + (fun c' -> String.compare (Loc.v c'.Ast.counter_name) c_name = 0) + counters + in + ra_counters.(p_id) <- + Some + ( { + Ast.counter_name = c.Ast.counter_name; + Ast.counter_test = c.Ast.counter_test; + Ast.counter_delta = 0, Loc.dummy; + }, + LKappa.Maintained ) + with Not_found -> + ra_counters.(p_id) <- + Some + ( { + Ast.counter_name = c_name, Loc.dummy; + Ast.counter_test = Some (Ast.CEQ min, Loc.dummy); + Ast.counter_delta = 0, Loc.dummy; + }, + LKappa.Maintained )) + | None -> ()) + ra_counters; + + let register_counter_modif c_id = + let counter_agent_info = Signature.get_counter_agent_info sigs in + let port_b = fst counter_agent_info.ports in + add_link_contact_map ag_id c_id counter_agent_info.id port_b + in + let _ : Mods.IntSet.t = + List.fold_left + (fun pset c -> + let port_name = c.Ast.counter_name in + let p_id = Signature.num_of_site ~agent_name port_name sign in + match Signature.counter_of_site_id p_id sign with + | None -> LKappa.raise_counter_misused agent_name c.Ast.counter_name + | Some _ -> + (); let pset' = Mods.IntSet.add p_id pset in - let () = if pset == pset' then - LKappa.several_occurence_of_site agent_name c.Ast.count_nme in - let () = register_counter_modif p_id in - let () = ra_counters.(p_id) <- Some (c,LKappa.Maintained) in - pset') Mods.IntSet.empty counts in - {ra;ra_counters;} + if pset == pset' then + LKappa.raise_several_occurence_of_site agent_name c.Ast.counter_name; + register_counter_modif p_id; + ra_counters.(p_id) <- Some (c, LKappa.Maintained); + pset') + Mods.IntSet.empty counters + in + { agent = ra; counters = ra_counters } diff --git a/core/grammar/counters_compiler.mli b/core/grammar/counters_compiler.mli index e59a09a167..66f6b5a0ab 100644 --- a/core/grammar/counters_compiler.mli +++ b/core/grammar/counters_compiler.mli @@ -6,43 +6,74 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type 'a rule_agent_counters = { - ra : 'a; - ra_counters : (Ast.counter * LKappa.switching) option array; +type 'a with_agent_counters = { + agent: 'a; + counters: (Ast.counter * LKappa.switching) option array; } +(** [with_agent_counters] annotates a agent type with rule agent counters if relevant. Used mainly with [rule_agent] and [Raw_mixture.agent]. + * + * Usually in the code a trailing underscore in a variable name marks that we have this data added, such as [rule_agent_] with [rule_agent_.agent] being a [rule_agent] *) -val compile : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - debugMode:bool -> Ast.parsing_compil -> Ast.parsing_compil * bool +type rule_mixture_with_agent_counters = + LKappa.rule_agent with_agent_counters list + +type raw_mixture_with_agent_counters = + Raw_mixture.agent with_agent_counters list + +val has_counters : Ast.parsing_compil -> bool + +val split_counter_variables_into_separate_rules : + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + debug_mode:bool -> + Ast.parsing_compil -> + Ast.parsing_compil val make_counter : int -> string -> Ast.counter -val remove_counter_rule : - Signature.s -> LKappa.rule_agent rule_agent_counters list -> - Raw_mixture.agent rule_agent_counters list -> - LKappa.rule_agent list * Raw_mixture.agent list +val compile_counter_in_rule : + Signature.s -> + LKappa.rule_agent with_agent_counters list -> + Raw_mixture.agent with_agent_counters list -> + LKappa.rule_agent list * Raw_mixture.agent list val counters_perturbations : - Signature.s -> Ast.mixture -> - (LKappa.rule_mixture, Raw_mixture.agent list, int,LKappa.rule) Ast.perturbation list + Signature.s -> + Ast.mixture -> + (LKappa.rule_mixture, Raw_mixture.t, int, LKappa.rule) Ast.perturbation list val annotate_dropped_counters : - Signature.t -> Ast.counter list -> LKappa.rule_agent -> int -> string -> - (int -> unit) option -> LKappa.rule_agent rule_agent_counters + Signature.t -> + Ast.counter list -> + LKappa.rule_agent -> + int -> + string -> + (int -> unit) option -> + LKappa.rule_agent with_agent_counters val annotate_edit_counters : - Signature.s -> string * Locality.t -> Ast.counter list -> LKappa.rule_agent -> - (int -> int -> int -> int -> unit) -> LKappa.rule_agent rule_agent_counters + Signature.s -> + string Loc.annoted -> + Ast.counter list -> + LKappa.rule_agent -> + (int -> int -> int -> int -> unit) -> + LKappa.rule_agent with_agent_counters val annotate_created_counters : - Signature.s -> string * Locality.t -> Ast.counter list -> - (int -> int -> int -> int -> unit) -> Raw_mixture.agent -> - Raw_mixture.agent rule_agent_counters + Signature.s -> + string Loc.annoted -> + Ast.counter list -> + (int -> int -> int -> int -> unit) -> + Raw_mixture.agent -> + Raw_mixture.agent with_agent_counters val annotate_counters_with_diff : - Signature.s -> string Locality.annot -> Ast.counter list -> Ast.counter list -> - LKappa.rule_agent -> (int -> int -> int -> int -> unit) -> - LKappa.rule_agent rule_agent_counters + Signature.s -> + string Loc.annoted -> + Ast.counter list -> + Ast.counter list -> + LKappa.rule_agent -> + (int -> int -> int -> int -> unit) -> + LKappa.rule_agent with_agent_counters val add_counter_to_contact_map : Signature.s -> (int -> int -> int -> int -> unit) -> unit diff --git a/core/grammar/cst.ml b/core/grammar/cst.ml index ddd477f82b..f1a3827622 100644 --- a/core/grammar/cst.ml +++ b/core/grammar/cst.ml @@ -9,30 +9,31 @@ let append_to_ast_compil rev_instr compil = List.fold_left (fun r -> function - | Ast.RULE ru -> - {r with Ast.rules = ru::r.Ast.rules} - | Ast.SIG ag -> - {r with Ast.signatures=ag::r.Ast.signatures} - | Ast.TOKENSIG (str_pos) -> - {r with Ast.tokens=str_pos::r.Ast.tokens} - | Ast.VOLSIG (vol_type,vol,vol_param) -> - {r with Ast.volumes=(vol_type,vol,vol_param)::r.Ast.volumes} - | Ast.INIT (alg,init_t) -> - {r with Ast.init=(alg,init_t)::r.Ast.init} - | Ast.DECLARE var -> - {r with Ast.variables = var::r.Ast.variables} - | Ast.OBS ((lbl,pos),_ as var) -> - (*for backward compatibility, shortcut for %var + %plot*) - {r with - Ast.variables = var::r.Ast.variables; - Ast.observables = (Alg_expr.ALG_VAR lbl,pos)::r.Ast.observables} - | Ast.PLOT expr -> - {r with Ast.observables = expr::r.Ast.observables} - | Ast.PERT ((alarm,pre,effect,opt),pos) -> - {r with + | Ast.RULE ru -> { r with Ast.rules = ru :: r.Ast.rules } + | Ast.SIG ag -> { r with Ast.signatures = ag :: r.Ast.signatures } + | Ast.TOKENSIG str_pos -> { r with Ast.tokens = str_pos :: r.Ast.tokens } + | Ast.VOLSIG (vol_type, vol, vol_param) -> + { r with Ast.volumes = (vol_type, vol, vol_param) :: r.Ast.volumes } + | Ast.INIT (alg, init_t) -> + { r with Ast.init = (alg, init_t) :: r.Ast.init } + | Ast.DECLARE var -> { r with Ast.variables = var :: r.Ast.variables } + | Ast.OBS (((lbl, pos), _) as var) -> + (*for backward compatibility, shortcut for %var + %plot*) + { + r with + Ast.variables = var :: r.Ast.variables; + Ast.observables = (Alg_expr.ALG_VAR lbl, pos) :: r.Ast.observables; + } + | Ast.PLOT expr -> { r with Ast.observables = expr :: r.Ast.observables } + | Ast.PERT ((alarm, pre, effect, opt), pos) -> + { + r with Ast.perturbations = - ((alarm,pre,effect,opt),pos)::r.Ast.perturbations} - | Ast.CONFIG (param_name,value_list) -> - {r with - Ast.configurations = (param_name,value_list)::r.Ast.configurations} - ) compil (List.rev rev_instr) + ((alarm, pre, effect, opt), pos) :: r.Ast.perturbations; + } + | Ast.CONFIG (param_name, value_list) -> + { + r with + Ast.configurations = (param_name, value_list) :: r.Ast.configurations; + }) + compil (List.rev rev_instr) diff --git a/core/grammar/dune b/core/grammar/dune index a3a316161d..90d0f3cae5 100644 --- a/core/grammar/dune +++ b/core/grammar/dune @@ -1,12 +1,19 @@ (library - (name kappa_grammar) - (libraries yojson result lwt - kappa-library.generic kappa-library.runtime) - (flags (:standard -w @a - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms - -open Kappa_runtime))) + (name kappa_grammar) + (libraries yojson result lwt kappa-library.generic kappa-library.runtime) + (flags + (:standard + -w + @a-40-42 + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms + -open + Kappa_runtime))) (ocamlyacc kparser4 kappaParser) + (ocamllex klexer4 kappaLexer) diff --git a/core/grammar/eval.ml b/core/grammar/eval.ml index 782660dbc7..197ce498d0 100644 --- a/core/grammar/eval.ml +++ b/core/grammar/eval.ml @@ -8,600 +8,687 @@ open Ast -let rec compile_alg ~debugMode ~compileModeOn domain (alg,pos) = +let rec compile_alg ~debug_mode ~compile_mode_on domain (alg, pos) = match alg with | Alg_expr.KAPPA_INSTANCE ast -> - begin - match domain with - | Some (origin,contact_map,domain) -> - begin - let domain',ccs = - Pattern_compiler.connected_components_sum_of_ambiguous_mixture - ~debugMode ~compileModeOn contact_map domain ?origin ast - in - let out_ccs = List.map (fun (x,_) -> Array.map fst x) ccs in - (Some (origin,contact_map,domain'), - (Alg_expr.KAPPA_INSTANCE out_ccs,pos)) - end - | None -> - raise (ExceptionDefn.Internal_Error - ("Theoritically pure alg_expr has a mixture",pos)) - end - | Alg_expr.ALG_VAR i -> (domain,(Alg_expr.ALG_VAR i,pos)) - | Alg_expr.TOKEN_ID i -> (domain,(Alg_expr.TOKEN_ID i,pos)) - | Alg_expr.STATE_ALG_OP (op) -> (domain,(Alg_expr.STATE_ALG_OP (op),pos)) - | Alg_expr.CONST n -> (domain,(Alg_expr.CONST n,pos)) + (match domain with + | Some (origin, contact_map, domain) -> + let domain', ccs = + Pattern_compiler.connected_components_sum_of_ambiguous_mixture + ~debug_mode ~compile_mode_on contact_map domain ?origin ast + in + let out_ccs = List.map (fun (x, _) -> Array.map fst x) ccs in + Some (origin, contact_map, domain'), (Alg_expr.KAPPA_INSTANCE out_ccs, pos) + | None -> + raise + (ExceptionDefn.Internal_Error + ("Theoritically pure alg_expr has a mixture", pos))) + | Alg_expr.ALG_VAR i -> domain, (Alg_expr.ALG_VAR i, pos) + | Alg_expr.TOKEN_ID i -> domain, (Alg_expr.TOKEN_ID i, pos) + | Alg_expr.STATE_ALG_OP op -> domain, (Alg_expr.STATE_ALG_OP op, pos) + | Alg_expr.CONST n -> domain, (Alg_expr.CONST n, pos) | Alg_expr.BIN_ALG_OP (op, a, b) -> - let domain',a' = compile_alg ~debugMode ~compileModeOn domain a in - let domain'',b' = compile_alg ~debugMode ~compileModeOn domain' b in - (domain'',(Alg_expr.BIN_ALG_OP (op,a',b'),pos)) - | Alg_expr.UN_ALG_OP (op,a) -> - let domain',a' = compile_alg ~debugMode ~compileModeOn domain a in - (domain',(Alg_expr.UN_ALG_OP (op,a'),pos)) - | Alg_expr.IF (cond,yes,no) -> - let domain',cond' = compile_bool ~debugMode ~compileModeOn domain cond in - let domain'',yes' = compile_alg ~debugMode ~compileModeOn domain' yes in - let domain''',no' = compile_alg ~debugMode ~compileModeOn domain'' no in - (domain''',(Alg_expr.IF (cond',yes',no'),pos)) - | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ -> + let domain', a' = compile_alg ~debug_mode ~compile_mode_on domain a in + let domain'', b' = compile_alg ~debug_mode ~compile_mode_on domain' b in + domain'', (Alg_expr.BIN_ALG_OP (op, a', b'), pos) + | Alg_expr.UN_ALG_OP (op, a) -> + let domain', a' = compile_alg ~debug_mode ~compile_mode_on domain a in + domain', (Alg_expr.UN_ALG_OP (op, a'), pos) + | Alg_expr.IF (cond, yes, no) -> + let domain', cond' = + compile_bool ~debug_mode ~compile_mode_on domain cond + in + let domain'', yes' = compile_alg ~debug_mode ~compile_mode_on domain' yes in + let domain''', no' = compile_alg ~debug_mode ~compile_mode_on domain'' no in + domain''', (Alg_expr.IF (cond', yes', no'), pos) + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ -> raise (ExceptionDefn.Internal_Error - ("Cannot deal with derivative in expressions",pos)) -and compile_bool ~debugMode ~compileModeOn domain = function - | Alg_expr.TRUE,pos -> (domain,(Alg_expr.TRUE,pos)) - | Alg_expr.FALSE,pos -> (domain,(Alg_expr.FALSE,pos)) - | Alg_expr.BIN_BOOL_OP (op,a,b), pos -> - let domain',a' = compile_bool ~debugMode ~compileModeOn domain a in - let domain'',b' = compile_bool ~debugMode ~compileModeOn domain' b in - (domain'',(Alg_expr.BIN_BOOL_OP (op,a',b'),pos)) - | Alg_expr.UN_BOOL_OP (op,a), pos -> - let domain',a' = compile_bool ~debugMode ~compileModeOn domain a in - (domain',(Alg_expr.UN_BOOL_OP (op,a'),pos)) - | Alg_expr.COMPARE_OP (op,a,b),pos -> - let (domain',a') = compile_alg ~debugMode ~compileModeOn domain a in - let (domain'',b') = compile_alg ~debugMode ~compileModeOn domain' b in - (domain'',(Alg_expr.COMPARE_OP (op,a',b'), pos)) + ("Cannot deal with derivative in expressions", pos)) + +and compile_bool ~debug_mode ~compile_mode_on domain = function + | Alg_expr.TRUE, pos -> domain, (Alg_expr.TRUE, pos) + | Alg_expr.FALSE, pos -> domain, (Alg_expr.FALSE, pos) + | Alg_expr.BIN_BOOL_OP (op, a, b), pos -> + let domain', a' = compile_bool ~debug_mode ~compile_mode_on domain a in + let domain'', b' = compile_bool ~debug_mode ~compile_mode_on domain' b in + domain'', (Alg_expr.BIN_BOOL_OP (op, a', b'), pos) + | Alg_expr.UN_BOOL_OP (op, a), pos -> + let domain', a' = compile_bool ~debug_mode ~compile_mode_on domain a in + domain', (Alg_expr.UN_BOOL_OP (op, a'), pos) + | Alg_expr.COMPARE_OP (op, a, b), pos -> + let domain', a' = compile_alg ~debug_mode ~compile_mode_on domain a in + let domain'', b' = compile_alg ~debug_mode ~compile_mode_on domain' b in + domain'', (Alg_expr.COMPARE_OP (op, a', b'), pos) -let compile_pure_alg ~debugMode ~compileModeOn (alg,pos) = - snd @@ compile_alg ~debugMode ~compileModeOn None (alg,pos) +let compile_pure_alg ~debug_mode ~compile_mode_on (alg, pos) = + snd @@ compile_alg ~debug_mode ~compile_mode_on None (alg, pos) -let compile_alg ~debugMode ~compileModeOn ?origin contact_map domain (alg,pos) = - match compile_alg - ~debugMode ~compileModeOn - (Some (origin,contact_map,domain)) (alg,pos) +let compile_alg ~debug_mode ~compile_mode_on ?origin contact_map domain + (alg, pos) = + match + compile_alg ~debug_mode ~compile_mode_on + (Some (origin, contact_map, domain)) + (alg, pos) with - | Some (_, _,domain),alg -> domain,alg + | Some (_, _, domain), alg -> domain, alg | None, _ -> failwith "domain has been lost in Expr.compile_alg" -let compile_bool - ~debugMode ~compileModeOn ?origin contact_map domain (alg,pos) = - match compile_bool - ~debugMode ~compileModeOn - (Some (origin,contact_map,domain)) (alg,pos) +let compile_bool ~debug_mode ~compile_mode_on ?origin contact_map domain + (alg, pos) = + match + compile_bool ~debug_mode ~compile_mode_on + (Some (origin, contact_map, domain)) + (alg, pos) with - | Some (_, _,domain),alg -> domain,alg + | Some (_, _, domain), alg -> domain, alg | None, _ -> failwith "domain has been lost in Expr.compile_alg" -let tokenify ~debugMode ~compileModeOn contact_map domain l = +let tokenify ~debug_mode ~compile_mode_on contact_map domain l = List.fold_right - (fun (alg_expr,id) (domain,out) -> - let (domain',alg) = - compile_alg ~debugMode ~compileModeOn contact_map domain alg_expr in - (domain',(alg,id)::out) - ) l (domain,[]) + (fun (alg_expr, id) (domain, out) -> + let domain', alg = + compile_alg ~debug_mode ~compile_mode_on contact_map domain alg_expr + in + domain', (alg, id) :: out) + l (domain, []) (* transform an LKappa rule into a Primitives rule *) -let rules_of_ast - ~debugMode ~warning ?deps_machinery ~compileModeOn - contact_map domain ~syntax_ref (rule,_) = - let domain',delta_toks = - tokenify - ~debugMode ~compileModeOn contact_map domain rule.LKappa.r_delta_tokens in - (* let one_side syntax_ref label (domain,deps_machinery,unary_ccs,acc) - rate unary_rate lhs rhs rm add =*) - let origin,deps = +let rules_of_ast ~debug_mode ~warning ?deps_machinery ~compile_mode_on + contact_map domain ~syntax_ref (rule, _) = + let domain', delta_toks = + tokenify ~debug_mode ~compile_mode_on contact_map domain + rule.LKappa.r_delta_tokens + in + (* let one_side syntax_ref label (domain,deps_machinery,unary_ccs,acc) + rate unary_rate lhs rhs rm add =*) + let origin, deps = match deps_machinery with - | None -> None,None - | Some (o,d) -> Some o, Some d in + | None -> None, None + | Some (o, d) -> Some o, Some d + in let unary_infos = let crp = - compile_pure_alg ~debugMode ~compileModeOn rule.LKappa.r_rate in + compile_pure_alg ~debug_mode ~compile_mode_on rule.LKappa.r_rate + in match rule.LKappa.r_un_rate with - | None -> fun _ -> crp,None - | Some ((_,pos as rate),dist) -> - let dist' = match dist with + | None -> fun _ -> crp, None + | Some (((_, pos) as rate), dist) -> + let dist' = + match dist with | None -> None | Some d -> - let (d', _) = compile_pure_alg ~debugMode ~compileModeOn d in - Some d' in - let unrate = compile_pure_alg ~debugMode ~compileModeOn rate in + let d', _ = compile_pure_alg ~debug_mode ~compile_mode_on d in + Some d' + in + let unrate = compile_pure_alg ~debug_mode ~compile_mode_on rate in fun ccs -> - match Array.length ccs with - | (0 | 1) -> + (match Array.length ccs with + | 0 | 1 -> let () = - warning - ~pos - (fun f -> - Format.pp_print_text - f "Useless molecular ambiguity, the rules is \ - always considered as unary.") in - unrate,None - | 2 -> - crp,Some (unrate, dist') + warning ~pos (fun f -> + Format.pp_print_text f + "Useless molecular ambiguity, the rules is always considered \ + as unary.") + in + unrate, None + | 2 -> crp, Some (unrate, dist') | n -> - raise (ExceptionDefn.Malformed_Decl - ("Unary rule does not deal with "^ - string_of_int n^" connected components.",pos)) in - let build deps (origin,ccs,syntax,(neg,pos)) = + raise + (ExceptionDefn.Malformed_Decl + ( "Unary rule does not deal with " ^ string_of_int n + ^ " connected components.", + pos ))) + in + let build deps (origin, ccs, syntax, (neg, pos)) = let ccs' = Array.map fst ccs in - let rate,unrate = unary_infos ccs' in - Option_util.map - (fun x -> - let origin = - match origin with Some o -> o | None -> failwith "ugly Eval.rule_of_ast" in - let x' = - match unrate with - | None -> x - | Some (ur,_) -> Alg_expr.add_dep x origin ur in - Alg_expr.add_dep x' origin rate) - deps,{ - Primitives.unary_rate = unrate; - Primitives.rate = rate; - Primitives.connected_components = ccs'; - Primitives.removed = neg; - Primitives.inserted = pos; - Primitives.delta_tokens = delta_toks; - Primitives.syntactic_rule = syntax_ref; - Primitives.instantiations = syntax; - } in - let rule_mixtures,(domain',origin') = - Pattern_compiler.connected_components_sum_of_ambiguous_rule - ~debugMode ~compileModeOn contact_map - domain' ?origin rule.LKappa.r_mix rule.LKappa.r_created in - let deps_algs',rules_l = + let rate, unrate = unary_infos ccs' in + ( Option_util.map + (fun x -> + let origin = + match origin with + | Some o -> o + | None -> failwith "ugly Eval.rule_of_ast" + in + let x' = + match unrate with + | None -> x + | Some (ur, _) -> Alg_expr.add_dep x origin ur + in + Alg_expr.add_dep x' origin rate) + deps, + { + Primitives.unary_rate = unrate; + Primitives.rate; + Primitives.connected_components = ccs'; + Primitives.removed = neg; + Primitives.inserted = pos; + Primitives.delta_tokens = delta_toks; + Primitives.syntactic_rule = syntax_ref; + Primitives.instantiations = syntax; + } ) + in + let rule_mixtures, (domain', origin') = + Pattern_compiler.connected_components_sum_of_ambiguous_rule ~debug_mode + ~compile_mode_on contact_map domain' ?origin rule.LKappa.r_mix + rule.LKappa.r_created + in + let deps_algs', rules_l = List.fold_right - (fun r (deps_algs,out) -> - let deps_algs',r'' = build deps_algs r in - deps_algs',r''::out) - rule_mixtures (deps,[]) in - domain',(match origin' with - | None -> None - | Some o -> Some (o, - match deps_algs' with - | Some d -> d - | None -> failwith "ugly Eval.rule_of_ast")), - rules_l + (fun r (deps_algs, out) -> + let deps_algs', r'' = build deps_algs r in + deps_algs', r'' :: out) + rule_mixtures (deps, []) + in + ( domain', + (match origin' with + | None -> None + | Some o -> + Some + ( o, + match deps_algs' with + | Some d -> d + | None -> failwith "ugly Eval.rule_of_ast" )), + rules_l ) -let obs_of_result - ~debugMode ~compileModeOn contact_map domain alg_deps res = - let domain,out = +let obs_of_result ~debug_mode ~compile_mode_on contact_map domain alg_deps res = + let domain, out = List.fold_left - (fun (domain,cont) alg_expr -> - let (domain',alg_pos) = - compile_alg - ~debugMode ~compileModeOn contact_map domain alg_expr in - domain',alg_pos :: cont) - (domain,[]) res.observables in + (fun (domain, cont) alg_expr -> + let domain', alg_pos = + compile_alg ~debug_mode ~compile_mode_on contact_map domain alg_expr + in + domain', alg_pos :: cont) + (domain, []) res.observables + in if List.exists (Alg_expr.has_progress_dep ~only_time:false alg_deps) out then - (domain, List.rev out) + domain, List.rev out else - (domain, - Locality.dummy_annot (Alg_expr.STATE_ALG_OP Operator.TIME_VAR) - :: List.rev out) + ( domain, + Loc.annot_with_dummy (Alg_expr.STATE_ALG_OP Operator.TIME_VAR) + :: List.rev out ) -let compile_print_expr ~debugMode ~compileModeOn contact_map domain ex = +let compile_print_expr ~debug_mode ~compile_mode_on contact_map domain ex = List.fold_right - (fun el (domain,out) -> - match el with - | Primitives.Str_pexpr s -> (domain,Primitives.Str_pexpr s::out) - | Primitives.Alg_pexpr ast_alg -> - let (domain', alg) = - compile_alg - ~debugMode ~compileModeOn contact_map domain ast_alg in - (domain',(Primitives.Alg_pexpr alg::out))) - ex (domain,[]) + (fun el (domain, out) -> + match el with + | Primitives.Str_pexpr s -> domain, Primitives.Str_pexpr s :: out + | Primitives.Alg_pexpr ast_alg -> + let domain', alg = + compile_alg ~debug_mode ~compile_mode_on contact_map domain ast_alg + in + domain', Primitives.Alg_pexpr alg :: out) + ex (domain, []) -let cflows_of_label - ~debugMode origin ~compileModeOn - contact_map domain on algs rules (label,pos) rev_effects = +let cflows_of_label ~debug_mode origin ~compile_mode_on contact_map domain on + algs rules (label, pos) rev_effects = let adds tests l x = - if on then Primitives.CFLOW (Some label,x,tests) :: l - else Primitives.CFLOWOFF (Some label,x) :: l in + if on then + Primitives.CFLOW (Some label, x, tests) :: l + else + Primitives.CFLOWOFF (Some label, x) :: l + in let mix = try - let (_,(rule,_)) = - List.find (function None,_ -> false | Some (l,_),_ -> l=label) rules in + let _, (rule, _) = + List.find + (function + | None, _ -> false + | Some (l, _), _ -> l = label) + rules + in LKappa.to_maintained rule.LKappa.r_mix with Not_found -> - try let (_,(var,_)) = List.find (fun ((l,_),_) -> l = label) algs in - match var with - | Alg_expr.KAPPA_INSTANCE mix -> mix - | (Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.ALG_VAR _ | Alg_expr.TOKEN_ID _ | Alg_expr.CONST _ - | Alg_expr.IF _ | Alg_expr.DIFF_TOKEN _ - | Alg_expr.DIFF_KAPPA_INSTANCE _) -> raise Not_found - with Not_found -> - raise (ExceptionDefn.Malformed_Decl - ("Label '" ^ label ^ - "' does not refer to a non ambiguous Kappa expression" - ,pos)) in - let domain',ccs = - Pattern_compiler.connected_components_sum_of_ambiguous_mixture - ~debugMode ~compileModeOn contact_map domain ~origin mix in - (domain', - List.fold_left (fun x (y,t) -> adds t x (Array.map fst y)) rev_effects ccs) + (try + let _, (var, _) = List.find (fun ((l, _), _) -> l = label) algs in + match var with + | Alg_expr.KAPPA_INSTANCE mix -> mix + | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ | Alg_expr.TOKEN_ID _ + | Alg_expr.CONST _ | Alg_expr.IF _ | Alg_expr.DIFF_TOKEN _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ -> + raise Not_found + with Not_found -> + raise + (ExceptionDefn.Malformed_Decl + ( "Label '" ^ label + ^ "' does not refer to a non ambiguous Kappa expression", + pos ))) + in + let domain', ccs = + Pattern_compiler.connected_components_sum_of_ambiguous_mixture ~debug_mode + ~compile_mode_on contact_map domain ~origin mix + in + ( domain', + List.fold_left (fun x (y, t) -> adds t x (Array.map fst y)) rev_effects ccs + ) -let effects_of_modif - ~debugMode ~warning ast_algs ast_rules origin ~compileModeOn - contact_map (domain,rev_effects) = function - | APPLY (alg_expr, (_,pos as pack)) -> - let (domain',alg_pos) = - compile_alg - ~debugMode ~compileModeOn contact_map domain alg_expr in - let domain'',_,elem_rules = - rules_of_ast ~debugMode ~warning - ~compileModeOn contact_map domain' ~syntax_ref:0 pack in - let elem_rule = match elem_rules with +let effects_of_modif ~debug_mode ~warning ast_algs ast_rules origin + ~compile_mode_on contact_map (domain, rev_effects) = function + | APPLY (alg_expr, ((_, pos) as pack)) -> + let domain', alg_pos = + compile_alg ~debug_mode ~compile_mode_on contact_map domain alg_expr + in + let domain'', _, elem_rules = + rules_of_ast ~debug_mode ~warning ~compile_mode_on contact_map domain' + ~syntax_ref:0 pack + in + let elem_rule = + match elem_rules with | [ r ] -> r | _ -> raise (ExceptionDefn.Malformed_Decl - ("Ambiguous rule in modifition is impossible",pos)) in - (domain'', - (Primitives.ITER_RULE (alg_pos, elem_rule))::rev_effects) + ("Ambiguous rule in modifition is impossible", pos)) + in + domain'', Primitives.ITER_RULE (alg_pos, elem_rule) :: rev_effects | UPDATE ((i, _), alg_expr) -> - let (domain', alg_pos) = - compile_alg - ~debugMode ~compileModeOn contact_map domain alg_expr in - (domain',(Primitives.UPDATE (i, alg_pos))::rev_effects) - | SNAPSHOT (raw,pexpr) -> - let (domain',pexpr') = - compile_print_expr ~debugMode ~compileModeOn contact_map domain pexpr in + let domain', alg_pos = + compile_alg ~debug_mode ~compile_mode_on contact_map domain alg_expr + in + domain', Primitives.UPDATE (i, alg_pos) :: rev_effects + | SNAPSHOT (raw, pexpr) -> + let domain', pexpr' = + compile_print_expr ~debug_mode ~compile_mode_on contact_map domain pexpr + in (*when specializing snapshots to particular mixtures, add variables below*) - (domain', (Primitives.SNAPSHOT (raw,pexpr'))::rev_effects) + domain', Primitives.SNAPSHOT (raw, pexpr') :: rev_effects | STOP pexpr -> - let (domain',pexpr') = - compile_print_expr ~debugMode ~compileModeOn contact_map domain pexpr in - (domain', (Primitives.STOP pexpr')::rev_effects) - | CFLOWLABEL (on,lab) -> - cflows_of_label ~debugMode origin ~compileModeOn - contact_map domain on ast_algs ast_rules lab rev_effects - | CFLOWMIX (on,(ast,_)) -> + let domain', pexpr' = + compile_print_expr ~debug_mode ~compile_mode_on contact_map domain pexpr + in + domain', Primitives.STOP pexpr' :: rev_effects + | CFLOWLABEL (on, lab) -> + cflows_of_label ~debug_mode origin ~compile_mode_on contact_map domain on + ast_algs ast_rules lab rev_effects + | CFLOWMIX (on, (ast, _)) -> let adds tests l x = - if on then Primitives.CFLOW (None,x,tests) :: l - else Primitives.CFLOWOFF (None,x) :: l in - let domain',ccs = - Pattern_compiler.connected_components_sum_of_ambiguous_mixture - ~debugMode ~compileModeOn contact_map domain ~origin ast in - (domain', - List.fold_left (fun x (y,t) -> adds t x (Array.map fst y)) rev_effects ccs) - | DIN (rel,pexpr) -> - let (domain',pexpr') = - compile_print_expr ~debugMode ~compileModeOn contact_map domain pexpr in - (domain', (Primitives.DIN (rel,pexpr'))::rev_effects) + if on then + Primitives.CFLOW (None, x, tests) :: l + else + Primitives.CFLOWOFF (None, x) :: l + in + let domain', ccs = + Pattern_compiler.connected_components_sum_of_ambiguous_mixture ~debug_mode + ~compile_mode_on contact_map domain ~origin ast + in + ( domain', + List.fold_left + (fun x (y, t) -> adds t x (Array.map fst y)) + rev_effects ccs ) + | DIN (rel, pexpr) -> + let domain', pexpr' = + compile_print_expr ~debug_mode ~compile_mode_on contact_map domain pexpr + in + domain', Primitives.DIN (rel, pexpr') :: rev_effects | DINOFF pexpr -> - let (domain',pexpr') = - compile_print_expr ~debugMode ~compileModeOn contact_map domain pexpr in - (domain', (Primitives.DINOFF pexpr')::rev_effects) - | Ast.PRINT (pexpr,print) -> - let (domain',pexpr') = - compile_print_expr ~debugMode ~compileModeOn contact_map domain pexpr in - let (domain'',print') = - compile_print_expr ~debugMode ~compileModeOn contact_map domain' print in - (domain'', (Primitives.PRINT (pexpr',print'))::rev_effects) - | PLOTENTRY -> - (domain, (Primitives.PLOTENTRY)::rev_effects) - | SPECIES_OF (on,pexpr,(ast,pos)) -> - let (domain',pexpr') = - compile_print_expr ~debugMode ~compileModeOn contact_map domain pexpr in + let domain', pexpr' = + compile_print_expr ~debug_mode ~compile_mode_on contact_map domain pexpr + in + domain', Primitives.DINOFF pexpr' :: rev_effects + | Ast.PRINT (pexpr, print) -> + let domain', pexpr' = + compile_print_expr ~debug_mode ~compile_mode_on contact_map domain pexpr + in + let domain'', print' = + compile_print_expr ~debug_mode ~compile_mode_on contact_map domain' print + in + domain'', Primitives.PRINT (pexpr', print') :: rev_effects + | PLOTENTRY -> domain, Primitives.PLOTENTRY :: rev_effects + | SPECIES_OF (on, pexpr, (ast, pos)) -> + let domain', pexpr' = + compile_print_expr ~debug_mode ~compile_mode_on contact_map domain pexpr + in let adds tests l x = - if on then Primitives.SPECIES (pexpr',x,tests) :: l - else Primitives.SPECIES_OFF pexpr' :: l in - let domain'',ccs = - Pattern_compiler.connected_components_sum_of_ambiguous_mixture - ~debugMode ~compileModeOn contact_map domain' ~origin ast in + if on then + Primitives.SPECIES (pexpr', x, tests) :: l + else + Primitives.SPECIES_OFF pexpr' :: l + in + let domain'', ccs = + Pattern_compiler.connected_components_sum_of_ambiguous_mixture ~debug_mode + ~compile_mode_on contact_map domain' ~origin ast + in let () = List.iter - (fun (arr,_) -> + (fun (arr, _) -> if Array.length arr > 1 then - raise (ExceptionDefn.Malformed_Decl - ("SPECIES_OF can only be applied to one connected component", - pos))) ccs in - (domain'', - List.fold_left (fun x (y,t) -> adds t x (Array.map fst y)) rev_effects ccs) + raise + (ExceptionDefn.Malformed_Decl + ( "SPECIES_OF can only be applied to one connected component", + pos ))) + ccs + in + ( domain'', + List.fold_left + (fun x (y, t) -> adds t x (Array.map fst y)) + rev_effects ccs ) -let effects_of_modifs - ~debugMode ~warning - ast_algs ast_rules origin ~compileModeOn contact_map domain l = - let domain',rev_effects = +let effects_of_modifs ~debug_mode ~warning ast_algs ast_rules origin + ~compile_mode_on contact_map domain l = + let domain', rev_effects = List.fold_left - (effects_of_modif ~debugMode ~warning - ast_algs ast_rules origin ~compileModeOn contact_map) - (domain,[]) l in - domain',List.rev rev_effects + (effects_of_modif ~debug_mode ~warning ast_algs ast_rules origin + ~compile_mode_on contact_map) + (domain, []) l + in + domain', List.rev rev_effects let compile_modifications_no_track = effects_of_modifs [] [] (Operator.MODIF (-1)) (* interventions without pre and post, but with alarm are not applied -at initialisation *) + at initialisation *) let pert_not_init overwrite_t0 x y z = - match x,y,z with + match x, y, z with | _, Some p, _ -> p | Some _, None, None -> let t_var = - Locality.dummy_annot (Alg_expr.STATE_ALG_OP Operator.TIME_VAR) in + Loc.annot_with_dummy (Alg_expr.STATE_ALG_OP Operator.TIME_VAR) + in let t0 = Option_util.fold (fun _ x -> Nbr.F x) Nbr.zero overwrite_t0 in - let init_t = Locality.dummy_annot (Alg_expr.CONST t0) in - Locality.dummy_annot (Alg_expr.COMPARE_OP (Operator.GREATER,t_var,init_t)) + let init_t = Loc.annot_with_dummy (Alg_expr.CONST t0) in + Loc.annot_with_dummy (Alg_expr.COMPARE_OP (Operator.GREATER, t_var, init_t)) | None, None, None | Some _, None, Some _ | None, None, Some _ -> - Locality.dummy_annot (Alg_expr.TRUE) - + Loc.annot_with_dummy Alg_expr.TRUE -let pert_of_result - ~debugMode ~warning ?overwrite_t0 ast_algs ast_rules alg_deps ~compileModeOn - contact_map domain res = - let (domain, out_alg_deps, _, lpert,tracking_enabled) = +let pert_of_result ~debug_mode ~warning ?overwrite_t0 ast_algs ast_rules + alg_deps ~compile_mode_on contact_map domain res = + let domain, out_alg_deps, _, lpert, tracking_enabled = List.fold_left (fun (domain, alg_deps, p_id, lpert, tracking_enabled) - ((alarm, pre_expr, modif_expr_list, opt_post),pos) -> + ((alarm, pre_expr, modif_expr_list, opt_post), pos) -> let () = match alarm with | Some n -> - if ((Nbr.compare n Nbr.zero) <= 0) then - raise (ExceptionDefn.Malformed_Decl - ("alarm has to be strictly greater than 0.0", pos)) else () - | None -> () in + if Nbr.compare n Nbr.zero <= 0 then + raise + (ExceptionDefn.Malformed_Decl + ("alarm has to be strictly greater than 0.0", pos)) + else + () + | None -> () + in let origin = Operator.MODIF p_id in let pre_expr' = pert_not_init overwrite_t0 alarm pre_expr opt_post in - let (domain',pre) = - compile_bool - ~debugMode ~compileModeOn ~origin contact_map domain pre_expr' in - let alg_deps' = match alarm with + let domain', pre = + compile_bool ~debug_mode ~compile_mode_on ~origin contact_map domain + pre_expr' + in + let alg_deps' = + match alarm with | Some _ -> alg_deps - | None -> Alg_expr.add_dep_bool alg_deps origin pre in - let (domain, effects) = - effects_of_modifs - ~debugMode ~warning ast_algs ast_rules origin ~compileModeOn - contact_map domain' modif_expr_list in - let domain,opt = + | None -> Alg_expr.add_dep_bool alg_deps origin pre + in + let domain, effects = + effects_of_modifs ~debug_mode ~warning ast_algs ast_rules origin + ~compile_mode_on contact_map domain' modif_expr_list + in + let domain, opt = match opt_post with - | None -> (domain,None) + | None -> domain, None | Some post_expr -> - let (domain',(post,post_pos)) = - compile_bool - ~debugMode ~compileModeOn contact_map domain post_expr in - (domain',Some (post,post_pos)) + let domain', (post, post_pos) = + compile_bool ~debug_mode ~compile_mode_on contact_map domain + post_expr + in + domain', Some (post, post_pos) in let has_tracking = - tracking_enabled || List.exists - (function - | Primitives.CFLOW _ | Primitives.SPECIES _ -> true - | (Primitives.CFLOWOFF _ | Primitives.PRINT _ | - Primitives.UPDATE _ | Primitives.SNAPSHOT _ - | Primitives.DIN _ | Primitives.DINOFF _ | - Primitives.PLOTENTRY | Primitives.STOP _ | - Primitives.ITER_RULE _ | Primitives.SPECIES_OFF _ ) -> false) - effects in + tracking_enabled + || List.exists + (function + | Primitives.CFLOW _ | Primitives.SPECIES _ -> true + | Primitives.CFLOWOFF _ | Primitives.PRINT _ + | Primitives.UPDATE _ | Primitives.SNAPSHOT _ + | Primitives.DIN _ | Primitives.DINOFF _ | Primitives.PLOTENTRY + | Primitives.STOP _ | Primitives.ITER_RULE _ + | Primitives.SPECIES_OFF _ -> + false) + effects + in let needs_backtrack = List.exists (function - Primitives.UPDATE _ | - Primitives.STOP _ | Primitives.ITER_RULE _ -> true - | Primitives.CFLOW _ | Primitives.SPECIES _ | - Primitives.CFLOWOFF _ | Primitives.PRINT _ | - Primitives.SNAPSHOT _ | Primitives.DIN _ | - Primitives.DINOFF _ | Primitives.PLOTENTRY | - Primitives.SPECIES_OFF _ -> false) - effects in - let repeat = match opt with - None -> Locality.dummy_annot Alg_expr.FALSE - | Some p -> p in + | Primitives.UPDATE _ | Primitives.STOP _ | Primitives.ITER_RULE _ + -> + true + | Primitives.CFLOW _ | Primitives.SPECIES _ + | Primitives.CFLOWOFF _ | Primitives.PRINT _ + | Primitives.SNAPSHOT _ | Primitives.DIN _ | Primitives.DINOFF _ + | Primitives.PLOTENTRY | Primitives.SPECIES_OFF _ -> + false) + effects + in + let repeat = + match opt with + | None -> Loc.annot_with_dummy Alg_expr.FALSE + | Some p -> p + in let pert = - { Primitives.alarm = alarm; + { + Primitives.alarm; Primitives.precondition = pre; Primitives.effect = effects; - Primitives.repeat = repeat; - Primitives.needs_backtrack = needs_backtrack; - } in - (domain, alg_deps', succ p_id, pert::lpert,has_tracking) - ) - (domain, alg_deps, 0, [], false) res.perturbations + Primitives.repeat; + Primitives.needs_backtrack; + } + in + domain, alg_deps', succ p_id, pert :: lpert, has_tracking) + (domain, alg_deps, 0, [], false) + res.perturbations in - (domain, out_alg_deps, List.rev lpert,tracking_enabled) + domain, out_alg_deps, List.rev lpert, tracking_enabled -let compile_inits - ~debugMode ~warning ?rescale ~compileModeOn contact_map env inits = - let init_l,_ = +let compile_inits ~debug_mode ~warning ?rescale ~compile_mode_on contact_map env + inits = + let init_l, _ = List_util.fold_right_map - (fun (alg,init_t) preenv -> - let () = - if Alg_expr.has_mix ~var_decls:(Model.get_alg env) (fst alg) then - raise - (ExceptionDefn.Malformed_Decl - ("Initial quantities cannot depend on a number of occurence", - snd alg)) in - let alg = match rescale with - | None -> alg - | Some r -> Alg_expr.mult alg (Alg_expr.float r) in - match init_t with - | INIT_MIX (raw_mix,mix_pos) -> - let sigs = Model.signatures env in - let (preenv',alg') = - compile_alg ~debugMode ~compileModeOn contact_map preenv alg in - let fake_rule = { - LKappa.r_mix = []; - LKappa.r_created = raw_mix; - LKappa.r_delta_tokens = []; - LKappa.r_rate = Alg_expr.const Nbr.zero; - LKappa.r_un_rate = None; - LKappa.r_editStyle = true; - } in - let preenv'',state' = - match - rules_of_ast - ~debugMode ~warning ~compileModeOn contact_map - preenv' ~syntax_ref:0 (fake_rule,mix_pos) - with - | domain'',_,[ compiled_rule ] -> - (fst alg',compiled_rule),domain'' - | _,_,_ -> - raise (ExceptionDefn.Malformed_Decl - (Format.asprintf - "initial mixture %a is partially defined" - (Raw_mixture.print - ~noCounters:debugMode ~created:true - ~initial_comma:false ~sigs) - raw_mix, - mix_pos)) in - preenv'',state' - | INIT_TOK tk_l -> - let r_delta_tokens = - List.map (fun (tk_id,_pos_tk) -> (alg,tk_id)) tk_l in - let fake_rule = { - LKappa.r_mix = []; LKappa.r_created = []; - LKappa.r_delta_tokens; - LKappa.r_rate = Alg_expr.const Nbr.zero; - LKappa.r_un_rate = None; LKappa.r_editStyle = false; - } in - match - rules_of_ast - ~debugMode ~warning ~compileModeOn - contact_map preenv ~syntax_ref:0 (Locality.dummy_annot fake_rule) + (fun (alg, init_t) preenv -> + let () = + if Alg_expr.has_mix ~var_decls:(Model.get_alg env) (fst alg) then + raise + (ExceptionDefn.Malformed_Decl + ( "Initial quantities cannot depend on a number of occurence", + snd alg )) + in + let alg = + match rescale with + | None -> alg + | Some r -> Alg_expr.mult alg (Alg_expr.float r) + in + match init_t with + | INIT_MIX (raw_mix, mix_pos) -> + let sigs = Model.signatures env in + let preenv', alg' = + compile_alg ~debug_mode ~compile_mode_on contact_map preenv alg + in + let fake_rule = + { + LKappa.r_mix = []; + LKappa.r_created = raw_mix; + LKappa.r_delta_tokens = []; + LKappa.r_rate = Alg_expr.const Nbr.zero; + LKappa.r_un_rate = None; + LKappa.r_edit_style = true; + } + in + let preenv'', state' = + match + rules_of_ast ~debug_mode ~warning ~compile_mode_on contact_map + preenv' ~syntax_ref:0 (fake_rule, mix_pos) + with + | domain'', _, [ compiled_rule ] -> + (fst alg', compiled_rule), domain'' + | _, _, _ -> + raise + (ExceptionDefn.Malformed_Decl + ( Format.asprintf "initial mixture %a is partially defined" + (Raw_mixture.print ~noCounters:debug_mode ~created:true + ~initial_comma:false ~sigs) + raw_mix, + mix_pos )) + in + preenv'', state' + | INIT_TOK tk_l -> + let r_delta_tokens = + List.map (fun (tk_id, _pos_tk) -> alg, tk_id) tk_l + in + let fake_rule = + { + LKappa.r_mix = []; + LKappa.r_created = []; + LKappa.r_delta_tokens; + LKappa.r_rate = Alg_expr.const Nbr.zero; + LKappa.r_un_rate = None; + LKappa.r_edit_style = false; + } + in + (match + rules_of_ast ~debug_mode ~warning ~compile_mode_on contact_map + preenv ~syntax_ref:0 + (Loc.annot_with_dummy fake_rule) with - | domain'',_,[ compiled_rule ] -> - (Alg_expr.CONST Nbr.one,compiled_rule),domain'' - | _,_,_ -> assert false - ) inits (Pattern.PreEnv.empty (Model.signatures env)) in + | domain'', _, [ compiled_rule ] -> + (Alg_expr.CONST Nbr.one, compiled_rule), domain'' + | _, _, _ -> assert false)) + inits + (Pattern.PreEnv.empty (Model.signatures env)) + in init_l -let compile_alg_vars ~debugMode ~compileModeOn contact_map domain vars = +let compile_alg_vars ~debug_mode ~compile_mode_on contact_map domain vars = Tools.array_fold_left_mapi - (fun i domain (lbl_pos,ast) -> - let (domain',alg) = - compile_alg - ~debugMode ~compileModeOn ~origin:(Operator.ALG i) - contact_map domain ast - in (domain',(lbl_pos,alg))) domain - (Array.of_list vars) + (fun i domain (lbl_pos, ast) -> + let domain', alg = + compile_alg ~debug_mode ~compile_mode_on ~origin:(Operator.ALG i) + contact_map domain ast + in + domain', (lbl_pos, alg)) + domain (Array.of_list vars) -let compile_rules - ~debugMode ~warning alg_deps ~compileModeOn contact_map domain rules = +let compile_rules ~debug_mode ~warning alg_deps ~compile_mode_on contact_map + domain rules = match List.fold_left - (fun (domain,syntax_ref,deps_machinery,acc) (_,rule) -> - let (domain',origin',cr) = - rules_of_ast - ~debugMode ~warning ?deps_machinery ~compileModeOn - contact_map domain ~syntax_ref rule in - (domain',succ syntax_ref,origin', - List.append cr acc)) - (domain,1,Some (Operator.RULE 0,alg_deps),[]) - rules with - | fdomain,_,Some (_,falg_deps),frules -> - fdomain,falg_deps,List.rev frules - | _, _, None, _ -> - failwith "The origin of Eval.compile_rules has been lost" + (fun (domain, syntax_ref, deps_machinery, acc) (_, rule) -> + let domain', origin', cr = + rules_of_ast ~debug_mode ~warning ?deps_machinery ~compile_mode_on + contact_map domain ~syntax_ref rule + in + domain', succ syntax_ref, origin', List.append cr acc) + (domain, 1, Some (Operator.RULE 0, alg_deps), []) + rules + with + | fdomain, _, Some (_, falg_deps), frules -> + fdomain, falg_deps, List.rev frules + | _, _, None, _ -> failwith "The origin of Eval.compile_rules has been lost" (*let translate_contact_map sigs kasa_contact_map = - let wdl = Locality.dummy_annot in - let sol = Array.init - (Signature.size sigs) - (fun i -> Array.make (Signature.arity sigs i) ([],[])) in - let () = - Mods.StringMap.iter - (fun agent_name sites -> - let id_a = Signature.num_of_agent (wdl agent_name) sigs in - Mods.StringMap.iter - (fun site_name (states,links) -> - let id_s = - Signature.num_of_site - ~agent_name (wdl site_name) (Signature.get sigs id_a) in - sol.(id_a).(id_s) <- - (List.map - (fun state -> Signature.num_of_internal_state - id_s (wdl state) (Signature.get sigs id_a)) - states, - List.map - (fun (agent_name,b) -> - let id_a = - Signature.num_of_agent (wdl agent_name) sigs in - let id_b = - Signature.num_of_site - ~agent_name (wdl b) (Signature.get sigs id_a) in - (id_a,id_b)) - links)) sites) kasa_contact_map in - sol + let wdl = Loc.annot_with_dummy in + let sol = Array.init + (Signature.size sigs) + (fun i -> Array.make (Signature.arity sigs i) ([],[])) in + let () = + Mods.StringMap.iter + (fun agent_name sites -> + let id_a = Signature.num_of_agent (wdl agent_name) sigs in + Mods.StringMap.iter + (fun site_name (states,links) -> + let id_s = + Signature.num_of_site + ~agent_name (wdl site_name) (Signature.get sigs id_a) in + sol.(id_a).(id_s) <- + (List.map + (fun state -> Signature.num_of_internal_state + id_s (wdl state) (Signature.get sigs id_a)) + states, + List.map + (fun (agent_name,b) -> + let id_a = + Signature.num_of_agent (wdl agent_name) sigs in + let id_b = + Signature.num_of_site + ~agent_name (wdl b) (Signature.get sigs id_a) in + (id_a,id_b)) + links)) sites) kasa_contact_map in + sol -let init_kasa called_from sigs result = - let pre_kasa_state = Export_to_KaSim.init ~compil:result ~called_from () in - let kasa_state,contact_map = Export_to_KaSim.get_contact_map pre_kasa_state in - let () = Export_to_KaSim.dump_errors_light kasa_state in - translate_contact_map sigs contact_map, - Export_to_KaSim.flush_errors kasa_state + let init_kasa called_from sigs result = + let pre_kasa_state = Export_to_KaSim.init ~compil:result ~called_from () in + let kasa_state,contact_map = Export_to_KaSim.get_contact_map pre_kasa_state in + let () = Export_to_KaSim.dump_errors_light kasa_state in + translate_contact_map sigs contact_map, + Export_to_KaSim.flush_errors kasa_state *) -let compile - ~outputs ~pause ~return ~sharing ~debugMode ~compileModeOn - ?overwrite_init ?overwrite_t0 ?rescale_init sigs_nd tk_nd contact_map result = - let warning ~pos msg = outputs (Data.Warning (Some pos,msg)) in +let compile ~outputs ~pause ~return ~sharing ~debug_mode ~compile_mode_on + ?overwrite_init ?overwrite_t0 ?rescale_init sigs_nd tk_nd contact_map result + = + let warning ~pos msg = outputs (Data.Warning (Some pos, msg)) in outputs (Data.Log "+ Building initial simulation conditions..."); let preenv = Pattern.PreEnv.empty sigs_nd in outputs (Data.Log "\t -variable declarations"); - let preenv',alg_a = - compile_alg_vars - ~debugMode ~compileModeOn - contact_map preenv result.Ast.variables in + let preenv', alg_a = + compile_alg_vars ~debug_mode ~compile_mode_on contact_map preenv + result.Ast.variables + in let alg_nd = NamedDecls.create alg_a in let alg_deps = Alg_expr.setup_alg_vars_rev_dep tk_nd alg_a in pause @@ fun () -> outputs (Data.Log "\t -rules"); - let (preenv',alg_deps',compiled_rules) = - compile_rules - ~debugMode ~warning alg_deps ~compileModeOn - contact_map preenv' result.Ast.rules in + let preenv', alg_deps', compiled_rules = + compile_rules ~debug_mode ~warning alg_deps ~compile_mode_on contact_map + preenv' result.Ast.rules + in let rule_nd = Array.of_list compiled_rules in pause @@ fun () -> outputs (Data.Log "\t -interventions"); - let (preenv,alg_deps'',pert,has_tracking) = - pert_of_result - ~debugMode ~warning ?overwrite_t0 result.variables result.rules alg_deps' ~compileModeOn - contact_map preenv' result in + let preenv, alg_deps'', pert, has_tracking = + pert_of_result ~debug_mode ~warning ?overwrite_t0 result.variables + result.rules alg_deps' ~compile_mode_on contact_map preenv' result + in pause @@ fun () -> outputs (Data.Log "\t -observables"); - let preenv,obs = - obs_of_result - ~debugMode ~compileModeOn contact_map preenv alg_deps result in + let preenv, obs = + obs_of_result ~debug_mode ~compile_mode_on contact_map preenv alg_deps + result + in outputs (Data.Log "\t -update_domain construction"); pause @@ fun () -> - let domain,dom_stats = - Pattern.finalize ~debugMode ~sharing preenv contact_map in - outputs (Data.Log ("\t "^string_of_int dom_stats.Pattern.PreEnv.stat_nodes^ - " (sub)observables "^ - string_of_int dom_stats.Pattern.PreEnv.stat_nav_steps^ - " navigation steps")); + let domain, dom_stats = + Pattern.finalize ~debug_mode ~sharing preenv contact_map + in + outputs + (Data.Log + ("\t " + ^ string_of_int dom_stats.Pattern.PreEnv.stat_nodes + ^ " (sub)observables " + ^ string_of_int dom_stats.Pattern.PreEnv.stat_nav_steps + ^ " navigation steps")); let env = Model.init ~filenames:result.filenames domain tk_nd alg_nd alg_deps'' - (Array.of_list result.rules,rule_nd) - (Array.of_list obs) (Array.of_list pert) contact_map in + (Array.of_list result.rules, rule_nd) + (Array.of_list obs) (Array.of_list pert) contact_map + in outputs (Data.Log "\t -initial conditions"); pause @@ fun () -> let init_l = - compile_inits - ~debugMode ~warning ?rescale:rescale_init ~compileModeOn - contact_map env (Option_util.unsome result.Ast.init overwrite_init) in - return (env,has_tracking,init_l) + compile_inits ~debug_mode ~warning ?rescale:rescale_init ~compile_mode_on + contact_map env + (Option_util.unsome result.Ast.init overwrite_init) + in + return (env, has_tracking, init_l) -let build_initial_state - ~bind ~return ~debugMode ~outputs counter env +let build_initial_state ~bind ~return ~debug_mode ~outputs counter env ~with_trace ~with_delta_activities random_state init_l = - let graph0 = Rule_interpreter.empty - ~outputs ~with_trace random_state env counter in + let graph0 = + Rule_interpreter.empty ~outputs ~with_trace random_state env counter + in let state0 = State_interpreter.empty ~with_delta_activities counter env in - State_interpreter.initialize - ~bind ~return ~debugMode ~outputs env counter graph0 state0 init_l + State_interpreter.initialize ~bind ~return ~debug_mode ~outputs env counter + graph0 state0 init_l diff --git a/core/grammar/eval.mli b/core/grammar/eval.mli index 53095cfe22..547b83b04f 100644 --- a/core/grammar/eval.mli +++ b/core/grammar/eval.mli @@ -10,45 +10,69 @@ (*val init_kasa : Remanent_parameters_sig.called_from -> Signature.s -> - (string Locality.annot * Ast.port list, Ast.mixture, string, Ast.rule) + (string Loc.annoted * Ast.port list, Ast.mixture, string, Ast.rule) Ast.compil -> Primitives.contact_map * Export_to_KaSim.state *) +val compile_bool : + debug_mode:bool -> + compile_mode_on:bool -> + ?origin:Operator.rev_dep -> + Contact_map.t -> + Pattern.PreEnv.t -> + (LKappa.rule_mixture, int) Alg_expr.bool Loc.annoted -> + Pattern.PreEnv.t * (Pattern.id array list, int) Alg_expr.bool Loc.annoted -val compile_bool: - debugMode:bool -> compileModeOn:bool -> ?origin:Operator.rev_dep -> - Contact_map.t -> Pattern.PreEnv.t -> - (LKappa.rule_mixture, int) Alg_expr.bool Locality.annot -> - Pattern.PreEnv.t * - (Pattern.id array list,int) Alg_expr.bool Locality.annot - -val compile_modifications_no_track: - debugMode:bool -> warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - compileModeOn:bool -> Contact_map.t -> Pattern.PreEnv.t -> +val compile_modifications_no_track : + debug_mode:bool -> + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + compile_mode_on:bool -> + Contact_map.t -> + Pattern.PreEnv.t -> (LKappa.rule_mixture, Raw_mixture.t, int, LKappa.rule) Ast.modif_expr list -> Pattern.PreEnv.t * Primitives.modification list -val compile_inits: - debugMode:bool -> - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - ?rescale:float -> compileModeOn:bool -> Contact_map.t -> Model.t -> - (LKappa.rule_mixture, Raw_mixture.t, int) Ast.init_statment list -> +val compile_inits : + debug_mode:bool -> + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + ?rescale:float -> + compile_mode_on:bool -> + Contact_map.t -> + Model.t -> + (LKappa.rule_mixture, Raw_mixture.t, int) Ast.init_statement list -> (Primitives.alg_expr * Primitives.elementary_rule) list val compile : - outputs:(Data.t -> unit) -> pause:((unit -> 'b) -> 'b) -> - return:(Model.t * bool (*has_tracking*) * - (Primitives.alg_expr * Primitives.elementary_rule) list -> 'b) -> - sharing:Pattern.sharing_level -> debugMode:bool -> compileModeOn:bool -> - ?overwrite_init:(LKappa.rule_mixture, Raw_mixture.t, int) Ast.init_statment list -> - ?overwrite_t0: float -> - ?rescale_init:float -> Signature.s -> unit NamedDecls.t -> Contact_map.t -> - ('c, LKappa.rule_mixture, Raw_mixture.t, int, LKappa.rule) Ast.compil -> 'b + outputs:(Data.t -> unit) -> + pause:((unit -> 'b) -> 'b) -> + return: + (Model.t + * bool (*has_tracking*) + * (Primitives.alg_expr * Primitives.elementary_rule) list -> + 'b) -> + sharing:Pattern.sharing_level -> + debug_mode:bool -> + compile_mode_on:bool -> + ?overwrite_init: + (LKappa.rule_mixture, Raw_mixture.t, int) Ast.init_statement list -> + ?overwrite_t0:float -> + ?rescale_init:float -> + Signature.s -> + unit NamedDecls.t -> + Contact_map.t -> + ('c, LKappa.rule_mixture, Raw_mixture.t, int, LKappa.rule) Ast.compil -> + 'b val build_initial_state : bind:('a -> (bool * Rule_interpreter.t * State_interpreter.t -> 'a) -> 'a) -> return:(bool * Rule_interpreter.t * State_interpreter.t -> 'a) -> - debugMode:bool -> outputs:(Data.t -> unit) -> Counter.t -> Model.t -> - with_trace:bool -> with_delta_activities:bool -> Random.State.t -> - (Primitives.alg_expr * Primitives.elementary_rule) list -> 'a + debug_mode:bool -> + outputs:(Data.t -> unit) -> + Counter.t -> + Model.t -> + with_trace:bool -> + with_delta_activities:bool -> + Random.State.t -> + (Primitives.alg_expr * Primitives.elementary_rule) list -> + 'a diff --git a/core/grammar/evaluator.ml b/core/grammar/evaluator.ml index 14de4c9892..c5c4c3cf52 100644 --- a/core/grammar/evaluator.ml +++ b/core/grammar/evaluator.ml @@ -6,83 +6,101 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -let do_interactive_directives ~debugMode ~outputs ~sharing ~syntax_version +let do_interactive_directives ~debug_mode ~outputs ~sharing ~syntax_version contact_map env counter graph state e = - let warning ~pos msg = outputs (Data.Warning (Some pos,msg)) in - let cc_preenv = - Pattern.PreEnv.of_env (Model.domain env) in + let warning ~pos msg = outputs (Data.Warning (Some pos, msg)) in + let cc_preenv = Pattern.PreEnv.of_env (Model.domain env) in let contact_map' = Array.map Array.copy contact_map in - let e',_ = + let e', _ = List_util.fold_right_map - (LKappa_compiler.modif_expr_of_ast - ~warning - ~syntax_version (Model.signatures env) (Model.tokens_finder env) - (Model.algs_finder env) contact_map') e [] in + (LKappa_compiler.modif_expr_of_ast ~warning ~syntax_version + (Model.signatures env) (Model.tokens_finder env) + (Model.algs_finder env) contact_map') + e [] + in let () = - if Tools.array_fold_lefti - (fun n -> Tools.array_fold_lefti - (fun s b x -> b || x != contact_map.(n).(s))) - false contact_map' then - raise (ExceptionDefn.Malformed_Decl - (Locality.dummy_annot "Creating new link type is forbidden")) in - let cc_preenv', e'' = Eval.compile_modifications_no_track - ~debugMode ~warning ~compileModeOn:false contact_map cc_preenv e' in - let env',graph' = - if cc_preenv == cc_preenv' then (env,graph) - else - let fenv,_ = - Pattern.finalize ~debugMode ~sharing cc_preenv' contact_map in - (Model.new_domain fenv env, - List.fold_left - (Rule_interpreter.incorporate_extra_pattern - ~debugMode fenv) - graph - (Primitives.extract_connected_components_modifications e'')) in - let (ostop,ograph,ostate,_) = - State_interpreter.do_modifications - ~debugMode ~outputs env' counter graph' state e'' in + if + Tools.array_fold_lefti + (fun n -> + Tools.array_fold_lefti (fun s b x -> b || x != contact_map.(n).(s))) + false contact_map' + then + raise + (ExceptionDefn.Malformed_Decl + (Loc.annot_with_dummy "Creating new link type is forbidden")) + in + let cc_preenv', e'' = + Eval.compile_modifications_no_track ~debug_mode ~warning + ~compile_mode_on:false contact_map cc_preenv e' + in + let env', graph' = + if cc_preenv == cc_preenv' then + env, graph + else ( + let fenv, _ = + Pattern.finalize ~debug_mode ~sharing cc_preenv' contact_map + in + ( Model.new_domain fenv env, + List.fold_left + (Rule_interpreter.incorporate_extra_pattern ~debug_mode fenv) + graph + (Primitives.extract_connected_components_modifications e'') ) + ) + in + let ostop, ograph, ostate, _ = + State_interpreter.do_modifications ~debug_mode ~outputs env' counter graph' + state e'' + in e'', (env', (ostop, ograph, ostate)) -let get_pause_criteria - ~debugMode ~outputs ~sharing ~syntax_version contact_map env graph b = - let warning ~pos msg = outputs (Data.Warning (Some pos,msg)) in - let cc_preenv = - Pattern.PreEnv.of_env (Model.domain env) in +let get_pause_criteria ~debug_mode ~outputs ~sharing ~syntax_version contact_map + env graph b = + let warning ~pos msg = outputs (Data.Warning (Some pos, msg)) in + let cc_preenv = Pattern.PreEnv.of_env (Model.domain env) in let b' = - LKappa_compiler.bool_expr_of_ast - ~warning ~syntax_version - (Model.signatures env) (Model.tokens_finder env) - (Model.algs_finder env) b in - let cc_preenv',(b'',pos_b'' as bpos'') = - Eval.compile_bool - ~debugMode ~compileModeOn:false contact_map cc_preenv b' in - let env',graph' = - if cc_preenv == cc_preenv' then (env,graph) - else - let fenv,_ = - Pattern.finalize ~debugMode ~sharing cc_preenv' contact_map in - (Model.new_domain fenv env, - List.fold_left - (Rule_interpreter.incorporate_extra_pattern ~debugMode fenv) - graph - (Primitives.extract_connected_components_bool bpos'')) in + LKappa_compiler.bool_expr_of_ast ~warning ~syntax_version + (Model.signatures env) (Model.tokens_finder env) (Model.algs_finder env) b + in + let cc_preenv', ((b'', pos_b'') as bpos'') = + Eval.compile_bool ~debug_mode ~compile_mode_on:false contact_map cc_preenv + b' + in + let env', graph' = + if cc_preenv == cc_preenv' then + env, graph + else ( + let fenv, _ = + Pattern.finalize ~debug_mode ~sharing cc_preenv' contact_map + in + ( Model.new_domain fenv env, + List.fold_left + (Rule_interpreter.incorporate_extra_pattern ~debug_mode fenv) + graph + (Primitives.extract_connected_components_bool bpos'') ) + ) + in let () = if Alg_expr.is_equality_test_time (Model.all_dependencies env) b'' then - raise (ExceptionDefn.Malformed_Decl - ("[T] can only be used in inequalities",pos_b'')) in - (env',graph',b'') + raise + (ExceptionDefn.Malformed_Decl + ("[T] can only be used in inequalities", pos_b'')) + in + env', graph', b'' -let find_all_embeddings ~debugMode env tr = +let find_all_embeddings ~debug_mode env tr = let domain = Model.domain env in let dummy_instances = Instances.empty env in - let graph = List.fold_left + let graph = + List.fold_left (Rule_interpreter.apply_concrete_positive_transformation (Model.signatures env) ?mod_connectivity_store:None dummy_instances) (Edges.empty ~with_connected_components:false) - tr in - let out,_ = - Rule_interpreter.obs_from_transformations ~debugMode domain graph tr in + tr + in + let out, _ = + Rule_interpreter.obs_from_transformations ~debug_mode domain graph tr + in List.map - (fun (p,(root,_)) -> - (p, Matching.reconstruct_renaming ~debugMode domain graph p root)) + (fun (p, (root, _)) -> + p, Matching.reconstruct_renaming ~debug_mode domain graph p root) out diff --git a/core/grammar/evaluator.mli b/core/grammar/evaluator.mli index 3ba305bc25..86e25d8a26 100644 --- a/core/grammar/evaluator.mli +++ b/core/grammar/evaluator.mli @@ -7,20 +7,32 @@ (******************************************************************************) val do_interactive_directives : - debugMode:bool -> outputs:(Data.t -> unit) -> sharing:Pattern.sharing_level -> - syntax_version:Ast.syntax_version -> Contact_map.t -> Model.t -> Counter.t -> - Rule_interpreter.t -> State_interpreter.t -> - (Ast.mixture, Ast.mixture, string,Ast.rule) Ast.modif_expr list -> - Primitives.modification list * - (Model.t * (bool * Rule_interpreter.t * State_interpreter.t)) + debug_mode:bool -> + outputs:(Data.t -> unit) -> + sharing:Pattern.sharing_level -> + syntax_version:Ast.syntax_version -> + Contact_map.t -> + Model.t -> + Counter.t -> + Rule_interpreter.t -> + State_interpreter.t -> + (Ast.mixture, Ast.mixture, string, Ast.rule) Ast.modif_expr list -> + Primitives.modification list + * (Model.t * (bool * Rule_interpreter.t * State_interpreter.t)) val get_pause_criteria : - debugMode:bool -> outputs:(Data.t -> unit) -> sharing:Pattern.sharing_level -> - syntax_version:Ast.syntax_version -> Contact_map.t -> Model.t -> - Rule_interpreter.t -> (Ast.mixture, string) Alg_expr.bool Locality.annot -> + debug_mode:bool -> + outputs:(Data.t -> unit) -> + sharing:Pattern.sharing_level -> + syntax_version:Ast.syntax_version -> + Contact_map.t -> + Model.t -> + Rule_interpreter.t -> + (Ast.mixture, string) Alg_expr.bool Loc.annoted -> Model.t * Rule_interpreter.t * (Pattern.id array list, int) Alg_expr.bool val find_all_embeddings : - debugMode:bool -> Model.t -> + debug_mode:bool -> + Model.t -> Instantiation.concrete Primitives.Transformation.t list -> (Pattern.id * Renaming.t) list diff --git a/core/grammar/kamoha_mpi.ml b/core/grammar/kamoha_mpi.ml index 21e64154fd..a5bb4541e9 100644 --- a/core/grammar/kamoha_mpi.ml +++ b/core/grammar/kamoha_mpi.ml @@ -15,17 +15,22 @@ type _ handle = | Ast : Ast.parsing_compil handle type box = - B : 'a handle * int * ('a, Result_util.message list) Result_util.t -> box + | B : 'a handle * int * ('a, Result_util.message list) Result_util.t -> box let reply post write_v id v = let message = JsonUtil.string_of_write (fun b () -> - JsonUtil.write_sequence b [ - (fun b -> Yojson.Basic.write_int b id); - (fun b -> Result_util.write_t - write_v (JsonUtil.write_list Result_util.write_message) b v); - ]) () in + JsonUtil.write_sequence b + [ + (fun b -> Yojson.Basic.write_int b id); + (fun b -> + Result_util.write_t write_v + (JsonUtil.write_list Result_util.write_message) + b v); + ]) + () + in post message let write_catalog_items = JsonUtil.write_list Kfiles.write_catalog_item @@ -33,106 +38,128 @@ let write_catalog_items = JsonUtil.write_list Kfiles.write_catalog_item let lift_answer = function | Result.Ok x -> Result_util.ok x | Result.Error text -> - Result_util.error [{Result_util.range = None; severity = Logs.Error; text}] + Result_util.error + [ { Result_util.range = None; severity = Logs.Error; text } ] let on_message yield post = let current_id = ref None in fun text -> - try - Lwt.bind - (JsonUtil.read_of_string - (JsonUtil.read_variant Yojson.Basic.read_int - (fun st b msg_id -> - let () = current_id := Some msg_id in - JsonUtil.read_next_item - (JsonUtil.read_variant Yojson.Basic.read_string - (fun st b -> function - | "FileCatalog" -> - let out = Kfiles.catalog catalog in - Lwt.return (B (Catalog, msg_id, Result_util.ok out)) - | "FileCreate" -> - let position = - JsonUtil.read_next_item Yojson.Basic.read_int st b in - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let content = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let out = - Kfiles.file_create ~position ~id ~content catalog in - Lwt.return (B (Nothing, msg_id, lift_answer out)) - | "FileGet" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let out = Kfiles.file_get ~id catalog in - Lwt.return (B (Info, msg_id, lift_answer out)) - | "FileMove" -> - let position = - JsonUtil.read_next_item Yojson.Basic.read_int st b in - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let out = Kfiles.file_move ~position ~id catalog in - Lwt.return (B (Nothing, msg_id, lift_answer out)) - | "FileUpdate" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let content = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let out = Kfiles.file_patch ~id content catalog in - Lwt.return (B (Nothing, msg_id, lift_answer out)) - | "FileDelete" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let out = Kfiles.file_delete ~id catalog in - Lwt.return (B (Nothing, msg_id, lift_answer out)) - | "ProjectParse" -> - Lwt.bind - (Kfiles.parse yield catalog) - (fun out -> Lwt.return (B (Ast, msg_id, out))) - | "ProjectOverwrite" -> - let id = - JsonUtil.read_next_item Yojson.Basic.read_string st b in - let content = - JsonUtil.read_next_item Ast.read_parsing_compil st b in - let () = Kfiles.overwrite id content catalog in - Lwt.return (B (Nothing, msg_id, Result_util.ok ())) - | x -> - Lwt.return - (B (Nothing, msg_id, - Result_util.error [{ - Result_util.severity = Logs.Error; - range = None; - text = ("Invalid directive: "^x); - }])))) - st b)) - text) - (fun answer -> - let () = current_id := None in - match answer with - | B (Catalog, msg_id, x) -> reply post write_catalog_items msg_id x - | B (Nothing, msg_id, x) -> reply post Yojson.Basic.write_null msg_id x - | B (Ast, msg_id, x) -> reply post Ast.write_parsing_compil msg_id x - | B (Info, msg_id, x) -> - reply post - (JsonUtil.write_compact_pair - Yojson.Basic.write_string Yojson.Basic.write_int) - msg_id x) - with e -> - match !current_id with - | Some msg_id -> - reply post Yojson.Basic.write_null msg_id - (Result_util.error [{Result_util.severity = Logs.Error; - range = None; - text = ("Exception raised: "^ - Printexc.to_string e);}]) - | None -> - match e with - | Yojson.Json_error x -> - post - (Yojson.to_string - (`String (x^"\nMessage format must be [ id, [\"Request\", ... ] ]"))) - | e -> - post - (Yojson.to_string - (`String ("unexpected exception: "^ - Printexc.to_string e^ - "\nMessage format must be [ id, [\"Request\", ... ] ]"))) + try + Lwt.bind + (JsonUtil.read_of_string + (JsonUtil.read_variant Yojson.Basic.read_int (fun st b msg_id -> + let () = current_id := Some msg_id in + JsonUtil.read_next_item + (JsonUtil.read_variant Yojson.Basic.read_string (fun st b -> + function + | "FileCatalog" -> + let out = Kfiles.catalog catalog in + Lwt.return (B (Catalog, msg_id, Result_util.ok out)) + | "FileCreate" -> + let position = + JsonUtil.read_next_item Yojson.Basic.read_int st b + in + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let content = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let out = + Kfiles.file_create ~position ~id ~content catalog + in + Lwt.return (B (Nothing, msg_id, lift_answer out)) + | "FileGet" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let out = Kfiles.file_get ~id catalog in + Lwt.return (B (Info, msg_id, lift_answer out)) + | "FileMove" -> + let position = + JsonUtil.read_next_item Yojson.Basic.read_int st b + in + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let out = Kfiles.file_move ~position ~id catalog in + Lwt.return (B (Nothing, msg_id, lift_answer out)) + | "FileUpdate" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let content = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let out = Kfiles.file_patch ~id content catalog in + Lwt.return (B (Nothing, msg_id, lift_answer out)) + | "FileDelete" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let out = Kfiles.file_delete ~id catalog in + Lwt.return (B (Nothing, msg_id, lift_answer out)) + | "ProjectParse" -> + Lwt.bind (Kfiles.parse yield catalog) (fun out -> + Lwt.return (B (Ast, msg_id, out))) + | "ProjectOverwrite" -> + let id = + JsonUtil.read_next_item Yojson.Basic.read_string st b + in + let content = + JsonUtil.read_next_item Ast.read_parsing_compil st b + in + let () = Kfiles.overwrite id content catalog in + Lwt.return (B (Nothing, msg_id, Result_util.ok ())) + | x -> + Lwt.return + (B + ( Nothing, + msg_id, + Result_util.error + [ + { + Result_util.severity = Logs.Error; + range = None; + text = "Invalid directive: " ^ x; + }; + ] )))) + st b)) + text) + (fun answer -> + let () = current_id := None in + match answer with + | B (Catalog, msg_id, x) -> reply post write_catalog_items msg_id x + | B (Nothing, msg_id, x) -> + reply post Yojson.Basic.write_null msg_id x + | B (Ast, msg_id, x) -> reply post Ast.write_parsing_compil msg_id x + | B (Info, msg_id, x) -> + reply post + (JsonUtil.write_compact_pair Yojson.Basic.write_string + Yojson.Basic.write_int) + msg_id x) + with e -> + (match !current_id with + | Some msg_id -> + reply post Yojson.Basic.write_null msg_id + (Result_util.error + [ + { + Result_util.severity = Logs.Error; + range = None; + text = "Exception raised: " ^ Printexc.to_string e; + }; + ]) + | None -> + (match e with + | Yojson.Json_error x -> + post + (Yojson.to_string + (`String + (x ^ "\nMessage format must be [ id, [\"Request\", ... ] ]"))) + | e -> + post + (Yojson.to_string + (`String + ("unexpected exception: " ^ Printexc.to_string e + ^ "\nMessage format must be [ id, [\"Request\", ... ] ]"))))) diff --git a/core/grammar/kamoha_mpi.mli b/core/grammar/kamoha_mpi.mli index 29b5d740d9..c5f9aa6ace 100644 --- a/core/grammar/kamoha_mpi.mli +++ b/core/grammar/kamoha_mpi.mli @@ -1,3 +1,2 @@ -val on_message: -(unit -> unit Lwt.t) -> - (string -> 'a Lwt.t) -> string -> 'a Lwt.t +val on_message : + (unit -> unit Lwt.t) -> (string -> 'a Lwt.t) -> string -> 'a Lwt.t diff --git a/core/grammar/kappaLexer.mli b/core/grammar/kappaLexer.mli index 632d2c133d..05b5cb6559 100644 --- a/core/grammar/kappaLexer.mli +++ b/core/grammar/kappaLexer.mli @@ -1,9 +1,10 @@ -val compile: +val compile : Format.formatter -> - (Ast.agent, Ast.mixture, Ast.mixture, string, Ast.rule) - Ast.compil -> string -> Ast.parsing_compil + (Ast.agent, Ast.mixture, Ast.mixture, string, Ast.rule) Ast.compil -> + string (** file *) -> + Ast.parsing_compil -val position: Lexing.lexbuf -> string * int * int -val space_chars: char list -val reset_eof: Lexing.lexbuf -> unit -val token: Lexing.lexbuf -> KappaParser.token +val position : Lexing.lexbuf -> string * int * int +val space_chars : char list +val reset_eof : Lexing.lexbuf -> unit +val token : Lexing.lexbuf -> KappaParser.token diff --git a/core/grammar/kappaLexer.mll b/core/grammar/kappaLexer.mll index 86dcb5a5ba..f6b2258ff2 100644 --- a/core/grammar/kappaLexer.mll +++ b/core/grammar/kappaLexer.mll @@ -72,7 +72,7 @@ rule token = parse raise (ExceptionDefn.Syntax_Error ("Perturbation effect \""^s^"\" is not defined", - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } | '[' blank* (id as lab) blank* ']' { @@ -102,7 +102,7 @@ rule token = parse | _ as s -> raise (ExceptionDefn.Syntax_Error ("Symbol \""^s^"\" is not defined", - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } | ':' {TYPE} @@ -115,7 +115,7 @@ rule token = parse | integer as n {try INT (int_of_string n) with Failure _ -> raise (ExceptionDefn.Syntax_Error (n^" is a incorrect integer", - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf)))} | real as f {FLOAT (float_of_string f)} @@ -150,7 +150,7 @@ rule token = parse | _ as s -> raise (ExceptionDefn.Syntax_Error ("Instruction \""^s^"\" not recognized", - Locality.of_pos + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } @@ -166,7 +166,7 @@ rule token = parse | _ as c { raise (ExceptionDefn.Syntax_Error ("invalid use of character "^ String.make 1 c, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } @@ -193,13 +193,13 @@ and inline_comment = parse | '/' '*' {inline_comment lexbuf; inline_comment lexbuf} | _ {inline_comment lexbuf} { - let compile logger compil fic = - let d = open_in fic in + let compile logger compil file = + let d = open_in file in let lexbuf = Lexing.from_channel d in - let () = lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = fic} in - let compil = { compil with Ast.filenames = fic :: compil.Ast.filenames } in + let () = lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = file} in + let compil = { compil with Ast.filenames = file :: compil.Ast.filenames } in try - let () = Format.fprintf logger "Parsing %s...@." fic in + let () = Format.fprintf logger "Parsing %s...@." file in let out = KappaParser.start_rule token lexbuf compil in let () = Format.fprintf logger "done@." in let () = close_in d in out diff --git a/core/grammar/kappaParser.mly b/core/grammar/kappaParser.mly index 651838deb3..c370ee69b4 100644 --- a/core/grammar/kappaParser.mly +++ b/core/grammar/kappaParser.mly @@ -8,9 +8,9 @@ %{ let add_pos x = - (x,Locality.of_pos (Parsing.symbol_start_pos ()) (Parsing.symbol_end_pos ())) + (x,Loc.of_pos (Parsing.symbol_start_pos ()) (Parsing.symbol_end_pos ())) let rhs_pos i = - Locality.of_pos (Parsing.rhs_start_pos i) (Parsing.rhs_end_pos i) + Loc.of_pos (Parsing.rhs_start_pos i) (Parsing.rhs_end_pos i) %} %token EOF NEWLINE SEMICOLON COMMA DOT OP_PAR CL_PAR OP_CUR CL_CUR AT TYPE LAR @@ -47,7 +47,7 @@ %type <(Ast.mixture,Ast.mixture,string,Ast.rule) Ast.modif_expr list> standalone_effect_list %start standalone_bool_expr -%type <(Ast.mixture,string) Alg_expr.bool Locality.annot> standalone_bool_expr +%type <(Ast.mixture,string) Alg_expr.bool Loc.annoted> standalone_bool_expr %% /*Grammar rules*/ @@ -402,9 +402,9 @@ rate: | alg_expr OP_PAR alg_with_radius CL_PAR { ($1,Some $3) } | alg_expr {($1,None)} | OP_CUR alg_with_radius CL_CUR - {(Locality.dummy_annot (Alg_expr.CONST Nbr.zero),Some $2)} + {(Loc.annot_with_dummy (Alg_expr.CONST Nbr.zero),Some $2)} | alg_expr OP_CUR CL_CUR - {($1,Some (Locality.dummy_annot (Alg_expr.CONST Nbr.zero),None))} + {($1,Some (Loc.annot_with_dummy (Alg_expr.CONST Nbr.zero),None))} | {raise (ExceptionDefn.Syntax_Error (add_pos "missing rule rate"))} ; @@ -421,15 +421,15 @@ pattern: non_empty_mixture: | ID OP_PAR interface_expression CL_PAR - { [[Ast.Present (($1,rhs_pos 1), $3, None)]] } + { [[Ast.Present (($1,rhs_pos 1), $3, Ast.NoMod)]] } | ID OP_PAR interface_expression CL_PAR COMMA pattern - { [Ast.Present (($1,rhs_pos 1), $3, None) :: $6]} + { [Ast.Present (($1,rhs_pos 1), $3, Ast.NoMod) :: $6]} ; mod_agent: - | { None } - | PLUS { Some Ast.Create } - | MINUS { Some Ast.Erase }; + | { Ast.NoMod } + | PLUS { Ast.Create } + | MINUS { Ast.Erase }; agent_expression: | mod_agent ID OP_PAR interface_expression CL_PAR @@ -448,50 +448,51 @@ interface_expression: counter_test: | TYPE INT { Some (Ast.CEQ $2,rhs_pos 2)} | TYPE GREATER INT { Some (Ast.CGTE $3,rhs_pos 3)} + | TYPE SMALLER INT { Some (Ast.CLTE $3,rhs_pos 3)} | TYPE ID { Some (Ast.CVAR $2,rhs_pos 2)} port_expression: | ID internal_state link_state_mod { Ast.Port - {Ast.port_nme=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_lnk=[]; - Ast.port_int_mod = None; Ast.port_lnk_mod = $3; } } + {Ast.port_name=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_link=[]; + Ast.port_int_mod = None; Ast.port_link_mod = $3; } } | ID internal_state link_state link_state_mod { Ast.Port - {Ast.port_nme=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_lnk=$3; - Ast.port_int_mod = None; Ast.port_lnk_mod = $4; } } + {Ast.port_name=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_link=$3; + Ast.port_int_mod = None; Ast.port_link_mod = $4; } } | ID internal_state DIV KAPPA_MRK link_state_mod { Ast.Port - {Ast.port_nme=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_lnk=[]; - Ast.port_int_mod = Some($4,rhs_pos 4); Ast.port_lnk_mod = $5; } } + {Ast.port_name=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_link=[]; + Ast.port_int_mod = Some($4,rhs_pos 4); Ast.port_link_mod = $5; } } | ID internal_state DIV KAPPA_MRK link_state link_state_mod { Ast.Port - {Ast.port_nme=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_lnk=$5; - Ast.port_int_mod = Some($4,rhs_pos 4); Ast.port_lnk_mod = $6; } } + {Ast.port_name=($1,rhs_pos 1); Ast.port_int=$2; Ast.port_link=$5; + Ast.port_int_mod = Some($4,rhs_pos 4); Ast.port_link_mod = $6; } } | ID PLUS EQUAL INT { Ast.Counter - { Ast.count_nme = ($1,rhs_pos 1); - Ast.count_test = None; - Ast.count_delta = ($4,rhs_pos 4)} } + { Ast.counter_name = ($1,rhs_pos 1); + Ast.counter_test = None; + Ast.counter_delta = ($4,rhs_pos 4)} } | ID PLUS EQUAL MINUS INT { Ast.Counter - { Ast.count_nme = ($1,rhs_pos 1); - Ast.count_test = None; - Ast.count_delta = (-$5,rhs_pos 5)} } + { Ast.counter_name = ($1,rhs_pos 1); + Ast.counter_test = None; + Ast.counter_delta = (-$5,rhs_pos 5)} } | ID counter_test PLUS EQUAL INT { Ast.Counter - { Ast.count_nme = ($1,rhs_pos 1); - Ast.count_test = $2; - Ast.count_delta = ($5,rhs_pos 5)} } + { Ast.counter_name = ($1,rhs_pos 1); + Ast.counter_test = $2; + Ast.counter_delta = ($5,rhs_pos 5)} } | ID counter_test PLUS EQUAL MINUS INT { Ast.Counter - { Ast.count_nme = ($1,rhs_pos 1); - Ast.count_test = $2; - Ast.count_delta = (- $6,rhs_pos 6)} } + { Ast.counter_name = ($1,rhs_pos 1); + Ast.counter_test = $2; + Ast.counter_delta = (- $6,rhs_pos 6)} } | ID counter_test { Ast.Counter - { Ast.count_nme = ($1,rhs_pos 1); - Ast.count_test = $2; - Ast.count_delta = Locality.dummy_annot 0} } + { Ast.counter_name = ($1,rhs_pos 1); + Ast.counter_test = $2; + Ast.counter_delta = Loc.annot_with_dummy 0} } ; internal_state: @@ -528,7 +529,7 @@ link_state: | a_link_state {[$1]}; interactive_command: - | RUN NEWLINE {Ast.RUN (Locality.dummy_annot Alg_expr.FALSE)} + | RUN NEWLINE {Ast.RUN (Loc.annot_with_dummy Alg_expr.FALSE)} | RUN bool_expr NEWLINE {Ast.RUN $2} | effect_list NEWLINE {Ast.MODIFY $1} | EOF {Ast.QUIT} diff --git a/core/grammar/kfiles.ml b/core/grammar/kfiles.ml index 95cbf5718c..36bbd8c2f6 100644 --- a/core/grammar/kfiles.ml +++ b/core/grammar/kfiles.ml @@ -8,21 +8,15 @@ open Lwt.Infix -type item = { - rank : int; - content : string; -} +type item = { rank: int; content: string } type catalog = { - elements : (string,item) Hashtbl.t; - index : string option Mods.DynArray.t; - ast : Ast.parsing_compil option ref; + elements: (string, item) Hashtbl.t; + index: string option Mods.DynArray.t; + ast: Ast.parsing_compil option ref; } -type catalog_item = { - position : int; - id : string; -} +type catalog_item = { position: int; id: string } let write_catalog_item ob { position; id } = let () = Buffer.add_char ob '{' in @@ -32,23 +26,29 @@ let write_catalog_item ob { position; id } = Buffer.add_char ob '}' let read_catalog_item p lb = - let (position,id,count) = + let position, id, count = Yojson.Basic.read_fields - (fun (pos,i,c) key p lb -> - if key = "position" then (Yojson.Basic.read_int p lb,i,succ c) - else let () = assert (key = "id") in - (pos,Yojson.Basic.read_string p lb,succ c)) - (-1,"",0) p lb in - let () = assert (count = 2) in { position; id } - -let create () = { - elements = Hashtbl.create 1; - index = Mods.DynArray.create 1 None; - ast = ref None; -} - -let put ~position:(rank) ~id ~content catalog = - let () = Hashtbl.replace catalog.elements id {rank; content} in + (fun (pos, i, c) key p lb -> + if key = "position" then + Yojson.Basic.read_int p lb, i, succ c + else ( + let () = assert (key = "id") in + pos, Yojson.Basic.read_string p lb, succ c + )) + (-1, "", 0) p lb + in + let () = assert (count = 2) in + { position; id } + +let create () = + { + elements = Hashtbl.create 1; + index = Mods.DynArray.create 1 None; + ast = ref None; + } + +let put ~position:rank ~id ~content catalog = + let () = Hashtbl.replace catalog.elements id { rank; content } in match Mods.DynArray.get catalog.index rank with | None -> let () = Mods.DynArray.set catalog.index rank (Some id) in @@ -56,17 +56,19 @@ let put ~position:(rank) ~id ~content catalog = Result.Ok () | Some aie -> Result.Error - ("Slot "^string_of_int rank^" is not available. There is already "^aie) + ("Slot " ^ string_of_int rank ^ " is not available. There is already " + ^ aie) let file_create ~position ~id ~content catalog = if Hashtbl.mem catalog.elements id then - Result.Error ("A file called \""^id^"\" is already present in the catalog") + Result.Error + ("A file called \"" ^ id ^ "\" is already present in the catalog") else put ~position ~id ~content catalog let file_move ~position ~id catalog = match Hashtbl.find_all catalog.elements id with - | [] -> Result.Error ("Missing file \""^id^"\" in the catalog") + | [] -> Result.Error ("Missing file \"" ^ id ^ "\" in the catalog") | _ :: _ :: _ -> Result.Error "File catalog has serious problems" | [ { rank; content } ] -> let () = Mods.DynArray.set catalog.index rank None in @@ -74,7 +76,7 @@ let file_move ~position ~id catalog = let file_patch ~id content catalog = match Hashtbl.find_all catalog.elements id with - | [] -> Result.Error ("Unknown file \""^id^"\"") + | [] -> Result.Error ("Unknown file \"" ^ id ^ "\"") | _ :: _ :: _ -> Result.Error "Serious problems in file catalog" | [ { rank; _ } ] -> let () = Hashtbl.replace catalog.elements id { rank; content } in @@ -83,26 +85,26 @@ let file_patch ~id content catalog = let file_delete ~id catalog = match Hashtbl.find_all catalog.elements id with - | [] -> Result.Error ("No file \""^id^"\"") + | [] -> Result.Error ("No file \"" ^ id ^ "\"") | _ :: _ :: _ -> failwith "Big troubles in file catalog" | [ { rank; _ } ] -> - let () = Mods.DynArray.set catalog.index rank None in - let () = Hashtbl.remove catalog.elements id in - let () = catalog.ast := None in - Result.Ok () + let () = Mods.DynArray.set catalog.index rank None in + let () = Hashtbl.remove catalog.elements id in + let () = catalog.ast := None in + Result.Ok () let file_get ~id catalog = match Hashtbl.find_all catalog.elements id with - | [] -> Result.Error ("File \""^id^"\" does not exist") + | [] -> Result.Error ("File \"" ^ id ^ "\" does not exist") | _ :: _ :: _ -> Result.Error "Corrupted file catalog" - | [ { rank; content } ] -> - Result.Ok (content,rank) + | [ { rank; content } ] -> Result.Ok (content, rank) let catalog catalog = Mods.DynArray.fold_righti - (fun position x acc -> match x with - | None -> acc - | Some id -> { position; id }::acc) + (fun position x acc -> + match x with + | None -> acc + | Some id -> { position; id } :: acc) catalog.index [] let parse yield catalog = @@ -110,57 +112,67 @@ let parse yield catalog = | Some compile -> Lwt.return (Result_util.ok compile) | None -> Mods.DynArray.fold_righti - (fun _ x acc -> match x with - | None -> acc - | Some x -> - let file = Hashtbl.find catalog.elements x in - let lexbuf = Lexing.from_string file.content in - let () = lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = x } in - acc >>= fun (compile,err) -> - let compile = - { compile with Ast.filenames = x :: compile.Ast.filenames } in - Lwt.catch - (fun () -> - (Lwt.wrap1 Klexer4.model lexbuf) >>= - (fun (insts,err') -> - (yield ()) >>= - (fun () -> - Lwt.return - (Cst.append_to_ast_compil insts compile,err'@err)))) - (function - | ExceptionDefn.Syntax_Error (message,range) - | ExceptionDefn.Malformed_Decl (message,range) - | ExceptionDefn.Internal_Error (message,range) -> - Lwt.return (compile,(message,range)::err) - | Invalid_argument error -> - Lwt.return - (compile, - (Locality.dummy_annot ("Runtime error "^ error))::err) - | exn -> - let message = Printexc.to_string exn in - Lwt.return (compile,(Locality.dummy_annot message)::err)) - ) catalog.index (Lwt.return (Ast.empty_compil,[])) >>= function + (fun _ x acc -> + match x with + | None -> acc + | Some x -> + let file = Hashtbl.find catalog.elements x in + let lexbuf = Lexing.from_string file.content in + let () = + lexbuf.Lexing.lex_curr_p <- + { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = x } + in + acc >>= fun (compile, err) -> + let compile = + { compile with Ast.filenames = x :: compile.Ast.filenames } + in + Lwt.catch + (fun () -> + Lwt.wrap1 Klexer4.model lexbuf >>= fun (insts, err') -> + yield () >>= fun () -> + Lwt.return (Cst.append_to_ast_compil insts compile, err' @ err)) + (function + | ExceptionDefn.Syntax_Error (message, range) + | ExceptionDefn.Malformed_Decl (message, range) + | ExceptionDefn.Internal_Error (message, range) -> + Lwt.return (compile, (message, range) :: err) + | Invalid_argument error -> + Lwt.return + ( compile, + Loc.annot_with_dummy ("Runtime error " ^ error) :: err ) + | exn -> + let message = Printexc.to_string exn in + Lwt.return (compile, Loc.annot_with_dummy message :: err))) + catalog.index + (Lwt.return (Ast.empty_compil, [])) + >>= ( function | compile, [] -> let () = catalog.ast := Some compile in Lwt.return (Result_util.ok compile) | _, err -> - let err = List.map - (fun (text,p as x) -> - let range = - if Locality.has_dummy_annot x then None else Some p in - {Result_util.severity = Logs.Error; range; text}) - err in - Lwt.return (Result_util.error err) + let err = + List.map + (fun ((text, p) as x) -> + let range = + if Loc.is_annoted_with_dummy x then + None + else + Some p + in + { Result_util.severity = Logs.Error; range; text }) + err + in + Lwt.return (Result_util.error err) ) let overwrite filename ast catalog = - let content = Format.asprintf "%a" Ast.print_parsing_compil_kappa ast in + let content = Format.asprintf "%a" Ast.print_parsing_compil_kappa ast in let it = { rank = 0; content } in let () = Hashtbl.reset catalog.elements in let () = Hashtbl.add catalog.elements filename it in let () = Mods.DynArray.iteri (fun i _ -> Mods.DynArray.set catalog.index i None) - catalog.index in + catalog.index + in let () = Mods.DynArray.set catalog.index 0 (Some filename) in catalog.ast := Some ast diff --git a/core/grammar/kfiles.mli b/core/grammar/kfiles.mli index 1b4cf0b37e..9ca9999113 100644 --- a/core/grammar/kfiles.mli +++ b/core/grammar/kfiles.mli @@ -7,37 +7,35 @@ (******************************************************************************) type catalog - -type catalog_item = { - position : int; - id : string; -} +type catalog_item = { position: int; id: string } val write_catalog_item : Buffer.t -> catalog_item -> unit val read_catalog_item : Yojson.lexer_state -> Lexing.lexbuf -> catalog_item - val create : unit -> catalog val file_create : - position:int -> id:string -> content:string -> catalog -> - (unit,string) Result.result + position:int -> + id:string -> + content:string -> + catalog -> + (unit, string) Result.result (** Fails if ([id] exists or) [position] is not available *) val file_move : - position:int -> id:string -> catalog -> (unit,string) Result.result + position:int -> id:string -> catalog -> (unit, string) Result.result (** Fails if [position] is not available *) -val file_patch : id:string -> string -> catalog -> (unit,string) Result.result - -val file_delete : id:string -> catalog -> (unit,string) Result.result +val file_patch : id:string -> string -> catalog -> (unit, string) Result.result +val file_delete : id:string -> catalog -> (unit, string) Result.result -val file_get : id:string -> catalog -> (string * int,string) Result.result +val file_get : id:string -> catalog -> (string * int, string) Result.result (** @return (content, position) *) val catalog : catalog -> catalog_item list val parse : - (unit -> unit Lwt.t) -> catalog -> + (unit -> unit Lwt.t) -> + catalog -> (Ast.parsing_compil, Result_util.message list) Result_util.t Lwt.t val overwrite : string -> Ast.parsing_compil -> catalog -> unit diff --git a/core/grammar/klexer4.mli b/core/grammar/klexer4.mli index 0151a779e9..45b3d89d75 100644 --- a/core/grammar/klexer4.mli +++ b/core/grammar/klexer4.mli @@ -1,5 +1,10 @@ -val model: Lexing.lexbuf -> Ast.parsing_instruction list * string Locality.annot list -val compile: Format.formatter -> - (Ast.agent, Ast.mixture, Ast.mixture, string, Ast.rule) - Ast.compil -> string -> Ast.parsing_compil -val token: Lexing.lexbuf -> Kparser4.token +val model : + Lexing.lexbuf -> Ast.parsing_instruction list * string Loc.annoted list + +val compile : + Format.formatter -> + (Ast.agent, Ast.mixture, Ast.mixture, string, Ast.rule) Ast.compil -> + string -> + Ast.parsing_compil + +val token : Lexing.lexbuf -> Kparser4.token diff --git a/core/grammar/klexer4.mll b/core/grammar/klexer4.mll index 6811d5db77..7cdb66a5bd 100644 --- a/core/grammar/klexer4.mll +++ b/core/grammar/klexer4.mll @@ -40,6 +40,7 @@ rule token = parse | "&&" { AND } | "||" { OR } | "<->" { LRAR } + | "<-" {LAR} | "->" { RAR } | "<>" { DIFF } | ':' { COLON } @@ -67,16 +68,16 @@ rule token = parse | integer as n { INT (int_of_string n) } | real as f { FLOAT (float_of_string f) } | '\'' ([^'\n' '\'']+ as x) '\''{ LABEL(x) } - | '\"' ([^'\n' '\"']+ as x) '\"'{ STRING(x) } + | '\"' ([^'\n' '\"']* as x) '\"'{ STRING(x) } | '\'' ([^'\n' '\'']+ as s) (eof | '\n') { raise (ExceptionDefn.Syntax_Error ("Unterminated label: "^s, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf)))} | '\"' ([^'\n' '\"']+ as s) (eof | '\n') { raise (ExceptionDefn.Syntax_Error ("Unterminated string: "^s, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf)))} | id as str { keyword_or_id str } | '%' (id as lab) ':' { @@ -91,7 +92,7 @@ rule token = parse | "token" -> TOKEN | _ as s -> raise (ExceptionDefn.Syntax_Error ("Unknown directive: "^s, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } | '[' blank* '?' blank* ']' { THEN } @@ -120,7 +121,7 @@ rule token = parse | "not" -> NOT | _ as s -> raise (ExceptionDefn.Syntax_Error ("Unknown primitive: "^s, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } | '$' (id as s) { @@ -140,13 +141,13 @@ rule token = parse | "SPECIES_OF" -> SPECIES_OF | s -> raise (ExceptionDefn.Syntax_Error ("Unknown intervention: "^s, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } | eof { lexbuf.Lexing.lex_eof_reached <- true; EOF } | _ as c { raise (ExceptionDefn.Syntax_Error ("Unknown character: "^String.make 1 c, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf))) } and inline_comment acc = parse @@ -164,7 +165,7 @@ and inline_comment acc = parse | (('*' | '/')? '\"' [^'\n' '\"']+ (eof | '\n')) as x { raise (ExceptionDefn.Syntax_Error ("Unterminated string in comment: "^x, - Locality.of_pos (Lexing.lexeme_start_p lexbuf) + Loc.of_pos (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf)))} | '/' '*' { inline_comment ("*/"::(inline_comment ["/*"] lexbuf):: acc) lexbuf } diff --git a/core/grammar/kparser4.mly b/core/grammar/kparser4.mly index 99f11d3e4e..3bed553a17 100644 --- a/core/grammar/kparser4.mly +++ b/core/grammar/kparser4.mly @@ -9,9 +9,9 @@ %{ let add_pos e x = (x, - Locality.of_pos (Parsing.symbol_start_pos ()) (Parsing.rhs_end_pos e)) + Loc.of_pos (Parsing.symbol_start_pos ()) (Parsing.rhs_end_pos e)) let rhs_pos i = - Locality.of_pos (Parsing.rhs_start_pos i) (Parsing.rhs_end_pos i) + Loc.of_pos (Parsing.rhs_start_pos i) (Parsing.rhs_end_pos i) let end_pos = Parsing.rhs_end_pos let start_pos = Parsing.rhs_start_pos @@ -24,7 +24,7 @@ %token EOF COMMA DOT OP_PAR CL_PAR OP_CUR CL_CUR OP_BRA CL_BRA AT SEMICOLON %token PLUS MINUS MULT DIV MOD MAX MIN SINUS COSINUS TAN POW ABS SQRT EXPONENT %token LOG OR AND NOT THEN ELSE DIFF EQUAL SMALLER GREATER TRUE FALSE INFINITY -%token SHARP UNDERSCORE PIPE RAR LRAR EMAX TMAX CPUTIME TIME EVENT NULL_EVENT +%token SHARP UNDERSCORE PIPE RAR LRAR LAR EMAX TMAX CPUTIME TIME EVENT NULL_EVENT %token COLON NEWLINE BACKSLASH SIGNATURE TOKEN INIT OBS PLOT PERT CONFIG APPLY %token DELETE INTRO SNAPSHOT STOP FLUX TRACK ASSIGN PRINTF PLOTENTRY SPECIES_OF %token DO REPEAT ALARM RUN LET @@ -44,15 +44,15 @@ <(Ast.mixture,Ast.mixture,string,Ast.rule) Ast.modif_expr list> standalone_effect_list %start standalone_bool_expr -%type <(Ast.mixture,string) Alg_expr.bool Locality.annot> standalone_bool_expr +%type <(Ast.mixture,string) Alg_expr.bool Loc.annoted> standalone_bool_expr %% -annot: +annoted: | { [] } - | NEWLINE annot { "\n"::$2 } - | SPACE annot { $1::$2 } - | COMMENT annot { $1::$2 } + | NEWLINE annoted { "\n"::$2 } + | SPACE annoted { $1::$2 } + | COMMENT annoted { $1::$2 } ; nbr: @@ -65,24 +65,24 @@ link_state: | DOT { add_pos 1 LKappa.LNK_FREE } | INT { add_pos 1 (LKappa.LNK_VALUE ($1,())) } | UNDERSCORE { add_pos 1 LKappa.LNK_SOME } - | ID annot DOT annot ID + | ID annoted DOT annoted ID { add_pos 5 (LKappa.LNK_TYPE (($1,rhs_pos 1),($5,rhs_pos 5))) } | SHARP { add_pos 1 LKappa.LNK_ANY } - | ID annot error + | ID annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "incomplete link state")) } ; link_states: - | link_state annot { [$1] } - | link_state annot link_states { $1 :: $3 } - | link_state annot COMMA annot link_states { $1 :: $5 } + | link_state annoted { [$1] } + | link_state annoted link_states { $1 :: $3 } + | link_state annoted COMMA annoted link_states { $1 :: $5 } ; link_modif: | { None } - | DIV annot DOT annot { Some None } - | DIV annot INT annot { Some (Some ($3, rhs_pos 3)) } - | DIV annot error + | DIV annoted DOT annoted { Some None } + | DIV annoted INT annoted { Some (Some ($3, rhs_pos 3)) } + | DIV annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "incomplete link modification")) } ; @@ -93,22 +93,22 @@ internal_state: ; internal_states: - | internal_state annot { [$1] } - | internal_state annot internal_states { $1 :: $3 } - | internal_state annot COMMA annot internal_states { $1 :: $5 } + | internal_state annoted { [$1] } + | internal_state annoted internal_states { $1 :: $3 } + | internal_state annoted COMMA annoted internal_states { $1 :: $5 } ; internal_modif: | { None } - | DIV annot ID annot { Some ($3, rhs_pos 3) } - | DIV annot error + | DIV annoted ID annoted { Some ($3, rhs_pos 3) } + | DIV annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "incomplete link modification")) } ; site_link: - | annot link_states link_modif CL_BRA { ($2, $3) } - | annot error + | annoted link_states link_modif CL_BRA { ($2, $3) } + | annoted error { raise (ExceptionDefn.Syntax_Error ("invalid linking state or missing ']'",rhs_pos 2)) } ; @@ -121,55 +121,56 @@ site_internal: ; counter_modif: - | PLUS annot EQUAL annot INT { ($5, rhs_pos 5) } - | PLUS annot EQUAL annot MINUS annot INT { (- $7, rhs_pos 7) } - | MINUS annot EQUAL annot INT { (- $5, rhs_pos 5) } + | PLUS annoted EQUAL annoted INT { ($5, rhs_pos 5) } + | PLUS annoted EQUAL annoted MINUS annoted INT { (- $7, rhs_pos 7) } + | MINUS annoted EQUAL annoted INT { (- $5, rhs_pos 5) } ; counter_test: - | EQUAL annot INT { (Ast.CEQ $3,rhs_pos 3) } - | GREATER annot EQUAL annot INT { (Ast.CGTE $5,rhs_pos 5) } - | EQUAL annot ID { (Ast.CVAR $3,rhs_pos 3) } + | EQUAL annoted INT { (Ast.CEQ $3,rhs_pos 3) } + | GREATER annoted EQUAL annoted INT { (Ast.CGTE $5,rhs_pos 5) } + | SMALLER annoted EQUAL annoted INT { (Ast.CLTE $5,rhs_pos 5) } + | EQUAL annoted ID { (Ast.CVAR $3,rhs_pos 3) } ; site_counter: - | counter_modif annot CL_CUR annot { (None, $1) } - | counter_test annot CL_CUR annot { (Some $1, Locality.dummy_annot 0) } - | counter_test annot DIV annot counter_modif annot CL_CUR annot + | counter_modif annoted CL_CUR annoted { (None, $1) } + | counter_test annoted CL_CUR annoted { (Some $1, Loc.annot_with_dummy 0) } + | counter_test annoted DIV annoted counter_modif annoted CL_CUR annoted { (Some $1,$5) } ; site: - | ID annot OP_BRA site_link annot OP_CUR annot site_internal annot - { let (port_lnk, port_lnk_mod) = $4 in + | ID annoted OP_BRA site_link annoted OP_CUR annoted site_internal annoted + { let (port_link, port_link_mod) = $4 in let (port_int, port_int_mod) = $8 in Ast.Port - { Ast.port_nme=($1,rhs_pos 1); Ast.port_int; - Ast.port_lnk; Ast.port_int_mod; Ast.port_lnk_mod; } } - | ID annot OP_CUR annot site_internal annot OP_BRA site_link annot + { Ast.port_name=($1,rhs_pos 1); Ast.port_int; + Ast.port_link; Ast.port_int_mod; Ast.port_link_mod; } } + | ID annoted OP_CUR annoted site_internal annoted OP_BRA site_link annoted { let (port_int, port_int_mod) = $5 in - let (port_lnk, port_lnk_mod) = $8 in + let (port_link, port_link_mod) = $8 in Ast.Port - { Ast.port_nme=($1,rhs_pos 1); Ast.port_int; - Ast.port_lnk; Ast.port_int_mod; Ast.port_lnk_mod; } } - | ID annot OP_BRA site_link annot - { let (port_lnk, port_lnk_mod) = $4 in + { Ast.port_name=($1,rhs_pos 1); Ast.port_int; + Ast.port_link; Ast.port_int_mod; Ast.port_link_mod; } } + | ID annoted OP_BRA site_link annoted + { let (port_link, port_link_mod) = $4 in Ast.Port - { Ast.port_nme=($1,rhs_pos 1); Ast.port_int=[]; - Ast.port_lnk; Ast.port_int_mod=None; Ast.port_lnk_mod; } } - | ID annot OP_CUR annot site_internal annot + { Ast.port_name=($1,rhs_pos 1); Ast.port_int=[]; + Ast.port_link; Ast.port_int_mod=None; Ast.port_link_mod; } } + | ID annoted OP_CUR annoted site_internal annoted { let (port_int, port_int_mod) = $5 in Ast.Port - { Ast.port_nme=($1,rhs_pos 1);Ast.port_lnk=[]; - Ast.port_int; Ast.port_int_mod; Ast.port_lnk_mod=None; } } - | ID annot OP_CUR annot site_counter - { let (count_test,count_delta) = $5 in + { Ast.port_name=($1,rhs_pos 1);Ast.port_link=[]; + Ast.port_int; Ast.port_int_mod; Ast.port_link_mod=None; } } + | ID annoted OP_CUR annoted site_counter + { let (counter_test,counter_delta) = $5 in Ast.Counter - { Ast.count_nme=($1,rhs_pos 1); Ast.count_test; Ast.count_delta } } - | ID annot + { Ast.counter_name=($1,rhs_pos 1); Ast.counter_test; Ast.counter_delta } } + | ID annoted { Ast.Port - { Ast.port_nme=($1,rhs_pos 1);Ast.port_lnk=[]; Ast.port_int=[]; - Ast.port_int_mod=None; Ast.port_lnk_mod=None; } } + { Ast.port_name=($1,rhs_pos 1);Ast.port_link=[]; Ast.port_int=[]; + Ast.port_int_mod=None; Ast.port_link_mod=None; } } ; interface: @@ -178,37 +179,37 @@ interface: { raise (ExceptionDefn.Syntax_Error (add_pos 1 ("Malformed site expression"))) } | site interface { $1 :: $2 } - | site COMMA annot interface { $1 :: $4 } + | site COMMA annoted interface { $1 :: $4 } ; agent_modif: - | annot { None,start_pos 1,$1 } - | annot PLUS annot { Some Ast.Create,end_pos 2,$3 } - | annot MINUS annot { Some Ast.Erase,end_pos 2,$3 } + | annoted { Ast.NoMod,start_pos 1,$1 } + | annoted PLUS annoted { Ast.Create,end_pos 2,$3 } + | annoted MINUS annoted { Ast.Erase,end_pos 2,$3 } ; agent: - | DOT annot { (Ast.Absent (rhs_pos 1),end_pos 1,$2) } - | ID annot OP_PAR annot interface CL_PAR agent_modif + | DOT annoted { (Ast.Absent (rhs_pos 1),end_pos 1,$2) } + | ID annoted OP_PAR annoted interface CL_PAR agent_modif { let modif,pend,an = $7 in (Ast.Present (($1,rhs_pos 1), $5, modif),pend,an) } - | ID annot COLON annot ID annot OP_PAR annot interface CL_PAR agent_modif + | ID annoted COLON annoted ID annoted OP_PAR annoted interface CL_PAR agent_modif { let modif,pend,an = $11 in (Ast.Present (($5,rhs_pos 5), $9, modif),pend,an) } - | ID annot error + | ID annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 ("Malformed agent '"^$1^"'"))) } ; pattern: - | agent COMMA annot pattern + | agent COMMA annoted pattern { let (x,_,_) = $1 in match $4 with | (y::z,pend,p) -> ((x::y)::z,pend,p) | ([],_,_) -> raise (ExceptionDefn.Internal_Error (add_pos 4 ("assertion failure in pattern parsing"))) } - | agent BACKSLASH annot pattern + | agent BACKSLASH annoted pattern { let (x,_,_) = $1 in let (y,pend,p) = $4 in ([x]::y,pend,p) } | agent { let (x,pend,p) = $1 in ([[x]],pend,p) } ; @@ -221,8 +222,8 @@ constant: ; variable: - | PIPE annot ID annot PIPE { add_pos 5 (Alg_expr.TOKEN_ID ($3)) } - | PIPE annot pattern PIPE + | PIPE annoted ID annoted PIPE { add_pos 5 (Alg_expr.TOKEN_ID ($3)) } + | PIPE annoted pattern PIPE { let (p,_,_) = $3 in add_pos 4 (Alg_expr.KAPPA_INSTANCE p) } | ID { add_pos 1 (Alg_expr.ALG_VAR ($1)) } | LABEL { add_pos 1 (Alg_expr.ALG_VAR ($1)) } @@ -233,86 +234,86 @@ variable: ; small_alg_expr: - | OP_PAR annot alg_expr CL_PAR { let (x,_,_) = $3 in x } + | OP_PAR annoted alg_expr CL_PAR { let (x,_,_) = $3 in x } | constant { $1 } | variable { $1 } - | MAX annot small_alg_expr annot small_alg_expr + | MAX annoted small_alg_expr annoted small_alg_expr { add_pos 5 (Alg_expr.BIN_ALG_OP(Operator.MAX,$3,$5)) } - | MIN annot small_alg_expr annot small_alg_expr + | MIN annoted small_alg_expr annoted small_alg_expr { add_pos 5 (Alg_expr.BIN_ALG_OP(Operator.MIN,$3,$5)) } - | EXPONENT annot small_alg_expr + | EXPONENT annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.EXP,$3)) } - | SINUS annot small_alg_expr + | SINUS annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.SINUS,$3)) } - | COSINUS annot small_alg_expr + | COSINUS annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.COSINUS,$3)) } - | TAN annot small_alg_expr + | TAN annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.TAN,$3)) } - | ABS annot small_alg_expr + | ABS annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.INT,$3)) } - | SQRT annot small_alg_expr + | SQRT annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.SQRT,$3)) } - | LOG annot small_alg_expr + | LOG annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.LOG,$3)) } - | MINUS annot small_alg_expr + | MINUS annoted small_alg_expr { add_pos 3 (Alg_expr.UN_ALG_OP(Operator.UMINUS,$3)) } ; alg_expr_up_to_mod: - | small_alg_expr annot { ($1,end_pos 1,$2) } - | small_alg_expr annot POW annot alg_expr_up_to_mod + | small_alg_expr annoted { ($1,end_pos 1,$2) } + | small_alg_expr annoted POW annoted alg_expr_up_to_mod { let (x,y,z) = $5 in (add_pos 4 (Alg_expr.BIN_ALG_OP(Operator.POW,$1,x)),y,z) } ; alg_expr_up_to_prod: | alg_expr_up_to_mod { $1 } - | alg_expr_up_to_prod MOD annot alg_expr_up_to_mod + | alg_expr_up_to_prod MOD annoted alg_expr_up_to_mod { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.BIN_ALG_OP (Operator.MODULO,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } ; alg_expr_up_to_sum: | alg_expr_up_to_prod { $1 } - | alg_expr_up_to_sum MULT annot alg_expr_up_to_prod + | alg_expr_up_to_sum MULT annoted alg_expr_up_to_prod { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.BIN_ALG_OP(Operator.MULT,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } - | alg_expr_up_to_sum DIV annot alg_expr_up_to_prod + | alg_expr_up_to_sum DIV annoted alg_expr_up_to_prod { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.BIN_ALG_OP(Operator.DIV,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } ; alg_expr_up_to_if: | alg_expr_up_to_sum { $1 } - | alg_expr_up_to_if PLUS annot alg_expr_up_to_sum + | alg_expr_up_to_if PLUS annoted alg_expr_up_to_sum { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.BIN_ALG_OP(Operator.SUM,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } - | alg_expr_up_to_if MINUS annot alg_expr_up_to_sum + | alg_expr_up_to_if MINUS annoted alg_expr_up_to_sum { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.BIN_ALG_OP(Operator.MINUS,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } alg_expr: | alg_expr_up_to_if { $1 } - | bool_expr THEN annot alg_expr ELSE annot small_alg_expr annot + | bool_expr THEN annoted alg_expr ELSE annoted small_alg_expr annoted { let (i,_,_) = $1 in let (t,_,_) = $4 in ((Alg_expr.IF(i,t,$7), - Locality.of_pos (start_pos 1) (end_pos 7)),end_pos 7,$8) } + Loc.of_pos (start_pos 1) (end_pos 7)),end_pos 7,$8) } ; boolean: @@ -321,64 +322,64 @@ boolean: ; small_bool_expr: - | OP_PAR annot bool_expr CL_PAR { let (x,_,_) = $3 in x } + | OP_PAR annoted bool_expr CL_PAR { let (x,_,_) = $3 in x } | TRUE { add_pos 1 Alg_expr.TRUE } | FALSE { add_pos 1 Alg_expr.FALSE } - | NOT annot small_bool_expr + | NOT annoted small_bool_expr { add_pos 3 (Alg_expr.UN_BOOL_OP(Operator.NOT,$3)) } ; bool_expr_comp: - | small_bool_expr annot { ($1,end_pos 1, $2) } - | alg_expr_up_to_if GREATER annot alg_expr + | small_bool_expr annoted { ($1,end_pos 1, $2) } + | alg_expr_up_to_if GREATER annoted alg_expr { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.COMPARE_OP(Operator.GREATER,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } - | alg_expr_up_to_if SMALLER annot alg_expr + | alg_expr_up_to_if SMALLER annoted alg_expr { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.COMPARE_OP(Operator.SMALLER,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } - | alg_expr_up_to_if EQUAL annot alg_expr + | alg_expr_up_to_if EQUAL annoted alg_expr { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.COMPARE_OP(Operator.EQUAL,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } - | alg_expr_up_to_if DIFF annot alg_expr + | alg_expr_up_to_if DIFF annoted alg_expr { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.COMPARE_OP(Operator.DIFF,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } ; bool_expr_no_or: | bool_expr_comp { $1 } - | bool_expr_comp AND annot bool_expr_no_or + | bool_expr_comp AND annoted bool_expr_no_or { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.BIN_BOOL_OP(Operator.AND,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } ; bool_expr: | bool_expr_no_or { $1 } - | bool_expr_no_or OR annot bool_expr + | bool_expr_no_or OR annoted bool_expr { let (y,pend,an) = $4 in let (x,_,_) = $1 in ((Alg_expr.BIN_BOOL_OP(Operator.OR,x,y), - Locality.of_pos (start_pos 1) pend), + Loc.of_pos (start_pos 1) pend), pend,an) } ; standalone_bool_expr: - | annot bool_expr EOF { let (x,_,_) = $2 in x } - | annot error + | annoted bool_expr EOF { let (x,_,_) = $2 in x } + | annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 2 "Problematic boolean expression")) } ; @@ -389,36 +390,36 @@ arrow: ; sum_token: - | small_alg_expr annot ID annot { [($1,($3,rhs_pos 3))],end_pos 3,$4 } - | small_alg_expr annot ID annot COMMA annot sum_token + | small_alg_expr annoted ID annoted { [($1,($3,rhs_pos 3))],end_pos 3,$4 } + | small_alg_expr annoted ID annoted COMMA annoted sum_token { let (l,pend,an) = $7 in ($1,($3,rhs_pos 3)) :: l,pend,an } ; rule_side: | pattern { let (p,pend,an) = $1 in (p,[],pend,an) } - | pattern PIPE annot sum_token + | pattern PIPE annoted sum_token { let (p,_,_) = $1 in let (t,pend,an) = $4 in (p, t, pend, an) } - | PIPE annot sum_token { let (t,pend,an) = $3 in ([], t, pend, an) } - | pattern PIPE annot error + | PIPE annoted sum_token { let (t,pend,an) = $3 in ([], t, pend, an) } + | pattern PIPE annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 4 "Malformed token expression, I was expecting a_0 t_0, ... \ , a_n t_n where t_i are tokens and a_i any algebraic formula")) } - | PIPE annot error + | PIPE annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "Malformed token expression, I was expecting a_0 t_0, ... \ , a_n t_n where t_i are tokens and a_i any algebraic formula")) } ; rule_content: - | rule_side arrow annot rule_side + | rule_side arrow annoted rule_side { let (lhs,rm_token,_,_) = $1 in let (rhs,add_token,pend,an) = $4 in (Ast.Arrow {Ast.lhs; Ast.rm_token; Ast.rhs; Ast.add_token},$2,pend,an) } - | rule_side arrow annot + | rule_side arrow annoted { let (lhs,rm_token,_,_) = $1 in (Ast.Arrow {Ast.lhs; Ast.rm_token; Ast.rhs=[]; Ast.add_token=[]},$2,end_pos 2,$3) } - | arrow annot rule_side + | arrow annoted rule_side { let (rhs,add_token,pend,an) = $3 in (Ast.Arrow {Ast.lhs=[]; Ast.rm_token=[]; Ast.rhs; Ast.add_token},$1,pend,an) } | rule_side @@ -428,21 +429,21 @@ rule_content: alg_with_radius: | alg_expr { let (x,_,_) = $1 in (x,None) } - | alg_expr COLON annot alg_expr + | alg_expr COLON annoted alg_expr { let (x,_,_) = $1 in let (y,_,_) = $4 in (x, Some y) } ; rate: - | OP_CUR annot alg_with_radius CL_CUR annot alg_expr + | OP_CUR annoted alg_with_radius CL_CUR annoted alg_expr { let (b,pend,an) = $6 in (b,Some $3,pend,an) } - | alg_expr OP_CUR annot alg_with_radius CL_CUR annot + | alg_expr OP_CUR annoted alg_with_radius CL_CUR annoted { let (x,_,_) = $1 in (x,Some $4,end_pos 5,$6) } | alg_expr { let (a,pend,an) = $1 in (a,None,pend,an) } ; birate: - | AT annot rate { let (k2,k1,pend,an) = $3 in (k2,k1,None,None,pend,an) } - | AT annot rate COMMA annot rate + | AT annoted rate { let (k2,k1,pend,an) = $3 in (k2,k1,None,None,pend,an) } + | AT annoted rate COMMA annoted rate { let (k2,k1,_,_) = $3 in let (kback,kback1,pend,an) = $6 in (k2,k1,Some kback,kback1,pend,an) } @@ -455,18 +456,18 @@ rule: ({ Ast.rewrite;Ast.bidirectional; Ast.k_def; Ast.k_un; Ast.k_op; Ast.k_op_un; - },Locality.of_pos (start_pos 1) pos_end) } + },Loc.of_pos (start_pos 1) pos_end) } | rule_content error { raise (ExceptionDefn.Syntax_Error (add_pos 2 "rule rate expected")) } ; variable_declaration: - | LABEL annot alg_expr { let (v,pend,an) = $3 in (($1,rhs_pos 1),v,pend,an) } - | ID annot alg_expr { let (v,pend,an) = $3 in (($1,rhs_pos 1),v,pend,an) } - | LABEL annot error + | LABEL annoted alg_expr { let (v,pend,an) = $3 in (($1,rhs_pos 1),v,pend,an) } + | ID annoted alg_expr { let (v,pend,an) = $3 in (($1,rhs_pos 1),v,pend,an) } + | LABEL annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 ("Illegal definition of variable '"^$1^"'"))) } - | ID annot error + | ID annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 ("Illegal definition of variable '"^$1^"'"))) } | error @@ -474,74 +475,76 @@ variable_declaration: ; id_list: - | ID annot { [ $1,rhs_pos 1 ] } - | ID annot COMMA annot id_list { ($1,rhs_pos 1) :: $5 } + | ID annoted { [ $1,rhs_pos 1 ] } + | ID annoted COMMA annoted id_list { ($1,rhs_pos 1) :: $5 } ; init_declaration: | alg_expr pattern { let (v,_,_) = $1 in let (p,pend,_) = $2 in - (v,Ast.INIT_MIX (p,Locality.of_pos (start_pos 2) pend)) } - | alg_expr OP_PAR annot pattern CL_PAR annot + (v,Ast.INIT_MIX (p,Loc.of_pos (start_pos 2) pend)) } + | alg_expr OP_PAR annoted pattern CL_PAR annoted { let (v,_,_) = $1 in let (p,pend,_) = $4 in - (v,Ast.INIT_MIX (p,Locality.of_pos (start_pos 4) pend)) } + (v,Ast.INIT_MIX (p,Loc.of_pos (start_pos 4) pend)) } | alg_expr id_list { let (v,_,_) = $1 in (v,Ast.INIT_TOK $2) } /* - | ID annot OP_CUR annot init_declaration CL_CUR annot + | ID annoted OP_CUR annoted init_declaration CL_CUR annoted { let (_,alg,init) = $5 in (Some ($1,rhs_pos 1),alg,init) } */ + | ID LAR annoted alg_expr + { let (v,_,_) = $4 in (v,Ast.INIT_TOK [$1,rhs_pos 1])} | error { raise (ExceptionDefn.Syntax_Error (add_pos 1 "Malformed initial condition")) } ; value_list: - | STRING annot {[$1, rhs_pos 1]} - | STRING annot value_list {($1,rhs_pos 1)::$3} + | STRING annoted {[$1, rhs_pos 1]} + | STRING annoted value_list {($1,rhs_pos 1)::$3} ; nonempty_print_expr: - | STRING annot + | STRING annoted { ([Primitives.Str_pexpr (add_pos 1 $1)],end_pos 1,$2) } | alg_expr_up_to_if { let (a,pend,p) = $1 in ([Primitives.Alg_pexpr a],pend,p) } | print_expr_list { $1 } - | OP_PAR annot print_expr_list CL_PAR annot + | OP_PAR annoted print_expr_list CL_PAR annoted { let (v,_,an) = $3 in (v,end_pos 4,an @ $5) } ; print_expr_list: - | STRING annot DOT annot nonempty_print_expr + | STRING annoted DOT annoted nonempty_print_expr { let (l,pend,p) = $5 in (Primitives.Str_pexpr ($1, rhs_pos 1)::l,pend,p) } - | alg_expr_up_to_if DOT annot nonempty_print_expr + | alg_expr_up_to_if DOT annoted nonempty_print_expr { let (l,pend,p) = $4 in let (v,_,_) = $1 in (Primitives.Alg_pexpr v::l,pend,p) } ; print_expr: - | annot { ([],start_pos 1,$1) } - | annot nonempty_print_expr { $2 } + | annoted { ([],start_pos 1,$1) } + | annoted nonempty_print_expr { $2 } ; effect: - | ASSIGN annot ID annot alg_expr + | ASSIGN annoted ID annoted alg_expr { let (a,pend,p) = $5 in (Ast.UPDATE (($3,rhs_pos 3),a),pend,p) } - | ASSIGN annot LABEL annot alg_expr + | ASSIGN annoted LABEL annoted alg_expr { let (a,pend,p) = $5 in (Ast.UPDATE (($3,rhs_pos 3),a),pend,p) } - | TRACK annot LABEL annot boolean annot + | TRACK annoted LABEL annoted boolean annoted { (Ast.CFLOWLABEL ($5,($3,rhs_pos 3)),end_pos 5,$6) } - | TRACK annot pattern boolean annot + | TRACK annoted pattern boolean annoted { let (pat,epat,_) = $3 in - (Ast.CFLOWMIX ($4,(pat,Locality.of_pos (start_pos 3) epat)),end_pos 4, $5) } - | FLUX annot nonempty_print_expr boolean annot + (Ast.CFLOWMIX ($4,(pat,Loc.of_pos (start_pos 3) epat)),end_pos 4, $5) } + | FLUX annoted nonempty_print_expr boolean annoted { let (p,_,_) = $3 in ((if $4 then Ast.DIN (Primitives.RELATIVE,p) else Ast.DINOFF p), end_pos 4,$5) } - | FLUX annot nonempty_print_expr STRING annot boolean annot + | FLUX annoted nonempty_print_expr STRING annoted boolean annoted { let (p,_,_) = $3 in if $6 && $4 = "absolute" then (Ast.DIN (Primitives.ABSOLUTE,p),end_pos 6,$7) @@ -551,17 +554,17 @@ effect: (Ast.DIN (Primitives.RELATIVE,p),end_pos 6,$7) else raise (ExceptionDefn.Syntax_Error ("Incorrect DIN expression",rhs_pos 4)) } - | APPLY annot alg_expr rule_content + | APPLY annoted alg_expr rule_content { let (rewrite,_,pend,an) = $4 in let (v,_,_) = $3 in Ast.APPLY(v, ({ Ast.rewrite; Ast.bidirectional = false; Ast.k_def=Alg_expr.const Nbr.zero;Ast.k_un=None; Ast.k_op=None; Ast.k_op_un=None}, - Locality.of_pos (start_pos 3) pend)), + Loc.of_pos (start_pos 3) pend)), pend,an } - | INTRO annot alg_expr pattern + | INTRO annoted alg_expr pattern { let (m,pend,p) = $4 in let (v,_,_) = $3 in (Ast.APPLY(v, @@ -571,13 +574,13 @@ effect: Ast.bidirectional=false; Ast.k_def=Alg_expr.const Nbr.zero; Ast.k_un=None; Ast.k_op=None; Ast.k_op_un=None}, - Locality.of_pos (start_pos 4) pend)), + Loc.of_pos (start_pos 4) pend)), pend,p) } - | INTRO annot error + | INTRO annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "Malformed intervention instruction, I was expecting \ '$ADD alg_expression kappa_expression'")) } - | DELETE annot alg_expr pattern + | DELETE annoted alg_expr pattern { let (m,pend,p) = $4 in let (v,_,_) = $3 in (Ast.APPLY(v, @@ -587,92 +590,142 @@ effect: Ast.bidirectional=false; Ast.k_def=Alg_expr.const Nbr.zero; Ast.k_un=None; Ast.k_op=None; Ast.k_op_un=None}, - Locality.of_pos (start_pos 4) pend)), + Loc.of_pos (start_pos 4) pend)), pend,p) } - | DELETE annot error + | DELETE annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "Malformed intervention instruction, I was \ expecting '$DEL alg_expression kappa_expression'")) } | SNAPSHOT print_expr { let (s,pend,p) = $2 in (Ast.SNAPSHOT (false,s),pend,p) } - | SNAPSHOT print_expr boolean annot { let (s,_,_) = $2 in (Ast.SNAPSHOT ($3,s),end_pos 3,$4) } + | SNAPSHOT print_expr boolean annoted { let (s,_,_) = $2 in (Ast.SNAPSHOT ($3,s),end_pos 3,$4) } | STOP print_expr { let (s,pend,p) = $2 in (Ast.STOP s,pend,p) } | PRINTF print_expr GREATER print_expr { let (f,pend,p) = $4 in let (c,_,_) = $2 in (Ast.PRINT (f,c),pend,p) } | PRINTF print_expr { let (c,pend,p) = $2 in (Ast.PRINT ([],c),pend,p) } - | PLOTENTRY annot { (Ast.PLOTENTRY,end_pos 1,$2) } - | SPECIES_OF annot pattern boolean annot GREATER print_expr + | PLOTENTRY annoted { (Ast.PLOTENTRY,end_pos 1,$2) } + | SPECIES_OF annoted pattern boolean annoted GREATER print_expr { let (file,pend,p) = $7 in let (pat,pendp,_) = $3 in - (Ast.SPECIES_OF ($4,file,(pat, Locality.of_pos (start_pos 3) pendp)), + (Ast.SPECIES_OF ($4,file,(pat, Loc.of_pos (start_pos 3) pendp)), pend,p) } ; +idin: +| ID annoted LAR annoted alg_expr { + let (v,pend,p) = $5 in + let tk = ($1,rhs_pos 1) in + (Ast.APPLY(Alg_expr.const Nbr.one, + ({Ast.rewrite = + Ast.Edit + {Ast.mix=[]; + Ast.delta_token = + [(Alg_expr.BIN_ALG_OP(Operator.MINUS,v,(Alg_expr.TOKEN_ID $1,rhs_pos 1)),rhs_pos 1),tk]; + }; + Ast.bidirectional=false; + Ast.k_def=Alg_expr.const Nbr.zero; Ast.k_un=None; + Ast.k_op=None; Ast.k_op_un=None}, Loc.of_pos (start_pos 4) pend)),pend,p) + } +| ID annoted LAR error + { raise (ExceptionDefn.Syntax_Error + (add_pos 3 "Malformed intervention instruction, I was \ +expecting 'ID <- alg_expression'")) } +| ID error + { raise (ExceptionDefn.Syntax_Error + (add_pos 2 "Malformed intervention instruction, I was \ + expecting 'ID <- alg_expression'")) }; +; + +effect_or_idin: + | effect {$1} + | idin {$1} + partial_effect_list: - | effect SEMICOLON annot { let (e,_,_) = $1 in ([e],end_pos 2,$3) } - | effect { let (e,p,a) = $1 in ([e],p,a) } - | effect SEMICOLON annot partial_effect_list + | OP_PAR annoted partial_effect_list CL_PAR annoted { $3 } + | effect_or_idin SEMICOLON annoted { let (e,_,_) = $1 in ([e],end_pos 2,$3) } + | effect_or_idin { let (e,p,a) = $1 in ([e],p,a) } + | effect_or_idin SEMICOLON annoted partial_effect_list { let (e,_,_) = $1 in let (l,pend,a) = $4 in (e::l,pend,a) } +partial_effect_list_at_least_one_idin: + | idin SEMICOLON annoted { let (e,_,_) = $1 in ([e],end_pos 2,$3) } + | idin { let (e,p,a) = $1 in ([e],p,a) } + | idin SEMICOLON annoted partial_effect_list + { let (e,_,_) = $1 in let (l,pend,a) = $4 in (e::l,pend,a) } + effect_list: - | OP_PAR annot partial_effect_list CL_PAR annot { $3 } - | effect SEMICOLON annot { let (e,_,_) = $1 in ([e],end_pos 2,$3) } - | effect SEMICOLON annot effect_list + | OP_PAR annoted partial_effect_list CL_PAR annoted { $3 } + | OP_PAR annoted partial_effect_list CL_PAR annoted SEMICOLON annoted {let (e,_,_) = $3 in e,end_pos 6,$7 } + | effect SEMICOLON annoted { let (e,_,_) = $1 in ([e],end_pos 2,$3) } + | effect SEMICOLON annoted effect_list { let (e,_,_) = $1 in let (l,pend,a) = $4 in (e::l,pend,a) } ; standalone_effect_list: - | annot partial_effect_list EOF { let (e,_,_) = $2 in e } + | annoted partial_effect_list EOF { let (e,_,_) = $2 in e } | error { raise (ExceptionDefn.Syntax_Error (add_pos 1 "Problematic effect list")) } ; perturbation_alarm: - | annot { None } - | annot ALARM annot nbr annot { Some $4 } - | annot ALARM error + | annoted { None } + | annoted ALARM annoted nbr annoted { Some $4 } + | annoted ALARM error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "alarm takes a number as argument")) } ; +perturbation_post_closed: + | REPEAT annoted bool_expr { let (b,pend,p) = $3 in (Some b,pend,p) } + perturbation_post: | { (None, Parsing.symbol_start_pos (),[]) } - | REPEAT annot bool_expr { let (b,pend,p) = $3 in (Some b,pend,p) } + | perturbation_post_closed {$1} ; perturbation_declaration: - | perturbation_alarm bool_expr DO annot effect_list perturbation_post + | perturbation_alarm bool_expr DO annoted effect_list perturbation_post { let (pre,_,_) = $2 in let (e,_,_) = $5 in let (post,_,_) = $6 in ($1,Some pre,e,post) } - | perturbation_alarm DO annot effect_list perturbation_post + | perturbation_alarm DO annoted effect_list perturbation_post { let (e,_,_) = $4 in let (post,_,_) = $5 in ($1,None,e,post) } + + | perturbation_alarm bool_expr DO annoted partial_effect_list_at_least_one_idin perturbation_post_closed + { let (pre,_,_) = $2 in + let (e,_,_) = $5 in + let (post,_,_) = $6 in + ($1,Some pre,e,post) } + | perturbation_alarm DO annoted partial_effect_list_at_least_one_idin perturbation_post_closed + { let (e,_,_) = $4 in + let (post,_,_) = $5 in + ($1,None,e,post) } ; sentence: - | LABEL annot rule + | LABEL annoted rule { add (Ast.RULE(Some ($1, rhs_pos 1),$3)) } - | LABEL annot EQUAL annot alg_expr + | LABEL annoted EQUAL annoted alg_expr { let (v,_,_) = $5 in add (Ast.DECLARE (($1,rhs_pos 1),v)) } | rule { add (Ast.RULE (None,$1)) } - | SIGNATURE annot agent { let (a,_,_) = $3 in add (Ast.SIG a) } - | SIGNATURE annot error + | SIGNATURE annoted agent { let (a,_,_) = $3 in add (Ast.SIG a) } + | SIGNATURE annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "Malformed agent signature")) } - | TOKEN annot ID annot { add (Ast.TOKENSIG ($3,rhs_pos 3)) } - | PLOT annot alg_expr { let (v,_,_) = $3 in add (Ast.PLOT v) } - | PLOT annot error + | TOKEN annoted ID annoted { add (Ast.TOKENSIG ($3,rhs_pos 3)) } + | PLOT annoted alg_expr { let (v,_,_) = $3 in add (Ast.PLOT v) } + | PLOT annoted error { raise (ExceptionDefn.Syntax_Error (add_pos 3 "Malformed plot instruction, \ an algebraic expression is expected")) } - | LET annot variable_declaration + | LET annoted variable_declaration { let (i,v,_,_) = $3 in add (Ast.DECLARE (i,v)) } - | OBS annot variable_declaration { let (i,v,_,_) = $3 in add (Ast.OBS (i,v)) } - | INIT annot init_declaration + | OBS annoted variable_declaration { let (i,v,_,_) = $3 in add (Ast.OBS (i,v)) } + | INIT annoted init_declaration { let (alg,init) = $3 in add (Ast.INIT (alg,init)) } | PERT perturbation_declaration { add (Ast.PERT ($2, rhs_pos 2)) } - | CONFIG annot STRING annot value_list + | CONFIG annoted STRING annoted value_list { add (Ast.CONFIG (($3,rhs_pos 3),$5)) } ; @@ -682,17 +735,17 @@ model_body: ; model: - | annot model_body { $2 } + | annoted model_body { $2 } | error { raise (ExceptionDefn.Syntax_Error - (add_pos 1 "Incorrect beginning of sentence")) } + (add_pos 1 "Incorrect beginning of sentence !!!")) } ; interactive_command: - | annot RUN annot SEMICOLON { Ast.RUN (Locality.dummy_annot Alg_expr.FALSE) } - | annot RUN annot bool_expr SEMICOLON { let (pause,_,_) = $4 in Ast.RUN pause } - | annot effect SEMICOLON { let (eff,_,_) = $2 in Ast.MODIFY [eff] } - | annot EOF { Ast.QUIT } + | annoted RUN annoted SEMICOLON { Ast.RUN (Loc.annot_with_dummy Alg_expr.FALSE) } + | annoted RUN annoted bool_expr SEMICOLON { let (pause,_,_) = $4 in Ast.RUN pause } + | annoted effect SEMICOLON { let (eff,_,_) = $2 in Ast.MODIFY [eff] } + | annoted EOF { Ast.QUIT } | error { raise (ExceptionDefn.Syntax_Error (add_pos 1 "Unrecognized command")) } ; diff --git a/core/grammar/lKappa_compiler.ml b/core/grammar/lKappa_compiler.ml index 8ad1be5747..f6631c9265 100644 --- a/core/grammar/lKappa_compiler.ml +++ b/core/grammar/lKappa_compiler.ml @@ -6,649 +6,853 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) +(* TODO originally_from term/lKappa.ml, see if it makes sense here *) +let raise_if_modification_agent (pos : Loc.t) = function + | Ast.NoMod -> () + | Ast.Erase | Ast.Create -> + raise + (ExceptionDefn.Malformed_Decl ("A modification is forbidden here.", pos)) + let build_l_type sigs pos dst_ty dst_p switch = let ty_id = Signature.num_of_agent dst_ty sigs in let p_id = Signature.id_of_site dst_ty dst_p sigs in - ((LKappa.LNK_TYPE (p_id,ty_id),pos),switch) + (LKappa.LNK_TYPE (p_id, ty_id), pos), switch let add_link_contact_map ?contact_map sty sp dty dp = match contact_map with | None -> () | Some contact_map -> let si, sl = contact_map.(sty).(sp) in - let di,dl = contact_map.(dty).(dp) in - let () = contact_map.(sty).(sp) <- - si, Mods.Int2Set.add (dty,dp) sl in - contact_map.(dty).(dp) <- - di, Mods.Int2Set.add (sty,sp) dl + let di, dl = contact_map.(dty).(dp) in + let () = contact_map.(sty).(sp) <- si, Mods.Int2Set.add (dty, dp) sl in + contact_map.(dty).(dp) <- di, Mods.Int2Set.add (sty, sp) dl let rule_induces_link_permutation ~warning ~pos ?dst_ty sigs sort site = let warning_for_counters = - if Signature.is_counter_agent sigs sort then true - else - match dst_ty with - | None -> false - | Some s -> Signature.is_counter_agent sigs s in - - if not(warning_for_counters) then - warning - ~pos - (fun f -> - Format.fprintf - f "rule induces a link permutation on site '%a' of agent '%a'" - (Signature.print_site sigs sort) site - (Signature.print_agent sigs) sort) - -let build_link - ?warn_on_swap sigs ?contact_map pos i ag_ty p_id switch - (links_one,links_two) = + if Signature.is_counter_agent sigs sort then + true + else ( + match dst_ty with + | None -> false + | Some s -> Signature.is_counter_agent sigs s + ) + in + + if not warning_for_counters then + warning ~pos (fun f -> + Format.fprintf f + "rule induces a link permutation on site '%a' of agent '%a'" + (Signature.print_site sigs sort) + site + (Signature.print_agent sigs) + sort) + +let site_should_made_be_free i sigs ag_ty p_id pos = + LKappa.raise_link_should_be_removed i + (let () = + Format.fprintf Format.str_formatter "%a" + (Signature.print_agent sigs) + ag_ty + in + Format.flush_str_formatter ()) + ( (let () = + Format.fprintf Format.str_formatter "%a" + (Signature.print_site sigs ag_ty) + p_id + in + Format.flush_str_formatter ()), + pos ) + +let build_link ?warn_on_swap sigs ?contact_map pos i ag_ty p_id switch + (links_one, links_two) = if Mods.IntMap.mem i links_two then - raise (ExceptionDefn.Malformed_Decl - ("This is the third occurence of link '"^string_of_int i - ^"' in the same mixture.",pos)) - else match Mods.IntMap.pop i links_one with - | None,one' -> - let new_link = match switch with + raise + (ExceptionDefn.Malformed_Decl + ( "This is the third occurence of link '" ^ string_of_int i + ^ "' in the same mixture.", + pos )) + else ( + match Mods.IntMap.pop i links_one with + | None, one' -> + let new_link = + match switch with | LKappa.Linked j -> Some j - | LKappa.Freed | LKappa.Erased | LKappa.Maintained -> None in - ((LKappa.LNK_VALUE (i,(-1,-1)),pos),switch), - (Mods.IntMap.add i (ag_ty,p_id,new_link,pos) one',links_two) - | Some (dst_ty,dst_p,dst_id,_),one' -> - if Signature.allowed_link ag_ty p_id dst_ty dst_p sigs then + | LKappa.Freed | LKappa.Erased | LKappa.Maintained -> None + in + ( ((LKappa.LNK_VALUE (i, (-1, -1)), pos), switch), + (Mods.IntMap.add i (ag_ty, p_id, new_link, pos, switch) one', links_two) + ) + | Some (dst_ty, dst_p, dst_id, pos', switch'), one' -> + if Signature.allowed_link ag_ty p_id dst_ty dst_p sigs then ( let () = add_link_contact_map ?contact_map ag_ty p_id dst_ty dst_p in - let maintained = match switch with + let maintained = + match switch with | LKappa.Linked j -> - let link_swap = (Some j <> dst_id) in - let () = - if link_swap then - match warn_on_swap with - | None -> () - | Some warning -> - rule_induces_link_permutation - ~warning ~pos ~dst_ty sigs ag_ty p_id in - not(link_swap) - | LKappa.Freed | LKappa.Erased | LKappa.Maintained -> false in - ((LKappa.LNK_VALUE (i,(dst_p,dst_ty)),pos), - if maintained then LKappa.Maintained else switch), - (one',Mods.IntMap.add i (ag_ty,p_id,maintained) links_two) - else - raise (ExceptionDefn.Malformed_Decl - (Format.asprintf - "Forbidden link to a %a.%a from signature declaration" - (Signature.print_site sigs dst_ty) dst_p - (Signature.print_agent sigs) dst_ty, - pos)) - -let annotate_dropped_agent - ~warning ~syntax_version ~r_editStyle - sigs links_annot (agent_name, _ as ag_ty) intf counts = + let link_swap = Some j <> dst_id in + let () = + if link_swap then ( + match warn_on_swap with + | None -> () + | Some warning -> + rule_induces_link_permutation ~warning ~pos ~dst_ty sigs ag_ty + p_id + ) + in + not link_swap + | LKappa.Freed | LKappa.Erased | LKappa.Maintained -> false + in + let _check_compatibilty = + match switch, switch' with + | LKappa.Maintained, LKappa.Maintained -> () + | LKappa.Maintained, (LKappa.Freed | LKappa.Erased | LKappa.Linked _) + -> + site_should_made_be_free i sigs ag_ty p_id pos + | (LKappa.Freed | LKappa.Erased | LKappa.Linked _), LKappa.Maintained + -> + site_should_made_be_free i sigs dst_ty dst_p pos' + | ( (LKappa.Freed | LKappa.Erased | LKappa.Linked _), + (LKappa.Freed | LKappa.Erased | LKappa.Linked _) ) -> + () + in + ( ( (LKappa.LNK_VALUE (i, (dst_p, dst_ty)), pos), + if maintained then + LKappa.Maintained + else + switch ), + (one', Mods.IntMap.add i (ag_ty, p_id, maintained) links_two) ) + ) else + raise + (ExceptionDefn.Malformed_Decl + ( Format.asprintf + "Forbidden link to a %a.%a from signature declaration" + (Signature.print_site sigs dst_ty) + dst_p + (Signature.print_agent sigs) + dst_ty, + pos )) + ) + +let annotate_dropped_agent ~warning ~syntax_version ~r_edit_style sigs + links_annot ((agent_name, _) as ag_ty) intf counts = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in let ports = - Array.make arity (Locality.dummy_annot LKappa.LNK_ANY, LKappa.Erased) in + Array.make arity (Loc.annot_with_dummy LKappa.LNK_ANY, LKappa.Erased) + in let internals = - Array.init arity - (fun i -> - match Signature.default_internal_state ag_id i sigs with - | None -> LKappa.I_ANY | Some _ -> LKappa.I_ANY_ERASED) in - let lannot,_ = + Array.init arity (fun i -> + match Signature.default_internal_state ag_id i sigs with + | None -> LKappa.I_ANY + | Some _ -> LKappa.I_ANY_ERASED) + in + let lannot, _ = List.fold_left - (fun (lannot,pset) p -> - let (_,p_pos as p_na) = p.Ast.port_nme in - let p_id = Signature.num_of_site ~agent_name p_na sign in - let () = match Signature.counter_of_site p_id sign with - | Some _ -> - LKappa.counter_misused agent_name p.Ast.port_nme | None -> () in - let pset' = Mods.IntSet.add p_id pset in - let () = if pset == pset' then - LKappa.several_occurence_of_site agent_name p.Ast.port_nme in - let () = LKappa.forbid_modification p_pos p.Ast.port_lnk_mod in - let () = LKappa.forbid_modification p_pos p.Ast.port_int_mod in - - let () = match p.Ast.port_int with - | [] | [ None , _ ] -> () - | [ Some va,pos ] -> - internals.(p_id) <- - LKappa.I_VAL_ERASED - (Signature.num_of_internal_state p_id (va,pos) sign) - | _ :: (_, pos) :: _ -> LKappa.several_internal_states pos in - match p.Ast.port_lnk with - | [LKappa.LNK_ANY, pos] -> - let () = ports.(p_id) <- ((LKappa.ANY_FREE,pos), LKappa.Erased) in - (lannot,pset') - | [LKappa.LNK_SOME, pos_lnk] -> - let (na,pos) = p.Ast.port_nme in - let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- ((LKappa.LNK_SOME,pos_lnk), LKappa.Erased) in - (lannot,pset') - | [LKappa.LNK_TYPE (dst_p, dst_ty),pos_lnk] -> - let (na,pos) = p.Ast.port_nme in - let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- - build_l_type sigs pos_lnk dst_ty dst_p LKappa.Erased in - (lannot,pset') - | [LKappa.ANY_FREE,_] | [] when syntax_version = Ast.V3 -> - let () = ports.(p_id) <- - Locality.dummy_annot LKappa.LNK_FREE, LKappa.Erased in - (lannot,pset') - | [LKappa.ANY_FREE,_] | [] -> - let () = ports.(p_id) <- - Locality.dummy_annot LKappa.ANY_FREE, LKappa.Erased in - (lannot,pset') - | [LKappa.LNK_FREE,_] -> - let () = ports.(p_id) <- - Locality.dummy_annot LKappa.LNK_FREE, LKappa.Erased in - (lannot,pset') - | [LKappa.LNK_VALUE (i,()), pos] -> - let va,lannot' = - let warn_on_swap = if r_editStyle then None else Some warning in - build_link - ?warn_on_swap sigs pos i ag_id p_id LKappa.Erased lannot in - let () = ports.(p_id) <- va in (lannot',pset') - | _::(_,pos)::_ -> - raise (ExceptionDefn.Malformed_Decl - ("Several link state for a single site",pos))) - (links_annot,Mods.IntSet.empty) intf in - let ra = { - LKappa.ra_type = ag_id; ra_ports = ports; ra_ints = internals; - ra_erased = true; - ra_syntax = Some (Array.copy ports, Array.copy internals);} in - Counters_compiler.annotate_dropped_counters - sign counts ra arity agent_name None,lannot - -let annotate_created_agent - ~warning ~syntax_version ~r_editStyle - sigs ?contact_map rannot (agent_name, _ as ag_ty) intf = + (fun (lannot, pset) p -> + let ((_, p_pos) as port_name) = p.Ast.port_name in + let p_id = Signature.num_of_site ~agent_name port_name sign in + let () = + match Signature.counter_of_site_id p_id sign with + | Some _ -> LKappa.raise_counter_misused agent_name p.Ast.port_name + | None -> () + in + let pset' = Mods.IntSet.add p_id pset in + let () = + if pset == pset' then + LKappa.raise_several_occurence_of_site agent_name p.Ast.port_name + in + let () = + match p.Ast.port_link_mod, p.Ast.port_link with + | None, _ -> () + | Some None, [ (LKappa.LNK_VALUE (_, ()), _) ] + (* [i/.] is allowed in degraded agent. + It will be checked later that the other site with link id i is also freed in the rule *) + (* Please note that a rule written as A(x[1])-,B(x[1/.])- is allowed *) + -> + () + | ( Some (None | Some _), + ( [] + | [ (LKappa.LNK_VALUE (_, ()), _) ] + | [ (LKappa.ANY_FREE, _) ] + | [ (LKappa.LNK_FREE, _) ] + | [ (LKappa.LNK_ANY, _) ] + | [ (LKappa.LNK_SOME, _) ] + | [ (LKappa.LNK_TYPE (_, _), _) ] + | _ :: _ :: _ ) ) -> + LKappa.raise_if_modification p_pos p.Ast.port_link_mod + in + let () = LKappa.raise_if_modification p_pos p.Ast.port_int_mod in + + let () = + match p.Ast.port_int with + | [] | [ (None, _) ] -> () + | [ (Some va, pos) ] -> + internals.(p_id) <- + LKappa.I_VAL_ERASED + (Signature.num_of_internal_state p_id (va, pos) sign) + | _ :: (_, pos) :: _ -> LKappa.raise_several_internal_states pos + in + match p.Ast.port_link with + | [ (LKappa.LNK_ANY, pos) ] -> + let () = ports.(p_id) <- (LKappa.ANY_FREE, pos), LKappa.Erased in + lannot, pset' + | [ (LKappa.LNK_SOME, pos_link) ] -> + let na, pos = p.Ast.port_name in + let () = + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" + na) + in + let () = ports.(p_id) <- (LKappa.LNK_SOME, pos_link), LKappa.Erased in + lannot, pset' + | [ (LKappa.LNK_TYPE (dst_p, dst_ty), pos_link) ] -> + let na, pos = p.Ast.port_name in + let () = + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" + na) + in + let () = + ports.(p_id) <- + build_l_type sigs pos_link dst_ty dst_p LKappa.Erased + in + lannot, pset' + | ([ (LKappa.ANY_FREE, _) ] | []) when syntax_version = Ast.V3 -> + let () = + ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Erased + in + lannot, pset' + | [ (LKappa.ANY_FREE, _) ] | [] -> + let () = + ports.(p_id) <- Loc.annot_with_dummy LKappa.ANY_FREE, LKappa.Erased + in + lannot, pset' + | [ (LKappa.LNK_FREE, _) ] -> + let () = + ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Erased + in + lannot, pset' + | [ (LKappa.LNK_VALUE (i, ()), pos) ] -> + let va, lannot' = + let warn_on_swap = + if r_edit_style then + None + else + Some warning + in + build_link ?warn_on_swap sigs pos i ag_id p_id LKappa.Erased lannot + in + let () = ports.(p_id) <- va in + lannot', pset' + | _ :: (_, pos) :: _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Several link state for a single site", pos))) + (links_annot, Mods.IntSet.empty) + intf + in + let ra = + { + LKappa.ra_type = ag_id; + ra_ports = ports; + ra_ints = internals; + ra_erased = true; + ra_syntax = Some (Array.copy ports, Array.copy internals); + } + in + ( Counters_compiler.annotate_dropped_counters sign counts ra arity agent_name + None, + lannot ) + +let annotate_created_agent ~warning ~syntax_version ~r_edit_style sigs + ?contact_map rannot ((agent_name, _) as ag_ty) intf = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in - let ports = Array.make arity (Raw_mixture.FREE) in + let ports = Array.make arity Raw_mixture.FREE in let internals = - Array.init arity - (fun i -> - Signature.default_internal_state ag_id i sigs) in - let _,rannot = + Array.init arity (fun i -> Signature.default_internal_state ag_id i sigs) + in + let _, rannot = List.fold_left - (fun (pset,rannot) p -> - let (_,p_pos as p_na) = p.Ast.port_nme in - let p_id = Signature.num_of_site ~agent_name p_na sign in - let () = match Signature.counter_of_site p_id sign with - | Some _ -> - LKappa.counter_misused agent_name p.Ast.port_nme | None -> () in - let pset' = Mods.IntSet.add p_id pset in - let () = if pset == pset' then - LKappa.several_occurence_of_site agent_name p.Ast.port_nme in - let () = LKappa.forbid_modification p_pos p.Ast.port_lnk_mod in - let () = LKappa.forbid_modification p_pos p.Ast.port_int_mod in - let () = match p.Ast.port_int with - | [] -> () - | [ None, _ ] -> LKappa.not_enough_specified - ~status:"internal" ~side:"left" agent_name p_na - | [ Some va, pos ] -> - internals.(p_id) <- - Some (Signature.num_of_internal_state p_id (va,pos) sign) - | _ :: (_, pos) :: _ -> LKappa.several_internal_states pos in - match p.Ast.port_lnk with - | ([LKappa.LNK_ANY, _] | [LKappa.LNK_SOME, _] | - [LKappa.LNK_TYPE _, _] | _::_::_) -> - LKappa.not_enough_specified - ~status:"linking" ~side:"left" agent_name p_na - | [LKappa.ANY_FREE, _] when syntax_version = Ast.V4 -> - LKappa.not_enough_specified - ~status:"linking" ~side:"left" agent_name p_na - | [LKappa.LNK_VALUE (i,()), pos] -> - let () = ports.(p_id) <- Raw_mixture.VAL i in - let _,rannot' = - let warn_on_swap = if r_editStyle then None else Some warning in - build_link - ?warn_on_swap sigs - ?contact_map pos i ag_id p_id LKappa.Freed rannot in - pset',rannot' - | [(LKappa.ANY_FREE | LKappa.LNK_FREE), _] | [] -> pset',rannot - ) (Mods.IntSet.empty,rannot) intf in - rannot, - { Raw_mixture.a_type = ag_id; - Raw_mixture.a_ports = ports; Raw_mixture.a_ints = internals; } - -let translate_modification - ~warning sigs ?contact_map ag_id p_id - ?warn (lhs_links,rhs_links as links_annot) = function - | None -> LKappa.Maintained,links_annot + (fun (pset, rannot) p -> + let ((_, p_pos) as port_name) = p.Ast.port_name in + let p_id = Signature.num_of_site ~agent_name port_name sign in + let () = + match Signature.counter_of_site_id p_id sign with + | Some _ -> LKappa.raise_counter_misused agent_name p.Ast.port_name + | None -> () + in + let pset' = Mods.IntSet.add p_id pset in + let () = + if pset == pset' then + LKappa.raise_several_occurence_of_site agent_name p.Ast.port_name + in + let () = LKappa.raise_if_modification p_pos p.Ast.port_link_mod in + let () = LKappa.raise_if_modification p_pos p.Ast.port_int_mod in + let () = + match p.Ast.port_int with + | [] -> () + | [ (None, _) ] -> + LKappa.raise_not_enough_specified ~status:"internal" ~side:"left" + agent_name port_name + | [ (Some va, pos) ] -> + internals.(p_id) <- + Some (Signature.num_of_internal_state p_id (va, pos) sign) + | _ :: (_, pos) :: _ -> LKappa.raise_several_internal_states pos + in + match p.Ast.port_link with + | [ (LKappa.LNK_ANY, _) ] + | [ (LKappa.LNK_SOME, _) ] + | [ (LKappa.LNK_TYPE _, _) ] + | _ :: _ :: _ -> + LKappa.raise_not_enough_specified ~status:"linking" ~side:"left" + agent_name port_name + | [ (LKappa.ANY_FREE, _) ] when syntax_version = Ast.V4 -> + LKappa.raise_not_enough_specified ~status:"linking" ~side:"left" + agent_name port_name + | [ (LKappa.LNK_VALUE (i, ()), pos) ] -> + let () = ports.(p_id) <- Raw_mixture.VAL i in + let _, rannot' = + let warn_on_swap = + if r_edit_style then + None + else + Some warning + in + build_link ?warn_on_swap sigs ?contact_map pos i ag_id p_id + LKappa.Freed rannot + in + pset', rannot' + | [ ((LKappa.ANY_FREE | LKappa.LNK_FREE), _) ] | [] -> pset', rannot) + (Mods.IntSet.empty, rannot) + intf + in + ( rannot, + { + Raw_mixture.a_type = ag_id; + Raw_mixture.a_ports = ports; + Raw_mixture.a_ints = internals; + } ) + +let translate_modification ~warning sigs ?contact_map ag_id p_id ?warn + ((lhs_links, rhs_links) as links_annot) = function + | None -> LKappa.Maintained, links_annot | Some x -> let () = match warn with | None -> () - | Some (na,pos) -> - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - match x with - | None -> LKappa.Freed,links_annot - | Some (j,pos_j) -> - let _,rhs_links' = - build_link - ?warn_on_swap:None sigs - ?contact_map pos_j j ag_id p_id LKappa.Freed rhs_links in - LKappa.Linked j,(lhs_links,rhs_links') - -let annotate_edit_agent - ~warning ~syntax_version ~is_rule sigs ?contact_map (agent_name, _ as ag_ty) - links_annot intf counts = + | Some (na, pos) -> + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" na) + in + (match x with + | None -> LKappa.Freed, links_annot + | Some (j, pos_j) -> + let _, rhs_links' = + build_link ?warn_on_swap:None sigs ?contact_map pos_j j ag_id p_id + LKappa.Freed rhs_links + in + LKappa.Linked j, (lhs_links, rhs_links')) + +let annotate_edit_agent ~warning ~syntax_version ~is_rule sigs ?contact_map + ((agent_name, _) as ag_ty) links_annot intf counts = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in let ports = - Array.make arity (Locality.dummy_annot LKappa.LNK_ANY, LKappa.Maintained) in + Array.make arity (Loc.annot_with_dummy LKappa.LNK_ANY, LKappa.Maintained) + in let internals = Array.make arity LKappa.I_ANY in - let scan_port (links_annot,pset) p = - let (p_na,_) = p.Ast.port_nme in - let p_id = Signature.num_of_site ~agent_name p.Ast.port_nme sign in - let () = match Signature.counter_of_site p_id sign with - | Some _ -> - LKappa.counter_misused agent_name p.Ast.port_nme | None -> () in + let scan_port (links_annot, pset) p = + let port_name, _ = p.Ast.port_name in + let p_id = Signature.num_of_site ~agent_name p.Ast.port_name sign in + let () = + match Signature.counter_of_site_id p_id sign with + | Some _ -> LKappa.raise_counter_misused agent_name p.Ast.port_name + | None -> () + in let pset' = Mods.IntSet.add p_id pset in - let () = if pset == pset' then - LKappa.several_occurence_of_site agent_name p.Ast.port_nme in + let () = + if pset == pset' then + LKappa.raise_several_occurence_of_site agent_name p.Ast.port_name + in let links_annot' = - match p.Ast.port_lnk with - | [LKappa.LNK_SOME, pos as x] -> - let (modif,links_annot') = translate_modification - ~warning ~warn:(p_na,pos) sigs ?contact_map ag_id p_id - links_annot p.Ast.port_lnk_mod in - let () = ports.(p_id) <- (x, modif) in + match p.Ast.port_link with + | [ ((LKappa.LNK_SOME, pos) as x) ] -> + let modif, links_annot' = + translate_modification ~warning ~warn:(port_name, pos) sigs + ?contact_map ag_id p_id links_annot p.Ast.port_link_mod + in + let () = ports.(p_id) <- x, modif in links_annot' - | [(LKappa.LNK_ANY, pos)] -> - let (modif,links_annot') = translate_modification - ~warning ~warn:(p_na,pos) sigs ?contact_map ag_id p_id - links_annot p.Ast.port_lnk_mod in - let () = ports.(p_id) <- ((LKappa.ANY_FREE,pos), modif) in + | [ (LKappa.LNK_ANY, pos) ] -> + let modif, links_annot' = + translate_modification ~warning ~warn:(port_name, pos) sigs + ?contact_map ag_id p_id links_annot p.Ast.port_link_mod + in + let () = ports.(p_id) <- (LKappa.ANY_FREE, pos), modif in links_annot' - | ([] | [LKappa.ANY_FREE, _]) when syntax_version = Ast.V3 -> - let (modif,links_annot') = translate_modification - ~warning ?warn:None sigs ?contact_map ag_id p_id - links_annot p.Ast.port_lnk_mod in - let () = ports.(p_id) <- (Locality.dummy_annot LKappa.LNK_FREE, modif) in + | ([] | [ (LKappa.ANY_FREE, _) ]) when syntax_version = Ast.V3 -> + let modif, links_annot' = + translate_modification ~warning ?warn:None sigs ?contact_map ag_id + p_id links_annot p.Ast.port_link_mod + in + let () = ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, modif in links_annot' - | [] when p.Ast.port_lnk_mod = None -> links_annot - | ([LKappa.ANY_FREE, _] | []) -> - LKappa.not_enough_specified - ~status:"linking" ~side:"left" agent_name p.Ast.port_nme - | [LKappa.LNK_FREE, _] -> - let (modif,links_annot') = translate_modification - ~warning ?warn:None sigs ?contact_map ag_id p_id - links_annot p.Ast.port_lnk_mod in - let () = ports.(p_id) <- (Locality.dummy_annot LKappa.LNK_FREE, modif) in + | [] when p.Ast.port_link_mod = None -> links_annot + | [ (LKappa.ANY_FREE, _) ] | [] -> + LKappa.raise_not_enough_specified ~status:"linking" ~side:"left" + agent_name p.Ast.port_name + | [ (LKappa.LNK_FREE, _) ] -> + let modif, links_annot' = + translate_modification ~warning ?warn:None sigs ?contact_map ag_id + p_id links_annot p.Ast.port_link_mod + in + let () = ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, modif in links_annot' - | [LKappa.LNK_TYPE (dst_p,dst_ty), pos] -> - let (modif,links_annot') = translate_modification - ~warning ~warn:(p_na,pos) sigs ?contact_map ag_id p_id - links_annot p.Ast.port_lnk_mod in + | [ (LKappa.LNK_TYPE (dst_p, dst_ty), pos) ] -> + let modif, links_annot' = + translate_modification ~warning ~warn:(port_name, pos) sigs + ?contact_map ag_id p_id links_annot p.Ast.port_link_mod + in let () = ports.(p_id) <- build_l_type sigs pos dst_ty dst_p modif in links_annot' - | [LKappa.LNK_VALUE (i,()), pos] -> - let (modif,(lhs_links,rhs_links)) = translate_modification - ~warning ?warn:None sigs ?contact_map ag_id p_id - links_annot p.Ast.port_lnk_mod in - let va,lhs_links' = - build_link - sigs ?contact_map:(if is_rule then None else contact_map) - ?warn_on_swap:None pos i ag_id p_id modif lhs_links in + | [ (LKappa.LNK_VALUE (i, ()), pos) ] -> + let modif, (lhs_links, rhs_links) = + translate_modification ~warning ?warn:None sigs ?contact_map ag_id + p_id links_annot p.Ast.port_link_mod + in + let va, lhs_links' = + build_link sigs + ?contact_map: + (if is_rule then + None + else + contact_map) + ?warn_on_swap:None pos i ag_id p_id modif lhs_links + in let () = ports.(p_id) <- va in - (lhs_links',rhs_links) - | _::(_,pos)::_ -> - raise (ExceptionDefn.Malformed_Decl - ("Several link state for a single site",pos)) in + lhs_links', rhs_links + | _ :: (_, pos) :: _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Several link state for a single site", pos)) + in let () = - match p.Ast.port_int,p.Ast.port_int_mod with - | ([None,_] | []), None -> () - | [ Some va, pos ], Some va' -> + match p.Ast.port_int, p.Ast.port_int_mod with + | ([ (None, _) ] | []), None -> () + | [ (Some va, pos) ], Some va' -> internals.(p_id) <- LKappa.I_VAL_CHANGED - (Signature.num_of_internal_state p_id (va,pos) sign, - Signature.num_of_internal_state p_id va' sign) - | [], Some (_,pos as va) -> + ( Signature.num_of_internal_state p_id (va, pos) sign, + Signature.num_of_internal_state p_id va' sign ) + | [], Some ((_, pos) as va) -> let () = if syntax_version = Ast.V3 then - warning - ~pos - (fun f -> - Format.fprintf - f - "internal state of site '%s' of agent '%s' is modified \ - although it is left unpecified in the left hand side" - p_na agent_name) + warning ~pos (fun f -> + Format.fprintf f + "internal state of site '%s' of agent '%s' is modified \ + although it is left unpecified in the left hand side" + port_name agent_name) else - raise (ExceptionDefn.Malformed_Decl - ("Modified internal state must appear on the left",pos)) in + raise + (ExceptionDefn.Malformed_Decl + ("Modified internal state must appear on the left", pos)) + in internals.(p_id) <- LKappa.I_ANY_CHANGED (Signature.num_of_internal_state p_id va sign) - | [None,_], Some va -> + | [ (None, _) ], Some va -> internals.(p_id) <- LKappa.I_ANY_CHANGED (Signature.num_of_internal_state p_id va sign) - | [ Some va, pos ], None -> - let i_id = Signature.num_of_internal_state p_id (va,pos) sign in - internals.(p_id) <- LKappa.I_VAL_CHANGED (i_id,i_id) - | _ :: (_,pos) :: _, _ -> LKappa.several_internal_states pos in - (links_annot',pset') in - let annot',_ = - List.fold_left scan_port (links_annot,Mods.IntSet.empty) intf in + | [ (Some va, pos) ], None -> + let i_id = Signature.num_of_internal_state p_id (va, pos) sign in + internals.(p_id) <- LKappa.I_VAL_CHANGED (i_id, i_id) + | _ :: (_, pos) :: _, _ -> LKappa.raise_several_internal_states pos + in + links_annot', pset' + in + let annoted', _ = + List.fold_left scan_port (links_annot, Mods.IntSet.empty) intf + in let ra = - { LKappa.ra_type = ag_id; ra_ports = ports; ra_ints = internals; ra_erased = false; - ra_syntax = Some (Array.copy ports, Array.copy internals);} in - Counters_compiler.annotate_edit_counters - sigs ag_ty counts ra (add_link_contact_map ?contact_map),annot' - -let annotate_agent_with_diff - ~warning ~syntax_version sigs ?contact_map - (agent_name,_ as ag_ty) links_annot lp rp lc rc = + { + LKappa.ra_type = ag_id; + ra_ports = ports; + ra_ints = internals; + ra_erased = false; + ra_syntax = Some (Array.copy ports, Array.copy internals); + } + in + ( Counters_compiler.annotate_edit_counters sigs ag_ty counts ra + (add_link_contact_map ?contact_map), + annoted' ) + +let annotate_agent_with_diff ~warning ~syntax_version sigs ?contact_map + ((agent_name, _) as ag_ty) links_annot lp rp lc rc = let ag_id = Signature.num_of_agent ag_ty sigs in let sign = Signature.get sigs ag_id in let arity = Signature.arity sigs ag_id in let ports = - Array.make arity (Locality.dummy_annot LKappa.LNK_ANY, LKappa.Maintained) in + Array.make arity (Loc.annot_with_dummy LKappa.LNK_ANY, LKappa.Maintained) + in let internals = Array.make arity LKappa.I_ANY in - let register_port_modif p_id lnk1 p' (lhs_links,rhs_links as links_annot) = + let register_port_modif p_id lnk1 p' ((lhs_links, rhs_links) as links_annot) = let () = - LKappa.forbid_modification (snd p'.Ast.port_nme) p'.Ast.port_lnk_mod in - match lnk1,p'.Ast.port_lnk with - | [LKappa.LNK_ANY,pos], [LKappa.LNK_ANY,_] -> - let () = ports.(p_id) <- ((LKappa.ANY_FREE,pos), LKappa.Maintained) in + LKappa.raise_if_modification + (Loc.get_annot p'.Ast.port_name) + p'.Ast.port_link_mod + in + match lnk1, p'.Ast.port_link with + | [ (LKappa.LNK_ANY, pos) ], [ (LKappa.LNK_ANY, _) ] -> + let () = ports.(p_id) <- (LKappa.ANY_FREE, pos), LKappa.Maintained in links_annot - | [LKappa.LNK_SOME,pos], [LKappa.LNK_SOME,_] -> - let () = ports.(p_id) <- ((LKappa.LNK_SOME,pos), LKappa.Maintained) in + | [ (LKappa.LNK_SOME, pos) ], [ (LKappa.LNK_SOME, _) ] -> + let () = ports.(p_id) <- (LKappa.LNK_SOME, pos), LKappa.Maintained in links_annot - | [LKappa.LNK_TYPE ((dst_p'',_ as dst_p),(dst_ty'',_ as dst_ty)),pos], - [LKappa.LNK_TYPE ((dst_p',_),(dst_ty',_)),_] + | ( [ + ( LKappa.LNK_TYPE (((dst_p'', _) as dst_p), ((dst_ty'', _) as dst_ty)), + pos ); + ], + [ (LKappa.LNK_TYPE ((dst_p', _), (dst_ty', _)), _) ] ) when dst_p'' = dst_p' && dst_ty'' = dst_ty' -> - let () = ports.(p_id) <- - build_l_type sigs pos dst_ty dst_p LKappa.Maintained in + let () = + ports.(p_id) <- build_l_type sigs pos dst_ty dst_p LKappa.Maintained + in links_annot - | _, ([LKappa.LNK_ANY,_] | [LKappa.LNK_SOME,_] | [LKappa.LNK_TYPE _,_]) -> - LKappa.not_enough_specified - ~status:"linking" ~side:"right" agent_name p'.Ast.port_nme - | [LKappa.LNK_ANY,pos], [] when syntax_version = Ast.V3 -> - let () = ports.(p_id) <- ((LKappa.LNK_ANY,pos), LKappa.Freed) in + | ( _, + ( [ (LKappa.LNK_ANY, _) ] + | [ (LKappa.LNK_SOME, _) ] + | [ (LKappa.LNK_TYPE _, _) ] ) ) -> + LKappa.raise_not_enough_specified ~status:"linking" ~side:"right" + agent_name p'.Ast.port_name + | [ (LKappa.LNK_ANY, pos) ], [] when syntax_version = Ast.V3 -> + let () = ports.(p_id) <- (LKappa.LNK_ANY, pos), LKappa.Freed in links_annot - | [LKappa.LNK_ANY,pos], [(LKappa.LNK_FREE|LKappa.ANY_FREE),_] -> - let () = ports.(p_id) <- ((LKappa.LNK_ANY,pos), LKappa.Freed) in + | [ (LKappa.LNK_ANY, pos) ], [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] -> + let () = ports.(p_id) <- (LKappa.LNK_ANY, pos), LKappa.Freed in links_annot - | [LKappa.LNK_SOME,pos_lnk], [(LKappa.LNK_FREE|LKappa.ANY_FREE),_] -> - let (na,pos) = p'.Ast.port_nme in + | ( [ (LKappa.LNK_SOME, pos_link) ], + [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] ) -> + let na, pos = p'.Ast.port_name in let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- ((LKappa.LNK_SOME,pos_lnk), LKappa.Freed) in + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" na) + in + let () = ports.(p_id) <- (LKappa.LNK_SOME, pos_link), LKappa.Freed in links_annot - | [LKappa.LNK_TYPE (dst_p,dst_ty),pos_lnk], [(LKappa.LNK_FREE|LKappa.ANY_FREE),_] -> - let (na,pos) = p'.Ast.port_nme in + | ( [ (LKappa.LNK_TYPE (dst_p, dst_ty), pos_link) ], + [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] ) -> + let na, pos = p'.Ast.port_name in + let () = + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" na) + in let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- - build_l_type sigs pos_lnk dst_ty dst_p LKappa.Freed in + ports.(p_id) <- build_l_type sigs pos_link dst_ty dst_p LKappa.Freed + in links_annot - | [LKappa.LNK_SOME,pos_lnk], [] when syntax_version = Ast.V3 -> - let (na,pos) = p'.Ast.port_nme in + | [ (LKappa.LNK_SOME, pos_link) ], [] when syntax_version = Ast.V3 -> + let na, pos = p'.Ast.port_name in let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- ((LKappa.LNK_SOME,pos_lnk), LKappa.Freed) in + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" na) + in + let () = ports.(p_id) <- (LKappa.LNK_SOME, pos_link), LKappa.Freed in links_annot - | [LKappa.LNK_TYPE (dst_p,dst_ty),pos_lnk], [] when syntax_version = Ast.V3 -> - let (na,pos) = p'.Ast.port_nme in + | [ (LKappa.LNK_TYPE (dst_p, dst_ty), pos_link) ], [] + when syntax_version = Ast.V3 -> + let na, pos = p'.Ast.port_name in let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- - build_l_type sigs pos_lnk dst_ty dst_p LKappa.Freed in + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" na) + in + let () = + ports.(p_id) <- build_l_type sigs pos_link dst_ty dst_p LKappa.Freed + in links_annot - | ([(LKappa.LNK_FREE|LKappa.ANY_FREE),_] | []), - ([(LKappa.LNK_FREE|LKappa.ANY_FREE),_] | []) when syntax_version = Ast.V3 -> - let () = ports.(p_id) <- - (Locality.dummy_annot LKappa.LNK_FREE, LKappa.Maintained) in + | ( ([ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] | []), + ([ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] | []) ) + when syntax_version = Ast.V3 -> + let () = + ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Maintained + in links_annot - | ([(LKappa.LNK_FREE|LKappa.ANY_FREE),_], [(LKappa.LNK_FREE|LKappa.ANY_FREE),_]) -> - let () = ports.(p_id) <- - (Locality.dummy_annot LKappa.LNK_FREE, LKappa.Maintained) in + | ( [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ], + [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] ) -> + let () = + ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Maintained + in links_annot - | ([],[]) -> - let () = ports.(p_id) <- - (Locality.dummy_annot LKappa.LNK_ANY, LKappa.Maintained) in + | [], [] -> + let () = + ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_ANY, LKappa.Maintained + in links_annot - | [LKappa.LNK_VALUE (i,()),pos], [(LKappa.LNK_FREE|LKappa.ANY_FREE),_] -> - let va,lhs_links' = - build_link sigs ~warn_on_swap:warning pos i - ag_id p_id LKappa.Freed lhs_links in - let () = ports.(p_id) <- va in (lhs_links',rhs_links) - | [LKappa.LNK_VALUE (i,()),pos], [] when syntax_version = Ast.V3 -> - let va,lhs_links' = - build_link sigs ~warn_on_swap:warning pos i - ag_id p_id LKappa.Freed lhs_links in - let () = ports.(p_id) <- va in (lhs_links',rhs_links) - | [LKappa.LNK_ANY,pos_lnk], [LKappa.LNK_VALUE (i,()),pos] -> - let () = ports.(p_id) <- ((LKappa.LNK_ANY,pos_lnk), LKappa.Linked i) in - let _,rhs_links' = - build_link sigs ~warn_on_swap:warning ?contact_map pos i - ag_id p_id LKappa.Freed rhs_links in - lhs_links,rhs_links' - | [LKappa.LNK_SOME,pos_lnk], [LKappa.LNK_VALUE (i,()),pos'] -> - let (na,pos) = p'.Ast.port_nme in + | ( [ (LKappa.LNK_VALUE (i, ()), pos) ], + [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ] ) -> + let va, lhs_links' = + build_link sigs ~warn_on_swap:warning pos i ag_id p_id LKappa.Freed + lhs_links + in + let () = ports.(p_id) <- va in + lhs_links', rhs_links + | [ (LKappa.LNK_VALUE (i, ()), pos) ], [] when syntax_version = Ast.V3 -> + let va, lhs_links' = + build_link sigs ~warn_on_swap:warning pos i ag_id p_id LKappa.Freed + lhs_links + in + let () = ports.(p_id) <- va in + lhs_links', rhs_links + | [ (LKappa.LNK_ANY, pos_link) ], [ (LKappa.LNK_VALUE (i, ()), pos) ] -> + let () = ports.(p_id) <- (LKappa.LNK_ANY, pos_link), LKappa.Linked i in + let _, rhs_links' = + build_link sigs ~warn_on_swap:warning ?contact_map pos i ag_id p_id + LKappa.Freed rhs_links + in + lhs_links, rhs_links' + | [ (LKappa.LNK_SOME, pos_link) ], [ (LKappa.LNK_VALUE (i, ()), pos') ] -> + let na, pos = p'.Ast.port_name in + let () = + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" na) + in + let () = ports.(p_id) <- (LKappa.LNK_SOME, pos_link), LKappa.Linked i in + let _, rhs_links' = + build_link sigs ~warn_on_swap:warning ?contact_map pos' i ag_id p_id + LKappa.Freed rhs_links + in + lhs_links, rhs_links' + | ( [ (LKappa.LNK_TYPE (dst_p, dst_ty), pos_link) ], + [ (LKappa.LNK_VALUE (i, ()), pos') ] ) -> + let na, pos = p'.Ast.port_name in + let () = + warning ~pos (fun f -> + Format.fprintf f + "breaking a semi-link on site '%s' will induce a side effect" na) + in let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- - ((LKappa.LNK_SOME,pos_lnk), LKappa.Linked i) in - let _,rhs_links' = - build_link sigs ~warn_on_swap:warning ?contact_map pos' i - ag_id p_id LKappa.Freed rhs_links in - lhs_links,rhs_links' - | [LKappa.LNK_TYPE (dst_p,dst_ty),pos_lnk], [LKappa.LNK_VALUE (i,()),pos'] -> - let (na,pos) = p'.Ast.port_nme in + ports.(p_id) <- + build_l_type sigs pos_link dst_ty dst_p (LKappa.Linked i) + in + let _, rhs_links' = + build_link sigs ~warn_on_swap:warning ?contact_map pos' i ag_id p_id + LKappa.Freed rhs_links + in + lhs_links, rhs_links' + | ( [ ((LKappa.LNK_FREE | LKappa.ANY_FREE), _) ], + [ (LKappa.LNK_VALUE (i, ()), pos) ] ) -> let () = - warning - ~pos - (fun f -> - Format.fprintf - f "breaking a semi-link on site '%s' will induce a side effect" - na) in - let () = ports.(p_id) <- - build_l_type sigs pos_lnk dst_ty dst_p (LKappa.Linked i) in - let _,rhs_links' = - build_link sigs ~warn_on_swap:warning ?contact_map pos' i - ag_id p_id LKappa.Freed rhs_links in - lhs_links,rhs_links' - | [(LKappa.LNK_FREE|LKappa.ANY_FREE),_], [LKappa.LNK_VALUE (i,()),pos] -> - let () = ports.(p_id) <- - (Locality.dummy_annot LKappa.LNK_FREE, LKappa.Linked i) in - let _,rhs_links' = - build_link sigs ~warn_on_swap:warning ?contact_map pos i - ag_id p_id LKappa.Freed rhs_links in - lhs_links,rhs_links' - | [], [LKappa.LNK_VALUE (i,()),pos] when syntax_version = Ast.V3 -> - let () = ports.(p_id) <- - (Locality.dummy_annot LKappa.LNK_FREE, LKappa.Linked i) in - let _,rhs_links' = - build_link sigs ~warn_on_swap:warning ?contact_map pos i - ag_id p_id LKappa.Freed rhs_links in - lhs_links,rhs_links' - | [LKappa.LNK_VALUE (i,()),pos_i], [LKappa.LNK_VALUE (j,()),pos_j] -> - let va,lhs_links' = build_link sigs ~warn_on_swap:warning pos_i i - ag_id p_id (LKappa.Linked j) lhs_links in - let _,rhs_links' = - build_link sigs ~warn_on_swap:warning ?contact_map pos_j j - ag_id p_id LKappa.Freed rhs_links in - let () = ports.(p_id) <- va in (lhs_links',rhs_links') - | [(LKappa.LNK_VALUE (_, ()) | LKappa.LNK_FREE | LKappa.ANY_FREE | - LKappa.LNK_TYPE (_, _) | LKappa.LNK_SOME | LKappa.LNK_ANY), _], [] -> - LKappa.not_enough_specified - ~status:"linking" ~side:"right" agent_name p'.Ast.port_nme - | [], [(LKappa.ANY_FREE|LKappa.LNK_FREE|LKappa.LNK_VALUE (_, _)), _] -> - LKappa.not_enough_specified - ~status:"linking" ~side:"left" agent_name p'.Ast.port_nme - | _::(_,pos)::_, _ -> - raise (ExceptionDefn.Malformed_Decl - ("Several link state for a single site",pos)) - | _, _::(_,pos)::_ -> - raise (ExceptionDefn.Malformed_Decl - ("Several link state for a single site",pos)) in + ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Linked i + in + let _, rhs_links' = + build_link sigs ~warn_on_swap:warning ?contact_map pos i ag_id p_id + LKappa.Freed rhs_links + in + lhs_links, rhs_links' + | [], [ (LKappa.LNK_VALUE (i, ()), pos) ] when syntax_version = Ast.V3 -> + let () = + ports.(p_id) <- Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Linked i + in + let _, rhs_links' = + build_link sigs ~warn_on_swap:warning ?contact_map pos i ag_id p_id + LKappa.Freed rhs_links + in + lhs_links, rhs_links' + | ( [ (LKappa.LNK_VALUE (i, ()), pos_i) ], + [ (LKappa.LNK_VALUE (j, ()), pos_j) ] ) -> + let va, lhs_links' = + build_link sigs ~warn_on_swap:warning pos_i i ag_id p_id + (LKappa.Linked j) lhs_links + in + let _, rhs_links' = + build_link sigs ~warn_on_swap:warning ?contact_map pos_j j ag_id p_id + LKappa.Freed rhs_links + in + let () = ports.(p_id) <- va in + lhs_links', rhs_links' + | ( [ + ( ( LKappa.LNK_VALUE (_, ()) + | LKappa.LNK_FREE | LKappa.ANY_FREE + | LKappa.LNK_TYPE (_, _) + | LKappa.LNK_SOME | LKappa.LNK_ANY ), + _ ); + ], + [] ) -> + LKappa.raise_not_enough_specified ~status:"linking" ~side:"right" + agent_name p'.Ast.port_name + | [], [ ((LKappa.ANY_FREE | LKappa.LNK_FREE | LKappa.LNK_VALUE (_, _)), _) ] + -> + LKappa.raise_not_enough_specified ~status:"linking" ~side:"left" + agent_name p'.Ast.port_name + | _ :: (_, pos) :: _, _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Several link state for a single site", pos)) + | _, _ :: (_, pos) :: _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Several link state for a single site", pos)) + in let register_internal_modif p_id int1 p' = let () = - LKappa.forbid_modification (snd p'.Ast.port_nme) p'.Ast.port_int_mod in - match int1,p'.Ast.port_int with - | [], [] | [None,_], [None,_] -> () - | [ Some va, pos ], [ Some va', pos' ] -> + LKappa.raise_if_modification + (Loc.get_annot p'.Ast.port_name) + p'.Ast.port_int_mod + in + match int1, p'.Ast.port_int with + | [], [] | [ (None, _) ], [ (None, _) ] -> () + | [ (Some va, pos) ], [ (Some va', pos') ] -> internals.(p_id) <- LKappa.I_VAL_CHANGED - (Signature.num_of_internal_state p_id (va,pos) sign, - Signature.num_of_internal_state p_id (va',pos') sign) - | [], [ Some va, vapos ] when syntax_version = Ast.V3 -> - let (na,pos) = p'.Ast.port_nme in + ( Signature.num_of_internal_state p_id (va, pos) sign, + Signature.num_of_internal_state p_id (va', pos') sign ) + | [], [ (Some va, vapos) ] when syntax_version = Ast.V3 -> + let na, pos = p'.Ast.port_name in let () = - warning - ~pos - (fun f -> - Format.fprintf - f - "internal state of site '%s' of agent '%s' is modified \ -although it is left unpecified in the left hand side" - na agent_name) in + warning ~pos (fun f -> + Format.fprintf f + "internal state of site '%s' of agent '%s' is modified although \ + it is left unpecified in the left hand side" + na agent_name) + in internals.(p_id) <- LKappa.I_ANY_CHANGED - (Signature.num_of_internal_state p_id (va,vapos) sign) - | [None,_], [ Some va, vapos ] -> + (Signature.num_of_internal_state p_id (va, vapos) sign) + | [ (None, _) ], [ (Some va, vapos) ] -> internals.(p_id) <- LKappa.I_ANY_CHANGED - (Signature.num_of_internal_state p_id (va,vapos) sign) + (Signature.num_of_internal_state p_id (va, vapos) sign) | [], [ _ ] -> - LKappa.not_enough_specified - ~status:"internal" ~side:"left" agent_name p'.Ast.port_nme - | [_], ([None,_] | []) -> - LKappa.not_enough_specified - ~status:"internal" ~side:"right" agent_name p'.Ast.port_nme - | (_ :: (_,pos) :: _, _ | _, _ :: (_,pos) :: _) -> - LKappa.several_internal_states pos in - let find_in_r (na,pos) rp = - let (p',r) = - List.partition (fun p -> String.compare (fst p.Ast.port_nme) na = 0) rp in + LKappa.raise_not_enough_specified ~status:"internal" ~side:"left" + agent_name p'.Ast.port_name + | [ _ ], ([ (None, _) ] | []) -> + LKappa.raise_not_enough_specified ~status:"internal" ~side:"right" + agent_name p'.Ast.port_name + | _ :: (_, pos) :: _, _ | _, _ :: (_, pos) :: _ -> + LKappa.raise_several_internal_states pos + in + let find_in_r (na, pos) rp = + let p', r = + List.partition (fun p -> String.compare (Loc.v p.Ast.port_name) na = 0) rp + in match p' with - | [p'] -> (p',r) + | [ p' ] -> p', r | [] -> - LKappa.not_enough_specified - ~status:"linking" ~side:"right" agent_name (na,pos) - | _ :: _ -> LKappa.several_occurence_of_site agent_name (na,pos) in - let rp_r,annot,_ = + LKappa.raise_not_enough_specified ~status:"linking" ~side:"right" + agent_name (na, pos) + | _ :: _ -> LKappa.raise_several_occurence_of_site agent_name (na, pos) + in + let rp_r, annoted, _ = List.fold_left - (fun (rp,annot,pset) p -> - let (_,p_pos as p_na) = p.Ast.port_nme in - let p_id = Signature.num_of_site ~agent_name p_na sign in - let pset' = Mods.IntSet.add p_id pset in - let () = if pset == pset' then - LKappa.several_occurence_of_site agent_name p.Ast.port_nme in - let () = LKappa.forbid_modification p_pos p.Ast.port_lnk_mod in - let () = LKappa.forbid_modification p_pos p.Ast.port_int_mod in - - let p',rp' = find_in_r p_na rp in - let annot' = register_port_modif - p_id p.Ast.port_lnk p' annot in - let () = register_internal_modif p_id p.Ast.port_int p' in - (rp',annot',pset')) (rp,links_annot,Mods.IntSet.empty) lp in - let annot' = + (fun (rp, annoted, pset) p -> + let ((_, p_pos) as port_name) = p.Ast.port_name in + let p_id = Signature.num_of_site ~agent_name port_name sign in + let pset' = Mods.IntSet.add p_id pset in + let () = + if pset == pset' then + LKappa.raise_several_occurence_of_site agent_name p.Ast.port_name + in + let () = LKappa.raise_if_modification p_pos p.Ast.port_link_mod in + let () = LKappa.raise_if_modification p_pos p.Ast.port_int_mod in + + let p', rp' = find_in_r port_name rp in + let annoted' = register_port_modif p_id p.Ast.port_link p' annoted in + let () = register_internal_modif p_id p.Ast.port_int p' in + rp', annoted', pset') + (rp, links_annot, Mods.IntSet.empty) + lp + in + let annoted' = List.fold_left - (fun annot p -> - let p_na = p.Ast.port_nme in - let p_id = Signature.num_of_site ~agent_name p_na sign in - let () = register_internal_modif p_id [] p in - register_port_modif p_id [Locality.dummy_annot LKappa.LNK_ANY] p annot) - annot rp_r in - - let ra = { - LKappa.ra_type = ag_id; ra_ports = ports; ra_ints = internals; - ra_erased = false; - ra_syntax = Some (Array.copy ports, Array.copy internals);} in - Counters_compiler.annotate_counters_with_diff - sigs ag_ty lc rc ra (add_link_contact_map ?contact_map),annot' + (fun annoted p -> + let port_name = p.Ast.port_name in + let p_id = Signature.num_of_site ~agent_name port_name sign in + let () = register_internal_modif p_id [] p in + register_port_modif p_id + [ Loc.annot_with_dummy LKappa.LNK_ANY ] + p annoted) + annoted rp_r + in + + let ra = + { + LKappa.ra_type = ag_id; + ra_ports = ports; + ra_ints = internals; + ra_erased = false; + ra_syntax = Some (Array.copy ports, Array.copy internals); + } + in + ( Counters_compiler.annotate_counters_with_diff sigs ag_ty lc rc ra + (add_link_contact_map ?contact_map), + annoted' ) let refer_links_annot ?warning sigs links_annot mix = List.iter - (fun r -> - let ra = r.Counters_compiler.ra in - Array.iteri - (fun i -> function - | (LKappa.LNK_VALUE (j,(-1,-1)),pos),mods -> - begin - match Mods.IntMap.find_option j links_annot with - | None -> () - | Some (dst_ty,dst_p,maintained) -> - let mods' = if maintained then LKappa.Maintained else mods in - let () = match mods' with - | LKappa.Erased | LKappa.Freed | LKappa.Maintained -> () - | LKappa.Linked _ -> - match warning with - | None -> () - | Some warning -> - rule_induces_link_permutation - ~warning ~pos ~dst_ty sigs ra.LKappa.ra_type i in - ra.LKappa.ra_ports.(i) <- - ((LKappa.LNK_VALUE (j,(dst_p,dst_ty)),pos),mods') - end - | ((LKappa.LNK_VALUE _ | LKappa.LNK_ANY | LKappa.LNK_SOME - | LKappa.LNK_TYPE _ | LKappa.LNK_FREE | LKappa.ANY_FREE),_),_ -> ()) - ra.LKappa.ra_ports) mix + (fun (ra_ : LKappa.rule_agent Counters_compiler.with_agent_counters) -> + let ra = ra_.agent in + Array.iteri + (fun i -> function + | (LKappa.LNK_VALUE (j, (-1, -1)), pos), mods -> + (match Mods.IntMap.find_option j links_annot with + | None -> () + | Some (dst_ty, dst_p, maintained) -> + let mods' = + if maintained then + LKappa.Maintained + else + mods + in + let () = + match mods' with + | LKappa.Erased | LKappa.Freed | LKappa.Maintained -> () + | LKappa.Linked _ -> + (match warning with + | None -> () + | Some warning -> + rule_induces_link_permutation ~warning ~pos ~dst_ty sigs + ra.LKappa.ra_type i) + in + ra.LKappa.ra_ports.(i) <- + (LKappa.LNK_VALUE (j, (dst_p, dst_ty)), pos), mods') + | ( ( ( LKappa.LNK_VALUE _ | LKappa.LNK_ANY | LKappa.LNK_SOME + | LKappa.LNK_TYPE _ | LKappa.LNK_FREE | LKappa.ANY_FREE ), + _ ), + _ ) -> + ()) + ra.LKappa.ra_ports) + mix let separate_sites ls = - let (a,b) = + let a, b = List.fold_left - (fun (ps,cs) -> function - | Ast.Port p -> (p::ps,cs) - | Ast.Counter c -> (ps,c::cs)) ([],[]) ls in - (List.rev a,b) + (fun (ps, cs) -> function + | Ast.Port p -> p :: ps, cs + | Ast.Counter c -> ps, c :: cs) + ([], []) ls + in + List.rev a, b -let final_rule_sanity - ?warning sigs ((lhs_links_one,lhs_links_two),(rhs_links_one,_)) mix = +let final_rule_sanity ?warning sigs + ((lhs_links_one, lhs_links_two), (rhs_links_one, _)) mix = let () = match Mods.IntMap.root lhs_links_one with | None -> () - | Some (i,(_,_,_,pos)) -> LKappa.link_only_one_occurence i pos in + | Some (i, (_, _, _, pos, _)) -> LKappa.raise_link_only_one_occurence i pos + in let () = refer_links_annot ?warning sigs lhs_links_two mix in match Mods.IntMap.root rhs_links_one with | None -> () - | Some (i,(_,_,_,pos)) -> LKappa.link_only_one_occurence i pos + | Some (i, (_, _, _, pos, _)) -> LKappa.raise_link_only_one_occurence i pos (* Is responsible for the check that: @@ -659,154 +863,169 @@ Is responsible for the check that: - unique internal_state / site - links appear exactly twice *) -let annotate_lhs_with_diff_v3 - ~warning sigs ?contact_map lhs rhs = - let syntax_version=Ast.V3 in +let annotate_lhs_with_diff_v3 ~warning sigs ?contact_map lhs rhs = + let syntax_version = Ast.V3 in let rec aux links_annot acc lhs rhs = - match lhs,rhs with - | Ast.Absent pos::_, _ - | (Ast.Present _ :: _ | []), Ast.Absent pos::_ -> + match lhs, rhs with + | Ast.Absent pos :: _, _ | (Ast.Present _ :: _ | []), Ast.Absent pos :: _ -> raise - (ExceptionDefn.Malformed_Decl - ("Absent agent are KaSim > 3 syntax",pos)) - | Ast.Present ((lag_na,lpos as ag_ty),lag_s,lmod)::lt, - Ast.Present ((rag_na,rpos),rag_s,rmod)::rt - when String.compare lag_na rag_na = 0 && - Ast.no_more_site_on_right true lag_s rag_s -> - let () = LKappa.forbid_modification lpos lmod in - let () = LKappa.forbid_modification rpos rmod in - let (lag_p,lag_c) = separate_sites lag_s in - let (rag_p,rag_c) = separate_sites rag_s in - let ra,links_annot' = - annotate_agent_with_diff - ~warning ~syntax_version sigs ?contact_map - ag_ty links_annot lag_p rag_p lag_c rag_c in - aux links_annot' (ra::acc) lt rt - | (Ast.Present _ :: _ | [] as erased), added -> + (ExceptionDefn.Malformed_Decl ("Absent agent are KaSim > 3 syntax", pos)) + | ( Ast.Present (((lagent_name, lpos) as ag_ty), lag_s, lmod) :: lt, + Ast.Present ((ragent_name, rpos), rag_s, rmod) :: rt ) + when String.compare lagent_name ragent_name = 0 + && Ast.no_more_site_on_right true lag_s rag_s -> + raise_if_modification_agent lpos lmod; + raise_if_modification_agent rpos rmod; + let lag_p, lag_c = separate_sites lag_s in + let rag_p, rag_c = separate_sites rag_s in + let ra, links_annot' = + annotate_agent_with_diff ~warning ~syntax_version sigs ?contact_map + ag_ty links_annot lag_p rag_p lag_c rag_c + in + aux links_annot' (ra :: acc) lt rt + | ((Ast.Present _ :: _ | []) as erased), added -> let () = if added <> [] then - List.iter (function + List.iter + (function | Ast.Absent _ -> () - | Ast.Present ((lag,pos),lag_p,_) -> - if List.exists + | Ast.Present ((lag, pos), lag_p, _) -> + if + List.exists (function | Ast.Absent _ -> false - | Ast.Present ((rag,_),rag_p,_) -> - String.compare lag rag = 0 && - Ast.no_more_site_on_right false lag_p rag_p) added then - warning ~pos - (fun f -> - Format.fprintf - f "Rule induced deletion AND creation of the agent %s" - lag)) - erased in - let mix,llinks = + | Ast.Present ((rag, _), rag_p, _) -> + String.compare lag rag = 0 + && Ast.no_more_site_on_right false lag_p rag_p) + added + then + warning ~pos (fun f -> + Format.fprintf f + "Rule induced deletion AND creation of the agent %s" lag)) + erased + in + let mix, llinks = List.fold_left - (fun (acc,lannot) -> function - | Ast.Absent pos -> - raise - (ExceptionDefn.Malformed_Decl - ("Absent agent are KaSim > 3 syntax",pos)) - | Ast.Present ((_,pos as na),sites,modif) -> - let () = LKappa.forbid_modification pos modif in - let intf,counts = separate_sites sites in - let ra,lannot' = annotate_dropped_agent - ~warning ~syntax_version ~r_editStyle:false - sigs lannot na intf counts in - (ra::acc,lannot')) - (acc,fst links_annot) erased in - let cmix,rlinks = + (fun (acc, lannot) -> function + | Ast.Absent pos -> + raise + (ExceptionDefn.Malformed_Decl + ("Absent agent are KaSim > 3 syntax", pos)) + | Ast.Present (((_, pos) as na), sites, modif) -> + raise_if_modification_agent pos modif; + let intf, counts = separate_sites sites in + let ra, lannot' = + annotate_dropped_agent ~warning ~syntax_version + ~r_edit_style:false sigs lannot na intf counts + in + ra :: acc, lannot') + (acc, fst links_annot) + erased + in + let cmix, rlinks = List.fold_left - (fun (acc,rannot) -> function - | Ast.Absent pos -> - raise - (ExceptionDefn.Malformed_Decl - ("Absent agent are KaSim > 3 syntax",pos)) - | Ast.Present ((_,pos as na),sites,modif) -> - let () = LKappa.forbid_modification pos modif in - let intf,counts = separate_sites sites in - let rannot',x' = annotate_created_agent - ~warning ~syntax_version ~r_editStyle:false sigs - ?contact_map rannot na intf in - let x'' = - Counters_compiler.annotate_created_counters - sigs na counts (add_link_contact_map ?contact_map) x' in - x''::acc,rannot') - ([],snd links_annot) added in - let () = final_rule_sanity ~warning sigs (llinks,rlinks) mix in - List.rev mix, List.rev cmix in + (fun (acc, rannot) -> function + | Ast.Absent pos -> + raise + (ExceptionDefn.Malformed_Decl + ("Absent agent are KaSim > 3 syntax", pos)) + | Ast.Present (((_, pos) as na), sites, modif) -> + raise_if_modification_agent pos modif; + let intf, counts = separate_sites sites in + let rannot', x' = + annotate_created_agent ~warning ~syntax_version + ~r_edit_style:false sigs ?contact_map rannot na intf + in + let x'' = + Counters_compiler.annotate_created_counters sigs na counts + (add_link_contact_map ?contact_map) + x' + in + x'' :: acc, rannot') + ([], snd links_annot) + added + in + let () = final_rule_sanity ~warning sigs (llinks, rlinks) mix in + List.rev mix, List.rev cmix + in aux - ((Mods.IntMap.empty,Mods.IntMap.empty),(Mods.IntMap.empty,Mods.IntMap.empty)) + ( (Mods.IntMap.empty, Mods.IntMap.empty), + (Mods.IntMap.empty, Mods.IntMap.empty) ) [] (List.flatten lhs) (List.flatten rhs) let annotate_lhs_with_diff_v4 ~warning sigs ?contact_map lhs rhs = let syntax_version = Ast.V4 in let rec aux links_annot mix cmix lhs rhs = - match lhs,rhs with - | [], [] -> - links_annot, mix, cmix - | Ast.Absent _::lt, Ast.Absent _:: rt -> aux links_annot mix cmix lt rt - | Ast.Present ((_,pos as ty),sites,lmod) :: lt, Ast.Absent _ :: rt -> - let () = LKappa.forbid_modification pos lmod in - let (intf,counts) = separate_sites sites in - let ra,lannot' = annotate_dropped_agent - ~warning ~syntax_version ~r_editStyle:false - sigs (fst links_annot) ty intf counts in - aux (lannot',snd links_annot) (ra::mix) cmix lt rt - | Ast.Absent _ :: lt, Ast.Present ((_,pos as ty),sites,rmod) :: rt -> - let () = LKappa.forbid_modification pos rmod in - let (intf,counts) = separate_sites sites in - let rannot',x' = annotate_created_agent - ~warning ~syntax_version ~r_editStyle:false sigs - ?contact_map (snd links_annot) ty intf in + match lhs, rhs with + | [], [] -> links_annot, mix, cmix + | Ast.Absent _ :: lt, Ast.Absent _ :: rt -> aux links_annot mix cmix lt rt + | Ast.Present (((_, pos) as ty), sites, lmod) :: lt, Ast.Absent _ :: rt -> + raise_if_modification_agent pos lmod; + let intf, counts = separate_sites sites in + let ra, lannot' = + annotate_dropped_agent ~warning ~syntax_version ~r_edit_style:false sigs + (fst links_annot) ty intf counts + in + aux (lannot', snd links_annot) (ra :: mix) cmix lt rt + | Ast.Absent _ :: lt, Ast.Present (((_, pos) as ty), sites, rmod) :: rt -> + raise_if_modification_agent pos rmod; + let intf, counts = separate_sites sites in + let rannot', x' = + annotate_created_agent ~warning ~syntax_version ~r_edit_style:false sigs + ?contact_map (snd links_annot) ty intf + in let x'' = - Counters_compiler.annotate_created_counters - sigs ty counts (add_link_contact_map ?contact_map) x' in - aux (fst links_annot,rannot') mix (x''::cmix) lt rt - | Ast.Present ((lag_na,lpos as ag_ty),lag_s,lmod)::lt, - Ast.Present ((rag_na,rpos),rag_s,rmod)::rt -> - if String.compare lag_na rag_na = 0 && - Ast.no_more_site_on_right true lag_s rag_s then - let () = LKappa.forbid_modification lpos lmod in - let () = LKappa.forbid_modification rpos rmod in - let (lag_p,lag_c) = separate_sites lag_s in - let (rag_p,rag_c) = separate_sites rag_s in - let ra,links_annot' = - annotate_agent_with_diff - ~warning ~syntax_version sigs ?contact_map - ag_ty links_annot lag_p rag_p lag_c rag_c in - aux links_annot' (ra::mix) cmix lt rt - else + Counters_compiler.annotate_created_counters sigs ty counts + (add_link_contact_map ?contact_map) + x' + in + aux (fst links_annot, rannot') mix (x'' :: cmix) lt rt + | ( Ast.Present (((lagent_name, lpos) as ag_ty), lag_s, lmod) :: lt, + Ast.Present ((ragent_name, rpos), rag_s, rmod) :: rt ) -> + if + String.compare lagent_name ragent_name = 0 + && Ast.no_more_site_on_right true lag_s rag_s + then ( + raise_if_modification_agent lpos lmod; + raise_if_modification_agent rpos rmod; + let lag_p, lag_c = separate_sites lag_s in + let rag_p, rag_c = separate_sites rag_s in + let ra, links_annot' = + annotate_agent_with_diff ~warning ~syntax_version sigs ?contact_map + ag_ty links_annot lag_p rag_p lag_c rag_c + in + aux links_annot' (ra :: mix) cmix lt rt + ) else raise (ExceptionDefn.Malformed_Decl - ("Left hand side/right hand side agent mismatch",rpos)) - | (Ast.Present ((_,pos),_,_) | Ast.Absent pos)::_, [] - | [], (Ast.Present ((_,pos),_,_) | Ast.Absent pos)::_ -> + ("Left hand side/right hand side agent mismatch", rpos)) + | (Ast.Present ((_, pos), _, _) | Ast.Absent pos) :: _, [] + | [], (Ast.Present ((_, pos), _, _) | Ast.Absent pos) :: _ -> raise (ExceptionDefn.Malformed_Decl - ("Left hand side/right hand side agent mismatch",pos)) + ("Left hand side/right hand side agent mismatch", pos)) in let rec aux_line links_annot mix cmix lhs rhs = match lhs, rhs with | [], [] -> let () = final_rule_sanity ~warning sigs links_annot mix in List.rev mix, List.rev cmix - | hl::tl, hr::tr -> - let (links_annot',mix', cmix') = aux links_annot mix cmix hl hr in + | hl :: tl, hr :: tr -> + let links_annot', mix', cmix' = aux links_annot mix cmix hl hr in aux_line links_annot' mix' cmix' tl tr - | ((Ast.Present ((_,pos),_,_) | Ast.Absent pos)::_)::_, [] - | [], ((Ast.Present ((_,pos),_,_) | Ast.Absent pos)::_)::_ -> + | ((Ast.Present ((_, pos), _, _) | Ast.Absent pos) :: _) :: _, [] + | [], ((Ast.Present ((_, pos), _, _) | Ast.Absent pos) :: _) :: _ -> raise (ExceptionDefn.Malformed_Decl - ("Left hand side/right hand side agent mismatch",pos)) - | []::_, [] - | [], []::_ -> + ("Left hand side/right hand side agent mismatch", pos)) + | [] :: _, [] | [], [] :: _ -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot "Invariant violation in annotate_lhs_with...")) + (Loc.annot_with_dummy "Invariant violation in annotate_lhs_with...")) in aux_line - ((Mods.IntMap.empty,Mods.IntMap.empty),(Mods.IntMap.empty,Mods.IntMap.empty)) + ( (Mods.IntMap.empty, Mods.IntMap.empty), + (Mods.IntMap.empty, Mods.IntMap.empty) ) [] [] lhs rhs let annotate_lhs_with_diff ~warning ~syntax_version sigs ?contact_map lhs rhs = @@ -814,185 +1033,211 @@ let annotate_lhs_with_diff ~warning ~syntax_version sigs ?contact_map lhs rhs = | Ast.V3 -> annotate_lhs_with_diff_v3 ~warning sigs ?contact_map lhs rhs | Ast.V4 -> annotate_lhs_with_diff_v4 ~warning sigs ?contact_map lhs rhs -let annotate_edit_mixture - ~warning ~syntax_version ~is_rule sigs ?contact_map m = - let links_annot,mix,cmix = +let annotate_edit_mixture ~warning ~syntax_version ~is_rule sigs ?contact_map + (m : Ast.mixture) : + Counters_compiler.rule_mixture_with_agent_counters + * Counters_compiler.raw_mixture_with_agent_counters = + (* mix is the mixture from initial state of the rule, cmix is the mixture after the rule was applied *) + let links_annot, mix, cmix = List.fold_left - (List.fold_left - (fun (lannot,acc,news) -> function - | Ast.Absent _ -> (lannot,acc,news) - | Ast.Present (ty,sites,modif) -> - let (intf,counts) = separate_sites sites in - match modif with - | None -> - let a,lannot' = annotate_edit_agent - ~warning ~syntax_version ~is_rule sigs - ?contact_map ty lannot intf counts in - (lannot',a::acc,news) - | Some Ast.Create -> - let rannot',x' = annotate_created_agent - ~warning ~syntax_version ~r_editStyle:true sigs - ?contact_map (snd lannot) ty intf in - let x'' = - Counters_compiler.annotate_created_counters - sigs ty counts (add_link_contact_map ?contact_map) x' in - ((fst lannot,rannot'),acc,x''::news) - | Some Ast.Erase -> - let ra,lannot' = annotate_dropped_agent - ~warning ~syntax_version ~r_editStyle:true sigs - (fst lannot) ty intf counts in - ((lannot',snd lannot),ra::acc,news))) - (((Mods.IntMap.empty,Mods.IntMap.empty), - (Mods.IntMap.empty,Mods.IntMap.empty)),[],[]) - m in - let () = final_rule_sanity ?warning:None sigs links_annot mix in - (List.rev mix, List.rev cmix) - -let annotate_created_mixture - ~warning ~syntax_version sigs ?contact_map m = - let (rhs_links_one,_),cmix = + (List.fold_left (fun (lannot, acc, news) -> function + | Ast.Absent _ -> lannot, acc, news + | Ast.Present (ty, sites, modif) -> + let intf, counts = separate_sites sites in + (match modif with + | Ast.NoMod -> + let a, lannot' = + annotate_edit_agent ~warning ~syntax_version ~is_rule sigs + ?contact_map ty lannot intf counts + in + lannot', a :: acc, news + | Ast.Create -> + let rannot', x' = + annotate_created_agent ~warning ~syntax_version + ~r_edit_style:true sigs ?contact_map (snd lannot) ty intf + in + let x'' = + Counters_compiler.annotate_created_counters sigs ty counts + (add_link_contact_map ?contact_map) + x' + in + (fst lannot, rannot'), acc, x'' :: news + | Ast.Erase -> + let ra, lannot' = + annotate_dropped_agent ~warning ~syntax_version + ~r_edit_style:true sigs (fst lannot) ty intf counts + in + (lannot', snd lannot), ra :: acc, news))) + ( ( (Mods.IntMap.empty, Mods.IntMap.empty), + (Mods.IntMap.empty, Mods.IntMap.empty) ), + [], + [] ) + m + in + final_rule_sanity ?warning:None sigs links_annot mix; + List.rev mix, List.rev cmix + +let annotate_created_mixture ~warning ~syntax_version sigs ?contact_map + (m : Ast.mixture) : + Raw_mixture.agent Counters_compiler.with_agent_counters list = + let (rhs_links_one, _), cmix = List.fold_left - (List.fold_left - (fun (rannot,news) -> function - | Ast.Absent pos -> - raise - (ExceptionDefn.Malformed_Decl - ("Absent agent cannot occurs in created mixtures",pos)) - | Ast.Present (ty,sites,_modif) -> - let (intf,counts) = separate_sites sites in - let rannot',x' = annotate_created_agent - ~warning ~syntax_version ~r_editStyle:true sigs - ?contact_map rannot ty intf in - let x'' = - Counters_compiler.annotate_created_counters - sigs ty counts (add_link_contact_map ?contact_map) x' in - (rannot',x''::news))) - ((Mods.IntMap.empty,Mods.IntMap.empty),[]) - m in + (List.fold_left (fun (rannot, news) -> function + | Ast.Absent pos -> + raise + (ExceptionDefn.Malformed_Decl + ("Absent agent cannot occurs in created mixtures", pos)) + | Ast.Present (ty, sites, _modif) -> + let intf, counts = separate_sites sites in + let rannot', x' = + annotate_created_agent ~warning ~syntax_version ~r_edit_style:true + sigs ?contact_map rannot ty intf + in + let x'' = + Counters_compiler.annotate_created_counters sigs ty counts + (add_link_contact_map ?contact_map) + x' + in + rannot', x'' :: news)) + ((Mods.IntMap.empty, Mods.IntMap.empty), []) + m + in let () = match Mods.IntMap.root rhs_links_one with | None -> () - | Some (i,(_,_,_,pos)) -> LKappa.link_only_one_occurence i pos in + | Some (i, (_, _, _, pos, _)) -> LKappa.raise_link_only_one_occurence i pos + in List.rev cmix -let give_rule_label bidirectional (id,set) printer r = function - | None -> - (succ id,set), Format.asprintf "r%i: %a" id printer r - | Some (lab,pos) -> +let give_rule_label bidirectional (id, set) printer r = function + | None -> (succ id, set), Format.asprintf "r%i: %a" id printer r + | Some (lab, pos) -> let set' = Mods.StringSet.add lab set in if set == set' then raise (ExceptionDefn.Malformed_Decl - ("A rule named '"^lab^"' already exists.",pos)) - else if bidirectional then - let set'' = - Mods.StringSet.add (Ast.flip_label lab) set' in + ("A rule named '" ^ lab ^ "' already exists.", pos)) + else if bidirectional then ( + let set'' = Mods.StringSet.add (Ast.flip_label lab) set' in if set' == set'' then raise (ExceptionDefn.Malformed_Decl - ("A rule named '"^Ast.flip_label lab^"' already exists.",pos)) - else (id,set''),lab - else (id,set'),lab - -let mixture_of_ast ~warning ~syntax_version sigs ?contact_map pos mix = - match annotate_edit_mixture - ~warning ~syntax_version ~is_rule:false sigs ?contact_map mix with - | r, [] -> fst (Counters_compiler.remove_counter_rule sigs r []) - | _, _ -> raise (ExceptionDefn.Internal_Error - ("A mixture cannot create agents",pos)) - -let raw_mixture_of_ast ~warning ~syntax_version sigs ?contact_map mix = + ("A rule named '" ^ Ast.flip_label lab ^ "' already exists.", pos)) + else + (id, set''), lab + ) else + (id, set'), lab + +let mixture_of_ast ~warning ~syntax_version sigs ?contact_map (pos : Loc.t) + (mix : Ast.mixture) = + match + annotate_edit_mixture ~warning ~syntax_version ~is_rule:false sigs + ?contact_map mix + with + | r, [] -> fst (Counters_compiler.compile_counter_in_rule sigs r []) + | _, _ -> + raise (ExceptionDefn.Internal_Error ("A mixture cannot create agents", pos)) + +let raw_mixture_of_ast ~warning ~syntax_version sigs ?contact_map + (mix : Ast.mixture) = let b = - annotate_created_mixture ~warning ~syntax_version sigs ?contact_map mix in - snd (Counters_compiler.remove_counter_rule sigs [] b) + annotate_created_mixture ~warning ~syntax_version sigs ?contact_map mix + in + snd (Counters_compiler.compile_counter_in_rule sigs [] b) let convert_alg_var ?max_allowed_var algs lab pos = let i = match Mods.StringMap.find_option lab algs with | Some x -> x | None -> - raise (ExceptionDefn.Malformed_Decl - (lab ^" is not a declared variable",pos)) in + raise + (ExceptionDefn.Malformed_Decl (lab ^ " is not a declared variable", pos)) + in let () = match max_allowed_var with | Some j when j < i -> - raise (ExceptionDefn.Malformed_Decl - ("Reference to not yet defined '"^lab ^"' is forbidden.", - pos)) + raise + (ExceptionDefn.Malformed_Decl + ("Reference to not yet defined '" ^ lab ^ "' is forbidden.", pos)) | None | Some _ -> () in i -let convert_token_name tk_nme tok pos = - match Mods.StringMap.find_option tk_nme tok with +let convert_token_name tk_name tok pos = + match Mods.StringMap.find_option tk_name tok with | Some x -> x | None -> - raise (ExceptionDefn.Malformed_Decl - (tk_nme ^ " is not a declared token",pos)) - -let rec alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var (alg,pos) = - ((match alg with - | Alg_expr.KAPPA_INSTANCE ast -> - Alg_expr.KAPPA_INSTANCE - (mixture_of_ast ~warning ~syntax_version sigs pos ast) - | Alg_expr.ALG_VAR lab -> - Alg_expr.ALG_VAR (convert_alg_var ?max_allowed_var algs lab pos) - | Alg_expr.TOKEN_ID tk_nme -> - Alg_expr.TOKEN_ID (convert_token_name tk_nme tok pos) - | Alg_expr.DIFF_KAPPA_INSTANCE(expr,ast) -> - Alg_expr.DIFF_KAPPA_INSTANCE - (alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var expr, - mixture_of_ast ~warning ~syntax_version sigs pos ast) - | Alg_expr.DIFF_TOKEN(expr,tk_nme) -> - Alg_expr.DIFF_TOKEN - (alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var expr, - convert_token_name tk_nme tok pos) - | (Alg_expr.STATE_ALG_OP _ | Alg_expr.CONST _) as x -> x - | Alg_expr.BIN_ALG_OP (op, a, b) -> - Alg_expr.BIN_ALG_OP - (op, - alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var a, - alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var b) - | Alg_expr.UN_ALG_OP (op,a) -> - Alg_expr.UN_ALG_OP - (op,alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var a) - | Alg_expr.IF (cond,yes,no) -> - Alg_expr.IF - (bool_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var cond, - alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var yes, - alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var no) - ), - pos) -and bool_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var = function - | (Alg_expr.TRUE | Alg_expr.FALSE),_ as x -> x - | Alg_expr.BIN_BOOL_OP (op,x,y),pos -> - Alg_expr.BIN_BOOL_OP - (op, bool_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var x, - bool_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var y), - pos - | Alg_expr.UN_BOOL_OP (op,x),pos -> - Alg_expr.UN_BOOL_OP - (op, bool_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var x), - pos - | Alg_expr.COMPARE_OP (op,x,y),pos -> - Alg_expr.COMPARE_OP - (op,alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var x, - alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var y),pos + raise + (ExceptionDefn.Malformed_Decl (tk_name ^ " is not a declared token", pos)) + +let rec alg_expr_of_ast ~warning ~syntax_version sigs tok algs ?max_allowed_var + (alg, pos) = + ( (match alg with + | Alg_expr.KAPPA_INSTANCE ast -> + Alg_expr.KAPPA_INSTANCE + (mixture_of_ast ~warning ~syntax_version sigs pos ast) + | Alg_expr.ALG_VAR lab -> + Alg_expr.ALG_VAR (convert_alg_var ?max_allowed_var algs lab pos) + | Alg_expr.TOKEN_ID tk_name -> + Alg_expr.TOKEN_ID (convert_token_name tk_name tok pos) + | Alg_expr.DIFF_KAPPA_INSTANCE (expr, ast) -> + Alg_expr.DIFF_KAPPA_INSTANCE + ( alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var expr, + mixture_of_ast ~warning ~syntax_version sigs pos ast ) + | Alg_expr.DIFF_TOKEN (expr, tk_name) -> + Alg_expr.DIFF_TOKEN + ( alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var expr, + convert_token_name tk_name tok pos ) + | (Alg_expr.STATE_ALG_OP _ | Alg_expr.CONST _) as x -> x + | Alg_expr.BIN_ALG_OP (op, a, b) -> + Alg_expr.BIN_ALG_OP + ( op, + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var a, + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var b ) + | Alg_expr.UN_ALG_OP (op, a) -> + Alg_expr.UN_ALG_OP + ( op, + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var a ) + | Alg_expr.IF (cond, yes, no) -> + Alg_expr.IF + ( bool_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var cond, + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var yes, + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var no )), + pos ) + +and bool_expr_of_ast ~warning ~syntax_version sigs tok algs ?max_allowed_var = + function + | ((Alg_expr.TRUE | Alg_expr.FALSE), _) as x -> x + | Alg_expr.BIN_BOOL_OP (op, x, y), pos -> + ( Alg_expr.BIN_BOOL_OP + ( op, + bool_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var x, + bool_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var y ), + pos ) + | Alg_expr.UN_BOOL_OP (op, x), pos -> + ( Alg_expr.UN_BOOL_OP + ( op, + bool_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var x ), + pos ) + | Alg_expr.COMPARE_OP (op, x, y), pos -> + ( Alg_expr.COMPARE_OP + ( op, + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var x, + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var y ), + pos ) let print_expr_of_ast ~warning ~syntax_version sigs tok algs = function | Primitives.Str_pexpr _ as x -> x @@ -1000,397 +1245,1132 @@ let print_expr_of_ast ~warning ~syntax_version sigs tok algs = function Primitives.Alg_pexpr (alg_expr_of_ast ~warning ~syntax_version sigs tok algs x) -let assemble_rule ~warning ~syntax_version ~r_editStyle - sigs tok algs r_mix r_created rm_tk add_tk rate un_rate = - let tks = - List.rev_map (fun (al,(tk,pos)) -> - (alg_expr_of_ast ~warning ~syntax_version sigs tok algs - (Locality.dummy_annot (Alg_expr.UN_ALG_OP (Operator.UMINUS,al))), - convert_token_name tk tok pos)) - rm_tk in - let tks' = - List_util.rev_map_append (fun (al,(tk,pos)) -> - (alg_expr_of_ast ~warning ~syntax_version sigs tok algs al, - convert_token_name tk tok pos)) - add_tk tks in - { LKappa.r_mix; r_created; r_editStyle; - r_delta_tokens = List.rev tks'; - r_rate = alg_expr_of_ast ~warning ~syntax_version sigs tok algs rate; - r_un_rate = - let r_dist d = - alg_expr_of_ast - ~warning ~syntax_version sigs tok algs ?max_allowed_var:None d in - Option_util.map - (fun (un_rate',dist) -> - let un_rate'' = - alg_expr_of_ast ~warning ~syntax_version sigs tok algs - ?max_allowed_var:None un_rate' in - match dist with - | Some d -> (un_rate'', Some (r_dist d)) - | None -> (un_rate'', None)) - un_rate; +type rule_inter_rep = { + label_opt: (string * Loc.t) option; + bidirectional: bool; (* TODO check *) + mixture: LKappa.rule_agent Counters_compiler.with_agent_counters list; + created_mix: Raw_mixture.agent Counters_compiler.with_agent_counters list; + rm_token: + (((Ast.mixture, string) Alg_expr.e * Loc.t) * (string * Loc.t)) list; + add_token: + (((Ast.mixture, string) Alg_expr.e * Loc.t) * (string * Loc.t)) list; + k_def: (Ast.mixture, string) Alg_expr.e * Loc.t; + k_un: + (((Ast.mixture, string) Alg_expr.e * Loc.t) + * ((Ast.mixture, string) Alg_expr.e * Loc.t) option) + option; + pos: Loc.t; +} +(** Intermediate representation for rule type *) + +(** [assemble_rule] translates a rule_inter_rep into a LKappa.rule *) +let assemble_rule ~warning ~syntax_version (rule : rule_inter_rep) + (sigs : Signature.s) (tok : int Mods.StringMap.t) + (algs : int Mods.StringMap.t) : LKappa.rule = + let (r_mix, r_created) : LKappa.rule_mixture * Raw_mixture.t = + Counters_compiler.compile_counter_in_rule sigs rule.mixture rule.created_mix + in + let r_delta_tokens = + List.rev_map + (fun (al, (tk, pos)) -> + ( alg_expr_of_ast ~warning ~syntax_version sigs tok algs + (Loc.annot_with_dummy (Alg_expr.UN_ALG_OP (Operator.UMINUS, al))), + convert_token_name tk tok pos )) + rule.rm_token + |> List_util.rev_map_append + (fun (al, (tk, pos)) -> + ( alg_expr_of_ast ~warning ~syntax_version sigs tok algs al, + convert_token_name tk tok pos )) + rule.add_token + |> List.rev + in + let r_rate = + alg_expr_of_ast ~warning ~syntax_version sigs tok algs rule.k_def + in + let r_un_rate = + let r_dist d = + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var:None d + in + Option_util.map + (fun (un_rate', dist) -> + let un_rate'' = + alg_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var:None un_rate' + in + match dist with + | Some d -> un_rate'', Some (r_dist d) + | None -> un_rate'', None) + rule.k_un + in + { + LKappa.r_mix; + r_created; + r_edit_style = rule.bidirectional; + r_delta_tokens; + r_rate; + r_un_rate; } -let modif_expr_of_ast - ~warning ~syntax_version sigs tok algs contact_map modif acc = +let modif_expr_of_ast ~warning ~syntax_version sigs tok algs contact_map modif + acc = match modif with - | Ast.APPLY(nb,(r,pos)) -> - let (mix,cmix),rm_tok,add_tok,r_editStyle = - match r.Ast.rewrite with - | Ast.Edit e -> - annotate_edit_mixture - ~warning ~syntax_version:Ast.V4 ~is_rule:true - sigs ~contact_map e.Ast.mix, - [],e.Ast.delta_token,true - | Ast.Arrow a -> - annotate_lhs_with_diff - ~warning ~syntax_version sigs ~contact_map a.Ast.lhs a.Ast.rhs, - a.Ast.rm_token,a.Ast.add_token,false in - let mix,cmix = Counters_compiler.remove_counter_rule sigs mix cmix in - Ast.APPLY - (alg_expr_of_ast ~warning ~syntax_version sigs tok algs nb, - (assemble_rule - ~warning ~syntax_version ~r_editStyle - sigs tok algs mix cmix rm_tok add_tok - r.Ast.k_def r.Ast.k_un,pos)), - acc - | Ast.UPDATE ((lab,pos),how) -> + | Ast.APPLY (nb, (ast_rule, pos)) -> + let rule : rule_inter_rep = + match ast_rule.Ast.rewrite with + | Ast.Edit rule_content -> + let mixture, created_mix = + annotate_edit_mixture ~warning ~syntax_version:Ast.V4 ~is_rule:true + sigs ~contact_map rule_content.mix + in + { + label_opt = None; + bidirectional = true; + mixture; + created_mix; + rm_token = []; + add_token = rule_content.delta_token; + k_def = ast_rule.k_def; + k_un = ast_rule.k_un; + pos; + } + | Ast.Arrow rule_content -> + let mixture, created_mix = + annotate_lhs_with_diff ~warning ~syntax_version sigs ~contact_map + rule_content.lhs rule_content.rhs + in + { + label_opt = None; + bidirectional = false; + mixture; + created_mix; + rm_token = rule_content.rm_token; + add_token = rule_content.add_token; + k_def = ast_rule.k_def; + k_un = ast_rule.k_un; + pos; + } + in + ( Ast.APPLY + ( alg_expr_of_ast ~warning ~syntax_version sigs tok algs nb, + (assemble_rule ~warning ~syntax_version rule sigs tok algs, pos) ), + acc ) + | Ast.UPDATE ((lab, pos), how) -> let i = - match Mods.StringMap.find_option lab algs with - | Some i -> i - | None -> - raise (ExceptionDefn.Malformed_Decl - ("Variable " ^ (lab ^ " is not defined"),pos)) in - Ast.UPDATE - ((i,pos), - alg_expr_of_ast ~warning ~syntax_version sigs tok algs how), - i::acc + Option_util.unsome_or_raise + ~excep: + (ExceptionDefn.Malformed_Decl + ("Variable " ^ lab ^ " is not defined", pos)) + (Mods.StringMap.find_option lab algs) + in + ( Ast.UPDATE + ((i, pos), alg_expr_of_ast ~warning ~syntax_version sigs tok algs how), + i :: acc ) | Ast.STOP p -> - Ast.STOP - (List.map - (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p),acc - | Ast.SNAPSHOT (raw,p) -> - Ast.SNAPSHOT - (raw, - List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p), - acc - | Ast.DIN (rel,p) -> - Ast.DIN - (rel, - List.map - (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p),acc + ( Ast.STOP + (List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p), + acc ) + | Ast.SNAPSHOT (raw, p) -> + ( Ast.SNAPSHOT + ( raw, + List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p + ), + acc ) + | Ast.DIN (rel, p) -> + ( Ast.DIN + ( rel, + List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p + ), + acc ) | Ast.DINOFF p -> - Ast.DINOFF - (List.map - (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p),acc - | (Ast.PLOTENTRY | Ast.CFLOWLABEL (_,_ ) as x) -> x,acc - | Ast.PRINT (p,p') -> - Ast.PRINT - (List.map - (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p, - List.map - (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p'), - acc - | Ast.CFLOWMIX (b,(m,pos)) -> - Ast.CFLOWMIX - (b,(mixture_of_ast ~warning ~syntax_version sigs pos m,pos)),acc - | Ast.SPECIES_OF (b,p,(m,pos)) -> - Ast.SPECIES_OF - (b,List.map - (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p, - (mixture_of_ast ~warning ~syntax_version sigs pos m,pos)),acc - -let perturbation_of_ast - ~warning ~syntax_version sigs tok algs contact_map - ((alarm,pre,mods,post),pos) up_vars = - let mods',up_vars' = + ( Ast.DINOFF + (List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p), + acc ) + | (Ast.PLOTENTRY | Ast.CFLOWLABEL (_, _)) as x -> x, acc + | Ast.PRINT (p, p') -> + ( Ast.PRINT + ( List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p, + List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p' + ), + acc ) + | Ast.CFLOWMIX (b, (m, pos)) -> + ( Ast.CFLOWMIX (b, (mixture_of_ast ~warning ~syntax_version sigs pos m, pos)), + acc ) + | Ast.SPECIES_OF (b, p, (m, pos)) -> + ( Ast.SPECIES_OF + ( b, + List.map (print_expr_of_ast ~warning ~syntax_version sigs tok algs) p, + (mixture_of_ast ~warning ~syntax_version sigs pos m, pos) ), + acc ) + +let perturbation_of_ast ~warning ~syntax_version sigs tok algs contact_map + ((alarm, pre, mods, post), pos) up_vars : + (_, _, _, _) Ast.perturbation * int list = + let mods', up_vars' = List_util.fold_right_map (modif_expr_of_ast ~warning ~syntax_version sigs tok algs contact_map) - mods up_vars in + mods up_vars + in let max_allowed_var = None in - ((alarm, - Option_util.map - (bool_expr_of_ast ~warning ~syntax_version sigs tok algs ?max_allowed_var) - pre,mods', - Option_util.map - (bool_expr_of_ast ~warning ~syntax_version sigs tok algs ?max_allowed_var) - post),pos), - up_vars' + ( ( ( alarm, + Option_util.map + (bool_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var) + pre, + mods', + Option_util.map + (bool_expr_of_ast ~warning ~syntax_version sigs tok algs + ?max_allowed_var) + post ), + pos ), + up_vars' ) let init_of_ast ~warning ~syntax_version sigs tok contact_map = function - | Ast.INIT_MIX (who,pos) -> + | Ast.INIT_MIX (who, pos) -> Ast.INIT_MIX - (raw_mixture_of_ast ~warning ~syntax_version sigs ~contact_map who,pos) + (raw_mixture_of_ast ~warning ~syntax_version sigs ~contact_map who, pos) | Ast.INIT_TOK lab -> Ast.INIT_TOK - (List.map (fun (lab,pos) -> + (List.map + (fun (lab, pos) -> match Mods.StringMap.find_option lab tok with - | Some x -> x,pos + | Some x -> x, pos | None -> - raise (ExceptionDefn.Malformed_Decl - (lab ^" is not a declared token",pos))) - lab) + raise + (ExceptionDefn.Malformed_Decl + (lab ^ " is not a declared token", pos))) + lab) let add_un_variable k_un acc rate_var = match k_un with - | None -> (acc,None) - | Some (k,dist) -> - let acc_un,k' = if Alg_expr.has_mix (fst k) then - ((Locality.dummy_annot rate_var,k)::acc, - Locality.dummy_annot (Alg_expr.ALG_VAR rate_var)) - else (acc,k) in - (acc_un,Some (k',dist)) - -let name_and_purify_rule - ~warning ~syntax_version - sigs ~contact_map (pack,acc,rules) (label_opt,(r,r_pos)) = - let pack',label = give_rule_label - r.Ast.bidirectional pack Ast.print_ast_rule r label_opt in - let acc',k_def = - if Alg_expr.has_mix (fst r.Ast.k_def) then - let rate_var = label^"_rate" in - ((Locality.dummy_annot rate_var,r.Ast.k_def)::acc, - Locality.dummy_annot (Alg_expr.ALG_VAR rate_var)) - else (acc,r.Ast.k_def) in - let acc'',k_un = add_un_variable r.Ast.k_un acc' (label^"_un_rate") in - match r.Ast.rewrite with + | None -> acc, None + | Some (k, dist) -> + let acc_un, k' = + if Alg_expr.has_mix (Loc.v k) then + ( (Loc.annot_with_dummy rate_var, k) :: acc, + Loc.annot_with_dummy (Alg_expr.ALG_VAR rate_var) ) + else + acc, k + in + acc_un, Some (k', dist) + +type acc_function_rules = { + rule_names: int * Mods.StringSet.t; + extra_vars: + (string Loc.annoted * (Ast.mixture, string) Alg_expr.e Loc.annoted) list; + cleaned_rules: rule_inter_rep list; +} + +(** [name_and_purify] is called in a fold while compiling the rules from Ast.rules into rule_inter_rep *) +let name_and_purify_rule ~warning ~syntax_version sigs ~contact_map + (acc : acc_function_rules) + ((label_opt, (ast_rule, r_pos)) : + string Loc.annoted option * Ast.rule Loc.annoted) : acc_function_rules = + let rule_names', rule_label = + give_rule_label ast_rule.bidirectional acc.rule_names Ast.print_ast_rule + ast_rule label_opt + in + let acc', k_def = + if Alg_expr.has_mix (Loc.v ast_rule.k_def) then ( + let rate_var = rule_label ^ "_rate" in + ( (Loc.annot_with_dummy rate_var, ast_rule.k_def) :: acc.extra_vars, + Loc.annot_with_dummy (Alg_expr.ALG_VAR rate_var) ) + ) else + acc.extra_vars, ast_rule.Ast.k_def + in + let acc'', k_un = + add_un_variable ast_rule.k_un acc' (rule_label ^ "_un_rate") + in + match ast_rule.rewrite with | Ast.Edit e -> - let () = - if r.Ast.bidirectional || r.Ast.k_op <> None || r.Ast.k_op_un <> None then - raise - (ExceptionDefn.Malformed_Decl - ("Rules in edit notation cannot be bidirectional",r_pos)) in - let mix,created = annotate_edit_mixture - ~warning ~syntax_version ~is_rule:true sigs ~contact_map e.Ast.mix in - (pack',acc'', - (label_opt,true,mix,created,[],e.Ast.delta_token,k_def,k_un,r_pos)::rules) + if + ast_rule.bidirectional || ast_rule.k_op <> None + || ast_rule.k_op_un <> None + then + raise + (ExceptionDefn.Malformed_Decl + ("Rules in edit notation cannot be bidirectional", r_pos)); + let mixture, created_mix = + annotate_edit_mixture ~warning ~syntax_version ~is_rule:true sigs + ~contact_map e.Ast.mix + in + { + rule_names = rule_names'; + extra_vars = acc''; + cleaned_rules = + { + label_opt; + bidirectional = true; + mixture; + created_mix; + rm_token = []; + add_token = e.Ast.delta_token; + k_def; + k_un; + pos = r_pos; + } + :: acc.cleaned_rules; + } | Ast.Arrow a -> - let mix,created = - annotate_lhs_with_diff - ~warning ~syntax_version sigs ~contact_map a.Ast.lhs a.Ast.rhs in + let mixture, created_mix = + annotate_lhs_with_diff ~warning ~syntax_version sigs ~contact_map + a.Ast.lhs a.Ast.rhs + in let rules' = - (label_opt,false,mix,created, - a.Ast.rm_token,a.Ast.add_token,k_def,k_un,r_pos) - ::rules in - let acc''',rules'' = - match r.Ast.bidirectional,r.Ast.k_op with - | true, Some k when Alg_expr.has_mix (fst k) -> - let rate_var = (Ast.flip_label label)^"_rate" in - let rate_var_un = (Ast.flip_label label)^"_un_rate" in - let acc_un, k_op_un = add_un_variable r.Ast.k_op_un acc'' rate_var_un in - let mix,created = - annotate_lhs_with_diff - ~warning ~syntax_version sigs ~contact_map a.Ast.rhs a.Ast.lhs in - ((Locality.dummy_annot rate_var,k)::acc_un, - (Option_util.map (fun (l,p) -> (Ast.flip_label l,p)) label_opt, - false,mix,created,a.Ast.add_token,a.Ast.rm_token, - Locality.dummy_annot (Alg_expr.ALG_VAR rate_var), - k_op_un,r_pos)::rules') + { + label_opt; + bidirectional = false; + mixture; + created_mix; + rm_token = a.Ast.rm_token; + add_token = a.Ast.add_token; + k_def; + k_un; + pos = r_pos; + } + :: acc.cleaned_rules + in + let acc''', rules'' = + match ast_rule.bidirectional, ast_rule.k_op with + | true, Some k when Alg_expr.has_mix (Loc.v k) -> + let rate_var = Ast.flip_label rule_label ^ "_rate" in + let rate_var_un = Ast.flip_label rule_label ^ "_un_rate" in + let acc_un, k_op_un = + add_un_variable ast_rule.k_op_un acc'' rate_var_un + in + let mixture, created_mix = + annotate_lhs_with_diff ~warning ~syntax_version sigs ~contact_map + a.Ast.rhs a.Ast.lhs + in + ( (Loc.annot_with_dummy rate_var, k) :: acc_un, + { + label_opt = + Option_util.map (fun (l, p) -> Ast.flip_label l, p) label_opt; + bidirectional = false; + mixture; + created_mix; + rm_token = a.Ast.add_token; + add_token = a.Ast.rm_token; + k_def = Loc.annot_with_dummy (Alg_expr.ALG_VAR rate_var); + k_un = k_op_un; + pos = r_pos; + } + :: rules' ) | true, Some rate -> - let rate_var_un = (Ast.flip_label label)^"_un_rate" in - let acc_un, k_op_un = add_un_variable r.Ast.k_op_un acc'' rate_var_un in - let mix,created = - annotate_lhs_with_diff - ~warning ~syntax_version sigs ~contact_map a.Ast.rhs a.Ast.lhs in - (acc_un, - (Option_util.map (fun (l,p) -> (Ast.flip_label l,p)) label_opt, - false,mix,created,a.Ast.add_token,a.Ast.rm_token, - rate,k_op_un,r_pos)::rules') - | false, None -> (acc'',rules') - | (false, Some _ | true, None) -> + let rate_var_un = Ast.flip_label rule_label ^ "_un_rate" in + let acc_un, k_op_un = + add_un_variable ast_rule.k_op_un acc'' rate_var_un + in + let mixture, created_mix = + annotate_lhs_with_diff ~warning ~syntax_version sigs ~contact_map + a.Ast.rhs a.Ast.lhs + in + ( acc_un, + { + label_opt = + Option_util.map (fun (l, p) -> Ast.flip_label l, p) label_opt; + bidirectional = false; + mixture; + created_mix; + rm_token = a.Ast.add_token; + add_token = a.Ast.rm_token; + k_def = rate; + k_un = k_op_un; + pos = r_pos; + } + :: rules' ) + | false, None -> acc'', rules' + | false, Some _ | true, None -> raise (ExceptionDefn.Malformed_Decl - ("Incompatible arrow and kinectic rate for inverse definition", - r_pos)) in - (pack',acc''',rules'') + ( "Incompatible arrow and kinectic rate for inverse definition", + r_pos )) + in + { rule_names = rule_names'; extra_vars = acc'''; cleaned_rules = rules'' } + +type site_sig_with_links_as_lists = + (string Loc.annoted * string Loc.annoted) list Signature.site_sig +(** Temporary type to store site signature with list links instead of array array links *) -let create_t sites incr_info = - let (aux,counters) = +(** [prepare_agent_sig ~sites evaluates to (site_sigs, counter_list) which describe data that can be used to create a Signature.t for a single agent*) +let prepare_agent_sig ~(sites : Ast.site list) : + site_sig_with_links_as_lists NamedDecls.t * string Loc.annoted list = + let ( (site_sigs_pre_nameddecls : + (string Loc.annoted * site_sig_with_links_as_lists) list), + (counter_names : string Loc.annoted list) ) = List.fold_right - (fun site (acc,counts) -> - match site with - | Ast.Port p -> - (p.Ast.port_nme, - (NamedDecls.create - (Tools.array_map_of_list - (function - | Some x,pos -> ((x,pos),()) - | None, pos -> + (fun site (acc_site_sigs, acc_counter_names) -> + match site with + (* TODO see if can remove Ast here *) + | Ast.Port p -> + ( ( p.port_name, + { + Signature.internal_state = + NamedDecls.create + (Tools.array_map_of_list + (function + | Some x, pos -> (x, pos), () + | None, pos -> + raise + (ExceptionDefn.Malformed_Decl + ( "Forbidden internal state inside signature \ + definition", + pos ))) + p.port_int); + links = + Some + (List.fold_left + (fun acc_links' -> function + | ( (LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_ANY), + _ ) -> + acc_links' + | (LKappa.LNK_SOME | LKappa.LNK_VALUE _), pos -> + raise + (ExceptionDefn.Malformed_Decl + ( "Forbidden link status inside signature \ + definition", + pos )) + | LKappa.LNK_TYPE (a, b), _ -> (a, b) :: acc_links') + [] p.port_link); + counters_info = None; + } ) + :: acc_site_sigs, + acc_counter_names ) + | Counter c -> + (* We are reading here a signature, only CEQ tests are accepted *) + (match c.counter_test with + | None -> + let n, pos = c.counter_name in + raise + (ExceptionDefn.Internal_Error + ("Counter " ^ n ^ " should have a test in signature", pos)) + | Some (test, pos) -> + (match test with + | CVAR _ -> + raise + (ExceptionDefn.Internal_Error + ("Counter should not have a var in signature", pos)) + | CGTE _ -> + raise + (ExceptionDefn.Internal_Error + ("Counter should not have >= in signature", pos)) + | CLTE _ -> + raise + (ExceptionDefn.Internal_Error + ("Counter should not have <= in signature", pos)) + | CEQ j -> + ( ( c.counter_name, + { + internal_state = NamedDecls.create [||]; + (* Agent with counter can link to port [b] on counter agent [__counter_agent] *) + links = + Some + [ + ( Loc.annot_with_dummy "b", + Loc.annot_with_dummy "__counter_agent" ); + ]; + counters_info = Some (j, Loc.v c.counter_delta); + } ) + :: acc_site_sigs, + c.counter_name :: acc_counter_names )))) + sites ([], []) + in + NamedDecls.create_from_list site_sigs_pre_nameddecls, counter_names + +(** [make_counter_agent_site_sigs counters_per_agent] evaluates to + (counter_agent_name, site_sigs_counter_agent) which describe the counter + agent and its site signatures with possible links to other agents. + [counter_info] associates each agent to a list of counter ports, one for each defined counter *) +let make_counter_agent_site_sigs + (counters_per_agent : ((string * Loc.t) * (string * Loc.t) list) list) : + (string * Loc.t) + * ((string * Loc.t) * (string * Loc.t)) list Signature.site_sig NamedDecls.t + = + let counter_agent_name = "__counter_agent", Loc.dummy in + let a_port_name = "a", Loc.dummy in + (* after port *) + let b_port_name = "b", Loc.dummy in + + (* before port *) + + (* Port [a] can link to port b of agent of type counter agent *) + let a_port_sig = + { + Signature.internal_state = NamedDecls.create [||]; + links = Some [ b_port_name, counter_agent_name ]; + counters_info = None; + } + in + (* Port [b] can link to port a of agent of type counter agent + * OR for each agent [agent_name] with counters, to their ports + * [agent_counter_port_name] *) + let b_links = + List.fold_right + (fun (agent_name, counters_from_agent) acc -> + List.map + (fun agent_counter_port_name -> agent_counter_port_name, agent_name) + counters_from_agent + @ acc) + counters_per_agent + [ a_port_name, counter_agent_name ] + in + let b_port_sig = + { + Signature.internal_state = NamedDecls.create [||]; + links = Some b_links; + counters_info = None; + } + in + let site_sigs_counter_agent = + NamedDecls.create [| a_port_name, a_port_sig; b_port_name, b_port_sig |] + in + counter_agent_name, site_sigs_counter_agent + +let agent_sigs_of_agent_sigs_with_links_as_lists ~(build_contact_map : bool) + (agent_sigs_pre : site_sig_with_links_as_lists NamedDecls.t NamedDecls.t) : + Signature.t NamedDecls.t = + let size_sigs = NamedDecls.size agent_sigs_pre in + NamedDecls.mapi + (fun ag_id ag_name -> + NamedDecls.map (fun site_name_ag1 site_sig -> + if not build_contact_map then + { site_sig with Signature.links = None } + else ( + (* Update links *) + (* TODO improve comment above *) + let site_links = + Array.init (size_sigs - ag_id) (fun i -> + Array.make + (NamedDecls.size + (NamedDecls.elt_val agent_sigs_pre (i + ag_id))) + false) + in + List.iter + (fun (((site_name_ag2, pos) as site_name), ((ag2_name, _) as ag)) -> + let ag2_id = NamedDecls.elt_id ~kind:"ag" agent_sigs_pre ag in + let site_id = + NamedDecls.elt_id ~kind:"site name" + (NamedDecls.elt_val agent_sigs_pre ag2_id) + site_name + in + if ag2_id >= ag_id then + site_links.(ag2_id - ag_id).(site_id) <- true; + let should_raise_for_missing_link = + not + (List.exists + (fun ((x, _), (y, _)) -> + x = site_name_ag1 && y = ag_name) + ((NamedDecls.elt_val + (NamedDecls.elt_val agent_sigs_pre ag2_id) + site_id) + .links |> Option_util.unsome_or_raise)) + in + if should_raise_for_missing_link then + raise + (ExceptionDefn.Malformed_Decl + ( Format.asprintf "No link to %s.%s from %s.%s." + site_name_ag1 ag_name site_name_ag2 ag2_name, + pos ))) + (Option_util.unsome_or_raise site_sig.links); + { site_sig with Signature.links = Some site_links } + ))) + agent_sigs_pre + +let create_sigs (l : Ast.agent list) : Signature.s = + (* Contact map should be built only if a specific link is described in the definition of signature *) + let build_contact_map : bool = + List.fold_left + (fun acc0 -> function + | Ast.Absent pos -> + raise + (ExceptionDefn.Malformed_Decl + ("Absent agent are forbidden in signature", pos)) + | Ast.Present (_, sites, _) -> + List.fold_left + (fun acc1 site -> + match site with + | Ast.Counter _ -> acc1 + | Ast.Port p -> + List.fold_left + (fun acc2 -> function + | (LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_ANY), _ -> + acc2 + | (LKappa.LNK_SOME | LKappa.LNK_VALUE _), pos -> raise (ExceptionDefn.Malformed_Decl - ("Forbidden internal state inside signature definition",pos)) - ) p.Ast.port_int), - List.fold_left - (fun acc' -> function - | (LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_ANY), _ -> acc' - | (LKappa.LNK_SOME | LKappa.LNK_VALUE _), pos -> - raise - (ExceptionDefn.Malformed_Decl - ("Forbidden link status inside signature definition", - pos)) - | LKappa.LNK_TYPE (a,b), _ -> (a,b) :: acc') - [] p.Ast.port_lnk, - None))::acc,counts - | Ast.Counter c -> - match c.Ast.count_test with - | None -> - let (n,pos) = c.Ast.count_nme in - raise (ExceptionDefn.Internal_Error - ("Counter "^n^" should have a test in signature",pos)) - | Some (test,pos) -> - match test with - | Ast.CVAR _ -> - raise (ExceptionDefn.Internal_Error - ("Counter should not have a var in signature",pos)) - | Ast.CGTE _ -> - raise (ExceptionDefn.Internal_Error - ("Counter should not have >= in signature",pos)) - | Ast.CEQ j -> - (c.Ast.count_nme, - (NamedDecls.create [||], - [incr_info], - Some (j,(fst c.Ast.count_delta))))::acc, - c.Ast.count_nme::counts) - sites ([],[]) in - NamedDecls.create (Array.of_list aux),counters - -let create_sig l = - let with_contact_map = - List.fold_left - (fun contact -> function - | Ast.Absent pos -> - raise - (ExceptionDefn.Malformed_Decl - ("Absent agent are forbidden in signature",pos)) - | Ast.Present (_,sites,_) -> - List.fold_left - (fun contact' site -> - match site with - | Ast.Counter _ -> contact' - | Ast.Port p -> - contact'|| - List.fold_left (fun acc -> function - | (LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_ANY), _ -> acc - | (LKappa.LNK_SOME | LKappa.LNK_VALUE _), pos -> - raise - (ExceptionDefn.Malformed_Decl - ("Forbidden link status inside a definition of signature", - pos)) - | LKappa.LNK_TYPE (_,_), _ -> true) false p.Ast.port_lnk) - contact sites) - false l in - let annot = Locality.dummy in - let (sigs,counters) = + ( "Forbidden link status inside a definition of \ + signature", + pos )) + | LKappa.LNK_TYPE (_, _), _ -> true) + acc1 p.Ast.port_link) + acc0 sites) + false l + in + + let ( (sigs_with_links_as_lists : + (string Loc.annoted * site_sig_with_links_as_lists NamedDecls.t) list), + (counters_per_agent : + (string Loc.annoted * string Loc.annoted list) list) ) = List.fold_right - (fun ag (acc,counters) -> - match ag with - | Ast.Absent _ -> (acc,counters) - | Ast.Present (name,sites,_) -> - let (lnks,counters_ag) = - create_t sites (("b",annot),("__incr",annot)) in - let counters' = if counters_ag = [] then counters - else (name,counters_ag)::counters in - ((name,lnks)::acc,counters')) - l ([],[]) in - Signature.create ~counters with_contact_map sigs + (fun agent (acc_sigs, acc_counters_per_agent) -> + match agent with + | Ast.Absent _ -> acc_sigs, acc_counters_per_agent + | Ast.Present (agent_name, sites, _) -> + let site_sigs_nd, counters_agent = prepare_agent_sig ~sites in + let counters' = + if counters_agent = [] then + acc_counters_per_agent + else + (agent_name, counters_agent) :: acc_counters_per_agent + in + (agent_name, site_sigs_nd) :: acc_sigs, counters') + l ([], []) + in + + let agent_sigs : Signature.t NamedDecls.t = + (if counters_per_agent = [] then + sigs_with_links_as_lists + else + make_counter_agent_site_sigs counters_per_agent + :: sigs_with_links_as_lists) + |> NamedDecls.create_from_list + |> agent_sigs_of_agent_sigs_with_links_as_lists ~build_contact_map + in + + (* TODO see agent_sigs namings *) + Signature.create ~counters_per_agent agent_sigs let init_of_ast ~warning ~syntax_version sigs contact_map tok algs inits = - List.map (fun (expr,ini) -> - alg_expr_of_ast ~warning ~syntax_version sigs tok algs expr, - init_of_ast ~warning ~syntax_version sigs tok contact_map ini) + List.map + (fun (expr, ini) -> + ( alg_expr_of_ast ~warning ~syntax_version sigs tok algs expr, + init_of_ast ~warning ~syntax_version sigs tok contact_map ini )) inits -let compil_of_ast ~warning ~debugMode ~syntax_version overwrite c = - let (c,with_counters) = - Counters_compiler.compile ~warning ~debugMode c in - let c = - if c.Ast.signatures = [] && c.Ast.tokens = [] - then - if with_counters then - raise (ExceptionDefn.Malformed_Decl - ("implicit signature is incompatible with counters", - Locality.dummy)) - else Ast.implicit_signature c - else c in - let sigs = create_sig c.Ast.signatures in - let contact_map = - Array.init - (Signature.size sigs) - (fun i -> Array.init (Signature.arity sigs i) - (fun s -> (Tools.recti - (fun a k -> Mods.IntSet.add k a) Mods.IntSet.empty - (Signature.internal_states_number i s sigs), - Mods.Int2Set.empty))) in - let ((_,rule_names),extra_vars,cleaned_rules) = +type ast_compiled_data = { + agents_sig: Signature.s; + contact_map: Contact_map.t; + token_names: unit NamedDecls.t; + alg_vars_finder: int Mods.StringMap.t; + updated_alg_vars: int list; + result: + (Ast.agent, LKappa.rule_mixture, Raw_mixture.t, int, LKappa.rule) Ast.compil; + (** Compiled data where identifiers are i Ast.compil where identifiers + * are integers and not string, syntactic sugar on rules are expansed + * (syntactic sugar on mixture are not) *) +} + +(** Evaluates to a ast_compil where clte tests have been changed to cgte tests. + * For this, for each counter where a CLTE test is present, whose values are in [\[a, b\]], initialized at [i] and add a new counter belonging in [a, b] initialized at [a+b-i]. + * Each test [> value] is then translated into a test to the "inverted" counter as [< a+b-value]. + * Each delta [+ delta] is translated into a [- delta] *) +let translate_clte_into_cgte (ast_compil : Ast.parsing_compil) = + let counter_fold (f : 'a list -> string -> Ast.counter -> 'a list) : 'a list = List.fold_left - (name_and_purify_rule ~warning ~syntax_version sigs ~contact_map) - ((0,Mods.StringSet.empty),[],[]) c.Ast.rules in - let overwrite_overwritten = - List.fold_left (fun (over,acc) ((x,_),_ as e) -> - match List.partition (fun (x',_) -> x = x') over with - | [], over' -> (over',e::acc) - | [ x,v ], over' -> - (over',(Locality.dummy_annot x,Alg_expr.const v)::acc) - | (x,_)::_::_, _ -> - raise (ExceptionDefn.Malformed_Decl - ("variable '"^x^"' is overwritten more than once", - Locality.dummy))) in - let overwrite',rev_algs = - overwrite_overwritten - (overwrite_overwritten (overwrite,[]) c.Ast.variables) extra_vars in - let alg_vars_over = + (fun acc1 rule_def -> + let rule : Ast.rule = rule_def |> snd |> Loc.v in + match rule.rewrite with + | Ast.Edit _ -> acc1 (* no counter test allowed in edit rule *) + | Ast.Arrow content -> + List.fold_left + (fun acc2 agent_list -> + List.fold_left + (fun acc3 agent -> + match agent with + | Ast.Absent _ -> acc3 + | Ast.Present (agent_name, site_list, _) -> + List.fold_left + (fun acc4 site -> + match site with + | Ast.Port _ -> acc4 + | Counter counter -> f acc4 (Loc.v agent_name) counter) + acc3 site_list) + acc2 agent_list) + acc1 content.lhs) + [] ast_compil.rules + in + + let inverted_counter_suffix = "__inverted" in + let inverted_counter_name (name : string) : string = + name ^ inverted_counter_suffix + in + + (* Find counters that have CLTE tests, and build list: agent_name, counter_name, sum_bounds_ref list. + * sum_bounds_ref is then filled when reading the signature and used to specify for inverted counter init value or test value as [sum_bounds_ref - value] *) + let counters_with_clte_tests : (string * string * int ref) list = + counter_fold (fun acc agent_name counter -> + let counter_name = Loc.v counter.counter_name in + (* Forbid prefix to avoid nonsense in counter definition *) + if String.ends_with ~suffix:inverted_counter_suffix counter_name then + raise + (ExceptionDefn.Malformed_Decl + ( "cannot end counter name by \"" ^ inverted_counter_suffix ^ "\"", + Loc.get_annot counter.counter_name )); + (* Return counter name along with matching agent_name *) + match Option_util.map Loc.v counter.counter_test with + | Some (Ast.CLTE _) -> + if + List.exists + (fun (agent_name2, counter_name2, _) -> + String.equal agent_name agent_name2 + && String.equal counter_name counter_name2) + acc + then + acc + else + (agent_name, counter_name, ref 0) :: acc + | Some (Ast.CEQ _) | Some (Ast.CGTE _) | Some (Ast.CVAR _) | None -> acc) + in + + (* Create opposite counters that have the same tests *) + let signatures : Ast.agent list = + List.map + (fun agent -> + match agent with + | Ast.Absent _ -> agent + | Present (agent_name_, site_list, agent_mod) -> + let agent_name = Loc.v agent_name_ in + let counters_with_clte_tests_from_agent : + (string * string * int ref) list = + List.filter + (fun (agent_name_counter, _, _) -> + agent_name = agent_name_counter) + counters_with_clte_tests + in + let new_counter_sites : Ast.site list = + List.fold_left + (fun acc (_, counter_name, sum_bounds_ref) -> + (* Find counter to invert *) + let counter_orig : Ast.counter = + List.find_map + (fun site -> + match site with + | Ast.Port _ -> None + | Counter counter -> + if Loc.v counter.counter_name = counter_name then + Some counter + else + None) + site_list + |> Option_util.unsome_or_raise + in + + (* Make inverted counter declaration *) + let counter_name : string Loc.annoted = + Loc.map_annot + (fun name -> inverted_counter_name name) + counter_orig.counter_name + in + let counter_test = counter_orig.counter_test in + let counter_delta = counter_orig.counter_delta in + + (* Write in sum_bounds_ref the sum of the counter bounds above *) + let inf_bound = + match + counter_test |> Option_util.unsome_or_raise |> Loc.v + with + | CGTE _ | CLTE _ | CVAR _ -> + raise + (ExceptionDefn.Malformed_Decl + ( "Counter should have CEQ test value in signature \ + statement", + Loc.get_annot counter_name )) + | CEQ value -> value + in + let sup_bound = Loc.v counter_delta in + sum_bounds_ref := inf_bound + sup_bound; + + Ast.Counter { counter_name; counter_test; counter_delta } :: acc) + [] counters_with_clte_tests_from_agent + in + + Ast.Present (agent_name_, site_list @ new_counter_sites, agent_mod)) + ast_compil.signatures + in + + (* In rules, we need to replace the counter tests and the counter modifications *) + let replace_counter_by_invert (mix : Ast.mixture) : Ast.mixture = + List.map + (fun agent_list -> + List.map + (fun agent -> + match agent with + | Ast.Absent _ -> agent + | Present (agent_name_, site_list, agent_mod) -> + let agent_name : string = Loc.v agent_name_ in + let counters_with_clte_tests_from_agent : + (string * string * int ref) list = + List.filter + (fun (agent_name_counter, _, _) -> + agent_name = agent_name_counter) + counters_with_clte_tests + in + (* Add delta to counter as opposite deltas to counter_delta *) + let (added_sites, site_list_with_opposite_deltas) : + Ast.site list * Ast.site list = + List.fold_left_map + (fun acc site -> + match site with + | Ast.Port _ -> acc, site + | Counter counter -> + (match + List.find_opt + (fun (_, name, _) -> + String.equal (Loc.v counter.counter_name) name) + counters_with_clte_tests_from_agent + with + | None -> acc, site + | Some (_, _, sum_bounds_ref) -> + (* As we know that this counter uses a CLTE test, We introduce the inverted counter *) + (* [clte_value_or_none] discriminates the case where this site in this expression has a CLTE test *) + let clte_value_or_none = + match counter.counter_test with + | None -> None + | Some test -> + (match Loc.v test with + | Ast.CEQ _ | CGTE _ | CVAR _ -> None + | Ast.CLTE value -> Some value) + in + (match clte_value_or_none with + | None -> + (* If there is a test, it doesn't need inversion: we add inverted counter without test *) + if Loc.v counter.counter_delta == 0 then + acc, site + else ( + (* If the counter value is changing, we need to add it to the inverted counter *) + let inverted_counter_site = + Ast.Counter + { + counter_name = + Loc.map_annot inverted_counter_name + counter.counter_name; + counter_test = None; + counter_delta = + Loc.map_annot + (fun delta -> -delta) + counter.counter_delta; + } + in + inverted_counter_site :: acc, site + ) + | Some value -> + (* The test is CLTE, we invert it *) + + (* Site with inverted counter with CGTE test instead of CLTE test *) + let new_site = + Ast.Counter + { + counter_name = + Loc.map_annot inverted_counter_name + counter.counter_name; + counter_test = + Some + (Ast.CGTE (!sum_bounds_ref - value) + |> Loc.copy_annot + (Option_util.unsome_or_raise + counter.counter_test)); + counter_delta = + Loc.map_annot + (fun delta -> -delta) + counter.counter_delta; + } + in + if Loc.v counter.counter_delta == 0 then + acc, new_site + else ( + (* If the counter value is changing, we need to add it to the original counter too *) + let original_counter_site = + Ast.Counter { counter with counter_test = None } + in + original_counter_site :: acc, new_site + )))) + [] site_list + in + let new_site_list : Ast.site list = + site_list_with_opposite_deltas @ added_sites + in + Ast.Present (agent_name_, new_site_list, agent_mod)) + agent_list) + mix + in + let rules : (string Loc.annoted option * Ast.rule Loc.annoted) list = + List.map + (fun rule_def -> + ( fst rule_def, + Loc.map_annot + (fun (rule : Ast.rule) -> + let rewrite = + match rule.rewrite with + | Edit content -> + Ast.Edit + { content with mix = replace_counter_by_invert content.mix } + | Arrow content -> + Arrow + { + content with + lhs = replace_counter_by_invert content.lhs; + rhs = replace_counter_by_invert content.rhs; + } + in + { rule with rewrite }) + (snd rule_def) )) + ast_compil.rules + in + + let add_inverted_counter_to_init_mixture (mix : Ast.mixture) : Ast.mixture = + List.map + (fun agent_list -> + List.map + (fun agent -> + match agent with + | Ast.Absent _ -> agent + | Present (agent_name_, site_list, agent_mod) -> + let agent_name : string = Loc.v agent_name_ in + let counters_with_clte_tests_from_agent : + (string * string * int ref) list = + List.filter + (fun (agent_name_counter, _, _) -> + agent_name = agent_name_counter) + counters_with_clte_tests + in + (* Add delta to counter as opposite deltas to counter_delta *) + let added_sites : Ast.site list = + List.fold_left + (fun acc site -> + match site with + | Ast.Port _ -> acc + | Counter counter -> + (match + List.find_opt + (fun (_, name, _) -> + String.equal (Loc.v counter.counter_name) name) + counters_with_clte_tests_from_agent + with + | None -> acc + | Some (_, _, sum_bounds_ref) -> + (* As we know that this counter uses a CLTE test, We introduce the inverted counter *) + (match counter.counter_test with + | None -> + raise + (ExceptionDefn.Malformed_Decl + ( "Counter should have CEQ test value in init \ + statement", + Loc.get_annot counter.counter_name )) + | Some test -> + (match Loc.v test with + | Ast.CGTE _ | CLTE _ | CVAR _ -> + raise + (ExceptionDefn.Malformed_Decl + ( "Counter should have CEQ test value in init \ + statement", + Loc.get_annot test )) + | Ast.CEQ value -> + if Loc.v counter.counter_delta <> 0 then + raise + (ExceptionDefn.Malformed_Decl + ( "Counter delta should be 0 in init \ + statement", + Loc.get_annot test )) + else + Ast.Counter + { + counter_name = + Loc.map_annot inverted_counter_name + counter.counter_name; + counter_test = + Some + (Loc.copy_annot test + (Ast.CEQ (!sum_bounds_ref - value))); + counter_delta = + counter.counter_delta + (* 0 with annot as tested above *); + } + :: acc)))) + [] site_list + in + let new_site_list : Ast.site list = site_list @ added_sites in + Ast.Present (agent_name_, new_site_list, agent_mod)) + agent_list) + mix + in + let init : (Ast.mixture, Ast.mixture, string) Ast.init_statement list = + List.map + (fun (quantity_alg_expr, init_kind) -> + ( quantity_alg_expr, + match init_kind with + | Ast.INIT_TOK _ -> init_kind + | INIT_MIX mix_ -> + INIT_MIX (Loc.map_annot add_inverted_counter_to_init_mixture mix_) )) + ast_compil.init + in + + { ast_compil with signatures; rules; init } + +let compil_of_ast ~warning ~debug_mode ~syntax_version ~var_overwrite ast_compil + = + (* TODO test this *) + (* Translate CLTE tests in ast_compil into CGTE tests *) + let ast_compil = translate_clte_into_cgte ast_compil in + + let has_counters = Counters_compiler.has_counters ast_compil in + let agent_sig_is_implicit = + ast_compil.Ast.signatures = [] && ast_compil.Ast.tokens = [] + in + (* Infer agent signatures if the signature is implicit *) + let ast_compil = + if agent_sig_is_implicit && has_counters then + raise + (ExceptionDefn.Malformed_Decl + ("implicit signature is incompatible with counters", Loc.dummy)) + else if agent_sig_is_implicit then + Ast.infer_agent_signatures ast_compil + else + ast_compil + in + (* Remove counter variable definition by splitting in several rules *) + let ast_compil = + if has_counters then + Counters_compiler.split_counter_variables_into_separate_rules ~warning + ~debug_mode ast_compil + else + ast_compil + in + + let agents_sig : Signature.s = create_sigs ast_compil.Ast.signatures in + (* Set an empty contact map *) + let contact_map : (Mods.IntSet.t * Mods.Int2Set.t) array array = + Array.init (Signature.size agents_sig) (fun i -> + Array.init (Signature.arity agents_sig i) (fun s -> + ( Tools.recti + (fun a k -> Mods.IntSet.add k a) + Mods.IntSet.empty + (Signature.internal_states_number i s agents_sig), + Mods.Int2Set.empty ))) + in + let rule_names, extra_vars, cleaned_rules = + let acc = + List.fold_left + (name_and_purify_rule ~warning ~syntax_version agents_sig ~contact_map) + { + rule_names = 0, Mods.StringSet.empty; + extra_vars = []; + cleaned_rules = []; + } + ast_compil.Ast.rules + in + snd acc.rule_names, acc.extra_vars, acc.cleaned_rules + in + let overwrite_vars (var_overwrite : (string * Nbr.t) list) + (vars : (Ast.mixture, string) Ast.variable_def list) : + (string * Nbr.t) list * (Ast.mixture, string) Ast.variable_def list = + List.fold_left + (fun (overwrite_vars_remaining, acc_vars) (((x, _), _) as var) -> + let matchs, other_overwrite_vars = + List.partition (fun (x', _) -> x = x') overwrite_vars_remaining + in + let acc_vars_with_x_rewritten_if_present = + match matchs with + | [] -> var :: acc_vars + | [ (x, v) ] -> (Loc.annot_with_dummy x, Alg_expr.const v) :: acc_vars + | (x, _) :: _ :: _ -> + raise + (ExceptionDefn.Malformed_Decl + ( "variable '" ^ x ^ "' is overwritten more than once", + Loc.dummy )) + in + + other_overwrite_vars, acc_vars_with_x_rewritten_if_present) + (var_overwrite, []) vars + |> fun (var_overwrite_not_applied, rev_alg_vars) -> + var_overwrite_not_applied, List.rev rev_alg_vars + in + let var_overwrite_not_applied, alg_vars_with_rewritten_vars = + overwrite_vars var_overwrite (ast_compil.Ast.variables @ extra_vars) + in + let alg_vars_array = List_util.rev_map_append - (fun (x,v) -> (Locality.dummy_annot x, Alg_expr.const v)) - overwrite' (List.rev rev_algs) in - let alg_vars_array = Array.of_list alg_vars_over in - let algs = - (NamedDecls.create - ~forbidden:rule_names alg_vars_array).NamedDecls.finder in - let tk_nd = NamedDecls.create - (Tools.array_map_of_list (fun x -> (x,())) c.Ast.tokens) in - let tok = tk_nd.NamedDecls.finder in - let () = if with_counters then - Counters_compiler.add_counter_to_contact_map - sigs (add_link_contact_map ~contact_map) in - let perts',updated_vars = + (fun (x, v) -> Loc.annot_with_dummy x, Alg_expr.const v) + var_overwrite_not_applied alg_vars_with_rewritten_vars + |> Array.of_list + in + let alg_vars_finder = + alg_vars_array |> NamedDecls.create ~forbidden:rule_names |> fun nd -> + nd.NamedDecls.finder + in + let token_names = + ast_compil.Ast.tokens + |> Tools.array_map_of_list (fun x -> x, ()) + |> NamedDecls.create + in + let tokens_finder = token_names.NamedDecls.finder in + + if has_counters then + Counters_compiler.add_counter_to_contact_map agents_sig + (add_link_contact_map ~contact_map); + + let pertubations_without_counters, updated_alg_vars = List_util.fold_right_map - (perturbation_of_ast ~warning ~syntax_version sigs tok algs contact_map) - c.Ast.perturbations [] in - let perts'' = - if with_counters then - (Counters_compiler.counters_perturbations sigs [c.Ast.signatures])@perts' - else perts' in + (perturbation_of_ast ~warning ~syntax_version agents_sig tokens_finder + alg_vars_finder contact_map) + ast_compil.Ast.perturbations [] + in + let perturbations = + if has_counters then + Counters_compiler.counters_perturbations agents_sig + [ ast_compil.Ast.signatures ] + @ pertubations_without_counters + else + pertubations_without_counters + in + let rules = List.rev_map - (fun (label,r_editStyle,mix,created,rm_tk,add_tk,rate,un_rate,r_pos) -> - let mix,created = - Counters_compiler.remove_counter_rule sigs mix created in - label, - (assemble_rule - ~warning ~syntax_version ~r_editStyle - sigs tok algs mix created rm_tk add_tk rate un_rate, - r_pos)) - cleaned_rules in - sigs,contact_map,tk_nd,algs,updated_vars, + (fun (rule : rule_inter_rep) -> + ( rule.label_opt, + ( assemble_rule ~warning ~syntax_version rule agents_sig tokens_finder + alg_vars_finder, + rule.pos ) )) + cleaned_rules + in + + let variables = + Tools.array_fold_righti + (fun i (lab, expr) acc -> + ( lab, + alg_expr_of_ast ~warning ~syntax_version ~max_allowed_var:(pred i) + agents_sig tokens_finder alg_vars_finder expr ) + :: acc) + alg_vars_array [] + in + let observables = + List.rev_map + (fun expr -> + alg_expr_of_ast ~warning ~syntax_version agents_sig tokens_finder + alg_vars_finder expr) + (List.rev ast_compil.observables) + in + let init = + init_of_ast ~warning ~syntax_version agents_sig contact_map tokens_finder + alg_vars_finder ast_compil.init + in + { - Ast.filenames = c.Ast.filenames; - Ast.variables = - Tools.array_fold_righti - (fun i (lab,expr) acc -> - (lab,alg_expr_of_ast - ~warning ~syntax_version ~max_allowed_var:(pred i) - sigs tok algs expr)::acc) - alg_vars_array []; - Ast.rules; - Ast.observables = - List.rev_map (fun expr -> - alg_expr_of_ast ~warning ~syntax_version sigs tok algs expr) - (List.rev c.Ast.observables); - Ast.init = - init_of_ast ~warning ~syntax_version sigs contact_map tok algs c.Ast.init; - Ast.perturbations = perts''; - Ast.volumes = c.Ast.volumes; - Ast.tokens = c.Ast.tokens; - Ast.signatures = c.Ast.signatures; - Ast.configurations = c.Ast.configurations; + agents_sig; + contact_map; + token_names; + alg_vars_finder; + updated_alg_vars; + result = + { + filenames = ast_compil.filenames; + variables; + rules; + observables; + init; + perturbations; + volumes = ast_compil.volumes; + tokens = ast_compil.tokens; + signatures = ast_compil.signatures; + configurations = ast_compil.configurations; + }; } diff --git a/core/grammar/lKappa_compiler.mli b/core/grammar/lKappa_compiler.mli index 3dd2f70a0a..2bda341612 100644 --- a/core/grammar/lKappa_compiler.mli +++ b/core/grammar/lKappa_compiler.mli @@ -7,41 +7,65 @@ (******************************************************************************) val bool_expr_of_ast : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - syntax_version:Ast.syntax_version -> Signature.s -> int Mods.StringMap.t -> - int Mods.StringMap.t -> ?max_allowed_var: int -> - (Ast.mixture, string) Alg_expr.bool Locality.annot -> - (LKappa.rule_agent list, int) Alg_expr.bool Locality.annot + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + syntax_version:Ast.syntax_version -> + Signature.s -> + int Mods.StringMap.t -> + int Mods.StringMap.t -> + ?max_allowed_var:int -> + (Ast.mixture, string) Alg_expr.bool Loc.annoted -> + (LKappa.rule_agent list, int) Alg_expr.bool Loc.annoted val modif_expr_of_ast : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - syntax_version:Ast.syntax_version -> Signature.s -> int Mods.StringMap.t -> - int Mods.StringMap.t -> Contact_map.t -> - (Ast.mixture, Ast.mixture, string,Ast.rule) Ast.modif_expr -> int list -> - (LKappa.rule_agent list, Raw_mixture.t, int, LKappa.rule) Ast.modif_expr * - int list + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + syntax_version:Ast.syntax_version -> + Signature.s -> + int Mods.StringMap.t -> + int Mods.StringMap.t -> + Contact_map.t -> + (Ast.mixture, Ast.mixture, string, Ast.rule) Ast.modif_expr -> + int list -> + (LKappa.rule_agent list, Raw_mixture.t, int, LKappa.rule) Ast.modif_expr + * int list + val init_of_ast : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - syntax_version:Ast.syntax_version -> Signature.s -> Contact_map.t -> - int Mods.StringMap.t -> int Mods.StringMap.t -> - (Ast.mixture, Ast.mixture, string) Ast.init_statment list -> - (LKappa.rule_agent list, Raw_mixture.t, int) Ast.init_statment list + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + syntax_version:Ast.syntax_version -> + Signature.s -> + Contact_map.t -> + int Mods.StringMap.t -> + int Mods.StringMap.t -> + (Ast.mixture, Ast.mixture, string) Ast.init_statement list -> + (LKappa.rule_agent list, Raw_mixture.t, int) Ast.init_statement list + +type ast_compiled_data = { + agents_sig: Signature.s; + contact_map: Contact_map.t; + token_names: unit NamedDecls.t; + alg_vars_finder: int Mods.StringMap.t; + updated_alg_vars: int list; (** alg vars with forbidden constant prop *) + result: + ( Ast.agent, + LKappa.rule_agent list, + Raw_mixture.t, + int, + LKappa.rule ) + Ast.compil; + (** Compiled data where identifiers are i Ast.compil where identifiers + * are integers and not string, syntactic sugar on rules are expansed + * (syntactic sugar on mixture are not) *) +} val compil_of_ast : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - debugMode:bool -> syntax_version:Ast.syntax_version -> - (string * Nbr.t) list -> Ast.parsing_compil -> - Signature.s * Contact_map.t * unit NamedDecls.t * int Mods.StringMap.t * - int list * - (Ast.agent, LKappa.rule_agent list, Raw_mixture.t, int, LKappa.rule) - Ast.compil + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + debug_mode:bool -> + syntax_version:Ast.syntax_version -> + var_overwrite:(string * Nbr.t) list -> + Ast.parsing_compil -> + ast_compiled_data (** [compil_of_ast variable_overwrite ast] - @return the signature of agent, the contact map, the signature of - tokens, an algebraic variable finder, algebraic variable on which - constant propagation is forbidden, and an Ast.compil where identifiers - are integers and not string, syntactic sugar on rules are expansed - (syntactic sugar on mixture are not) + @return a [ast_compiled_data] instance: This function sorts out longest prefix convention as well as ensure a lot of sanity on mixtures: @@ -60,3 +84,15 @@ val compil_of_ast : After this step, [Ast.ANY_FREE] is a synonym of "an [Ast.LNK_ANY] explicitely given by the user". *) + +(** {2 Utils to build signatures} *) + +type site_sig_with_links_as_lists = + (string Loc.annoted * string Loc.annoted) list Signature.site_sig +(** Util type to store site signature with list links instead of array array links *) + +val agent_sigs_of_agent_sigs_with_links_as_lists : + build_contact_map:bool -> + site_sig_with_links_as_lists NamedDecls.t NamedDecls.t -> + Signature.t NamedDecls.t +(** Helper to build signatures: for each entry, translate [(string Loc.annoted * string Loc.annoted) list] into [bool array array option] *) diff --git a/core/logging/dune b/core/logging/dune index 8429d351c2..501e0308dc 100644 --- a/core/logging/dune +++ b/core/logging/dune @@ -1,8 +1,17 @@ (library - (name kappa_logging) - (libraries yojson - kappa-library.mixtures kappa_cli kappa_kasa_type_interface) - (flags (:standard -w @a - -open Kappa_generic_toolset - -open Kappa_cli - -open Kappa_kasa_type_interface))) + (name kappa_logging) + (libraries + yojson + kappa-library.mixtures + kappa_cli + kappa_kasa_type_interface) + (flags + (:standard + -w + @a + -open + Kappa_generic_toolset + -open + Kappa_cli + -open + Kappa_kasa_type_interface))) diff --git a/core/logging/loggers.ml b/core/logging/loggers.ml index e93141e843..3851930355 100644 --- a/core/logging/loggers.ml +++ b/core/logging/loggers.ml @@ -17,26 +17,39 @@ * under the terms of the GNU Library General Public License *) type encoding = - | Matrix | HTML_Graph | Js_Graph | HTML | HTML_Tabular - | DOT | TXT | TXT_Tabular | XLS - | Octave | Matlab | Maple | Mathematica | SBML | DOTNET - | Json | GEPHI - -module type FormatMap = -sig + | Matrix + | HTML_Graph + | Js_Graph + | HTML + | HTML_Tabular + | DOT + | TXT + | TXT_Tabular + | XLS + | Octave + | Matlab + | Maple + | Mathematica + | SBML + | DOTNET + | Json + | GEPHI + +module type FormatMap = sig type 'a t - val add : encoding -> 'a -> 'a t -> 'a t + + val add : encoding -> 'a -> 'a t -> 'a t val find : encoding -> 'a t -> 'a val empty : 'a t end -module FormatMap = - Map.Make(struct type t = encoding let compare = compare end) +module FormatMap = Map.Make (struct + type t = encoding + + let compare = compare +end) -type token = - | String of string - | Breakable_space - | Breakable_hint +type token = String of string | Breakable_space | Breakable_hint type logger = | DEVNUL @@ -45,20 +58,18 @@ type logger = | Infinite_buffer of string Infinite_buffers.t ref let breakable x = - match - x - with + match x with | HTML_Tabular | HTML | HTML_Graph | Js_Graph | TXT -> true - | Matrix | Json | Mathematica | Matlab | Octave | Maple | SBML | DOTNET - | DOT | GEPHI | TXT_Tabular | XLS -> false + | Matrix | Json | Mathematica | Matlab | Octave | Maple | SBML | DOTNET | DOT + | GEPHI | TXT_Tabular | XLS -> + false -type t = - { - encoding:encoding; - logger: logger; - channel_opt: out_channel option; - mutable current_line: token list; - } +type t = { + encoding: encoding; + logger: logger; + channel_opt: out_channel option; + mutable current_line: token list; +} let get_encoding_format t = t.encoding @@ -69,11 +80,11 @@ let dummy_html_logger = logger = DEVNUL; channel_opt = None; current_line = []; - (* fresh_id = ref 1; - nodes = ref []; - edges = ref []; - edges_map = ref Mods.String2Map.empty;*) - } + (* fresh_id = ref 1; + nodes = ref []; + edges = ref []; + edges_map = ref Mods.String2Map.empty;*) + } let dummy_txt_logger = { @@ -82,20 +93,20 @@ let dummy_txt_logger = channel_opt = None; logger = DEVNUL; current_line = []; - (* fresh_id = ref 1; - nodes = ref []; - edges = ref []; - edges_map = ref Mods.String2Map.empty;*) + (* fresh_id = ref 1; + nodes = ref []; + edges = ref []; + edges_map = ref Mods.String2Map.empty;*) } (* Warning, we have to keep the character @ when it is followed by a character followed by a letter or a digit should be preserved *) let dump_clean_string fmt = - String.iter - (fun a -> - if a = '\n' then () - else - Format.fprintf fmt "%c" a) + String.iter (fun a -> + if a = '\n' then + () + else + Format.fprintf fmt "%c" a) let clean_string s = let buffer = Buffer.create 0 in @@ -109,169 +120,126 @@ let clean fmt = let fmt_buffer = Format.formatter_of_buffer s in Format.kfprintf (fun _ -> - let () = Format.pp_print_flush fmt_buffer () in - dump_clean_string fmt (Buffer.contents s)) + let () = Format.pp_print_flush fmt_buffer () in + dump_clean_string fmt (Buffer.contents s)) fmt_buffer -let fprintf ?fprintnewline:(fprintnewline=false) logger = - match - logger.logger, fprintnewline || breakable logger.encoding - with - | DEVNUL,_ -> Format.ifprintf Format.std_formatter +let fprintf ?(fprintnewline = false) logger = + match logger.logger, fprintnewline || breakable logger.encoding with + | DEVNUL, _ -> Format.ifprintf Format.std_formatter | Formatter fmt, true -> Format.fprintf fmt | Formatter fmt, false -> clean fmt - | Circular_buffer _,bool - | Infinite_buffer _,bool -> + | Circular_buffer _, bool | Infinite_buffer _, bool -> let b = Buffer.create 0 in let fmt_buffer = Format.formatter_of_buffer b in Format.kfprintf (fun _ -> - let () = Format.pp_print_flush fmt_buffer () in - let str = Buffer.contents b in - logger.current_line <- (String (if bool then str else clean_string str) )::logger.current_line) + let () = Format.pp_print_flush fmt_buffer () in + let str = Buffer.contents b in + logger.current_line <- + String + (if bool then + str + else + clean_string str) + :: logger.current_line) fmt_buffer let print_breakable_space logger = - if breakable logger.encoding - then - match - logger.logger - with - | DEVNUL - | Formatter _ -> - fprintf logger "@ " - | Circular_buffer _ - | Infinite_buffer _ -> - logger.current_line <- Breakable_space::logger.current_line - else + if breakable logger.encoding then ( + match logger.logger with + | DEVNUL | Formatter _ -> fprintf logger "@ " + | Circular_buffer _ | Infinite_buffer _ -> + logger.current_line <- Breakable_space :: logger.current_line + ) else fprintf logger " " let print_breakable_hint logger = - if breakable logger.encoding - then - match - logger.logger - with - | DEVNUL - | Formatter _ -> - fprintf logger "@," - | Circular_buffer _ - | Infinite_buffer _ -> - logger.current_line <- Breakable_hint::logger.current_line - else - fprintf logger "" + if breakable logger.encoding then ( + match logger.logger with + | DEVNUL | Formatter _ -> fprintf logger "@," + | Circular_buffer _ | Infinite_buffer _ -> + logger.current_line <- Breakable_hint :: logger.current_line + ) else + fprintf logger "" let end_of_line_symbol logger = - match - logger.encoding - with + match logger.encoding with | HTML | HTML_Graph | Js_Graph -> "
    " - | Matrix | Matlab | Mathematica | Octave | Maple | SBML | DOTNET - | Json | GEPHI | HTML_Tabular | DOT | TXT | TXT_Tabular | XLS -> "" + | Matrix | Matlab | Mathematica | Octave | Maple | SBML | DOTNET | Json + | GEPHI | HTML_Tabular | DOT | TXT | TXT_Tabular | XLS -> + "" let dump_token f x = - match - x - with - | String s -> - Format.pp_print_string - f s - | Breakable_space -> - Format.fprintf f "@ " - | Breakable_hint -> - Format.fprintf f "@," + match x with + | String s -> Format.pp_print_string f s + | Breakable_space -> Format.fprintf f "@ " + | Breakable_hint -> Format.fprintf f "@," let print_newline logger = let () = - fprintf - ~fprintnewline:true - logger - "%s%t" - (end_of_line_symbol logger) + fprintf ~fprintnewline:true logger "%s%t" (end_of_line_symbol logger) (fun f -> Format.pp_print_newline f ()) in - match - logger.logger - with - | DEVNUL - | Formatter _ -> () + match logger.logger with + | DEVNUL | Formatter _ -> () | Circular_buffer bf -> - begin - let bf' = - Circular_buffers.add - (Format.asprintf "%a" - (Pp.list - (fun _ -> ()) - dump_token) - (List.rev logger.current_line)) - !bf - in - let () = bf:=bf' in - let () = logger.current_line <- [] in - () - end + let bf' = + Circular_buffers.add + (Format.asprintf "%a" + (Pp.list (fun _ -> ()) dump_token) + (List.rev logger.current_line)) + !bf + in + let () = bf := bf' in + let () = logger.current_line <- [] in + () | Infinite_buffer bf -> - begin - let bf' = - Infinite_buffers.add - (Format.asprintf "%a" - (Pp.list - (fun _ -> ()) - dump_token) - (List.rev logger.current_line)) - !bf - in - let () = bf:=bf' in - let () = logger.current_line <- [] in - () - end + let bf' = + Infinite_buffers.add + (Format.asprintf "%a" + (Pp.list (fun _ -> ()) dump_token) + (List.rev logger.current_line)) + !bf + in + let () = bf := bf' in + let () = logger.current_line <- [] in + () let print_cell logger s = - let open_cell_symbol,close_cell_symbol = - match - logger.encoding - with - | HTML_Tabular -> "","" - | TXT_Tabular -> "","\t" - | Matrix | GEPHI | Json | Mathematica | Matlab | Octave | Maple | SBML | DOTNET - | HTML_Graph | Js_Graph | HTML | DOT | TXT | XLS -> "","" + let open_cell_symbol, close_cell_symbol = + match logger.encoding with + | HTML_Tabular -> "", "" + | TXT_Tabular -> "", "\t" + | Matrix | GEPHI | Json | Mathematica | Matlab | Octave | Maple | SBML + | DOTNET | HTML_Graph | Js_Graph | HTML | DOT | TXT | XLS -> + "", "" in fprintf logger "%s%s%s" open_cell_symbol s close_cell_symbol let flush_logger logger = - match - logger.logger - with + match logger.logger with | DEVNUL -> () | Formatter fmt -> Format.pp_print_flush fmt () - | Circular_buffer _ - | Infinite_buffer _ -> () + | Circular_buffer _ | Infinite_buffer _ -> () let close_logger logger = let () = - match - logger.encoding - with - | HTML -> - fprintf logger "\n\n" - | HTML_Tabular -> - fprintf logger "\n\n" - | Matrix -> - fprintf logger "}\n" - | GEPHI | Json | Matlab | Mathematica | Octave | Maple | SBML | DOTNET - | HTML_Graph | Js_Graph | DOT | TXT | TXT_Tabular | XLS -> () + match logger.encoding with + | HTML -> fprintf logger "\n\n" + | HTML_Tabular -> fprintf logger "\n\n" + | Matrix -> fprintf logger "}\n" + | GEPHI | Json | Matlab | Mathematica | Octave | Maple | SBML | DOTNET + | HTML_Graph | Js_Graph | DOT | TXT | TXT_Tabular | XLS -> + () in let () = flush_logger logger in () let print_preamble logger = - match - logger.encoding - with - | HTML -> - fprintf logger "\n
    \n" - | HTML_Tabular -> - fprintf logger "\n
    \n\n" + match logger.encoding with + | HTML -> fprintf logger "\n
    \n" + | HTML_Tabular -> fprintf logger "\n
    \n
    \n" | Matrix -> let () = fprintf logger "{" in let () = print_newline logger in @@ -281,177 +249,147 @@ let print_preamble logger = let () = print_newline logger in () | GEPHI | Json | Matlab | Mathematica | Octave | Maple | SBML | DOTNET - | HTML_Graph | Js_Graph | DOT | TXT | TXT_Tabular | XLS -> () + | HTML_Graph | Js_Graph | DOT | TXT | TXT_Tabular | XLS -> + () -let open_logger_from_channel ?mode:(mode=TXT) channel = +let open_logger_from_channel ?(mode = TXT) channel = let formatter = Format.formatter_of_out_channel channel in let logger = { - (* id_map = ref StringMap.empty; - fresh_id = ref 1;*) + (* id_map = ref StringMap.empty; + fresh_id = ref 1;*) logger = Formatter formatter; channel_opt = Some channel; encoding = mode; current_line = []; - (* nodes = ref []; - edges = ref []; - edges_map = ref Mods.String2Map.empty;*) - } + (* nodes = ref []; + edges = ref []; + edges_map = ref Mods.String2Map.empty;*) + } in let () = print_preamble logger in logger -let open_logger_from_formatter ?mode:(mode=TXT) formatter = +let open_logger_from_formatter ?(mode = TXT) formatter = let logger = { - (* id_map = ref StringMap.empty; - fresh_id = ref 1;*) + (* id_map = ref StringMap.empty; + fresh_id = ref 1;*) logger = Formatter formatter; channel_opt = None; encoding = mode; current_line = []; - (* nodes = ref []; - edges = ref []; - edges_map = ref Mods.String2Map.empty;*) + (* nodes = ref []; + edges = ref []; + edges_map = ref Mods.String2Map.empty;*) } in let () = print_preamble logger in logger -let open_circular_buffer ?mode:(mode=TXT) ?size:(size=10) () = +let open_circular_buffer ?(mode = TXT) ?(size = 10) () = { - (* id_map = ref StringMap.empty; - fresh_id = ref 1;*) - logger = Circular_buffer (ref (Circular_buffers.create size "" )); + (* id_map = ref StringMap.empty; + fresh_id = ref 1;*) + logger = Circular_buffer (ref (Circular_buffers.create size "")); channel_opt = None; encoding = mode; current_line = []; - (* nodes = ref []; - edges = ref []; - edges_map = ref Mods.String2Map.empty;*) + (* nodes = ref []; + edges = ref []; + edges_map = ref Mods.String2Map.empty;*) } -let open_infinite_buffer ?mode:(mode=TXT) () = +let open_infinite_buffer ?(mode = TXT) () = let logger = { - (* id_map = ref StringMap.empty; - fresh_id = ref 1;*) - logger = Infinite_buffer (ref (Infinite_buffers.create 0 "")); - channel_opt = None; - encoding = mode; - current_line = []; - (* nodes = ref []; - edges = ref []; - edges_map = ref Mods.String2Map.empty;*) + (* id_map = ref StringMap.empty; + fresh_id = ref 1;*) + logger = Infinite_buffer (ref (Infinite_buffers.create 0 "")); + channel_opt = None; + encoding = mode; + current_line = []; + (* nodes = ref []; + edges = ref []; + edges_map = ref Mods.String2Map.empty;*) } in let () = print_preamble logger in logger let open_row logger = - match - logger.encoding - with + match logger.encoding with | HTML_Tabular -> fprintf logger "" | Matrix -> fprintf logger "[" - | Json | Matlab | Octave | Mathematica | Maple | SBML | DOTNET - | HTML_Graph | Js_Graph | XLS | HTML | DOT | TXT | TXT_Tabular | GEPHI -> () + | Json | Matlab | Octave | Mathematica | Maple | SBML | DOTNET | HTML_Graph + | Js_Graph | XLS | HTML | DOT | TXT | TXT_Tabular | GEPHI -> + () let close_row logger = - match - logger.encoding - with + match logger.encoding with | HTML_Tabular -> fprintf logger "@." | Matrix -> fprintf logger "]\n" - | Json | Matlab | Octave | Maple | Mathematica | SBML | DOTNET - | HTML_Graph | Js_Graph | XLS | HTML | DOT | TXT | TXT_Tabular - | GEPHI -> fprintf logger "@." + | Json | Matlab | Octave | Maple | Mathematica | SBML | DOTNET | HTML_Graph + | Js_Graph | XLS | HTML | DOT | TXT | TXT_Tabular | GEPHI -> + fprintf logger "@." let formatter_of_logger logger = - match - logger.logger - with + match logger.logger with | Formatter fmt -> Some fmt - | DEVNUL - | Circular_buffer _ - | Infinite_buffer _ -> None + | DEVNUL | Circular_buffer _ | Infinite_buffer _ -> None -let redirect logger fmt = - {logger with logger = Formatter fmt} - -let print_as_logger logger f = - fprintf logger "%t" f +let redirect logger fmt = { logger with logger = Formatter fmt } +let print_as_logger logger f = fprintf logger "%t" f let flush_buffer logger fmt = - match - logger.logger - with - | DEVNUL - | Formatter _ -> () + match logger.logger with + | DEVNUL | Formatter _ -> () | Circular_buffer a -> Circular_buffers.iter (Format.fprintf fmt "%s") !a - | Infinite_buffer b -> - Infinite_buffers.iter (Format.fprintf fmt "%s") !b + | Infinite_buffer b -> Infinite_buffers.iter (Format.fprintf fmt "%s") !b let flush_and_clean logger fmt = let () = flush_buffer logger fmt in match logger.logger with - | DEVNUL - | Formatter _ -> () - | Circular_buffer a -> - a:=Circular_buffers.clean !a - | Infinite_buffer b -> - b:=Infinite_buffers.clean !b - + | DEVNUL | Formatter _ -> () + | Circular_buffer a -> a := Circular_buffers.clean !a + | Infinite_buffer b -> b := Infinite_buffers.clean !b let fprintf logger = fprintf ~fprintnewline:false logger - let channel_of_logger logger = logger.channel_opt -let print_binding_type - t ?binding_type_symbol:(binding_type_symbol=".") - ~agent_name ~site_name () = - fprintf t - "%s" - (Public_data.string_of_binding_type ~binding_type_symbol ~agent_name ~site_name ()) +let print_binding_type t ?(binding_type_symbol = ".") ~agent_name ~site_name () + = + fprintf t "%s" + (Public_data.string_of_binding_type ~binding_type_symbol ~agent_name + ~site_name ()) let dump_json logger json = let channel_opt = channel_of_logger logger in let () = - match channel_opt - with + match channel_opt with | None -> () | Some channel -> - let () = - Yojson.Basic.to_channel channel json - in + let () = Yojson.Basic.to_channel channel json in () in () -let line_to_json line = - `Assoc ["line", JsonUtil.of_string line] +let line_to_json line = `Assoc [ "line", JsonUtil.of_string line ] let line_of_json json = - match - json - with - | `Assoc ["line", `String s] -> s - | _ -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "line" ,json)) + match json with + | `Assoc [ ("line", `String s) ] -> s + | _ -> raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "line", json)) let gen_iter iter list = let output = ref [] in - let () = iter (fun line -> output:=line::!output) list in + let () = iter (fun line -> output := line :: !output) list in JsonUtil.of_list line_to_json (List.rev !output) let of_json = JsonUtil.to_list ~error_msg:"line list" line_of_json let to_json logger = - match - logger.logger - with - | DEVNUL - | Formatter _ -> `List [] - | Circular_buffer a -> - gen_iter Circular_buffers.iter !a - | Infinite_buffer b -> - gen_iter Infinite_buffers.iter !b + match logger.logger with + | DEVNUL | Formatter _ -> `List [] + | Circular_buffer a -> gen_iter Circular_buffers.iter !a + | Infinite_buffer b -> gen_iter Infinite_buffers.iter !b diff --git a/core/logging/loggers.mli b/core/logging/loggers.mli index 8d42d7ad74..964b736639 100644 --- a/core/logging/loggers.mli +++ b/core/logging/loggers.mli @@ -17,50 +17,67 @@ * under the terms of the GNU Library General Public License *) type encoding = - | Matrix | HTML_Graph | Js_Graph | HTML | HTML_Tabular - | DOT | TXT | TXT_Tabular | XLS - | Octave | Matlab | Maple | Mathematica | SBML | DOTNET - | Json | GEPHI + | Matrix + | HTML_Graph + | Js_Graph + | HTML + | HTML_Tabular + | DOT + | TXT + | TXT_Tabular + | XLS + | Octave + | Matlab + | Maple + | Mathematica + | SBML + | DOTNET + | Json + | GEPHI -module type FormatMap = -sig +module type FormatMap = sig type 'a t - val add : encoding -> 'a -> 'a t -> 'a t + + val add : encoding -> 'a -> 'a t -> 'a t val find : encoding -> 'a t -> 'a val empty : 'a t end -module FormatMap:FormatMap +module FormatMap : FormatMap type t -val get_encoding_format: t -> encoding -val fprintf: t -> ('a, Format.formatter, unit) format -> 'a -val print_newline: t -> unit -val print_cell: t -> string -> unit -val print_as_logger: t -> (Format.formatter -> unit) -> unit -val flush_logger: t -> unit -val close_logger: t -> unit -val open_infinite_buffer: ?mode:encoding -> unit -> t -val open_circular_buffer: ?mode:encoding -> ?size:int -> unit -> t -val open_logger_from_formatter: ?mode:encoding -> Format.formatter -> t -val open_logger_from_channel: ?mode:encoding -> out_channel -> t -val open_row: t -> unit -val close_row: t -> unit -val print_breakable_space: t -> unit -val print_breakable_hint: t -> unit -val dummy_txt_logger: t -val dummy_html_logger: t -val redirect: t -> Format.formatter -> t -val formatter_of_logger: t -> Format.formatter option -val channel_of_logger: t -> out_channel option -val flush_buffer: t -> Format.formatter -> unit -val flush_and_clean: t -> Format.formatter -> unit +val get_encoding_format : t -> encoding +val fprintf : t -> ('a, Format.formatter, unit) format -> 'a +val print_newline : t -> unit +val print_cell : t -> string -> unit +val print_as_logger : t -> (Format.formatter -> unit) -> unit +val flush_logger : t -> unit +val close_logger : t -> unit +val open_infinite_buffer : ?mode:encoding -> unit -> t +val open_circular_buffer : ?mode:encoding -> ?size:int -> unit -> t +val open_logger_from_formatter : ?mode:encoding -> Format.formatter -> t +val open_logger_from_channel : ?mode:encoding -> out_channel -> t +val open_row : t -> unit +val close_row : t -> unit +val print_breakable_space : t -> unit +val print_breakable_hint : t -> unit +val dummy_txt_logger : t +val dummy_html_logger : t +val redirect : t -> Format.formatter -> t +val formatter_of_logger : t -> Format.formatter option +val channel_of_logger : t -> out_channel option +val flush_buffer : t -> Format.formatter -> unit +val flush_and_clean : t -> Format.formatter -> unit -val print_binding_type: - t -> ?binding_type_symbol:string -> agent_name:string -> - site_name:string -> unit -> unit +val print_binding_type : + t -> + ?binding_type_symbol:string -> + agent_name:string -> + site_name:string -> + unit -> + unit -val dump_json: t -> Yojson.Basic.t -> unit -val to_json: t -> Yojson.Basic.t -val of_json: Yojson.Basic.t -> string list +val dump_json : t -> Yojson.Basic.t -> unit +val to_json : t -> Yojson.Basic.t +val of_json : Yojson.Basic.t -> string list diff --git a/core/logging/loggers_string_of_op.ml b/core/logging/loggers_string_of_op.ml index 6133a5ff4d..7c53f29674 100644 --- a/core/logging/loggers_string_of_op.ml +++ b/core/logging/loggers_string_of_op.ml @@ -1,365 +1,248 @@ let string_of_un_op logger op = let format = Loggers.get_encoding_format logger in match op with - | Operator.UMINUS-> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab - | Loggers.Maple | Loggers.Mathematica -> "-" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + | Operator.UMINUS -> + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "-" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.LOG -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab - | Loggers.Maple | Loggers.Mathematica - -> "log" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "log" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.SQRT -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> - "sqrt" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "sqrt" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.EXP -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica -> - "exp" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "exp" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.SINUS -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> "sin" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "sin" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.COSINUS -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> - "cos" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "cos" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.TAN -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica -> - "tan" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "tan" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.INT -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica -> - "floor" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "floor" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") let string_of_compare_op logger op = let format = Loggers.get_encoding_format logger in match op with | Operator.EQUAL -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.Octave | Loggers.Matlab -> - "==" - | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica -> "=" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.Octave | Loggers.Matlab -> "==" + | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica -> "=" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.DIFF -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> - "!=" - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "!=" + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.SMALLER -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> - "<" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "<" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.GREATER -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> - ">" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + ">" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") let string_of_bin_op logger op = let format = Loggers.get_encoding_format logger in match op with | Operator.MODULO -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple - | Loggers.Mathematica -> "mod" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "mod" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.MAX -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> "max" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "max" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.MIN -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab | Loggers.Maple | Loggers.Mathematica - -> - "min" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Octave | Loggers.Matlab | Loggers.Maple + | Loggers.Mathematica -> + "min" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.DIV -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica | Loggers.Octave | Loggers.Matlab -> "/" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica | Loggers.Octave + | Loggers.Matlab -> + "/" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.SUM -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.Maple | Loggers.Mathematica - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab -> "+" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.Maple | Loggers.Mathematica | Loggers.DOTNET | Loggers.Octave + | Loggers.Matlab -> + "+" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.MINUS -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.Maple | Loggers.Mathematica - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab -> "-" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.Maple | Loggers.Mathematica | Loggers.DOTNET | Loggers.Octave + | Loggers.Matlab -> + "-" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.MULT -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.Maple | Loggers.Mathematica - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab -> "*" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.Maple | Loggers.Mathematica | Loggers.DOTNET | Loggers.Octave + | Loggers.Matlab -> + "*" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.POW -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.Maple | Loggers.Mathematica - | Loggers.DOTNET - | Loggers.Octave | Loggers.Matlab -> "**" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.GEPHI - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.Maple | Loggers.Mathematica | Loggers.DOTNET | Loggers.Octave + | Loggers.Matlab -> + "**" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.GEPHI + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") let string_of_bin_bool_op logger op = let format = Loggers.get_encoding_format logger in match op with | Operator.AND -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica - | Loggers.Octave | Loggers.Matlab -> "&" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.GEPHI - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica | Loggers.Octave + | Loggers.Matlab -> + "&" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.GEPHI + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") | Operator.OR -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica - | Loggers.Octave | Loggers.Matlab -> "|" - | Loggers.Matrix - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica | Loggers.Octave + | Loggers.Matlab -> + "|" + | Loggers.Matrix | Loggers.Json | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") let string_of_un_bool_op logger op = let format = Loggers.get_encoding_format logger in match op with | Operator.NOT -> - begin - match - format - with - | Loggers.SBML -> "" - | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica - | Loggers.Octave | Loggers.Matlab -> "!" - | Loggers.Json - | Loggers.Matrix - | Loggers.DOT - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.GEPHI - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - end + (match format with + | Loggers.SBML -> "" + | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica | Loggers.Octave + | Loggers.Matlab -> + "!" + | Loggers.Json | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.GEPHI + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "") diff --git a/core/logging/loggers_string_of_op.mli b/core/logging/loggers_string_of_op.mli index 2cefc77806..a44930ed42 100644 --- a/core/logging/loggers_string_of_op.mli +++ b/core/logging/loggers_string_of_op.mli @@ -1,5 +1,5 @@ -val string_of_un_bool_op: Loggers.t -> Operator.un_bool_op -> string -val string_of_bin_bool_op: Loggers.t -> Operator.bin_bool_op -> string -val string_of_bin_op: Loggers.t -> Operator.bin_alg_op -> string -val string_of_un_op: Loggers.t -> Operator.un_alg_op -> string -val string_of_compare_op: Loggers.t -> Operator.compare_op -> string +val string_of_un_bool_op : Loggers.t -> Operator.un_bool_op -> string +val string_of_bin_bool_op : Loggers.t -> Operator.bin_bool_op -> string +val string_of_bin_op : Loggers.t -> Operator.bin_alg_op -> string +val string_of_un_op : Loggers.t -> Operator.un_alg_op -> string +val string_of_compare_op : Loggers.t -> Operator.compare_op -> string diff --git a/core/main/KaSim.ml b/core/main/KaSim.ml index cf5f9be4b7..d43f97162f 100644 --- a/core/main/KaSim.ml +++ b/core/main/KaSim.ml @@ -9,131 +9,190 @@ open Lwt.Infix let usage_msg = - "KaSim "^Version.version_string^":\n"^ - "Usage is KaSim [-l time] [-p delta_t] [-o output_file] input_files\n" + "KaSim " ^ Version.version_string ^ ":\n" + ^ "Usage is KaSim [-l time] [-p delta_t] [-o output_file] input_files\n" -let tmp_trace = ref(None:string option) -let remove_trace () = match !tmp_trace with None -> () | Some d -> Sys.remove d +let tmp_trace = ref (None : string option) -let batch_loop - ~debugMode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash ~efficiency - progress env counter graph state = +let remove_trace () = + match !tmp_trace with + | None -> () + | Some d -> Sys.remove d + +let batch_loop ~debug_mode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash + ~efficiency progress env counter graph state = let rec iter graph state = Lwt.wrap4 - (State_interpreter.a_loop - ~debugMode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash) - env counter graph state >>= fun (stop,graph',state') -> - if stop then Lwt.return (graph',state') - else - let () = Progress_report.tick - ~efficiency (Counter.current_time counter) + (State_interpreter.a_loop ~debug_mode ~outputs ~dumpIfDeadlocked + ~maxConsecutiveClash) + env counter graph state + >>= fun (stop, graph', state') -> + if stop then + Lwt.return (graph', state') + else ( + let () = + Progress_report.tick ~efficiency + (Counter.current_time counter) (Counter.time_ratio counter) (Counter.current_event counter) - (Counter.event_ratio counter) progress in + (Counter.event_ratio counter) + progress + in (*Lwt.pause () >>= fun () ->*) iter graph' state' - in iter graph state + ) + in + iter graph state -let interactive_loop - ~debugMode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash ~efficiency - progress pause_criteria env counter graph state = +let interactive_loop ~debug_mode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash + ~efficiency progress pause_criteria env counter graph state = let user_interrupted = ref false in let old_sigint_behavior = Sys.signal Sys.sigint (Sys.Signal_handle - (fun _ -> if !user_interrupted then raise Sys.Break - else user_interrupted := true)) + (fun _ -> + if !user_interrupted then + raise Sys.Break + else + user_interrupted := true)) in let rec iter graph state = - if !user_interrupted || - Rule_interpreter.value_bool counter graph pause_criteria then + if + !user_interrupted + || Rule_interpreter.value_bool counter graph pause_criteria + then ( let () = Sys.set_signal Sys.sigint old_sigint_behavior in - let () = Format.print_newline () in Lwt.return (false,graph,state) - else - Lwt.wrap4 (State_interpreter.a_loop ~debugMode ~outputs - ~dumpIfDeadlocked ~maxConsecutiveClash) env counter graph state >>= - fun (stop,graph',state' as out) -> - if stop then + let () = Format.print_newline () in + Lwt.return (false, graph, state) + ) else + Lwt.wrap4 + (State_interpreter.a_loop ~debug_mode ~outputs ~dumpIfDeadlocked + ~maxConsecutiveClash) + env counter graph state + >>= fun ((stop, graph', state') as out) -> + if stop then ( let () = Sys.set_signal Sys.sigint old_sigint_behavior in Lwt.return out - else - let () = Progress_report.tick - ~efficiency (Counter.current_time counter) + ) else ( + let () = + Progress_report.tick ~efficiency + (Counter.current_time counter) (Counter.time_ratio counter) (Counter.current_event counter) - (Counter.event_ratio counter) progress in + (Counter.event_ratio counter) + progress + in (*Lwt.pause () >>= fun () ->*) iter graph' state' - in iter graph state + ) + in + iter graph state -let finalize - ~outputs dotFormat cflow_file trace_file - progress env counter graph state stories_compression = - Lwt.wrap4 (State_interpreter.end_of_simulation - ~outputs) env counter graph state >>= fun () -> +let finalize ~outputs dotFormat cflow_file trace_file progress env counter graph + state stories_compression = + Lwt.wrap4 + (State_interpreter.end_of_simulation ~outputs) + env counter graph state + >>= fun () -> Lwt.wrap3 Progress_report.complete_progress_bar - (Counter.current_time counter) (Counter.current_event counter) progress <&> - Lwt.wrap (Outputs.close ~event:(Counter.current_event counter)) >>= fun () -> - match trace_file,stories_compression with - | None,_ -> Lwt.return_unit + (Counter.current_time counter) + (Counter.current_event counter) + progress + <&> Lwt.wrap (Outputs.close ~event:(Counter.current_event counter)) + >>= fun () -> + match trace_file, stories_compression with + | None, _ -> Lwt.return_unit | Some _, None -> Lwt.return_unit - | Some dump, Some (none,weak,strong) -> - let args = ["-d"; Kappa_files.get_dir (); Kappa_files.path dump] in - let args = if none then "--none" :: args else args in - let args = if weak then "--weak" :: args else args in - let args = if strong then "--strong" :: args else args in + | Some dump, Some (none, weak, strong) -> + let args = [ "-d"; Kappa_files.get_dir (); Kappa_files.path dump ] in + let args = + if none then + "--none" :: args + else + args + in + let args = + if weak then + "--weak" :: args + else + args + in + let args = + if strong then + "--strong" :: args + else + args + in let args = "-format" :: dotFormat :: args in - let args = match cflow_file with + let args = + match cflow_file with | None -> args - | Some f -> "-o" :: f :: args in - let args = if !Parameter.time_independent - then "--time-independent" :: args else args in + | Some f -> "-o" :: f :: args + in + let args = + if !Parameter.time_independent then + "--time-independent" :: args + else + args + in let prog = let predir = Filename.dirname Sys.executable_name in - let dir = if Filename.is_implicit Sys.executable_name && - predir = "." then "" else predir^"/" in - if Filename.basename predir = "main" then + let dir = + if Filename.is_implicit Sys.executable_name && predir = "." then + "" + else + predir ^ "/" + in + if Filename.basename predir = "main" then ( let prepredir = Filename.dirname predir in - if Filename.basename prepredir = "core" && - Filename.basename (Filename.dirname prepredir) = "default" then - prepredir^"/agents/KaStor.exe" - else dir^"KaStor" - else dir^"KaStor" in - let pid = Lwt_process.open_process_none - ~stdin:`Keep ~stdout:`Keep ~stderr:`Keep - (prog,(Array.of_list (prog::args))) in + if + Filename.basename prepredir = "core" + && Filename.basename (Filename.dirname prepredir) = "default" + then + prepredir ^ "/agents/KaStor.exe" + else + dir ^ "KaStor" + ) else + dir ^ "KaStor" + in + let pid = + Lwt_process.open_process_none ~stdin:`Keep ~stdout:`Keep ~stderr:`Keep + (prog, Array.of_list (prog :: args)) + in let _old_sigint_behavior = - Sys.signal - Sys.sigint (Sys.Signal_handle (fun si -> pid#kill si)) in - pid#status >>= function + Sys.signal Sys.sigint (Sys.Signal_handle (fun si -> pid#kill si)) + in + pid#status >>= ( function | Unix.WEXITED 127 -> Lwt.fail (ExceptionDefn.Malformed_Decl - (Locality.dummy_annot - ("Executable '"^prog^"' can not be found to compute stories."))) - | Unix.WEXITED n -> if n <> 0 then exit n; Lwt.return_unit - | Unix.WSIGNALED n -> Lwt.fail_with ("Killed with signal "^string_of_int n) - | Unix.WSTOPPED n -> Lwt.fail_with ("Stopped with signal "^string_of_int n) - + (Loc.annot_with_dummy + ("Executable '" ^ prog ^ "' can not be found to compute stories."))) + | Unix.WEXITED n -> + if n <> 0 then exit n; + Lwt.return_unit + | Unix.WSIGNALED n -> Lwt.fail_with ("Killed with signal " ^ string_of_int n) + | Unix.WSTOPPED n -> Lwt.fail_with ("Stopped with signal " ^ string_of_int n) ) let read_interactive_command = let buffer = Buffer.create 256 in let rec aux_read_command () = Lwt_io.read_char_opt Lwt_io.stdin >>= function | Some char -> - let () = Buffer.add_char buffer char in - if char = ';' then + let () = Buffer.add_char buffer char in + if char = ';' then ( let m = Buffer.contents buffer in let () = Buffer.reset buffer in Lwt.return m - else if char = '\n' then + ) else if char = '\n' then Lwt_io.printf "> " >>= aux_read_command else aux_read_command () | None -> let m = Buffer.contents buffer in let () = Buffer.reset buffer in - Lwt.return m in + Lwt.return m + in aux_read_command let () = @@ -141,266 +200,356 @@ let () = let kasim_args = Kasim_args.default in let common_args = Common_args.default in let options = - Run_cli_args.options cli_args @ - Kasim_args.options kasim_args @ Common_args.options common_args in + Run_cli_args.options cli_args + @ Kasim_args.options kasim_args + @ Common_args.options common_args + in try - Arg.parse - options - (fun fic -> cli_args.Run_cli_args.inputKappaFileNames <- - fic::(cli_args.Run_cli_args.inputKappaFileNames)) + Arg.parse options + (fun fic -> + cli_args.Run_cli_args.inputKappaFileNames <- + fic :: cli_args.Run_cli_args.inputKappaFileNames) usage_msg; let () = Kappa_files.set_dir cli_args.Run_cli_args.outputDirectory in - let () = match kasim_args.Kasim_args.marshalizeOutFile with + let () = + match kasim_args.Kasim_args.marshalizeOutFile with | None -> () - | Some marshalizeOutFile -> - Kappa_files.set_marshalized marshalizeOutFile + | Some marshalizeOutFile -> Kappa_files.set_marshalized marshalizeOutFile in - let () = Parameter.debugModeOn := common_args.Common_args.debug in - let debugMode = common_args.Common_args.debug in + let () = Parameter.debug_modeOn := common_args.Common_args.debug in + let debug_mode = common_args.Common_args.debug in let () = - Parameter.time_independent := kasim_args.Kasim_args.timeIndependent in + Parameter.time_independent := kasim_args.Kasim_args.timeIndependent + in let abort = match cli_args.Run_cli_args.inputKappaFileNames with | [] -> kasim_args.Kasim_args.marshalizedInFile = "" - | _ -> false in - if abort then (prerr_string usage_msg ; exit 1) ; + | _ -> false + in + if abort then ( + prerr_string usage_msg; + exit 1 + ); let () = Sys.catch_break true in - Printexc.record_backtrace - (debugMode || common_args.Common_args.backtrace); - (*Possible backtrace*) + Printexc.record_backtrace (debug_mode || common_args.Common_args.backtrace); + (*Possible backtrace*) let cpu_time = Sys.time () in - let (conf, env, contact_map, _, story_compression, - formatCflows, cflowFile, init_l as init_result), - counter = - let warning ~pos msg = Outputs.go (Data.Warning (Some pos,msg)) in - Cli_init.get_compilation - ~warning ~debugMode - ~compileModeOn:kasim_args.Kasim_args.compileMode ~kasim_args cli_args in - let () = if kasim_args.Kasim_args.showEfficiency then - Format.printf " All that took %fs@." (Sys.time () -. cpu_time) in + (* TODO: init_result here didn't contain counter option before change, should we change rep? *) + let init_result : Cli_init.compilation_result = + let warning ~pos msg = Outputs.go (Data.Warning (Some pos, msg)) in + Cli_init.get_compilation ~warning ~debug_mode + ~compile_mode_on:kasim_args.Kasim_args.compile_mode ~kasim_args cli_args + in + let counter = + match init_result.counter_opt with + | None -> failwith "compilation_result here should contain counter info" + | Some c -> c + in + let () = + if kasim_args.Kasim_args.showEfficiency then + Format.printf " All that took %fs@." (Sys.time () -. cpu_time) + in - let theSeed,seed_arg = - match kasim_args.Kasim_args.seedValue,conf.Configuration.seed with - | Some seed,_ | None, Some seed -> seed,[||] + let the_seed, seed_arg = + match + kasim_args.Kasim_args.seedValue, init_result.conf.Configuration.seed + with + | Some seed, _ | None, Some seed -> seed, [||] | None, None -> let () = Format.printf "+ Self seeding...@." in let () = Random.self_init () in let out = Random.bits () in - out,[|"-seed";string_of_int out|] in - let () = Random.init theSeed (*for reproducible colors in dot snaphot*) in - let random_state = Random.State.make [|theSeed|] in + out, [| "-seed"; string_of_int out |] + in + let () = Random.init the_seed (*for reproducible colors in dot snaphot*) in + let random_state = Random.State.make [| the_seed |] in let () = - if cli_args.Run_cli_args.batchmode && - Counter.max_time counter = None && Counter.max_events counter = None then - Model.check_if_counter_is_filled_enough env in + if + cli_args.Run_cli_args.batchmode + && Counter.max_time counter = None + && Counter.max_events counter = None + then + Model.check_if_counter_is_filled_enough init_result.env + in let command_line = Format.asprintf "@[%a%t%a@]" - (Pp.array Pp.space - (fun i f s -> - Format.fprintf - f "'%s'" (if i = 0 then "KaSim" else s))) + (Pp.array Pp.space (fun i f s -> + Format.fprintf f "'%s'" + (if i = 0 then + "KaSim" + else + s))) Sys.argv (fun f -> if Array.length seed_arg > 0 then Format.pp_print_space f ()) - (Pp.array Pp.space (fun _ -> Format.pp_print_string)) seed_arg in + (Pp.array Pp.space (fun _ -> Format.pp_print_string)) + seed_arg + in - let trace_file,user_trace_file = - match kasim_args.Kasim_args.traceFile, - conf.Configuration.traceFileName with - | Some _ as x,_ -> x,x - | _, (Some _ as x) -> x,x + let trace_file, user_trace_file = + match + ( kasim_args.Kasim_args.traceFile, + init_result.conf.Configuration.traceFileName ) + with + | (Some _ as x), _ -> x, x + | _, (Some _ as x) -> x, x | None, None -> - match story_compression with - | None -> None,None + (match init_result.story_compression with + | None -> None, None | Some _ -> let () = tmp_trace := Some (Filename.temp_file "trace" ".json") in - !tmp_trace,None in - let plot_file = Option_util.unsome - (Option_util.unsome "data.csv" conf.Configuration.outputFileName) - cli_args.Run_cli_args.outputDataFile in + !tmp_trace, None) + in + let plot_file = + Option_util.unsome + (Option_util.unsome "data.csv" + init_result.conf.Configuration.outputFileName) + cli_args.Run_cli_args.outputDataFile + in let plotPack = let head = Model.map_observables - (fun o -> Format.asprintf "@[%a@]" - (Kappa_printer.alg_expr ~noCounters:debugMode ~env) o) - env in - if Array.length head > 1 then + (fun o -> + Format.asprintf "@[%a@]" + (Kappa_printer.alg_expr ~noCounters:debug_mode + ~env:init_result.env) + o) + init_result.env + in + if Array.length head > 1 then ( let title = "Output of " ^ command_line in - Some (plot_file,title,head) - else None in - let dumpIfDeadlocked = conf.Configuration.dumpIfDeadlocked in - let maxConsecutiveClash = conf.Configuration.maxConsecutiveClash in + Some (plot_file, title, head) + ) else + None + in + let dumpIfDeadlocked = init_result.conf.Configuration.dumpIfDeadlocked in + let maxConsecutiveClash = + init_result.conf.Configuration.maxConsecutiveClash + in let deltaActivitiesFileName = - conf.Configuration.deltaActivitiesFileName in + init_result.conf.Configuration.deltaActivitiesFileName + in let () = - if not kasim_args.Kasim_args.compileMode then + if not kasim_args.Kasim_args.compile_mode then ( match kasim_args.Kasim_args.logFile with | None -> () | Some filename -> Outputs.initial_inputs - {Configuration.seed = Some theSeed; - Configuration.progressChar = conf.Configuration.progressChar; - Configuration.progressSize = conf.Configuration.progressSize; - Configuration.dumpIfDeadlocked; Configuration.maxConsecutiveClash; - Configuration.deltaActivitiesFileName; - Configuration.traceFileName = user_trace_file; - Configuration.initial = - if Tools.float_is_zero (Counter.init_time counter) then None - else Some (Counter.init_time counter); - Configuration.plotPeriod = Some (Counter.plot_period counter); - Configuration.outputFileName = Some plot_file;} - env init_l ~filename - in - Kappa_files.setCheckFileExists - ~batchmode:cli_args.Run_cli_args.batchmode + { + Configuration.seed = Some the_seed; + Configuration.progressChar = + init_result.conf.Configuration.progressChar; + Configuration.progressSize = + init_result.conf.Configuration.progressSize; + Configuration.dumpIfDeadlocked; + Configuration.maxConsecutiveClash; + Configuration.deltaActivitiesFileName; + Configuration.traceFileName = user_trace_file; + Configuration.initial = + (if Tools.float_is_zero (Counter.init_time counter) then + None + else + Some (Counter.init_time counter)); + Configuration.plotPeriod = Some (Counter.plot_period counter); + Configuration.outputFileName = Some plot_file; + } + init_result.env init_result.init_l ~filename + ) + in + Kappa_files.setCheckFileExists ~batchmode:cli_args.Run_cli_args.batchmode plot_file; - if not kasim_args.Kasim_args.compileMode then - Outputs.initialize deltaActivitiesFileName trace_file plotPack env; + if not kasim_args.Kasim_args.compile_mode then + Outputs.initialize deltaActivitiesFileName trace_file plotPack + init_result.env; let outputs = Outputs.go in let () = - Kappa_files.with_marshalized - (fun d -> Marshal.to_channel d init_result []) in + Kappa_files.with_marshalized (fun d -> + Marshal.to_channel d init_result []) + in let cpu_time = Sys.time () in let () = Format.printf "+ Building initial state@?" in - let (stop,graph,state) = + let stop, graph, state = Eval.build_initial_state - ~bind:(fun x f -> f x) ~return:(fun x -> x) - ~debugMode ~outputs counter env ~with_trace:(trace_file<>None) - ~with_delta_activities:(deltaActivitiesFileName<>None) - random_state init_l in + ~bind:(fun x f -> f x) + ~return:(fun x -> x) + ~debug_mode ~outputs counter init_result.env + ~with_trace:(trace_file <> None) + ~with_delta_activities:(deltaActivitiesFileName <> None) + random_state init_result.init_l + in let () = Format.printf " (%a)" Rule_interpreter.print_stats graph in - let () = if kasim_args.Kasim_args.showEfficiency then - Format.printf " took %fs" (Sys.time () -. cpu_time) in + let () = + if kasim_args.Kasim_args.showEfficiency then + Format.printf " took %fs" (Sys.time () -. cpu_time) + in Format.printf "@.Done@.+ Command line to rerun is: %s@." command_line; let () = - if kasim_args.Kasim_args.compileMode || debugMode then + if kasim_args.Kasim_args.compile_mode || debug_mode then Format.eprintf - "@[@[Environment:@,%a@]@,@[Polymers:@,%a@]@,\ -@[Domain:@,%a@]@,@[Intial graph;@,%a@]@]@." - (Kappa_printer.env ~noCounters:debugMode) env - (Contact_map.print_cycles (Model.signatures env)) contact_map - (Pattern.Env.print ~noCounters:debugMode) - (Model.domain env) - (Rule_interpreter.print env) graph + "@[@[Environment:@,\ + %a@]@,\ + @[Polymers:@,\ + %a@]@,\ + @[Domain:@,\ + %a@]@,\ + @[Intial graph;@,\ + %a@]@]@." + (Kappa_printer.env ~noCounters:debug_mode) + init_result.env + (Contact_map.print_cycles (Model.signatures init_result.env)) + init_result.contact_map + (Pattern.Env.print ~noCounters:debug_mode) + (Model.domain init_result.env) + (Rule_interpreter.print init_result.env) + graph in (*------------------------------------------------------------*) - let () = match kasim_args.Kasim_args.domainOutputFile with + let () = + match kasim_args.Kasim_args.domainOutputFile with | None -> () | Some domainOutputFile -> - Yojson.Basic.to_file (Kappa_files.path domainOutputFile) - (Pattern.Env.to_yojson (Model.domain env)) in - Outputs.flush_warning () ; - (if kasim_args.Kasim_args.compileMode - then let () = remove_trace () in exit 0 - else ()); + Yojson.Basic.to_file + (Kappa_files.path domainOutputFile) + (Pattern.Env.to_yojson (Model.domain init_result.env)) + in + Outputs.flush_warning (); + if kasim_args.Kasim_args.compile_mode then ( + let () = remove_trace () in + exit 0 + ) else + (); - let () = match plotPack with + let () = + match plotPack with | Some _ -> if Counter.positive_plot_period counter then Outputs.go (Data.Plot - (State_interpreter.observables_values env graph counter)) + (State_interpreter.observables_values init_result.env graph + counter)) | _ -> () in - let progress = Progress_report.create - conf.Configuration.progressSize conf.Configuration.progressChar in + let progress = + Progress_report.create init_result.conf.Configuration.progressSize + init_result.conf.Configuration.progressChar + in Lwt_main.run - ((if stop then - finalize - ~outputs formatCflows cflowFile trace_file - progress env counter graph state story_compression - else if cli_args.Run_cli_args.batchmode then - batch_loop - ~debugMode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash - ~efficiency:kasim_args.Kasim_args.showEfficiency - progress env counter graph state >>= fun (graph',state') -> - finalize - ~outputs formatCflows cflowFile trace_file - progress env counter graph' state' story_compression - else - let rec toplevel env graph state = - let () = Outputs.flush_warning () in - Lwt.catch - (fun () -> + ( (if stop then + finalize ~outputs init_result.formatCflow init_result.cflowFile + trace_file progress init_result.env counter graph state + init_result.story_compression + else if cli_args.Run_cli_args.batchmode then + batch_loop ~debug_mode ~outputs ~dumpIfDeadlocked + ~maxConsecutiveClash + ~efficiency:kasim_args.Kasim_args.showEfficiency progress + init_result.env counter graph state + >>= fun (graph', state') -> + finalize ~outputs init_result.formatCflow init_result.cflowFile + trace_file progress init_result.env counter graph' state' + init_result.story_compression + else ( + let rec toplevel env graph state = + let () = Outputs.flush_warning () in + Lwt.catch + (fun () -> read_interactive_command () >>= fun str -> let lexbuf = Lexing.from_string str in (match cli_args.Run_cli_args.syntaxVersion with - | Ast.V3 -> - Lwt.wrap2 KappaParser.interactive_command KappaLexer.token lexbuf - | Ast.V4 -> - try Lwt.return (Kparser4.interactive_command Klexer4.token lexbuf) - with ExceptionDefn.Syntax_Error r -> - Lwt.fail (ExceptionDefn.Malformed_Decl r) - | e -> Lwt.fail e) >>= function + | Ast.V3 -> + Lwt.wrap2 KappaParser.interactive_command KappaLexer.token + lexbuf + | Ast.V4 -> + (try + Lwt.return + (Kparser4.interactive_command Klexer4.token lexbuf) + with + | ExceptionDefn.Syntax_Error r -> + Lwt.fail (ExceptionDefn.Malformed_Decl r) + | e -> Lwt.fail e)) + >>= function | Ast.RUN b -> Lwt.wrap4 - (Evaluator.get_pause_criteria - ~debugMode ~outputs + (Evaluator.get_pause_criteria ~debug_mode ~outputs ~sharing:kasim_args.Kasim_args.sharing - ~syntax_version:(cli_args.Run_cli_args.syntaxVersion)) - contact_map env graph b >>= fun (env',graph',b'') -> - let progress = Progress_report.create - conf.Configuration.progressSize - conf.Configuration.progressChar in - interactive_loop - ~debugMode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash - ~efficiency:kasim_args.Kasim_args.showEfficiency - progress b'' env' counter graph' state >>= - fun out -> Lwt.return (env',out) - | Ast.QUIT -> Lwt.return (env,(true,graph,state)) + ~syntax_version:cli_args.Run_cli_args.syntaxVersion) + init_result.contact_map init_result.env graph b + >>= fun (env', graph', b'') -> + let progress = + Progress_report.create + init_result.conf.Configuration.progressSize + init_result.conf.Configuration.progressChar + in + interactive_loop ~debug_mode ~outputs ~dumpIfDeadlocked + ~maxConsecutiveClash + ~efficiency:kasim_args.Kasim_args.showEfficiency progress + b'' env' counter graph' state + >>= fun out -> Lwt.return (env', out) + | Ast.QUIT -> Lwt.return (env, (true, graph, state)) | Ast.MODIFY e -> Lwt.wrap6 - (Evaluator.do_interactive_directives - ~debugMode ~outputs + (Evaluator.do_interactive_directives ~debug_mode ~outputs ~sharing:kasim_args.Kasim_args.sharing ~syntax_version:cli_args.Run_cli_args.syntaxVersion) - contact_map env counter graph state e >>= - fun (e', (env',_ as o)) -> + init_result.contact_map init_result.env counter graph state + e + >>= fun (e', ((env', _) as o)) -> Lwt_io.print "\xE2\x9C\x94 " >>= fun () -> - let () = Outputs.input_modifications - env' (Counter.current_event counter) e' in + let () = + Outputs.input_modifications env' + (Counter.current_event counter) + e' + in Lwt.return o) - (function - | ExceptionDefn.Syntax_Error (msg,pos) -> - let () = Pp.error Format.pp_print_string (msg,pos) in - Lwt.return (env,(false,graph,state)) - | ExceptionDefn.Malformed_Decl er -> - let () = Pp.error Format.pp_print_string er in - Lwt.return (env,(false,graph,state)) - | e -> Lwt.fail e) >>= fun (env',(stop,graph',state')) -> - if stop then - finalize - ~outputs formatCflows cflowFile trace_file - progress env counter graph' state' story_compression - else - toplevel env' graph' state' in - let toplevel_intro () = - Lwt_io.printf - "KaSim toplevel: type `$RUN (optionally followed by a pause \ - criteria) ;` to launch the simulation or a intervention effect \ - (followed by its `;`) to perform it\n> " in - if cli_args.Run_cli_args.interactive then - toplevel_intro () >>= fun () -> toplevel env graph state - else - interactive_loop - ~debugMode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash - ~efficiency:kasim_args.Kasim_args.showEfficiency - progress Alg_expr.FALSE env counter graph state >>= fun (stop,graph',state') -> - if stop then - finalize - ~outputs formatCflows cflowFile trace_file - progress env counter graph' state' story_compression - else - toplevel_intro () >>= fun () -> toplevel env graph' state') >>= fun () -> - Lwt_io.printl "Simulation ended" >>= fun () -> - remove_trace (); - Lwt_io.print (Format.asprintf "%a" Counter.print_efficiency counter)) + (function + | ExceptionDefn.Syntax_Error (msg, pos) -> + let () = Pp.error Format.pp_print_string (msg, pos) in + Lwt.return (env, (false, graph, state)) + | ExceptionDefn.Malformed_Decl er -> + let () = Pp.error Format.pp_print_string er in + Lwt.return (env, (false, graph, state)) + | e -> Lwt.fail e) + >>= fun (env', (stop, graph', state')) -> + if stop then + finalize ~outputs init_result.formatCflow init_result.cflowFile + trace_file progress init_result.env counter graph' state' + init_result.story_compression + else + toplevel env' graph' state' + in + let toplevel_intro () = + Lwt_io.printf + "KaSim toplevel: type `$RUN (optionally followed by a pause \ + criteria) ;` to launch the simulation or a intervention effect \ + (followed by its `;`) to perform it\n\ + > " + in + if cli_args.Run_cli_args.interactive then + toplevel_intro () >>= fun () -> + toplevel init_result.env graph state + else + interactive_loop ~debug_mode ~outputs ~dumpIfDeadlocked + ~maxConsecutiveClash + ~efficiency:kasim_args.Kasim_args.showEfficiency progress + Alg_expr.FALSE init_result.env counter graph state + >>= fun (stop, graph', state') -> + if stop then + finalize ~outputs init_result.formatCflow init_result.cflowFile + trace_file progress init_result.env counter graph' state' + init_result.story_compression + else + toplevel_intro () >>= fun () -> + toplevel init_result.env graph' state' + )) + >>= fun () -> + Lwt_io.printl "Simulation ended" >>= fun () -> + remove_trace (); + Lwt_io.print (Format.asprintf "%a" Counter.print_efficiency counter) ) with | ExceptionDefn.Malformed_Decl er -> let () = Outputs.close () in @@ -413,13 +562,15 @@ let () = let () = Pp.error (fun f x -> Format.fprintf f "Internal Error (please report):@ %s" x) - er in + er + in exit 2 | Sys.Break -> let () = Outputs.close () in let () = remove_trace () in let () = - Format.eprintf "@.***Interrupted by user out of simulation loop***@." in + Format.eprintf "@.***Interrupted by user out of simulation loop***@." + in exit 1 | Invalid_argument msg -> let () = Printexc.print_backtrace stderr in diff --git a/core/main/dune b/core/main/dune index 7b4e7fe2f0..072922ef7c 100644 --- a/core/main/dune +++ b/core/main/dune @@ -1,15 +1,34 @@ (executable - (name KaSim) - (libraries lwt.unix fmt num yojson - kappa-library.generic kappa-library.mixtures kappa-library.terms kappa-library.runtime - kappa_version kappa_grammar kappa_cli) - (public_name KaSim) - (package kappa-binaries) -(flags (:standard -w @a - -open Kappa_version - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms - -open Kappa_runtime - -open Kappa_grammar - -open Kappa_cli))) + (name KaSim) + (libraries + lwt.unix + fmt + num + yojson + kappa-library.generic + kappa-library.mixtures + kappa-library.terms + kappa-library.runtime + kappa_version + kappa_grammar + kappa_cli) + (public_name KaSim) + (package kappa-binaries) + (flags + (:standard + -w + @a-40-42 + -open + Kappa_version + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms + -open + Kappa_runtime + -open + Kappa_grammar + -open + Kappa_cli))) diff --git a/core/odes/KaDE.ml b/core/odes/KaDE.ml index 22256f78f1..a806318281 100644 --- a/core/odes/KaDE.ml +++ b/core/odes/KaDE.ml @@ -5,7 +5,7 @@ module A = Odes.Make (Symmetry_interface) -let main ?called_from:(called_from=Remanent_parameters_sig.Server) () = +let main ?(called_from = Remanent_parameters_sig.Server) () = let start_time = Sys.time () in let cli_args = Run_cli_args.default in let cli_args_gui = Run_cli_args.default_gui in @@ -13,15 +13,16 @@ let main ?called_from:(called_from=Remanent_parameters_sig.Server) () = let common_args_gui = Common_args.default_gui in let ode_args = Ode_args.default in let options = - List.rev (Run_cli_args.options_gui cli_args_gui + List.rev + (Run_cli_args.options_gui cli_args_gui @ Ode_args.options ode_args @ Common_args.options_gui common_args_gui) - in + in try let files = Ode_args.get_option options in let files = List.fold_left - (fun list elt -> elt::list) + (fun list elt -> elt :: list) !(cli_args_gui.Run_cli_args.inputKappaFileNames_gui) files in @@ -29,14 +30,14 @@ let main ?called_from:(called_from=Remanent_parameters_sig.Server) () = match files with | [] -> Format.printf "No input file has been provided.@."; - exit 0 - | _::_ -> () + exit 0 + | _ :: _ -> () in let () = Common_args.copy_from_gui common_args_gui common_args in let () = Run_cli_args.copy_from_gui cli_args_gui cli_args in let () = cli_args.Run_cli_args.inputKappaFileNames <- files in let () = Kappa_files.set_dir cli_args.Run_cli_args.outputDirectory in - let () = Parameter.debugModeOn := common_args.Common_args.debug in + let () = Parameter.debug_modeOn := common_args.Common_args.debug in let backend = match Tools.lowercase !(ode_args.Ode_args.backend) with | "octave" -> Loggers.Octave @@ -46,116 +47,83 @@ let main ?called_from:(called_from=Remanent_parameters_sig.Server) () = | "dotnet" -> Loggers.DOTNET | "sbml" -> Loggers.SBML | s -> - begin - Format.printf - "Wrong option %s.@.Only DOTNET, Matlab, Mathematica, Maple, Octave, and SBML backends are supported.@." - s; - exit 0 - end + Format.printf + "Wrong option %s.@.Only DOTNET, Matlab, Mathematica, Maple, Octave, \ + and SBML backends are supported.@." + s; + exit 0 in let rule_rate_convention = match Tools.lowercase !(ode_args.Ode_args.rule_rate_convention) with - | "kasim" -> Remanent_parameters_sig.No_correction - | "divide_by_nbr_of_autos_in_lhs" -> - Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs - | "biochemist" -> Remanent_parameters_sig.Biochemist - | s -> - begin + | "kasim" -> Remanent_parameters_sig.No_correction + | "divide_by_nbr_of_autos_in_lhs" -> + Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs + | "biochemist" -> Remanent_parameters_sig.Biochemist + | s -> Format.printf - "Wrong option %s.@.Only KaSim and Biochemist are supported.@." - s; + "Wrong option %s.@.Only KaSim and Biochemist are supported.@." s; exit 0 - end in let reaction_rate_convention = - match backend,Tools.lowercase !(ode_args.Ode_args.reaction_rate_convention) with - | - (Loggers.Octave - | Loggers.Matlab - | Loggers.Mathematica - | Loggers.Maple), - ("kasim" | "divide_by_nbr_of_autos_in_lhs" | "biochemist") - | _,"kasim" -> Remanent_parameters_sig.No_correction - | (Loggers.SBML | Loggers.DOTNET),"divide_by_nbr_of_autos_in_lhs" -> - Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs - | (Loggers.SBML | Loggers.DOTNET),"biochemist" -> Remanent_parameters_sig.Biochemist - | _,s -> - begin + match + backend, Tools.lowercase !(ode_args.Ode_args.reaction_rate_convention) + with + | ( (Loggers.Octave | Loggers.Matlab | Loggers.Mathematica | Loggers.Maple), + ("kasim" | "divide_by_nbr_of_autos_in_lhs" | "biochemist") ) + | _, "kasim" -> + Remanent_parameters_sig.No_correction + | (Loggers.SBML | Loggers.DOTNET), "divide_by_nbr_of_autos_in_lhs" -> + Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs + | (Loggers.SBML | Loggers.DOTNET), "biochemist" -> + Remanent_parameters_sig.Biochemist + | _, s -> Format.printf - "Wrong option %s.@.Only KaSim and Biochemist are supported.@." - s; + "Wrong option %s.@.Only KaSim and Biochemist are supported.@." s; exit 0 - end in let propagate_constants = !(ode_args.Ode_args.propagate_constants) in let max_size = !(ode_args.Ode_args.max_size_for_species) in let () = - match - !(ode_args.Ode_args.matlab_output) - with + match !(ode_args.Ode_args.matlab_output) with | None -> () - | Some s -> - Ode_loggers_sig.set_ode - ~mode:Loggers.Matlab - s + | Some s -> Ode_loggers_sig.set_ode ~mode:Loggers.Matlab s in let () = - match - !(ode_args.Ode_args.octave_output) - with + match !(ode_args.Ode_args.octave_output) with | None -> () - | Some s -> - Ode_loggers_sig.set_ode - ~mode:Loggers.Octave - s + | Some s -> Ode_loggers_sig.set_ode ~mode:Loggers.Octave s in (*smbl*) let () = - match - !(ode_args.Ode_args.sbml_output) - with + match !(ode_args.Ode_args.sbml_output) with | None -> () - | Some s -> - Ode_loggers_sig.set_ode - ~mode:Loggers.SBML - s + | Some s -> Ode_loggers_sig.set_ode ~mode:Loggers.SBML s in (*dotnet*) let () = - match - !(ode_args.Ode_args.dotnet_output) - with + match !(ode_args.Ode_args.dotnet_output) with | None -> () - | Some s -> - Ode_loggers_sig.set_ode - ~mode:Loggers.DOTNET - s + | Some s -> Ode_loggers_sig.set_ode ~mode:Loggers.DOTNET s in let count = match Tools.lowercase !(ode_args.Ode_args.count) with | "embedding" | "embeddings" -> Ode_args.Embeddings - | "occurrences" | "occurrence" | "instances" | "instance"-> + | "occurrences" | "occurrence" | "instances" | "instance" -> Ode_args.Occurrences - | s -> - begin + | s -> Format.printf - "Wrong option %s.@.Only Embeddings and Occurrences are supported.@." - s; + "Wrong option %s.@.Only Embeddings and Occurrences are supported.@." s; exit 0 - end in let internal_meaning = match Tools.lowercase !(ode_args.Ode_args.internal_meaning) with | "embedding" | "embeddings" -> Ode_args.Embeddings - | "occurrences" | "occurrence" | "instances" | "instance"-> + | "occurrences" | "occurrence" | "instances" | "instance" -> Ode_args.Occurrences - | s -> - begin + | s -> Format.printf - "Wrong option %s.@.Only Embeddings and Occurrences are supported.@." - s; + "Wrong option %s.@.Only Embeddings and Occurrences are supported.@." s; exit 0 - end in let show_reactions = !(ode_args.Ode_args.show_reactions) in let compute_jacobian = !(ode_args.Ode_args.compute_jacobian) in @@ -164,242 +132,196 @@ let main ?called_from:(called_from=Remanent_parameters_sig.Server) () = let initial_step = !(ode_args.Ode_args.initial_step) in let max_step = !(ode_args.Ode_args.max_step) in let reltol = !(ode_args.Ode_args.relative_tolerance) in - let abstol= !(ode_args.Ode_args.absolute_tolerance) in + let abstol = !(ode_args.Ode_args.absolute_tolerance) in let () = if not cli_args.Run_cli_args.batchmode then Kappa_files.check_not_exists (Ode_loggers_sig.get_ode ~mode:backend) in let command_line = Format.asprintf "%a" - (Pp.array (fun f -> Format.fprintf f " ") + (Pp.array + (fun f -> Format.fprintf f " ") (fun i f s -> - Format.fprintf - f "%s" (if i = 0 then "KaDE" else s))) + Format.fprintf f "%s" + (if i = 0 then + "KaDE" + else + s))) Sys.argv in let command_line_quotes = Format.asprintf "%a" - (Pp.array Pp.space - (fun i f s -> - Format.fprintf - f "'%s'" (if i = 0 then "KaDE" else s))) + (Pp.array Pp.space (fun i f s -> + Format.fprintf f "'%s'" + (if i = 0 then + "KaDE" + else + s))) Sys.argv in - let ignore_obs,dotnet = + let ignore_obs, dotnet = match backend with - | Loggers.DOTNET -> true,true - | Loggers.SBML - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | - Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular | Loggers.GEPHI - | Loggers.XLS -> true,false - | Loggers.Octave | Loggers.Matlab - | Loggers.Mathematica | Loggers.Maple | Loggers.Json -> false,false - in - let ast = - A.get_ast cli_args - in - let preprocessed_ast = - A.preprocess cli_args ast + | Loggers.DOTNET -> true, true + | Loggers.SBML | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.GEPHI | Loggers.XLS -> + true, false + | Loggers.Octave | Loggers.Matlab | Loggers.Mathematica | Loggers.Maple + | Loggers.Json -> + false, false in + let ast = A.get_ast cli_args in + let preprocessed_ast = A.preprocess cli_args ast in (*************************************************************) (*TEST-symmetries*) let parameters = - Ode_args.build_kasa_parameters ~called_from ode_args - common_args + Ode_args.build_kasa_parameters ~called_from ode_args common_args in let parameters' = parameters in - let ground, forward, backward = 0,1,2 in + let ground, forward, backward = 0, 1, 2 in let reduction = - match Tools.lowercase !(ode_args.Ode_args.with_symmetries) - with + match Tools.lowercase !(ode_args.Ode_args.with_symmetries) with | "none" | "ground" | "false" -> ground | "true" | "forward" -> forward | "backward" -> backward | _ -> ground in - let network,compil = - if - (not (reduction = ground)) - || !(ode_args.Ode_args.show_symmetries) - then + let network, compil = + if (not (reduction = ground)) || !(ode_args.Ode_args.show_symmetries) then let module B = (val Domain_selection.select_domain - ~reachability_parameters:(Remanent_parameters.get_reachability_analysis_parameters parameters) ()) + ~reachability_parameters: + (Remanent_parameters.get_reachability_analysis_parameters + parameters) + ()) in let export_to_kade = - (module Export_to_KaDE.Export(B) : Export_to_KaDE.Type) + (module Export_to_KaDE.Export (B) : Export_to_KaDE.Type) in - let module Export_to_kade = - (val export_to_kade : Export_to_KaDE.Type) + let module Export_to_kade = (val export_to_kade : Export_to_KaDE.Type) in let () = Format.printf "+ compute symmetric sites... @." in - let state = - Export_to_kade.init ~compil:(A.to_ast ast) () - in - let parameters = - Export_to_kade.get_parameters state - in - let state = - Export_to_kade.set_parameters parameters state - in + let state = Export_to_kade.init ~compil:(A.to_ast ast) () in + let parameters = Export_to_kade.get_parameters state in + let state = Export_to_kade.set_parameters parameters state in let _state, contact_map = - Export_to_kade.get_contact_map - ~accuracy_level:Public_data.High state + Export_to_kade.get_contact_map ~accuracy_level:Public_data.High state in let parameters = - Remanent_parameters.set_logger - parameters + Remanent_parameters.set_logger parameters (Remanent_parameters.get_logger parameters') in let parameters = - Remanent_parameters.set_trace - parameters + Remanent_parameters.set_trace parameters (Remanent_parameters.get_trace parameters') in let compil = - A.get_compil - ~debugMode:common_args.Common_args.debug ~dotnet - ~reaction_rate_convention ~rule_rate_convention - ~show_reactions ~count ~internal_meaning ~compute_jacobian - cli_args preprocessed_ast + A.get_compil ~debug_mode:common_args.Common_args.debug ~dotnet + ~reaction_rate_convention ~rule_rate_convention ~show_reactions + ~count ~internal_meaning ~compute_jacobian cli_args preprocessed_ast in let network = A.init compil in let network = - A.compute_symmetries_from_model - parameters - compil - network - contact_map + A.compute_symmetries_from_model parameters compil network contact_map in - let network,compil = - if reduction = backward - then - let network = - A.set_to_backward_symmetries_from_model - network - in + let network, compil = + if reduction = backward then ( + let network = A.set_to_backward_symmetries_from_model network in let bwd_bisim = A.init_bwd_bisim_info network in - let () = Format.printf "+ restart compilation to account for ~-equivalent patterns in algebraic expressions... @." in + let () = + Format.printf + "+ restart compilation to account for ~-equivalent patterns in \ + algebraic expressions... @." + in let compil = - A.get_compil - ~debugMode:common_args.Common_args.debug ~dotnet ?bwd_bisim - ~reaction_rate_convention ~rule_rate_convention ~show_reactions - ~count ~internal_meaning ~compute_jacobian + A.get_compil ~debug_mode:common_args.Common_args.debug ~dotnet + ?bwd_bisim ~reaction_rate_convention ~rule_rate_convention + ~show_reactions ~count ~internal_meaning ~compute_jacobian cli_args preprocessed_ast in let network = A.reset compil network in - let network = - A.set_to_backward_symmetries_from_model - network - in + let network = A.set_to_backward_symmetries_from_model network in network, compil - else if reduction = forward - then - A.set_to_forward_symmetries_from_model - network, compil + ) else if reduction = forward then + A.set_to_forward_symmetries_from_model network, compil else network, compil in let () = - if !(ode_args.Ode_args.show_symmetries) - then - A.print_symmetries - parameters compil - network + if !(ode_args.Ode_args.show_symmetries) then + A.print_symmetries parameters compil network in - network,compil - else + network, compil + else ( let compil = - A.get_compil - ~debugMode:common_args.Common_args.debug ~dotnet - ~reaction_rate_convention ~rule_rate_convention - ~show_reactions ~count ~internal_meaning ~compute_jacobian - cli_args preprocessed_ast + A.get_compil ~debug_mode:common_args.Common_args.debug ~dotnet + ~reaction_rate_convention ~rule_rate_convention ~show_reactions + ~count ~internal_meaning ~compute_jacobian cli_args preprocessed_ast in let network = A.init compil in - network,compil - in - let smash_reactions = - !(ode_args.Ode_args.smash_reactions) + network, compil + ) in + let smash_reactions = !(ode_args.Ode_args.smash_reactions) in let network = - A.network_from_compil - ?max_size ~smash_reactions ~ignore_obs parameters compil network + A.network_from_compil ?max_size ~smash_reactions ~ignore_obs parameters + compil network in (*************************************************************) let out_channel = Kappa_files.open_out (Ode_loggers_sig.get_ode ~mode:backend) in - let pre_logger = Loggers.open_logger_from_channel ~mode:backend out_channel in - let csv_sep = - !(ode_args.Ode_args.csv_sep) + let pre_logger = + Loggers.open_logger_from_channel ~mode:backend out_channel in + let csv_sep = !(ode_args.Ode_args.csv_sep) in let logger = Ode_loggers_sig.extend_logger ~csv_sep pre_logger in let logger_buffer = - begin - match backend with - | Loggers.SBML -> - Ode_loggers_sig.extend_logger ~csv_sep - (Loggers.open_infinite_buffer ~mode:backend ()) - | Loggers.DOTNET - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS | Loggers.GEPHI - | Loggers.Octave | Loggers.Matlab - | Loggers.Mathematica | Loggers.Maple | Loggers.Json -> - logger - end + match backend with + | Loggers.SBML -> + Ode_loggers_sig.extend_logger ~csv_sep + (Loggers.open_infinite_buffer ~mode:backend ()) + | Loggers.DOTNET | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.GEPHI | Loggers.Octave + | Loggers.Matlab | Loggers.Mathematica | Loggers.Maple | Loggers.Json -> + logger in let logger_err = match backend with - | Loggers.DOTNET - | Loggers.SBML -> Loggers.open_infinite_buffer ~mode:backend () + | Loggers.DOTNET | Loggers.SBML -> + Loggers.open_infinite_buffer ~mode:backend () | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML - | Loggers.HTML_Tabular | Loggers.GEPHI - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS -> pre_logger - | Loggers.Octave | Loggers.Matlab - | Loggers.Mathematica | Loggers.Maple | Loggers.Json -> pre_logger + | Loggers.HTML_Tabular | Loggers.GEPHI | Loggers.DOT | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS -> + pre_logger + | Loggers.Octave | Loggers.Matlab | Loggers.Mathematica | Loggers.Maple + | Loggers.Json -> + pre_logger in let network = - A.export_network - ~command_line - ~command_line_quotes + A.export_network ~command_line ~command_line_quotes ?data_file:cli_args.Run_cli_args.outputDataFile ?init_t:cli_args.Run_cli_args.minValue ~max_t:(Option_util.unsome 1. cli_args.Run_cli_args.maxValue) - ~propagate_constants - ~compute_jacobian - ~show_time_advance - ~nonnegative - ~initial_step - ~max_step - ~reltol - ~abstol - ?plot_period:cli_args.Run_cli_args.plotPeriod - parameters - logger - logger_buffer - logger_err - compil network + ~propagate_constants ~compute_jacobian ~show_time_advance ~nonnegative + ~initial_step ~max_step ~reltol ~abstol + ?plot_period:cli_args.Run_cli_args.plotPeriod parameters logger + logger_buffer logger_err compil network in let () = Ode_loggers_sig.flush_logger logger in let () = close_out out_channel in let () = - if !(ode_args.Ode_args.print_efficiency) - then + if !(ode_args.Ode_args.print_efficiency) then ( let end_time = Sys.time () in let cpu_time = end_time -. start_time in let nrules, nreactions, nspecies = A.get_data network in let () = - Format.printf - "CPU time: %g s.; %i rules; %i species; %i reactions.@." + Format.printf "CPU time: %g s.; %i rules; %i species; %i reactions.@." cpu_time nrules nspecies nreactions in () + ) in () with diff --git a/core/odes/dune b/core/odes/dune index b4344fea64..43e27d2eff 100644 --- a/core/odes/dune +++ b/core/odes/dune @@ -1,19 +1,41 @@ (executable - (name KaDE) - (libraries num yojson str kappa-library.runtime kappa_grammar kappa_cli kappa_staticanalyses kappa_kasa_export ) - (public_name KaDE) - (package kappa-binaries) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms - -open Kappa_runtime - -open Kappa_grammar - -open Kappa_cli - -open Kappa_logging - -open Kappa_parameters - -open Kappa_staticanalyses - -open Kappa_symmetries - -open Kappa_reachability - -open Kappa_kasa_export - -open Kappa_kasa_type_interface))) + (name KaDE) + (libraries + num + yojson + str + kappa-library.runtime + kappa_grammar + kappa_cli + kappa_staticanalyses + kappa_kasa_export) + (public_name KaDE) + (package kappa-binaries) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms + -open + Kappa_runtime + -open + Kappa_grammar + -open + Kappa_cli + -open + Kappa_logging + -open + Kappa_parameters + -open + Kappa_staticanalyses + -open + Kappa_symmetries + -open + Kappa_reachability + -open + Kappa_kasa_export + -open + Kappa_kasa_type_interface))) diff --git a/core/odes/lin_comb.ml b/core/odes/lin_comb.ml index ac796a7b92..e07d4e6fb7 100644 --- a/core/odes/lin_comb.ml +++ b/core/odes/lin_comb.ml @@ -1,43 +1,44 @@ -module type Expr_sig = -sig +module type Expr_sig = sig type mix type id end -type ('mix,'id) var = - | Token of 'id - | Instances of 'mix +type ('mix, 'id) var = Token of 'id | Instances of 'mix -module type Lin_comb = -sig +module type Lin_comb = sig type mix type id type elt type t - val of_expr: - (id -> (mix,id) Alg_expr.e Locality.annot option) -> - (mix,id) Alg_expr.e Locality.annot -> t option + val of_expr : + (id -> (mix, id) Alg_expr.e Loc.annoted option) -> + (mix, id) Alg_expr.e Loc.annoted -> + t option - val print: + val print : sep:string -> product:string -> (Ode_loggers_sig.t -> mix -> unit) -> (Ode_loggers_sig.t -> id -> unit) -> - Ode_loggers_sig.t -> t -> unit - + Ode_loggers_sig.t -> + t -> + unit end module Make = - functor (Expr_sig:Expr_sig) -> - (struct +functor + (Expr_sig : Expr_sig) + -> + ( + struct type mix = Expr_sig.mix type id = Expr_sig.id - type elt = (mix,id) var + type elt = (mix, id) var - module O = - struct + module O = struct type t = elt + let compare = compare let print _ _ = () end @@ -47,156 +48,121 @@ module Make = type t = Nbr.t Map.t - let liftunit1 f () () a b c = - (), f a b c - - let liftunit2 f () () a b c d = - (), f a b c d - - let empty = - Some (Map.empty) + let liftunit1 f () () a b c = (), f a b c + let liftunit2 f () () a b c d = (), f a b c d + let empty = Some Map.empty let fold2 f g h t1 t2 acc = snd - ( - Map.monadic_fold2 () () - (liftunit2 h) - (liftunit1 f) - (liftunit1 g) - t1 t2 - acc - ) - + (Map.monadic_fold2 () () (liftunit2 h) (liftunit1 f) (liftunit1 g) t1 + t2 acc) let add t1 t2 = - fold2 - Map.add - Map.add + fold2 Map.add Map.add (fun k x y t -> - let z = Nbr.add x y in - if Nbr.is_zero z then t - else Map.add k z t) + let z = Nbr.add x y in + if Nbr.is_zero z then + t + else + Map.add k z t) t1 t2 Map.empty - let singleton elt = - Some (Map.add elt (Nbr.one) Map.empty) + let singleton elt = Some (Map.add elt Nbr.one Map.empty) let scale alpha t = - if Nbr.is_zero alpha then Map.empty - else if Nbr.is_equal alpha Nbr.one then t + if Nbr.is_zero alpha then + Map.empty + else if Nbr.is_equal alpha Nbr.one then + t else Map.map (Nbr.mult alpha) t let minus_one = Nbr.neg Nbr.one - let lift1 f = - (fun a -> - match a with None -> None - | Some a -> Some (f a)) + let lift1 f a = + match a with + | None -> None + | Some a -> Some (f a) - let lift2 f = - (fun a b -> - match a,b with None,_ | _,None -> None - | Some a,Some b -> Some (f a b)) + let lift2 f a b = + match a, b with + | None, _ | _, None -> None + | Some a, Some b -> Some (f a b) let add = lift2 add let scale a = lift1 (scale a) let rec of_expr env expr = - match expr - with - | Alg_expr.BIN_ALG_OP (op,a,b),_ -> - begin - match op with - | Operator.SUM -> - add - (of_expr env a) - (of_expr env b) - | Operator.MINUS -> - add - (of_expr env a) - (scale minus_one (of_expr env b)) - | Operator.MULT -> - begin - match a,b with - | (Alg_expr.CONST a,_), b - | b,(Alg_expr.CONST a,_) - -> - scale a (of_expr env b) - | (Alg_expr.DIFF_KAPPA_INSTANCE _,_ - | Alg_expr.DIFF_TOKEN _,_ - | Alg_expr.STATE_ALG_OP _,_ - | Alg_expr.ALG_VAR _,_ - | Alg_expr.KAPPA_INSTANCE _,_ - | Alg_expr.TOKEN_ID _,_ - | Alg_expr.IF _,_ - | Alg_expr.BIN_ALG_OP _,_ - | Alg_expr.UN_ALG_OP _,_), - (Alg_expr.DIFF_KAPPA_INSTANCE _,_ - | Alg_expr.DIFF_TOKEN _,_ - | Alg_expr.STATE_ALG_OP _,_ - | Alg_expr.ALG_VAR _,_ - | Alg_expr.KAPPA_INSTANCE _,_ - | Alg_expr.TOKEN_ID _,_ - | Alg_expr.IF _,_ - | Alg_expr.BIN_ALG_OP _,_ - | Alg_expr.UN_ALG_OP _,_) -> None - end - | Operator.DIV -> - begin - match b with - | Alg_expr.CONST b,_ when Nbr.is_zero b -> None - | Alg_expr.CONST b,_ -> - scale - (Nbr.internal_div Nbr.one b) - (of_expr env a) - | ( Alg_expr.ALG_VAR _ - | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_ - -> None - end - | Operator.POW - | Operator.MODULO - | Operator.MIN | Operator.MAX -> None - end - | Alg_expr.UN_ALG_OP (op,a),_ -> - begin - match op with - | Operator.UMINUS -> - scale minus_one (of_expr env a) - | Operator.COSINUS | Operator.EXP - | Operator.SINUS | Operator.TAN - | Operator.SQRT - | Operator.LOG | Operator.INT - -> None - end - | Alg_expr.CONST a,_ when Nbr.is_zero a-> empty - | Alg_expr.ALG_VAR x,_ -> - begin - match env x with + match expr with + | Alg_expr.BIN_ALG_OP (op, a, b), _ -> + (match op with + | Operator.SUM -> add (of_expr env a) (of_expr env b) + | Operator.MINUS -> + add (of_expr env a) (scale minus_one (of_expr env b)) + | Operator.MULT -> + (match a, b with + | (Alg_expr.CONST a, _), b | b, (Alg_expr.CONST a, _) -> + scale a (of_expr env b) + | ( ( Alg_expr.DIFF_KAPPA_INSTANCE _, _ + | Alg_expr.DIFF_TOKEN _, _ + | Alg_expr.STATE_ALG_OP _, _ + | Alg_expr.ALG_VAR _, _ + | Alg_expr.KAPPA_INSTANCE _, _ + | Alg_expr.TOKEN_ID _, _ + | Alg_expr.IF _, _ + | Alg_expr.BIN_ALG_OP _, _ + | Alg_expr.UN_ALG_OP _, _ ), + ( Alg_expr.DIFF_KAPPA_INSTANCE _, _ + | Alg_expr.DIFF_TOKEN _, _ + | Alg_expr.STATE_ALG_OP _, _ + | Alg_expr.ALG_VAR _, _ + | Alg_expr.KAPPA_INSTANCE _, _ + | Alg_expr.TOKEN_ID _, _ + | Alg_expr.IF _, _ + | Alg_expr.BIN_ALG_OP _, _ + | Alg_expr.UN_ALG_OP _, _ ) ) -> + None) + | Operator.DIV -> + (match b with + | Alg_expr.CONST b, _ when Nbr.is_zero b -> None + | Alg_expr.CONST b, _ -> + scale (Nbr.internal_div Nbr.one b) (of_expr env a) + | ( ( Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ + | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.DIFF_TOKEN _ ), + _ ) -> + None) + | Operator.POW | Operator.MODULO | Operator.MIN | Operator.MAX -> None) + | Alg_expr.UN_ALG_OP (op, a), _ -> + (match op with + | Operator.UMINUS -> scale minus_one (of_expr env a) + | Operator.COSINUS | Operator.EXP | Operator.SINUS | Operator.TAN + | Operator.SQRT | Operator.LOG | Operator.INT -> + None) + | Alg_expr.CONST a, _ when Nbr.is_zero a -> empty + | Alg_expr.ALG_VAR x, _ -> + (match env x with | None -> None - | Some a -> - of_expr env (Alg_expr_extra.simplify a) - end - | Alg_expr.KAPPA_INSTANCE mix,_ -> - singleton (Instances mix) - | Alg_expr.TOKEN_ID id,_ -> - singleton (Token id) - | Alg_expr.DIFF_KAPPA_INSTANCE _,_ - | Alg_expr.DIFF_TOKEN _,_ - | Alg_expr.STATE_ALG_OP _,_ - | Alg_expr.CONST _,_ - | Alg_expr.IF _,_ -> None + | Some a -> of_expr env (Alg_expr_extra.simplify a)) + | Alg_expr.KAPPA_INSTANCE mix, _ -> singleton (Instances mix) + | Alg_expr.TOKEN_ID id, _ -> singleton (Token id) + | Alg_expr.DIFF_KAPPA_INSTANCE _, _ + | Alg_expr.DIFF_TOKEN _, _ + | Alg_expr.STATE_ALG_OP _, _ + | Alg_expr.CONST _, _ + | Alg_expr.IF _, _ -> + None let to_list t = - List.rev_map (fun (a,b) -> (b,a)) (List.rev (Map.bindings t)) + List.rev_map (fun (a, b) -> b, a) (List.rev (Map.bindings t)) let print_first logger sep first = - if first then () - else Ode_loggers_sig.fprintf logger "%s" sep + if first then + () + else + Ode_loggers_sig.fprintf logger "%s" sep let print_v pr_mix pr_token logger var = match var with @@ -207,32 +173,30 @@ module Make = let l = to_list t in let _ = List.fold_left - (fun first (coef,var) -> - if Nbr.is_zero coef - then first - else - let () = print_first logger sep first in - if Nbr.is_equal Nbr.one coef then - let () = - print_v pr_mix pr_token logger var - in - false - else - let () = - Ode_loggers_sig.fprintf logger "%s%s" (Nbr.to_string coef) product - in - let () = print_v pr_mix pr_token logger var in - false) - true - l + (fun first (coef, var) -> + if Nbr.is_zero coef then + first + else ( + let () = print_first logger sep first in + if Nbr.is_equal Nbr.one coef then ( + let () = print_v pr_mix pr_token logger var in + false + ) else ( + let () = + Ode_loggers_sig.fprintf logger "%s%s" (Nbr.to_string coef) + product + in + let () = print_v pr_mix pr_token logger var in + false + ) + )) + true l in () + end : + Lin_comb with type mix = Expr_sig.mix and type id = Expr_sig.id) - end: Lin_comb with type mix = Expr_sig.mix and type id = Expr_sig.id) - -module Lin = - Make - (struct - type id = int - type mix = int - end) +module Lin = Make (struct + type id = int + type mix = int +end) diff --git a/core/odes/lin_comb.mli b/core/odes/lin_comb.mli index 767512754f..548799c4de 100644 --- a/core/odes/lin_comb.mli +++ b/core/odes/lin_comb.mli @@ -1,24 +1,22 @@ -module type Lin_comb = -sig - - +module type Lin_comb = sig type mix type id - type elt type t + val of_expr : + (id -> (mix, id) Alg_expr.e Loc.annoted option) -> + (mix, id) Alg_expr.e Loc.annoted -> + t option - val of_expr: - (id -> (mix,id) Alg_expr.e Locality.annot option) -> - (mix,id) Alg_expr.e Locality.annot -> t option - - val print: + val print : sep:string -> product:string -> (Ode_loggers_sig.t -> mix -> unit) -> (Ode_loggers_sig.t -> id -> unit) -> - Ode_loggers_sig.t -> t -> unit + Ode_loggers_sig.t -> + t -> + unit end module Lin : Lin_comb with type mix = int and type id = int diff --git a/core/odes/network_handler.ml b/core/odes/network_handler.ml index 107f0783fa..859433345d 100644 --- a/core/odes/network_handler.ml +++ b/core/odes/network_handler.ml @@ -1,6 +1,5 @@ -type ('a,'b) t = - { - int_of_obs: 'b -> int; - int_of_kappa_instance: 'a -> int; - int_of_token_id: 'b -> int; - } +type ('a, 'b) t = { + int_of_obs: 'b -> int; + int_of_kappa_instance: 'a -> int; + int_of_token_id: 'b -> int; +} diff --git a/core/odes/ode_loggers.ml b/core/odes/ode_loggers.ml index 681554985a..ed5b03c580 100644 --- a/core/odes/ode_loggers.ml +++ b/core/odes/ode_loggers.ml @@ -17,344 +17,377 @@ * under the terms of the GNU Library General Public License *) type correct = Div of int | Mul of int | Nil - -type options = - | Comment of string +type options = Comment of string let shall_I_do_it format filter_in filter_out = let b1 = - match - filter_in - with + match filter_in with | None -> true | Some l -> List.mem format l in - b1 && (not (List.mem format filter_out)) - + b1 && not (List.mem format filter_out) let print_list logger l = List.iter (fun s -> - let () = Ode_loggers_sig.fprintf logger "%s" s in - Ode_loggers_sig.print_newline logger) + let () = Ode_loggers_sig.fprintf logger "%s" s in + Ode_loggers_sig.print_newline logger) l -let print_ode_preamble - logger - command_line - ~may_be_not_time_homogeneous - ~count - ~rule_rate_convention - ?reaction_rate_convention - ?filter_in:(filter_in=None) ?filter_out:(filter_out=[]) - () - = +let print_ode_preamble logger command_line ~may_be_not_time_homogeneous ~count + ~rule_rate_convention ?reaction_rate_convention ?(filter_in = None) + ?(filter_out = []) () = let format = Ode_loggers_sig.get_encoding_format logger in - if shall_I_do_it format filter_in filter_out - then - match - format - with - | Loggers.Matlab | Loggers.Octave -> - begin - let () = command_line logger in - let () = print_list logger - [ - "%% THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS:"; - "%% "; - "%% init - the initial abundances of each species and token"; - "%% tinit - the initial simulation time (likely 0)"; - "%% tend - the final simulation time "; - "%% initialstep - initial time step at the beginning of numerical integration"; - "%% maxstep - maximal time step for numerical integration"; - "%% reltol - relative error tolerance;"; - "%% abstol - absolute error tolerance;"; - "%% "^(Ode_loggers_sig.string_of_array_name Ode_loggers_sig.Period_t_points)^" - the time period between points to return"; - "%%" ; - "%% "^ - (match - count - with - | Ode_args.Embeddings -> "variables (init(i),y(i)) denote numbers of embeddings " - | Ode_args.Occurrences -> "variables (init(i),y(i)) denote numbers occurrences"); - "%% "^ - (match - rule_rate_convention - with - | Remanent_parameters_sig.Common -> - "rule rates are corrected by automorphisms of the lhs that induce an automorphism in the rhs as weel; and by the automorphisms of the rhs that induce an automorphism in the lhs as well " - | Remanent_parameters_sig.Biochemist -> - "rule rates are corrected by the number of automorphisms that induce an automorphism in the rhs as well" - | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> - "rule rates are corrected by the number of automorphisms in the lhs of rules" - | Remanent_parameters_sig.No_correction -> - "no correcion is applied on rule rates")] - in - let () = Ode_loggers_sig.print_newline logger in - () - end + if shall_I_do_it format filter_in filter_out then ( + match format with + | Loggers.Matlab | Loggers.Octave -> + let () = command_line logger in + let () = + print_list logger + [ + "%% THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS:"; + "%% "; + "%% init - the initial abundances of each species and token"; + "%% tinit - the initial simulation time (likely 0)"; + "%% tend - the final simulation time "; + "%% initialstep - initial time step at the beginning of numerical \ + integration"; + "%% maxstep - maximal time step for numerical integration"; + "%% reltol - relative error tolerance;"; + "%% abstol - absolute error tolerance;"; + "%% " + ^ Ode_loggers_sig.string_of_array_name + Ode_loggers_sig.Period_t_points + ^ " - the time period between points to return"; + "%%"; + ("%% " + ^ + match count with + | Ode_args.Embeddings -> + "variables (init(i),y(i)) denote numbers of embeddings " + | Ode_args.Occurrences -> + "variables (init(i),y(i)) denote numbers occurrences"); + ("%% " + ^ + match rule_rate_convention with + | Remanent_parameters_sig.Common -> + "rule rates are corrected by automorphisms of the lhs that \ + induce an automorphism in the rhs as weel; and by the \ + automorphisms of the rhs that induce an automorphism in the lhs \ + as well " + | Remanent_parameters_sig.Biochemist -> + "rule rates are corrected by the number of automorphisms that \ + induce an automorphism in the rhs as well" + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + "rule rates are corrected by the number of automorphisms in the \ + lhs of rules" + | Remanent_parameters_sig.No_correction -> + "no correcion is applied on rule rates"); + ] + in + let () = Ode_loggers_sig.print_newline logger in + () | Loggers.DOTNET -> - begin - let () = command_line logger in - let () = - print_list logger - ([ - "# THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS:"; - "# "; - "# init - the initial abundances of each species and token"; - "# tinit - the initial simulation time (likely 0)"; - "# tend - the final simulation time "; - "# initialstep - initial time step at the beginning of numerical integration"; - "# maxstep - maximal time step for numerical integration"; - "# reltol - relative error tolerance;"; - "# abstol - absolute error tolerance;"; - "# "^(Ode_loggers_sig.string_of_array_name Ode_loggers_sig.Period_t_points)^" - the time period between points to return"; - "#" ; - "# "^ - (match - count - with - | Ode_args.Embeddings -> "variables (init(i),y(i)) denote numbers of embeddings " - | Ode_args.Occurrences -> "variables (init(i),y(i)) denote numbers occurrences"); - "# "^ - (match - rule_rate_convention - with - | Remanent_parameters_sig.Common -> - "rule rates are corrected by automorphisms common to the lhs and the rhs" - | Remanent_parameters_sig.Biochemist -> - "rule rates are corrected by the number of automorphisms that induce an automorphism in the rhs as well" - | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> - "rule rates are corrected by the number of automorphisms in the lhs of rules" - | Remanent_parameters_sig.No_correction -> - "no correcion is applied on rule rates"); - "# "^ - (match - reaction_rate_convention - with - | Some Remanent_parameters_sig.Common - | Some Remanent_parameters_sig.Biochemist -> - "reaction rates are corrected by the product, for each species, of the factorial of the min number of occurrence of this species in the lhs and in the rhs" - | Some Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> - "reaction rates are corrected by the product, for each species, of the factorial of the number of occurrence of this species in the lhs" - | None | Some (Remanent_parameters_sig.No_correction) -> - "no correcion is applied on reaction rates"); - - ]) - in () - end + let () = command_line logger in + let () = + print_list logger + [ + "# THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS:"; + "# "; + "# init - the initial abundances of each species and token"; + "# tinit - the initial simulation time (likely 0)"; + "# tend - the final simulation time "; + "# initialstep - initial time step at the beginning of numerical \ + integration"; + "# maxstep - maximal time step for numerical integration"; + "# reltol - relative error tolerance;"; + "# abstol - absolute error tolerance;"; + "# " + ^ Ode_loggers_sig.string_of_array_name + Ode_loggers_sig.Period_t_points + ^ " - the time period between points to return"; + "#"; + ("# " + ^ + match count with + | Ode_args.Embeddings -> + "variables (init(i),y(i)) denote numbers of embeddings " + | Ode_args.Occurrences -> + "variables (init(i),y(i)) denote numbers occurrences"); + ("# " + ^ + match rule_rate_convention with + | Remanent_parameters_sig.Common -> + "rule rates are corrected by automorphisms common to the lhs and \ + the rhs" + | Remanent_parameters_sig.Biochemist -> + "rule rates are corrected by the number of automorphisms that \ + induce an automorphism in the rhs as well" + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + "rule rates are corrected by the number of automorphisms in the \ + lhs of rules" + | Remanent_parameters_sig.No_correction -> + "no correcion is applied on rule rates"); + ("# " + ^ + match reaction_rate_convention with + | Some Remanent_parameters_sig.Common + | Some Remanent_parameters_sig.Biochemist -> + "reaction rates are corrected by the product, for each species, \ + of the factorial of the min number of occurrence of this \ + species in the lhs and in the rhs" + | Some Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + "reaction rates are corrected by the product, for each species, \ + of the factorial of the number of occurrence of this species in \ + the lhs" + | None | Some Remanent_parameters_sig.No_correction -> + "no correcion is applied on reaction rates"); + ] + in + () | Loggers.SBML -> - begin - let () = print_list logger - [ - "";] in - let () = command_line logger in - let () = print_list logger - ([ - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - "";]@(if may_be_not_time_homogeneous then - [ - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - ""; - "";] else [])@[ + let () = + print_list logger [ "" ] + in + let () = command_line logger in + let () = + print_list logger + ([ + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ] + @ (if may_be_not_time_homogeneous then + [ + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ""; + ] + else + []) + @ [ ""; ""; - ""; + ""; ""; - ]) - in () - end + ]) + in + () | Loggers.Maple -> - begin - let () = command_line logger in - let () = print_list logger - [ - "## THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS:"; - "## "; - "## init - the initial abundances of each species and token"; - "## tinit - the initial simulation time (likely 0)"; - "## tend - the final simulation time "; - "## initialstep - initial time step at the beginning of numerical integration"; - "## maxstep - maximal time step for numerical integration"; - "## reltol - relative error tolerance;"; - "## abstol - absolute error tolerance;"; - "## "^(Ode_loggers_sig.string_of_array_name Ode_loggers_sig.Period_t_points)^" - the time period between points to return"; - "##" ; - "## "^ - (match - count - with - | Ode_args.Embeddings -> "variables (initi(t),yi(t)) denote numbers of embeddings " - | Ode_args.Occurrences -> "variables (initi(t)),yi(t)) denote numbers occurrences"); - "## "^ - (match - rule_rate_convention - with - | Remanent_parameters_sig.Common -> - "rule rates are corrected by automorphisms of the lhs that induce an automorphism in the rhs as weel; and by the automorphisms of the rhs that induce an automorphism in the lhs as well " - | Remanent_parameters_sig.Biochemist -> - "rule rates are corrected by the number of automorphisms that induce an automorphism in the rhs as well" - | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> - "rule rates are corrected by the number of automorphisms in the lhs of rules" - | Remanent_parameters_sig.No_correction -> - "no correcion is applied on rule rates")] - in - let () = Ode_loggers_sig.print_newline logger in - () - end + let () = command_line logger in + let () = + print_list logger + [ + "## THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS:"; + "## "; + "## init - the initial abundances of each species and token"; + "## tinit - the initial simulation time (likely 0)"; + "## tend - the final simulation time "; + "## initialstep - initial time step at the beginning of numerical \ + integration"; + "## maxstep - maximal time step for numerical integration"; + "## reltol - relative error tolerance;"; + "## abstol - absolute error tolerance;"; + "## " + ^ Ode_loggers_sig.string_of_array_name + Ode_loggers_sig.Period_t_points + ^ " - the time period between points to return"; + "##"; + ("## " + ^ + match count with + | Ode_args.Embeddings -> + "variables (initi(t),yi(t)) denote numbers of embeddings " + | Ode_args.Occurrences -> + "variables (initi(t)),yi(t)) denote numbers occurrences"); + ("## " + ^ + match rule_rate_convention with + | Remanent_parameters_sig.Common -> + "rule rates are corrected by automorphisms of the lhs that \ + induce an automorphism in the rhs as weel; and by the \ + automorphisms of the rhs that induce an automorphism in the lhs \ + as well " + | Remanent_parameters_sig.Biochemist -> + "rule rates are corrected by the number of automorphisms that \ + induce an automorphism in the rhs as well" + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + "rule rates are corrected by the number of automorphisms in the \ + lhs of rules" + | Remanent_parameters_sig.No_correction -> + "no correcion is applied on rule rates"); + ] + in + let () = Ode_loggers_sig.print_newline logger in + () | Loggers.Mathematica -> - begin - let () = command_line logger in - let () = print_list logger - [ - "(* THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS: *)"; - "(* *) "; - "(* init - the initial abundances of each species and token *)"; - "(* tinit - the initial simulation time (likely 0) *)"; - "(* tend - the final simulation time *)"; - "(* initialstep - initial time step at the beginning of numerical integration *)"; - "(* maxstep - maximal time step for numerical integration *)"; - "(* reltol - relative error tolerance *)"; - "(* abstol - absolute error tolerance *)"; - "(* "^(Ode_loggers_sig.string_of_array_name - Ode_loggers_sig.Period_t_points)^" - the time period between points to return *)"; - "(* *)" ; - "(* "^ - (match - count - with - | Ode_args.Embeddings -> "variables (initi[t],yi[t]) denote numbers of embeddings *)" - | Ode_args.Occurrences -> "variables (initi[t]),yi[t]) denote numbers occurrences *)"); - "(* "^ - (match - rule_rate_convention - with - | Remanent_parameters_sig.Common -> - "rule rates are corrected by automorphisms of the lhs that induce an automorphism in the rhs as weel; and by the automorphisms of the rhs that induce an automorphism in the lhs as well *)" - | Remanent_parameters_sig.Biochemist -> - "rule rates are corrected by the number of automorphisms that induce an automorphism in the rhs as well *)" - | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> - "rule rates are corrected by the number of automorphisms in the lhs of rules *)" - | Remanent_parameters_sig.No_correction -> - "no correcion is applied on rule rates*)")] - in - let () = Ode_loggers_sig.print_newline logger in - () - end - | Loggers.Json | Loggers.GEPHI - | Loggers.DOT - | Loggers.Matrix - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS -> () + let () = command_line logger in + let () = + print_list logger + [ + "(* THINGS THAT ARE KNOWN FROM KAPPA FILE AND KaSim OPTIONS: *)"; + "(* *) "; + "(* init - the initial abundances of each species and token *)"; + "(* tinit - the initial simulation time (likely 0) *)"; + "(* tend - the final simulation time *)"; + "(* initialstep - initial time step at the beginning of numerical \ + integration *)"; + "(* maxstep - maximal time step for numerical integration *)"; + "(* reltol - relative error tolerance *)"; + "(* abstol - absolute error tolerance *)"; + "(* " + ^ Ode_loggers_sig.string_of_array_name + Ode_loggers_sig.Period_t_points + ^ " - the time period between points to return *)"; + "(* *)"; + ("(* " + ^ + match count with + | Ode_args.Embeddings -> + "variables (initi[t],yi[t]) denote numbers of embeddings *)" + | Ode_args.Occurrences -> + "variables (initi[t]),yi[t]) denote numbers occurrences *)"); + ("(* " + ^ + match rule_rate_convention with + | Remanent_parameters_sig.Common -> + "rule rates are corrected by automorphisms of the lhs that \ + induce an automorphism in the rhs as weel; and by the \ + automorphisms of the rhs that induce an automorphism in the lhs \ + as well *)" + | Remanent_parameters_sig.Biochemist -> + "rule rates are corrected by the number of automorphisms that \ + induce an automorphism in the rhs as well *)" + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + "rule rates are corrected by the number of automorphisms in the \ + lhs of rules *)" + | Remanent_parameters_sig.No_correction -> + "no correcion is applied on rule rates*)"); + ] + in + let () = Ode_loggers_sig.print_newline logger in + () + | Loggers.Json | Loggers.GEPHI | Loggers.DOT | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + ) let declare_global logger string = let format = Ode_loggers_sig.get_encoding_format logger in let string = Ode_loggers_sig.string_of_array_name string in - match - format - with - | Loggers.Matlab | Loggers.Octave -> - begin - let () = Ode_loggers_sig.fprintf logger "global %s" string in - let () = Ode_loggers_sig.print_newline logger in - () - end - | Loggers.SBML | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica -> () - | Loggers.Json - | Loggers.DOT - | Loggers.Matrix | Loggers.GEPHI + match format with + | Loggers.Matlab | Loggers.Octave -> + let () = Ode_loggers_sig.fprintf logger "global %s" string in + let () = Ode_loggers_sig.print_newline logger in + () + | Loggers.SBML | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica -> () + | Loggers.Json | Loggers.DOT | Loggers.Matrix | Loggers.GEPHI | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let affect_symbol logger = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica -> "=" + match format with + | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica -> "=" | Loggers.Maple -> ":=" - | Loggers.Json - | Loggers.SBML | Loggers.DOTNET - | Loggers.Matrix | Loggers.DOT + | Loggers.Json | Loggers.SBML | Loggers.DOTNET | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.GEPHI - | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS -> "" - + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "" let repeat f last = let rec aux f k n = - if k>n then () - else - if k=1 then + if k > n then + () + else if k = 1 then ( let () = f false k in - aux f (k+1) n - else + aux f (k + 1) n + ) else ( let () = f true k in - aux f (k+1) n - in aux f 1 last + aux f (k + 1) n + ) + in + aux f 1 last let of_t ~side logger s = let format = Ode_loggers_sig.get_encoding_format logger in @@ -366,271 +399,206 @@ let of_t ~side logger s = match format with | Loggers.Maple -> Format.sprintf "(%s)" s | Loggers.Mathematica -> Format.sprintf "[%s%s]" s ext - | Loggers.Matlab | Loggers.Octave - | Loggers.SBML | Loggers.DOTNET - | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph - | Loggers.Js_Graph | Loggers.HTML | Loggers.GEPHI - | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS - | Loggers.Json -> "" - - + | Loggers.Matlab | Loggers.Octave | Loggers.SBML | Loggers.DOTNET + | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.GEPHI | Loggers.HTML_Tabular | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Json -> + "" let instruction_sep logger = let format = Ode_loggers_sig.get_encoding_format logger in match format with | Loggers.Maple -> ":" | Loggers.Mathematica -> ";" - | Loggers.Matlab | Loggers.Octave -> ";" - | Loggers.SBML | Loggers.DOTNET - | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph - | Loggers.Js_Graph | Loggers.HTML | Loggers.GEPHI - | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Json -> "" + | Loggers.Matlab | Loggers.Octave -> ";" + | Loggers.SBML | Loggers.DOTNET | Loggers.Matrix | Loggers.DOT + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.GEPHI + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS + | Loggers.Json -> + "" -let csv_sep logger = - Ode_loggers_sig.csv_sep logger +let csv_sep logger = Ode_loggers_sig.csv_sep logger let initialize ~nodevar logger variable = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab | Loggers.Octave -> - begin - let () = - match variable with - | Ode_loggers_sig.Rate _ - | Ode_loggers_sig.Rated _ - | Ode_loggers_sig.Rateun _ - | Ode_loggers_sig.Rateund _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nrules,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Stochiometric_coef _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nrules,max_stoc_coef)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Jacobian_stochiometric_coef _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nrules,max_stoc_coef,nodevar)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateund _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nrules,nodevar)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Expr _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nvar,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Init _ -> - Ode_loggers_sig.fprintf logger "%s=sparse(nodevar,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Initbis _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nodevar,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Concentration _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nodevar,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Deriv _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nodevar,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Jacobian _ -> - Ode_loggers_sig.fprintf logger "%s=sparse(nodevar,nodevar)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Jacobian_var _ -> - Ode_loggers_sig.fprintf logger "%s=sparse(nvar,nodevar)%s" + match format with + | Loggers.Matlab | Loggers.Octave -> + let () = + match variable with + | Ode_loggers_sig.Rate _ | Ode_loggers_sig.Rated _ + | Ode_loggers_sig.Rateun _ | Ode_loggers_sig.Rateund _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nrules,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Stochiometric_coef _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nrules,max_stoc_coef)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Jacobian_stochiometric_coef _ -> + Ode_loggers_sig.fprintf logger + "%s=zeros(nrules,max_stoc_coef,nodevar)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rateun _ + | Ode_loggers_sig.Jacobian_rated _ | Ode_loggers_sig.Jacobian_rateund _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nrules,nodevar)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Expr _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nvar,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Init _ -> + Ode_loggers_sig.fprintf logger "%s=sparse(nodevar,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Initbis _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nodevar,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Concentration _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nodevar,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Deriv _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nodevar,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Jacobian _ -> + Ode_loggers_sig.fprintf logger "%s=sparse(nodevar,nodevar)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Jacobian_var _ -> + Ode_loggers_sig.fprintf logger "%s=sparse(nvar,nodevar)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.Obs _ -> + Ode_loggers_sig.fprintf logger "%s=zeros(nobs,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + | Ode_loggers_sig.NonNegative | Ode_loggers_sig.Tinit + | Ode_loggers_sig.Tend | Ode_loggers_sig.MaxStep + | Ode_loggers_sig.InitialStep | Ode_loggers_sig.AbsTol + | Ode_loggers_sig.RelTol | Ode_loggers_sig.Period_t_points + | Ode_loggers_sig.N_ode_var | Ode_loggers_sig.N_var + | Ode_loggers_sig.N_rows | Ode_loggers_sig.N_obs + | Ode_loggers_sig.N_max_stoc_coef | Ode_loggers_sig.Current_time + | Ode_loggers_sig.Time_scale_factor | Ode_loggers_sig.N_rules -> + () + | Ode_loggers_sig.Tmp -> + Ode_loggers_sig.fprintf logger "%s = zeros(nodevar,1)%s" + (Ode_loggers_sig.string_of_array_name variable) + (instruction_sep logger) + in + let () = + match variable with + | Ode_loggers_sig.Tmp | Ode_loggers_sig.Rate _ | Ode_loggers_sig.Rateun _ + | Ode_loggers_sig.Rated _ | Ode_loggers_sig.Rateund _ + | Ode_loggers_sig.Expr _ | Ode_loggers_sig.Init _ + | Ode_loggers_sig.Initbis _ | Ode_loggers_sig.Concentration _ + | Ode_loggers_sig.Deriv _ | Ode_loggers_sig.Obs _ + | Ode_loggers_sig.Jacobian _ | Ode_loggers_sig.Jacobian_var _ + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rateun _ + | Ode_loggers_sig.Jacobian_rated _ | Ode_loggers_sig.Jacobian_rateund _ + | Ode_loggers_sig.Jacobian_stochiometric_coef _ + | Ode_loggers_sig.Stochiometric_coef _ -> + Ode_loggers_sig.print_newline logger + | Ode_loggers_sig.Tinit | Ode_loggers_sig.Tend | Ode_loggers_sig.MaxStep + | Ode_loggers_sig.InitialStep | Ode_loggers_sig.AbsTol + | Ode_loggers_sig.RelTol | Ode_loggers_sig.N_ode_var + | Ode_loggers_sig.N_rows | Ode_loggers_sig.N_var | Ode_loggers_sig.N_obs + | Ode_loggers_sig.N_rules | Ode_loggers_sig.N_max_stoc_coef + | Ode_loggers_sig.Time_scale_factor | Ode_loggers_sig.NonNegative + | Ode_loggers_sig.Current_time | Ode_loggers_sig.Period_t_points -> + () + in + () + | Loggers.Json | Loggers.Maple | Loggers.Mathematica -> + let () = + match variable with + | Ode_loggers_sig.Rate _ | Ode_loggers_sig.Rated _ + | Ode_loggers_sig.Rateun _ | Ode_loggers_sig.Rateund _ + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rateun _ + | Ode_loggers_sig.Jacobian_rated _ | Ode_loggers_sig.Jacobian_rateund _ + | Ode_loggers_sig.Expr _ | Ode_loggers_sig.Concentration _ + | Ode_loggers_sig.Initbis _ | Ode_loggers_sig.Stochiometric_coef _ + | Ode_loggers_sig.Jacobian_stochiometric_coef _ + | Ode_loggers_sig.NonNegative | Ode_loggers_sig.Jacobian _ + | Ode_loggers_sig.Jacobian_var _ | Ode_loggers_sig.Obs _ + | Ode_loggers_sig.Tinit | Ode_loggers_sig.Tend | Ode_loggers_sig.MaxStep + | Ode_loggers_sig.InitialStep | Ode_loggers_sig.AbsTol + | Ode_loggers_sig.RelTol | Ode_loggers_sig.Period_t_points + | Ode_loggers_sig.N_ode_var | Ode_loggers_sig.N_var + | Ode_loggers_sig.N_rows | Ode_loggers_sig.N_obs + | Ode_loggers_sig.N_max_stoc_coef | Ode_loggers_sig.Current_time + | Ode_loggers_sig.Time_scale_factor | Ode_loggers_sig.Tmp + | Ode_loggers_sig.N_rules -> + () + | Ode_loggers_sig.Init _ -> + repeat + (fun _ k -> + let () = + Ode_loggers_sig.fprintf logger "%s%i%s0%s" (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.Obs _ -> - Ode_loggers_sig.fprintf logger "%s=zeros(nobs,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.Tend - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.Period_t_points - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.Current_time - | Ode_loggers_sig.Time_scale_factor - | Ode_loggers_sig.N_rules -> () - | Ode_loggers_sig.Tmp -> - Ode_loggers_sig.fprintf logger "%s = zeros(nodevar,1)%s" - (Ode_loggers_sig.string_of_array_name variable) - (instruction_sep logger) - in - let () = - match variable with - | Ode_loggers_sig.Tmp - | Ode_loggers_sig.Rate _ - | Ode_loggers_sig.Rateun _ - | Ode_loggers_sig.Rated _ - | Ode_loggers_sig.Rateund _ - | Ode_loggers_sig.Expr _ - | Ode_loggers_sig.Init _ - | Ode_loggers_sig.Initbis _ - | Ode_loggers_sig.Concentration _ - | Ode_loggers_sig.Deriv _ - | Ode_loggers_sig.Obs _ - | Ode_loggers_sig.Jacobian _ - | Ode_loggers_sig.Jacobian_var _ - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateund _ - | Ode_loggers_sig.Jacobian_stochiometric_coef _ - | Ode_loggers_sig.Stochiometric_coef _ - -> Ode_loggers_sig.print_newline logger - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.Tend - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_rules - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.Time_scale_factor - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.Current_time - | Ode_loggers_sig.Period_t_points -> () - in - () - end - | Loggers.Json - | Loggers.Maple | Loggers.Mathematica -> - begin - let () = - match variable with - | Ode_loggers_sig.Rate _ - | Ode_loggers_sig.Rated _ - | Ode_loggers_sig.Rateun _ - | Ode_loggers_sig.Rateund _ - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateund _ - | Ode_loggers_sig.Expr _ - | Ode_loggers_sig.Concentration _ - | Ode_loggers_sig.Initbis _ - | Ode_loggers_sig.Stochiometric_coef _ - | Ode_loggers_sig.Jacobian_stochiometric_coef _ - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.Jacobian _ - | Ode_loggers_sig.Jacobian_var _ - | Ode_loggers_sig.Obs _ - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.Tend - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.Period_t_points - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.Current_time - | Ode_loggers_sig.Time_scale_factor - | Ode_loggers_sig.Tmp - | Ode_loggers_sig.N_rules -> () - | Ode_loggers_sig.Init _ -> - repeat - (fun _ k -> - let () = - Ode_loggers_sig.fprintf logger "%s%i%s0%s" - (Ode_loggers_sig.string_of_array_name variable) - k - (affect_symbol logger) - (instruction_sep logger) - in - let () = - Ode_loggers_sig.print_newline logger - in - ()) - (nodevar-1) - | Ode_loggers_sig.Deriv _ -> - repeat - (fun _ k -> - let () = - Ode_loggers_sig.fprintf logger "%s%i%s%s0%s" + k (affect_symbol logger) (instruction_sep logger) + in + let () = Ode_loggers_sig.print_newline logger in + ()) + (nodevar - 1) + | Ode_loggers_sig.Deriv _ -> + repeat + (fun _ k -> + let () = + Ode_loggers_sig.fprintf logger "%s%i%s%s0%s" (Ode_loggers_sig.string_of_array_name variable) k (of_t ~side:Ode_loggers_sig.LHS logger "t") - (affect_symbol logger) - (instruction_sep logger) - in - let () = - Ode_loggers_sig.print_newline logger - in - ()) - (nodevar-1) - in - () - end + (affect_symbol logger) (instruction_sep logger) + in + let () = Ode_loggers_sig.print_newline logger in + ()) + (nodevar - 1) + in + () | Loggers.SBML | Loggers.DOTNET -> () - | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML - | Loggers.HTML_Tabular | Loggers.TXT | Loggers.GEPHI - | Loggers.TXT_Tabular | Loggers.XLS -> () - + | Loggers.Matrix | Loggers.DOT | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.GEPHI + | Loggers.TXT_Tabular | Loggers.XLS -> + () let print_newline logger = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica | Loggers.Maple - -> Ode_loggers_sig.print_newline logger - | Loggers.Json - | Loggers.SBML | Loggers.DOTNET -> () - | Loggers.DOT | Loggers.HTML_Graph | Loggers.GEPHI - | Loggers.Js_Graph | Loggers.HTML - | Loggers.Matrix | Loggers.HTML_Tabular | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS -> () + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica | Loggers.Maple -> + Ode_loggers_sig.print_newline logger + | Loggers.Json | Loggers.SBML | Loggers.DOTNET -> () + | Loggers.DOT | Loggers.HTML_Graph | Loggers.GEPHI | Loggers.Js_Graph + | Loggers.HTML | Loggers.Matrix | Loggers.HTML_Tabular | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS -> + () type bin_op_pos = PREFIX | INFIX | POSTFIX + let _ = POSTFIX + let bin_op_pos _logger op = match op with - | Operator.MULT | Operator.POW | Operator.MINUS | Operator.SUM | Operator.DIV -> INFIX + | Operator.MULT | Operator.POW | Operator.MINUS | Operator.SUM | Operator.DIV + -> + INFIX | Operator.MIN | Operator.MODULO | Operator.MAX -> PREFIX let string_of_bin_op logger op = match op with | Operator.MULT -> "*" | Operator.POW -> - begin - match Ode_loggers_sig.get_encoding_format logger with - | Loggers.Matlab -> "^" - | Loggers.Maple | Loggers.Mathematica | Loggers.Octave -> "**" - | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.GEPHI - | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS| Loggers.SBML | Loggers.DOTNET | - Loggers.Json -> "**" - end - + (match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab -> "^" + | Loggers.Maple | Loggers.Mathematica | Loggers.Octave -> "**" + | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML_Tabular | Loggers.DOT | Loggers.GEPHI | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.SBML | Loggers.DOTNET + | Loggers.Json -> + "**") | Operator.MINUS -> "-" | Operator.SUM -> "+" | Operator.DIV -> "/" @@ -641,17 +609,11 @@ let string_of_bin_op logger op = let is_fun _logger op = match op with | Operator.UMINUS -> false - | Operator.LOG | Operator.SQRT | Operator.EXP - | Operator.SINUS | Operator.COSINUS | Operator.TAN - | Operator.INT-> true - + | Operator.LOG | Operator.SQRT | Operator.EXP | Operator.SINUS + | Operator.COSINUS | Operator.TAN | Operator.INT -> + true -type parenthesis_mode = - Always - | Never - | In_sum - | In_product - | In_power +type parenthesis_mode = Always | Never | In_sum | In_product | In_power let parenthesis_needed ?parenthesis_mode () = match parenthesis_mode with @@ -661,7 +623,7 @@ let parenthesis_needed ?parenthesis_mode () = let parenthesis_needed_in_sum ?parenthesis_mode () = match parenthesis_mode with | Some (Never | In_sum) -> false - | None | Some Always | Some In_product | Some In_power-> true + | None | Some Always | Some In_product | Some In_power -> true let parenthesis_needed_in_product ?parenthesis_mode () = match parenthesis_mode with @@ -669,48 +631,43 @@ let parenthesis_needed_in_product ?parenthesis_mode () = | None | Some (Always | In_power) -> true let parenthesis_needed_in_power ?parenthesis_mode () = - match parenthesis_mode with - | Some (Never | In_product | In_sum | In_power) -> false - | None | Some Always -> true + match parenthesis_mode with + | Some (Never | In_product | In_sum | In_power) -> false + | None | Some Always -> true let keep_none a b = - match a with None -> None - | Some _ -> b + match a with + | None -> None + | Some _ -> b + let parenthesis_needed_in_bin_op ?parenthesis_mode bin_op = let keep_none a = keep_none parenthesis_mode (Some a) in match bin_op with | Operator.MULT -> - parenthesis_needed_in_product ?parenthesis_mode (), - keep_none In_product, - keep_none In_product + ( parenthesis_needed_in_product ?parenthesis_mode (), + keep_none In_product, + keep_none In_product ) | Operator.POW -> - parenthesis_needed_in_power ?parenthesis_mode (), - keep_none In_power, - keep_none In_power + ( parenthesis_needed_in_power ?parenthesis_mode (), + keep_none In_power, + keep_none In_power ) | Operator.MINUS -> - parenthesis_needed_in_sum ?parenthesis_mode (), - keep_none In_sum, - keep_none Always + ( parenthesis_needed_in_sum ?parenthesis_mode (), + keep_none In_sum, + keep_none Always ) | Operator.SUM -> - parenthesis_needed_in_sum ?parenthesis_mode (), - keep_none In_sum, - keep_none In_sum + ( parenthesis_needed_in_sum ?parenthesis_mode (), + keep_none In_sum, + keep_none In_sum ) | Operator.DIV -> - parenthesis_needed_in_product ?parenthesis_mode (), - keep_none In_product, - keep_none Always + ( parenthesis_needed_in_product ?parenthesis_mode (), + keep_none In_product, + keep_none Always ) | Operator.MIN -> - parenthesis_needed ?parenthesis_mode (), - keep_none Never, - keep_none Never - | Operator.MODULO -> - true, - keep_none Never, - keep_none Never + parenthesis_needed ?parenthesis_mode (), keep_none Never, keep_none Never + | Operator.MODULO -> true, keep_none Never, keep_none Never | Operator.MAX -> - parenthesis_needed ?parenthesis_mode (), - keep_none Never, - keep_none Never + parenthesis_needed ?parenthesis_mode (), keep_none Never, keep_none Never let parenthesis_needed_in_un_op ?parenthesis_mode logger op = let keep_none a = keep_none parenthesis_mode (Some a) in @@ -727,737 +684,676 @@ let parenthesis_needed_in_bin_bool_op ?parenthesis_mode () = let octave_matlab format = match format with - | Loggers.Matlab | Loggers.Octave -> true - | Loggers.Mathematica | Loggers.Maple - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> false + | Loggers.Matlab | Loggers.Octave -> true + | Loggers.Mathematica | Loggers.Maple | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + false let dotnet_format format = match format with | Loggers.DOTNET -> true - | Loggers.Matlab | Loggers.Octave - | Loggers.Mathematica | Loggers.Maple - | Loggers.SBML | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> false + | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica | Loggers.Maple + | Loggers.SBML | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + false let mathematica format = match format with | Loggers.Mathematica -> true - | Loggers.Maple - | Loggers.Matlab | Loggers.Octave - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> false - + | Loggers.Maple | Loggers.Matlab | Loggers.Octave | Loggers.SBML + | Loggers.DOTNET | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + false let mathematica_maple format = match format with | Loggers.Mathematica | Loggers.Maple -> true - | Loggers.Matlab | Loggers.Octave - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> false + | Loggers.Matlab | Loggers.Octave | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + false let show_time_advance logger = match Ode_loggers_sig.get_encoding_format logger with | Loggers.Octave | Loggers.Matlab -> let () = Ode_loggers_sig.fprintf logger "t" in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let associate_nonnegative logger bool = match Ode_loggers_sig.get_encoding_format logger with | Loggers.Octave | Loggers.Matlab -> - let side=Ode_loggers_sig.LHS in + let side = Ode_loggers_sig.LHS in let () = Ode_loggers_sig.fprintf logger "%s%s%s%s" - (Ode_loggers_sig.string_of_variable ~side logger Ode_loggers_sig.NonNegative) + (Ode_loggers_sig.string_of_variable ~side logger + Ode_loggers_sig.NonNegative) (affect_symbol logger) - (if bool then "true" else "false") + (if bool then + "true" + else + "false") (instruction_sep logger) in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let replace_exp s = let l = String.split_on_char 'e' s in match l with - | [a;b] -> a^"*^"^b + | [ a; b ] -> a ^ "*^" ^ b | _ -> s -let rec print_alg_expr ?init_mode ?parenthesis_mode string_of_var_id - logger logger_err alg_expr network_handler = - let var = match init_mode with +let rec print_alg_expr ?init_mode ?parenthesis_mode string_of_var_id logger + logger_err alg_expr network_handler = + let var = + match init_mode with | None -> "y" - | Some init_mode -> if init_mode then "init" else "y" in + | Some init_mode -> + if init_mode then + "init" + else + "y" + in let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab - | Loggers.Octave | Loggers.Mathematica | Loggers.Maple + match format with + | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica | Loggers.Maple | Loggers.DOTNET -> - begin - match fst alg_expr with - | Alg_expr.CONST (Nbr.I n) -> Ode_loggers_sig.fprintf logger "%i" n - | Alg_expr.CONST (Nbr.I64 n) -> Ode_loggers_sig.fprintf logger "%i" (Int64.to_int n) - | Alg_expr.CONST (Nbr.F f) -> - if (*fst (modf f) = 0.*) - (* No!!! *) - (* The float data-type contains more natural numbers than the int data type *) - (* Ex: int_of_float 6e23 = 0 *) - float_of_int (int_of_float f) = f - then - Ode_loggers_sig.fprintf logger "%i" (int_of_float f) - else - if mathematica format - then - let s = Printf.sprintf "%g" f in - let s = replace_exp s in - Ode_loggers_sig.fprintf logger "%s" s - else - Ode_loggers_sig.fprintf logger "%g" f - | Alg_expr.ALG_VAR x -> - if octave_matlab format then - Ode_loggers_sig.fprintf - logger "var(%i)" - (network_handler.Network_handler.int_of_obs x) - else if mathematica_maple format then - let ext = - match - init_mode - with - | Some true -> of_t ~side:Ode_loggers_sig.RHS logger "0" - | Some _ | None -> of_t ~side:Ode_loggers_sig.RHS logger "t" - in - Ode_loggers_sig.fprintf - logger "var%i%s" - (network_handler.Network_handler.int_of_obs x) - ext - else if dotnet_format format - then - Ode_loggers_sig.fprintf - logger "%s" - (string_of_var_id (network_handler.Network_handler.int_of_obs x)) - else () - | Alg_expr.DIFF_TOKEN((Alg_expr.ALG_VAR x,_),id) -> - if octave_matlab format then - Ode_loggers_sig.fprintf - logger "jacvar(%i,%i)" - (network_handler.Network_handler.int_of_obs x) - id - else - if dotnet_format format then - raise - (ExceptionDefn.Internal_Error - ("Differentiated expressions are not allowed in DOTNET backend!!!", - snd alg_expr)) - | Alg_expr.DIFF_KAPPA_INSTANCE((Alg_expr.ALG_VAR x,_),id) -> - if octave_matlab format then - Ode_loggers_sig.fprintf - logger "jacvar(%i,%i)" - (network_handler.Network_handler.int_of_obs x) - (network_handler.Network_handler.int_of_kappa_instance id) - else - if dotnet_format format then - raise - (ExceptionDefn.Internal_Error - ("Differentiated expressions are not allowed in DOTNET backend!!!",snd alg_expr)) - | Alg_expr.DIFF_TOKEN _ - | Alg_expr.DIFF_KAPPA_INSTANCE _ -> + (match fst alg_expr with + | Alg_expr.CONST (Nbr.I n) -> Ode_loggers_sig.fprintf logger "%i" n + | Alg_expr.CONST (Nbr.I64 n) -> + Ode_loggers_sig.fprintf logger "%i" (Int64.to_int n) + | Alg_expr.CONST (Nbr.F f) -> + if + (*fst (modf f) = 0.*) + (* No!!! *) + (* The float data-type contains more natural numbers than the int data type *) + (* Ex: int_of_float 6e23 = 0 *) + float_of_int (int_of_float f) = f + then + Ode_loggers_sig.fprintf logger "%i" (int_of_float f) + else if mathematica format then ( + let s = Printf.sprintf "%g" f in + let s = replace_exp s in + Ode_loggers_sig.fprintf logger "%s" s + ) else + Ode_loggers_sig.fprintf logger "%g" f + | Alg_expr.ALG_VAR x -> + if octave_matlab format then + Ode_loggers_sig.fprintf logger "var(%i)" + (network_handler.Network_handler.int_of_obs x) + else if mathematica_maple format then ( + let ext = + match init_mode with + | Some true -> of_t ~side:Ode_loggers_sig.RHS logger "0" + | Some _ | None -> of_t ~side:Ode_loggers_sig.RHS logger "t" + in + Ode_loggers_sig.fprintf logger "var%i%s" + (network_handler.Network_handler.int_of_obs x) + ext + ) else if dotnet_format format then + Ode_loggers_sig.fprintf logger "%s" + (string_of_var_id (network_handler.Network_handler.int_of_obs x)) + else + () + | Alg_expr.DIFF_TOKEN ((Alg_expr.ALG_VAR x, _), id) -> + if octave_matlab format then + Ode_loggers_sig.fprintf logger "jacvar(%i,%i)" + (network_handler.Network_handler.int_of_obs x) + id + else if dotnet_format format then raise (ExceptionDefn.Internal_Error - ("Differentiation should be pushed to the leaves of the expression!!!", - snd alg_expr)) - | Alg_expr.KAPPA_INSTANCE x -> - if octave_matlab format then - Ode_loggers_sig.fprintf - logger "%s(%i)" var - (network_handler.Network_handler.int_of_kappa_instance x) - else if mathematica_maple format then - let ext = - match init_mode with Some true -> "" - | None | Some _ -> of_t ~side:Ode_loggers_sig.RHS logger "t" - in - Ode_loggers_sig.fprintf - logger "%s%i%s" var - (network_handler.Network_handler.int_of_kappa_instance x) ext - else if dotnet_format format then - let () = - Sbml_backend.warn_expr - alg_expr - ("DOTNET backend does not support kappa expression in rates for rules: cowardly replacing it with 0") - logger - logger_err - in - Ode_loggers_sig.fprintf logger "0" - | Alg_expr.TOKEN_ID x -> - if octave_matlab format then - Ode_loggers_sig.fprintf - logger "%s(%i)" var - (network_handler.Network_handler.int_of_token_id x) - else if mathematica_maple format then - let ext = - match init_mode with Some true -> "" - | None | Some _ -> of_t ~side:Ode_loggers_sig.RHS logger "t" - in - Ode_loggers_sig.fprintf - logger "%s%i%s" var - (network_handler.Network_handler.int_of_kappa_instance x) ext - else if dotnet_format format then - let () = - Sbml_backend.warn_expr - alg_expr - ("DOTNET backend does not support token values in rates for rules: cowardly replacing it with 0") - logger - logger_err - in - Ode_loggers_sig.fprintf logger "0" - | Alg_expr.STATE_ALG_OP (Operator.TMAX_VAR) -> Ode_loggers_sig.fprintf logger "tend" - | Alg_expr.STATE_ALG_OP (Operator.CPUTIME) -> Ode_loggers_sig.fprintf logger "0" - | Alg_expr.STATE_ALG_OP (Operator.TIME_VAR) -> - if dotnet_format format then - let () = - Sbml_backend.warn_expr - alg_expr - ("DOTNET backend does not support time-dependent expressions in rates for rules: cowardly replacing it with 0") - logger - logger_err - in - Ode_loggers_sig.fprintf logger "0" - else - Ode_loggers_sig.fprintf logger "t" - | Alg_expr.STATE_ALG_OP (Operator.EVENT_VAR) -> Ode_loggers_sig.fprintf logger "0" - | Alg_expr.STATE_ALG_OP (Operator.EMAX_VAR) -> Ode_loggers_sig.fprintf logger "event_max" - | Alg_expr.STATE_ALG_OP (Operator.NULL_EVENT_VAR) -> Ode_loggers_sig.fprintf logger "0" - | Alg_expr.BIN_ALG_OP (op, a, b) -> - begin - let parenthesis_needed, mode1, mode2 = - parenthesis_needed_in_bin_op - ?parenthesis_mode - op - in - let string_op = string_of_bin_op logger op in - match bin_op_pos logger op - with - | INFIX -> - let () = - if parenthesis_needed - then - Ode_loggers_sig.fprintf logger "(" - in - let () = - print_alg_expr - ?parenthesis_mode:mode1 - ?init_mode - string_of_var_id logger logger_err a network_handler - in - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - let () = - print_alg_expr - ?parenthesis_mode:mode2 - ?init_mode - string_of_var_id logger logger_err b network_handler - in - let () = - if parenthesis_needed - then - Ode_loggers_sig.fprintf logger ")" in - () - | PREFIX -> - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - let () = Ode_loggers_sig.fprintf logger "(" in - let () = - print_alg_expr - ?parenthesis_mode:mode1 ?init_mode - string_of_var_id logger logger_err a network_handler - in - let () = Ode_loggers_sig.fprintf logger "," in - let () = - print_alg_expr - ?parenthesis_mode:mode2 ?init_mode - string_of_var_id logger logger_err b network_handler - in - let () = Ode_loggers_sig.fprintf logger ")" in - () - | POSTFIX -> - let () = Ode_loggers_sig.fprintf logger "(" in - let () = - print_alg_expr - ?parenthesis_mode:mode1 ?init_mode - string_of_var_id logger logger_err a network_handler - in - let () = Ode_loggers_sig.fprintf logger "," in - let () = - print_alg_expr - ?parenthesis_mode:mode2 ?init_mode - string_of_var_id logger logger_err b network_handler - in - let () = Ode_loggers_sig.fprintf logger ")" in - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - () - end - - | Alg_expr.UN_ALG_OP (op, a) -> - let parenthesis_needed_outside, - parenthesis_needed_inside, - mode - = - parenthesis_needed_in_un_op - ?parenthesis_mode logger - op + ( "Differentiated expressions are not allowed in DOTNET backend!!!", + snd alg_expr )) + | Alg_expr.DIFF_KAPPA_INSTANCE ((Alg_expr.ALG_VAR x, _), id) -> + if octave_matlab format then + Ode_loggers_sig.fprintf logger "jacvar(%i,%i)" + (network_handler.Network_handler.int_of_obs x) + (network_handler.Network_handler.int_of_kappa_instance id) + else if dotnet_format format then + raise + (ExceptionDefn.Internal_Error + ( "Differentiated expressions are not allowed in DOTNET backend!!!", + snd alg_expr )) + | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ -> + raise + (ExceptionDefn.Internal_Error + ( "Differentiation should be pushed to the leaves of the \ + expression!!!", + snd alg_expr )) + | Alg_expr.KAPPA_INSTANCE x -> + if octave_matlab format then + Ode_loggers_sig.fprintf logger "%s(%i)" var + (network_handler.Network_handler.int_of_kappa_instance x) + else if mathematica_maple format then ( + let ext = + match init_mode with + | Some true -> "" + | None | Some _ -> of_t ~side:Ode_loggers_sig.RHS logger "t" in + Ode_loggers_sig.fprintf logger "%s%i%s" var + (network_handler.Network_handler.int_of_kappa_instance x) + ext + ) else if dotnet_format format then ( let () = - if parenthesis_needed_outside - then - Ode_loggers_sig.fprintf logger "(" + Sbml_backend.warn_expr alg_expr + "DOTNET backend does not support kappa expression in rates for \ + rules: cowardly replacing it with 0" + logger logger_err in - let string_op = Ode_loggers_sig.string_of_un_op logger op in - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - let () = - if parenthesis_needed_inside - then Ode_loggers_sig.fprintf logger "(" + Ode_loggers_sig.fprintf logger "0" + ) + | Alg_expr.TOKEN_ID x -> + if octave_matlab format then + Ode_loggers_sig.fprintf logger "%s(%i)" var + (network_handler.Network_handler.int_of_token_id x) + else if mathematica_maple format then ( + let ext = + match init_mode with + | Some true -> "" + | None | Some _ -> of_t ~side:Ode_loggers_sig.RHS logger "t" in - let () = print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger logger_err a network_handler in + Ode_loggers_sig.fprintf logger "%s%i%s" var + (network_handler.Network_handler.int_of_kappa_instance x) + ext + ) else if dotnet_format format then ( let () = - if parenthesis_needed_inside - then Ode_loggers_sig.fprintf logger ")" + Sbml_backend.warn_expr alg_expr + "DOTNET backend does not support token values in rates for rules: \ + cowardly replacing it with 0" + logger logger_err in + Ode_loggers_sig.fprintf logger "0" + ) + | Alg_expr.STATE_ALG_OP Operator.TMAX_VAR -> + Ode_loggers_sig.fprintf logger "tend" + | Alg_expr.STATE_ALG_OP Operator.CPUTIME -> + Ode_loggers_sig.fprintf logger "0" + | Alg_expr.STATE_ALG_OP Operator.TIME_VAR -> + if dotnet_format format then ( let () = - if parenthesis_needed_outside - then - Ode_loggers_sig.fprintf logger ")" + Sbml_backend.warn_expr alg_expr + "DOTNET backend does not support time-dependent expressions in \ + rates for rules: cowardly replacing it with 0" + logger logger_err in - () - | Alg_expr.IF (cond, yes, no) -> - let mode = keep_none parenthesis_mode (Some Never) in - let () = Ode_loggers_sig.fprintf logger "merge(" in - let () = print_bool_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger logger_err cond network_handler in - let () = Ode_loggers_sig.fprintf logger "," in - let () = print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger logger_err yes network_handler in - let () = Ode_loggers_sig.fprintf logger "," in - let () = print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger logger_err no network_handler in - let () = Ode_loggers_sig.fprintf logger ")" in - () - end - | Loggers.SBML -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = - Sbml_backend.print_alg_expr_in_sbml - string_of_var_id logger logger_err alg_expr - network_handler in - let () = Ode_loggers_sig.fprintf logger "" in - () - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () - -and print_bool_expr ?parenthesis_mode ?init_mode string_of_var_id logger logger_err expr - network_handler = - match Ode_loggers_sig.get_encoding_format logger with - | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica | Loggers.Maple - -> - begin - match fst expr with - | Alg_expr.TRUE -> Ode_loggers_sig.fprintf logger "true" - | Alg_expr.FALSE -> Ode_loggers_sig.fprintf logger "false" - | Alg_expr.COMPARE_OP (op,a,b) -> - let mode = keep_none parenthesis_mode (Some Never) in + Ode_loggers_sig.fprintf logger "0" + ) else + Ode_loggers_sig.fprintf logger "t" + | Alg_expr.STATE_ALG_OP Operator.EVENT_VAR -> + Ode_loggers_sig.fprintf logger "0" + | Alg_expr.STATE_ALG_OP Operator.EMAX_VAR -> + Ode_loggers_sig.fprintf logger "event_max" + | Alg_expr.STATE_ALG_OP Operator.NULL_EVENT_VAR -> + Ode_loggers_sig.fprintf logger "0" + | Alg_expr.BIN_ALG_OP (op, a, b) -> + let parenthesis_needed, mode1, mode2 = + parenthesis_needed_in_bin_op ?parenthesis_mode op + in + let string_op = string_of_bin_op logger op in + (match bin_op_pos logger op with + | INFIX -> let () = - print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger logger_err a network_handler in - let () = Ode_loggers_sig.fprintf logger "%s" (Ode_loggers_sig.string_of_compare_op logger op) in - let () = print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger logger_err b network_handler in - let () = Ode_loggers_sig.fprintf logger ")" in - () - | Alg_expr.BIN_BOOL_OP (op,a,b) -> - let do_paren, mode = - parenthesis_needed_in_bin_bool_op ?parenthesis_mode () + if parenthesis_needed then Ode_loggers_sig.fprintf logger "(" in let () = - if do_paren then - Ode_loggers_sig.fprintf logger "(" + print_alg_expr ?parenthesis_mode:mode1 ?init_mode string_of_var_id + logger logger_err a network_handler in + let () = Ode_loggers_sig.fprintf logger "%s" string_op in let () = - print_bool_expr - ?parenthesis_mode:mode ?init_mode string_of_var_id logger logger_err a network_handler + print_alg_expr ?parenthesis_mode:mode2 ?init_mode string_of_var_id + logger logger_err b network_handler in - let () = Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_bin_bool_op logger op) in - let () = print_bool_expr ?init_mode string_of_var_id logger logger_err b network_handler in let () = - if do_paren then - Ode_loggers_sig.fprintf logger ")" + if parenthesis_needed then Ode_loggers_sig.fprintf logger ")" in () - | Alg_expr.UN_BOOL_OP (op,a) -> - let () = Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_un_bool_op logger op) in - let () = print_bool_expr ~parenthesis_mode:Always ?init_mode - string_of_var_id logger logger_err a network_handler in - () - end - | Loggers.SBML -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = - Sbml_backend.print_bool_expr_in_sbml - string_of_var_id logger logger_err expr network_handler - in - let () = Ode_loggers_sig.fprintf logger "" in () - | Loggers.DOTNET (*TODO*) - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () - -let print_alg_expr_few_parenthesis ?init_mode string_of_var_id logger logger_err alg_expr network_handler = - print_alg_expr - ?init_mode ?parenthesis_mode:(Some Never) - string_of_var_id logger logger_err - (Alg_expr_extra.simplify alg_expr) - network_handler - -let string_of_variable_sbml string_of_var_id variable = - match variable with - | Ode_loggers_sig.Expr i -> - string_of_var_id i - | Ode_loggers_sig.Concentration i -> "s"^(string_of_int i) - | Ode_loggers_sig.Obs _ - | Ode_loggers_sig.Init _ - | Ode_loggers_sig.Initbis _ - | Ode_loggers_sig.Deriv _ - | Ode_loggers_sig.Jacobian _ - | Ode_loggers_sig.Jacobian_var _ - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.Tend - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.Period_t_points - | Ode_loggers_sig.N_rules - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.Tmp -> Ode_loggers_sig.string_of_array_name variable - | Ode_loggers_sig.Time_scale_factor -> "t_correct_dimmension" - | Ode_loggers_sig.Current_time -> "t" - | Ode_loggers_sig.Rate int -> Printf.sprintf "k%i" int - | Ode_loggers_sig.Rated int -> Printf.sprintf "kd%i" int - | Ode_loggers_sig.Rateun int -> Printf.sprintf "kun%i" int - | Ode_loggers_sig.Rateund int -> Printf.sprintf "kdun%i" int - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateund _ - | Ode_loggers_sig.Stochiometric_coef _ - | Ode_loggers_sig.Jacobian_stochiometric_coef _ -> "" - - - - let unit_of_variable_sbml variable = - match variable with - | Ode_loggers_sig.Current_time - | Ode_loggers_sig.Period_t_points - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.Tend -> Some "time" - | Ode_loggers_sig.Time_scale_factor -> Some "time-per-substance" - | Ode_loggers_sig.Obs _ - | Ode_loggers_sig.Init _ - | Ode_loggers_sig.Concentration _ - | Ode_loggers_sig.Stochiometric_coef _ - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.Initbis _ -> Some "substance" - | Ode_loggers_sig.Expr _ - | Ode_loggers_sig.Deriv _ - | Ode_loggers_sig.Jacobian _ - | Ode_loggers_sig.Jacobian_var _ - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rateund _ - | Ode_loggers_sig.Jacobian_stochiometric_coef _ - | Ode_loggers_sig.Rate _ - | Ode_loggers_sig.Rated _ - | Ode_loggers_sig.Rateun _ - | Ode_loggers_sig.Rateund _ - | Ode_loggers_sig.N_rules - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.Tmp -> None - -let print_sbml_parameters string_of_var_id logger logger_buffer logger_err variable expr = - let unit_string = - match - unit_of_variable_sbml variable - with - | None -> "" - | Some x -> " units=\""^x^"\"" - in - let id = string_of_variable_sbml string_of_var_id variable in - let () = Ode_loggers_sig.set_id_of_global_parameter logger variable id in - let () = - Sbml_backend.do_sbml logger logger_err (fun logger logger_err -> - Sbml_backend.single_box - logger_buffer logger_err - "parameter" - ~options:(fun () -> - Format.sprintf - "metaid=\"%s\" id=\"%s\" value=\"%s\"%s" - (Sbml_backend.meta_id_of_logger logger) - id - (Nbr.to_string expr) - unit_string) - ) - in - Sbml_backend.do_dotnet logger logger_err - (fun logger logger_err -> - Sbml_backend.single_box - logger_buffer logger_err - "" - ~options:(fun () -> - Format.sprintf - "%s %s %s" - (Sbml_backend.dotnet_id_of_logger logger) - id - (Nbr.to_string expr)) - ) - -let print_comment - ?breakline:(breakline=false) - logger - ?filter_in:(filter_in=None) ?filter_out:(filter_out=[]) - string - = - if string = "" - then - () - else - let format = Ode_loggers_sig.get_encoding_format logger in - if shall_I_do_it format filter_in filter_out - then - match - format - with - | Loggers.Matlab - | Loggers.Octave -> - let () = Ode_loggers_sig.fprintf logger "%% %s" string in - if breakline then Ode_loggers_sig.print_newline logger - | Loggers.Maple -> - let () = Ode_loggers_sig.fprintf logger "# %s" string in - if breakline then Ode_loggers_sig.print_newline logger - | Loggers.Mathematica -> - let () = Ode_loggers_sig.fprintf logger "(* %s *)" string in - if breakline then Ode_loggers_sig.print_newline logger - | Loggers.SBML -> - let () = Ode_loggers_sig.fprintf logger "" (Sbml_backend.string_in_comment string) in - if breakline then - Ode_loggers_sig.print_newline logger - else Ode_loggers_sig.print_breakable_hint logger - | Loggers.DOTNET -> - (*print comments *) - let () = Ode_loggers_sig.fprintf logger "# %s" - (Sbml_backend.string_in_comment string) in - if breakline then - Ode_loggers_sig.print_newline logger - else Ode_loggers_sig.print_breakable_hint logger - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () - -let is_time expr = - fst expr = Alg_expr.STATE_ALG_OP (Operator.TIME_VAR) - -let associate ~propagate_constants ?init_mode:(init_mode=false) ?comment:(comment="") - string_of_var_id logger logger_buffer logger_err variable alg_expr network_handler = - let () = Ode_loggers_sig.set_expr logger variable alg_expr in - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab | Loggers.Octave -> - begin - let () = - Ode_loggers_sig.fprintf logger "%s=" - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger variable) - in - let () = print_alg_expr_few_parenthesis ~init_mode string_of_var_id logger logger_err alg_expr network_handler in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = if comment = "" then () else Ode_loggers_sig.fprintf logger " " in - let () = print_comment logger comment in - let () = Ode_loggers_sig.print_newline logger in - () - end - | Loggers.Maple -> - begin - match variable with - | Ode_loggers_sig.Expr int - | Ode_loggers_sig.Concentration int - | Ode_loggers_sig.Obs int - | Ode_loggers_sig.Deriv int - | Ode_loggers_sig.Rate int - | Ode_loggers_sig.Rated int - | Ode_loggers_sig.Rateun int - | Ode_loggers_sig.Rateund int - -> - begin - let () = - Ode_loggers_sig.fprintf logger "%s%i:=(t -> " - (Ode_loggers_sig.string_of_array_name variable) int - in - let () = - print_alg_expr_few_parenthesis - ~init_mode string_of_var_id logger logger_err - alg_expr network_handler - in - let () = Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) in - let () = if comment = "" then () else Ode_loggers_sig.fprintf logger " " in - let () = print_comment logger comment in - let () = Ode_loggers_sig.print_newline logger in - () - end - | Ode_loggers_sig.Stochiometric_coef (int1, int2) - -> - begin - let () = - Ode_loggers_sig.fprintf logger "%s%i_%i:=(t -> " - (Ode_loggers_sig.string_of_array_name variable) int1 int2 - in - let () = - print_alg_expr_few_parenthesis - ~init_mode string_of_var_id logger logger_err - alg_expr network_handler - in - let () = Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) in - let () = if comment = "" then () else Ode_loggers_sig.fprintf logger " " in - let () = print_comment logger comment in - let () = Ode_loggers_sig.print_newline logger in - () - end - - | Ode_loggers_sig.Init int - | Ode_loggers_sig.Initbis int -> + | PREFIX -> + let () = Ode_loggers_sig.fprintf logger "%s" string_op in + let () = Ode_loggers_sig.fprintf logger "(" in let () = - Ode_loggers_sig.fprintf logger "%s%i:=" - (Ode_loggers_sig.string_of_array_name variable) int + print_alg_expr ?parenthesis_mode:mode1 ?init_mode string_of_var_id + logger logger_err a network_handler in + let () = Ode_loggers_sig.fprintf logger "," in let () = - print_alg_expr_few_parenthesis - ~init_mode string_of_var_id logger logger_err - alg_expr network_handler + print_alg_expr ?parenthesis_mode:mode2 ?init_mode string_of_var_id + logger logger_err b network_handler in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = if comment = "" then () else Ode_loggers_sig.fprintf logger " " in - let () = print_comment logger comment in - let () = Ode_loggers_sig.print_newline logger in + let () = Ode_loggers_sig.fprintf logger ")" in () - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.Tend - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.Period_t_points - | Ode_loggers_sig.N_rules - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.Tmp - | Ode_loggers_sig.Current_time - | Ode_loggers_sig.Time_scale_factor -> + | POSTFIX -> + let () = Ode_loggers_sig.fprintf logger "(" in + let () = + print_alg_expr ?parenthesis_mode:mode1 ?init_mode string_of_var_id + logger logger_err a network_handler + in + let () = Ode_loggers_sig.fprintf logger "," in + let () = + print_alg_expr ?parenthesis_mode:mode2 ?init_mode string_of_var_id + logger logger_err b network_handler + in + let () = Ode_loggers_sig.fprintf logger ")" in + let () = Ode_loggers_sig.fprintf logger "%s" string_op in + ()) + | Alg_expr.UN_ALG_OP (op, a) -> + let parenthesis_needed_outside, parenthesis_needed_inside, mode = + parenthesis_needed_in_un_op ?parenthesis_mode logger op + in let () = - Ode_loggers_sig.fprintf logger "%s:=" + if parenthesis_needed_outside then Ode_loggers_sig.fprintf logger "(" + in + let string_op = Ode_loggers_sig.string_of_un_op logger op in + let () = Ode_loggers_sig.fprintf logger "%s" string_op in + let () = + if parenthesis_needed_inside then Ode_loggers_sig.fprintf logger "(" + in + let () = + print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger + logger_err a network_handler + in + let () = + if parenthesis_needed_inside then Ode_loggers_sig.fprintf logger ")" + in + let () = + if parenthesis_needed_outside then Ode_loggers_sig.fprintf logger ")" + in + () + | Alg_expr.IF (cond, yes, no) -> + let mode = keep_none parenthesis_mode (Some Never) in + let () = Ode_loggers_sig.fprintf logger "merge(" in + let () = + print_bool_expr ?parenthesis_mode:mode ?init_mode string_of_var_id + logger logger_err cond network_handler + in + let () = Ode_loggers_sig.fprintf logger "," in + let () = + print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger + logger_err yes network_handler + in + let () = Ode_loggers_sig.fprintf logger "," in + let () = + print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger + logger_err no network_handler + in + let () = Ode_loggers_sig.fprintf logger ")" in + ()) + | Loggers.SBML -> + let () = + Ode_loggers_sig.fprintf logger + "" + in + let () = + Sbml_backend.print_alg_expr_in_sbml string_of_var_id logger logger_err + alg_expr network_handler + in + let () = Ode_loggers_sig.fprintf logger "" in + () + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + +and print_bool_expr ?parenthesis_mode ?init_mode string_of_var_id logger + logger_err expr network_handler = + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave | Loggers.Mathematica | Loggers.Maple -> + (match fst expr with + | Alg_expr.TRUE -> Ode_loggers_sig.fprintf logger "true" + | Alg_expr.FALSE -> Ode_loggers_sig.fprintf logger "false" + | Alg_expr.COMPARE_OP (op, a, b) -> + let mode = keep_none parenthesis_mode (Some Never) in + let () = + print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger + logger_err a network_handler + in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_compare_op logger op) + in + let () = + print_alg_expr ?parenthesis_mode:mode ?init_mode string_of_var_id logger + logger_err b network_handler + in + let () = Ode_loggers_sig.fprintf logger ")" in + () + | Alg_expr.BIN_BOOL_OP (op, a, b) -> + let do_paren, mode = + parenthesis_needed_in_bin_bool_op ?parenthesis_mode () + in + let () = if do_paren then Ode_loggers_sig.fprintf logger "(" in + let () = + print_bool_expr ?parenthesis_mode:mode ?init_mode string_of_var_id + logger logger_err a network_handler + in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_bin_bool_op logger op) + in + let () = + print_bool_expr ?init_mode string_of_var_id logger logger_err b + network_handler + in + let () = if do_paren then Ode_loggers_sig.fprintf logger ")" in + () + | Alg_expr.UN_BOOL_OP (op, a) -> + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_un_bool_op logger op) + in + let () = + print_bool_expr ~parenthesis_mode:Always ?init_mode string_of_var_id + logger logger_err a network_handler + in + ()) + | Loggers.SBML -> + let () = + Ode_loggers_sig.fprintf logger + "" + in + let () = + Sbml_backend.print_bool_expr_in_sbml string_of_var_id logger logger_err + expr network_handler + in + let () = Ode_loggers_sig.fprintf logger "" in + () + | Loggers.DOTNET (*TODO*) + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + +let print_alg_expr_few_parenthesis ?init_mode string_of_var_id logger logger_err + alg_expr network_handler = + print_alg_expr ?init_mode ?parenthesis_mode:(Some Never) string_of_var_id + logger logger_err + (Alg_expr_extra.simplify alg_expr) + network_handler + +let string_of_variable_sbml string_of_var_id variable = + match variable with + | Ode_loggers_sig.Expr i -> string_of_var_id i + | Ode_loggers_sig.Concentration i -> "s" ^ string_of_int i + | Ode_loggers_sig.Obs _ | Ode_loggers_sig.Init _ | Ode_loggers_sig.Initbis _ + | Ode_loggers_sig.Deriv _ | Ode_loggers_sig.Jacobian _ + | Ode_loggers_sig.Jacobian_var _ | Ode_loggers_sig.NonNegative + | Ode_loggers_sig.Tinit | Ode_loggers_sig.Tend | Ode_loggers_sig.MaxStep + | Ode_loggers_sig.InitialStep | Ode_loggers_sig.AbsTol + | Ode_loggers_sig.RelTol | Ode_loggers_sig.Period_t_points + | Ode_loggers_sig.N_rules | Ode_loggers_sig.N_ode_var | Ode_loggers_sig.N_var + | Ode_loggers_sig.N_obs | Ode_loggers_sig.N_rows + | Ode_loggers_sig.N_max_stoc_coef | Ode_loggers_sig.Tmp -> + Ode_loggers_sig.string_of_array_name variable + | Ode_loggers_sig.Time_scale_factor -> "t_correct_dimmension" + | Ode_loggers_sig.Current_time -> "t" + | Ode_loggers_sig.Rate int -> Printf.sprintf "k%i" int + | Ode_loggers_sig.Rated int -> Printf.sprintf "kd%i" int + | Ode_loggers_sig.Rateun int -> Printf.sprintf "kun%i" int + | Ode_loggers_sig.Rateund int -> Printf.sprintf "kdun%i" int + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rateun _ + | Ode_loggers_sig.Jacobian_rated _ | Ode_loggers_sig.Jacobian_rateund _ + | Ode_loggers_sig.Stochiometric_coef _ + | Ode_loggers_sig.Jacobian_stochiometric_coef _ -> + "" + +let unit_of_variable_sbml variable = + match variable with + | Ode_loggers_sig.Current_time | Ode_loggers_sig.Period_t_points + | Ode_loggers_sig.MaxStep | Ode_loggers_sig.InitialStep + | Ode_loggers_sig.Tinit | Ode_loggers_sig.Tend -> + Some "time" + | Ode_loggers_sig.Time_scale_factor -> Some "time-per-substance" + | Ode_loggers_sig.Obs _ | Ode_loggers_sig.Init _ + | Ode_loggers_sig.Concentration _ | Ode_loggers_sig.Stochiometric_coef _ + | Ode_loggers_sig.AbsTol | Ode_loggers_sig.RelTol | Ode_loggers_sig.Initbis _ + -> + Some "substance" + | Ode_loggers_sig.Expr _ | Ode_loggers_sig.Deriv _ + | Ode_loggers_sig.Jacobian _ | Ode_loggers_sig.Jacobian_var _ + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rated _ + | Ode_loggers_sig.Jacobian_rateun _ | Ode_loggers_sig.Jacobian_rateund _ + | Ode_loggers_sig.Jacobian_stochiometric_coef _ | Ode_loggers_sig.Rate _ + | Ode_loggers_sig.Rated _ | Ode_loggers_sig.Rateun _ + | Ode_loggers_sig.Rateund _ | Ode_loggers_sig.N_rules + | Ode_loggers_sig.N_ode_var | Ode_loggers_sig.N_var | Ode_loggers_sig.N_obs + | Ode_loggers_sig.N_max_stoc_coef | Ode_loggers_sig.NonNegative + | Ode_loggers_sig.N_rows | Ode_loggers_sig.Tmp -> + None + +let print_sbml_parameters string_of_var_id logger logger_buffer logger_err + variable expr = + let unit_string = + match unit_of_variable_sbml variable with + | None -> "" + | Some x -> " units=\"" ^ x ^ "\"" + in + let id = string_of_variable_sbml string_of_var_id variable in + let () = Ode_loggers_sig.set_id_of_global_parameter logger variable id in + let () = + Sbml_backend.do_sbml logger logger_err (fun logger logger_err -> + Sbml_backend.single_box logger_buffer logger_err "parameter" + ~options:(fun () -> + Format.sprintf "metaid=\"%s\" id=\"%s\" value=\"%s\"%s" + (Sbml_backend.meta_id_of_logger logger) + id (Nbr.to_string expr) unit_string)) + in + Sbml_backend.do_dotnet logger logger_err (fun logger logger_err -> + Sbml_backend.single_box logger_buffer logger_err "" ~options:(fun () -> + Format.sprintf "%s %s %s" + (Sbml_backend.dotnet_id_of_logger logger) + id (Nbr.to_string expr))) + +let print_comment ?(breakline = false) logger ?(filter_in = None) + ?(filter_out = []) string = + if string = "" then + () + else ( + let format = Ode_loggers_sig.get_encoding_format logger in + if shall_I_do_it format filter_in filter_out then ( + match format with + | Loggers.Matlab | Loggers.Octave -> + let () = Ode_loggers_sig.fprintf logger "%% %s" string in + if breakline then Ode_loggers_sig.print_newline logger + | Loggers.Maple -> + let () = Ode_loggers_sig.fprintf logger "# %s" string in + if breakline then Ode_loggers_sig.print_newline logger + | Loggers.Mathematica -> + let () = Ode_loggers_sig.fprintf logger "(* %s *)" string in + if breakline then Ode_loggers_sig.print_newline logger + | Loggers.SBML -> + let () = + Ode_loggers_sig.fprintf logger "" + (Sbml_backend.string_in_comment string) + in + if breakline then + Ode_loggers_sig.print_newline logger + else + Ode_loggers_sig.print_breakable_hint logger + | Loggers.DOTNET -> + (*print comments *) + let () = + Ode_loggers_sig.fprintf logger "# %s" + (Sbml_backend.string_in_comment string) + in + if breakline then + Ode_loggers_sig.print_newline logger + else + Ode_loggers_sig.print_breakable_hint logger + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS + -> + () + ) + ) + +let is_time expr = fst expr = Alg_expr.STATE_ALG_OP Operator.TIME_VAR + +let associate ~propagate_constants ?(init_mode = false) ?(comment = "") + string_of_var_id logger logger_buffer logger_err variable alg_expr + network_handler = + let () = Ode_loggers_sig.set_expr logger variable alg_expr in + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave -> + let () = + Ode_loggers_sig.fprintf logger "%s=" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + variable) + in + let () = + print_alg_expr_few_parenthesis ~init_mode string_of_var_id logger + logger_err alg_expr network_handler + in + let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in + let () = + if comment = "" then + () + else + Ode_loggers_sig.fprintf logger " " + in + let () = print_comment logger comment in + let () = Ode_loggers_sig.print_newline logger in + () + | Loggers.Maple -> + (match variable with + | Ode_loggers_sig.Expr int + | Ode_loggers_sig.Concentration int + | Ode_loggers_sig.Obs int + | Ode_loggers_sig.Deriv int + | Ode_loggers_sig.Rate int + | Ode_loggers_sig.Rated int + | Ode_loggers_sig.Rateun int + | Ode_loggers_sig.Rateund int -> + let () = + Ode_loggers_sig.fprintf logger "%s%i:=(t -> " + (Ode_loggers_sig.string_of_array_name variable) + int + in + let () = + print_alg_expr_few_parenthesis ~init_mode string_of_var_id logger + logger_err alg_expr network_handler + in + let () = Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) in + let () = + if comment = "" then + () + else + Ode_loggers_sig.fprintf logger " " + in + let () = print_comment logger comment in + let () = Ode_loggers_sig.print_newline logger in + () + | Ode_loggers_sig.Stochiometric_coef (int1, int2) -> + let () = + Ode_loggers_sig.fprintf logger "%s%i_%i:=(t -> " (Ode_loggers_sig.string_of_array_name variable) + int1 int2 in let () = - print_alg_expr_few_parenthesis - ~init_mode string_of_var_id logger logger_err - alg_expr network_handler + print_alg_expr_few_parenthesis ~init_mode string_of_var_id logger + logger_err alg_expr network_handler + in + let () = Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) in + let () = + if comment = "" then + () + else + Ode_loggers_sig.fprintf logger " " + in + let () = print_comment logger comment in + let () = Ode_loggers_sig.print_newline logger in + () + | Ode_loggers_sig.Init int | Ode_loggers_sig.Initbis int -> + let () = + Ode_loggers_sig.fprintf logger "%s%i:=" + (Ode_loggers_sig.string_of_array_name variable) + int + in + let () = + print_alg_expr_few_parenthesis ~init_mode string_of_var_id logger + logger_err alg_expr network_handler in let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = if comment = "" then () else Ode_loggers_sig.fprintf logger " " in + let () = + if comment = "" then + () + else + Ode_loggers_sig.fprintf logger " " + in let () = print_comment logger comment in let () = Ode_loggers_sig.print_newline logger in () - | Ode_loggers_sig.Jacobian _ - | Ode_loggers_sig.Jacobian_var _ - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rateund _ - | Ode_loggers_sig.Jacobian_stochiometric_coef _ - -> () - end - | Loggers.Mathematica -> - begin + | Ode_loggers_sig.Tinit | Ode_loggers_sig.NonNegative | Ode_loggers_sig.Tend + | Ode_loggers_sig.MaxStep | Ode_loggers_sig.InitialStep + | Ode_loggers_sig.AbsTol | Ode_loggers_sig.RelTol + | Ode_loggers_sig.Period_t_points | Ode_loggers_sig.N_rules + | Ode_loggers_sig.N_ode_var | Ode_loggers_sig.N_var | Ode_loggers_sig.N_obs + | Ode_loggers_sig.N_rows | Ode_loggers_sig.N_max_stoc_coef + | Ode_loggers_sig.Tmp | Ode_loggers_sig.Current_time + | Ode_loggers_sig.Time_scale_factor -> let () = - Ode_loggers_sig.fprintf logger "%s=" - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger variable) + Ode_loggers_sig.fprintf logger "%s:=" + (Ode_loggers_sig.string_of_array_name variable) in let () = - print_alg_expr_few_parenthesis - ~init_mode string_of_var_id logger logger_err - alg_expr network_handler in + print_alg_expr_few_parenthesis ~init_mode string_of_var_id logger + logger_err alg_expr network_handler + in let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = if comment = "" then () else Ode_loggers_sig.fprintf logger " " in + let () = + if comment = "" then + () + else + Ode_loggers_sig.fprintf logger " " + in let () = print_comment logger comment in let () = Ode_loggers_sig.print_newline logger in () - end + | Ode_loggers_sig.Jacobian _ | Ode_loggers_sig.Jacobian_var _ + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rated _ + | Ode_loggers_sig.Jacobian_rateun _ | Ode_loggers_sig.Jacobian_rateund _ + | Ode_loggers_sig.Jacobian_stochiometric_coef _ -> + ()) + | Loggers.Mathematica -> + let () = + Ode_loggers_sig.fprintf logger "%s=" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + variable) + in + let () = + print_alg_expr_few_parenthesis ~init_mode string_of_var_id logger + logger_err alg_expr network_handler + in + let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in + let () = + if comment = "" then + () + else + Ode_loggers_sig.fprintf logger " " + in + let () = print_comment logger comment in + let () = Ode_loggers_sig.print_newline logger in + () | Loggers.DOTNET -> - if propagate_constants - then () - else - let doit ~must_be_fresh suffix = + if propagate_constants then + () + else ( + let doit ~must_be_fresh suffix = let id_init = string_of_variable_sbml string_of_var_id variable in let id = if must_be_fresh then @@ -1467,24 +1363,23 @@ let associate ~propagate_constants ?init_mode:(init_mode=false) ?comment:(commen in (* let () = Loggers.allocate logger id_init in*) let () = Ode_loggers_sig.flag_dangerous logger variable id in - if not (Ode_loggers_sig.is_dangerous_ode_variable logger variable) - then + if not (Ode_loggers_sig.is_dangerous_ode_variable logger variable) then ( let () = - Ode_loggers_sig.fprintf logger_buffer - "%s %s " + Ode_loggers_sig.fprintf logger_buffer "%s %s " (Sbml_backend.dotnet_id_of_logger logger) id in let alg_expr = - Sbml_backend.propagate_dangerous_var_names_in_alg_expr - logger network_handler alg_expr + Sbml_backend.propagate_dangerous_var_names_in_alg_expr logger + network_handler alg_expr in let () = - print_alg_expr_few_parenthesis - ~init_mode string_of_var_id logger_buffer logger_err - alg_expr network_handler in + print_alg_expr_few_parenthesis ~init_mode string_of_var_id + logger_buffer logger_err alg_expr network_handler + in let () = Ode_loggers_sig.print_newline logger_buffer in () + ) in let doit_const ~must_be_fresh suffix cst = let id_init = string_of_variable_sbml string_of_var_id variable in @@ -1496,46 +1391,40 @@ let associate ~propagate_constants ?init_mode:(init_mode=false) ?comment:(commen in let () = Ode_loggers_sig.allocate logger id_init in let () = Ode_loggers_sig.flag_dangerous logger variable id in - if not (Ode_loggers_sig.is_dangerous_ode_variable logger variable) - then + if not (Ode_loggers_sig.is_dangerous_ode_variable logger variable) then ( let () = - Ode_loggers_sig.fprintf logger_buffer - "%s %s %s" + Ode_loggers_sig.fprintf logger_buffer "%s %s %s" (Sbml_backend.dotnet_id_of_logger logger) - id - (Nbr.to_string cst) + id (Nbr.to_string cst) in let () = Ode_loggers_sig.print_newline logger_buffer in () + ) in - let doit_obs () = - let id = comment in + let doit_obs () = + let id = comment in let expr = Alg_expr_extra.simplify alg_expr in - if is_time expr - then () - else + if is_time expr then + () + else ( let lin = Lin_comb.Lin.of_expr (fun i -> - Ode_loggers_sig.get_expr logger - (Ode_loggers_sig.Expr - (network_handler.Network_handler.int_of_obs i)) - ) + Ode_loggers_sig.get_expr logger + (Ode_loggers_sig.Expr + (network_handler.Network_handler.int_of_obs i))) expr in let () = match lin with | Some lin -> let () = - Ode_loggers_sig.fprintf logger_buffer - "%i %s " + Ode_loggers_sig.fprintf logger_buffer "%i %s " (Ode_loggers_sig.get_fresh_obs_id logger) id in let () = - Lin_comb.Lin.print - ~sep:"," - ~product:"*" + Lin_comb.Lin.print ~sep:"," ~product:"*" (fun logger i -> Ode_loggers_sig.fprintf logger "%i" i) (fun logger i -> Ode_loggers_sig.fprintf logger "%i" i) logger lin @@ -1543,752 +1432,655 @@ let associate ~propagate_constants ?init_mode:(init_mode=false) ?comment:(commen () | None -> print_comment logger - ("Obs "^id^" is ignored: it is not linear") + ("Obs " ^ id ^ " is ignored: it is not linear") in let () = Ode_loggers_sig.print_newline logger_buffer in () + ) in - begin - match variable, init_mode with - | (Ode_loggers_sig.Tinit | - Ode_loggers_sig.Tend | - Ode_loggers_sig.Period_t_points - ) ,_ -> doit ~must_be_fresh:false "" - | Ode_loggers_sig.Expr _ , true -> - begin - match Sbml_backend.eval_const_alg_expr - logger network_handler alg_expr - with - | Some cst -> doit_const ~must_be_fresh:false "" cst - | None -> () - end - | Ode_loggers_sig.Rate _,_ - | Ode_loggers_sig.Rated _,_ - | Ode_loggers_sig.Rateun _,_ - | Ode_loggers_sig.Rateund _,_ -> - if Alg_expr.is_constant alg_expr then - doit ~must_be_fresh:true "_" - else if - not propagate_constants - && not - (match alg_expr with - | Alg_expr.ALG_VAR _,_ -> true - | ( Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ - | Alg_expr.IF _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ | Alg_expr.DIFF_TOKEN _ - | Alg_expr.CONST _), _ -> false) - then doit ~must_be_fresh:true "_" - | Ode_loggers_sig.Obs _,_ -> - doit_obs () - | Ode_loggers_sig.Stochiometric_coef _,_ - | Ode_loggers_sig.Jacobian_rate (_,_),_ - | Ode_loggers_sig.Jacobian_rateun (_,_),_ - | Ode_loggers_sig.Jacobian_rated _,_ - | Ode_loggers_sig.Jacobian_rateund (_,_),_ - | Ode_loggers_sig.Jacobian_stochiometric_coef _,_ - | Ode_loggers_sig.Expr _ , _ - | Ode_loggers_sig.Init _, _ - | Ode_loggers_sig.Initbis _, _ - | Ode_loggers_sig.Concentration _,_ - | Ode_loggers_sig.Deriv _,_ - | Ode_loggers_sig.Jacobian _,_ - | Ode_loggers_sig.Jacobian_var _,_ - | Ode_loggers_sig.MaxStep, _ - | Ode_loggers_sig.InitialStep,_ - | Ode_loggers_sig.AbsTol,_ - | Ode_loggers_sig.RelTol,_ - | Ode_loggers_sig.N_rules,_ - | Ode_loggers_sig.N_ode_var,_ - | Ode_loggers_sig.N_max_stoc_coef,_ - | Ode_loggers_sig.N_var,_ - | Ode_loggers_sig.N_obs,_ - | Ode_loggers_sig.N_rows,_ - | Ode_loggers_sig.Tmp,_ - | Ode_loggers_sig.Time_scale_factor,_ - | Ode_loggers_sig.NonNegative,_ - | Ode_loggers_sig.Current_time,_ -> () - end - - | Loggers.SBML -> - begin match variable, init_mode with - | Ode_loggers_sig.Expr _ , true -> + | ( ( Ode_loggers_sig.Tinit | Ode_loggers_sig.Tend + | Ode_loggers_sig.Period_t_points ), + _ ) -> + doit ~must_be_fresh:false "" + | Ode_loggers_sig.Expr _, true -> + (match + Sbml_backend.eval_const_alg_expr logger network_handler alg_expr + with + | Some cst -> doit_const ~must_be_fresh:false "" cst + | None -> ()) + | Ode_loggers_sig.Rate _, _ + | Ode_loggers_sig.Rated _, _ + | Ode_loggers_sig.Rateun _, _ + | Ode_loggers_sig.Rateund _, _ -> if Alg_expr.is_constant alg_expr then - print_sbml_parameters - string_of_var_id - logger - logger_buffer - logger_err - variable - (Sbml_backend.eval_init_alg_expr - logger - network_handler - alg_expr) - | (Ode_loggers_sig.Tinit | - Ode_loggers_sig.Tend | - Ode_loggers_sig.Period_t_points - ) ,_ -> - print_sbml_parameters - string_of_var_id - logger - logger_buffer - logger_err + doit ~must_be_fresh:true "_" + else if + (not propagate_constants) + && not + (match alg_expr with + | Alg_expr.ALG_VAR _, _ -> true + | ( ( Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.IF _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ | Alg_expr.DIFF_TOKEN _ + | Alg_expr.CONST _ ), + _ ) -> + false) + then + doit ~must_be_fresh:true "_" + | Ode_loggers_sig.Obs _, _ -> doit_obs () + | Ode_loggers_sig.Stochiometric_coef _, _ + | Ode_loggers_sig.Jacobian_rate (_, _), _ + | Ode_loggers_sig.Jacobian_rateun (_, _), _ + | Ode_loggers_sig.Jacobian_rated _, _ + | Ode_loggers_sig.Jacobian_rateund (_, _), _ + | Ode_loggers_sig.Jacobian_stochiometric_coef _, _ + | Ode_loggers_sig.Expr _, _ + | Ode_loggers_sig.Init _, _ + | Ode_loggers_sig.Initbis _, _ + | Ode_loggers_sig.Concentration _, _ + | Ode_loggers_sig.Deriv _, _ + | Ode_loggers_sig.Jacobian _, _ + | Ode_loggers_sig.Jacobian_var _, _ + | Ode_loggers_sig.MaxStep, _ + | Ode_loggers_sig.InitialStep, _ + | Ode_loggers_sig.AbsTol, _ + | Ode_loggers_sig.RelTol, _ + | Ode_loggers_sig.N_rules, _ + | Ode_loggers_sig.N_ode_var, _ + | Ode_loggers_sig.N_max_stoc_coef, _ + | Ode_loggers_sig.N_var, _ + | Ode_loggers_sig.N_obs, _ + | Ode_loggers_sig.N_rows, _ + | Ode_loggers_sig.Tmp, _ + | Ode_loggers_sig.Time_scale_factor, _ + | Ode_loggers_sig.NonNegative, _ + | Ode_loggers_sig.Current_time, _ -> + () + ) + | Loggers.SBML -> + (match variable, init_mode with + | Ode_loggers_sig.Expr _, true -> + if Alg_expr.is_constant alg_expr then + print_sbml_parameters string_of_var_id logger logger_buffer logger_err variable (Sbml_backend.eval_init_alg_expr logger network_handler alg_expr) - | Ode_loggers_sig.Rate _,_ - | Ode_loggers_sig.Rated _,_ - | Ode_loggers_sig.Rateun _,_ - | Ode_loggers_sig.Rateund _,_ -> - if Alg_expr.is_constant alg_expr then - print_sbml_parameters - string_of_var_id - logger - logger_buffer - logger_err - variable - (Sbml_backend.eval_init_alg_expr logger network_handler alg_expr) - | Ode_loggers_sig.Stochiometric_coef _,_ - | Ode_loggers_sig.Jacobian_rate (_,_),_ - | Ode_loggers_sig.Jacobian_rateun (_,_),_ - | Ode_loggers_sig.Jacobian_rated _,_ - | Ode_loggers_sig.Jacobian_rateund (_,_),_ - | Ode_loggers_sig.Jacobian_stochiometric_coef _,_ - | Ode_loggers_sig.Expr _ , _ - | Ode_loggers_sig.Init _, _ - | Ode_loggers_sig.Initbis _, _ - | Ode_loggers_sig.Concentration _,_ - | Ode_loggers_sig.Deriv _,_ - | Ode_loggers_sig.Obs _,_ - | Ode_loggers_sig.Jacobian _,_ - | Ode_loggers_sig.Jacobian_var _,_ - | Ode_loggers_sig.MaxStep, _ - | Ode_loggers_sig.InitialStep,_ - | Ode_loggers_sig.AbsTol,_ - | Ode_loggers_sig.RelTol,_ - | Ode_loggers_sig.N_rules,_ - | Ode_loggers_sig.N_ode_var,_ - | Ode_loggers_sig.N_max_stoc_coef,_ - | Ode_loggers_sig.N_var,_ - | Ode_loggers_sig.N_obs,_ - | Ode_loggers_sig.N_rows,_ - | Ode_loggers_sig.Tmp,_ - | Ode_loggers_sig.Time_scale_factor,_ - | Ode_loggers_sig.NonNegative,_ - | Ode_loggers_sig.Current_time,_ -> () - end - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | ( ( Ode_loggers_sig.Tinit | Ode_loggers_sig.Tend + | Ode_loggers_sig.Period_t_points ), + _ ) -> + print_sbml_parameters string_of_var_id logger logger_buffer logger_err + variable + (Sbml_backend.eval_init_alg_expr logger network_handler alg_expr) + | Ode_loggers_sig.Rate _, _ + | Ode_loggers_sig.Rated _, _ + | Ode_loggers_sig.Rateun _, _ + | Ode_loggers_sig.Rateund _, _ -> + if Alg_expr.is_constant alg_expr then + print_sbml_parameters string_of_var_id logger logger_buffer logger_err + variable + (Sbml_backend.eval_init_alg_expr logger network_handler alg_expr) + | Ode_loggers_sig.Stochiometric_coef _, _ + | Ode_loggers_sig.Jacobian_rate (_, _), _ + | Ode_loggers_sig.Jacobian_rateun (_, _), _ + | Ode_loggers_sig.Jacobian_rated _, _ + | Ode_loggers_sig.Jacobian_rateund (_, _), _ + | Ode_loggers_sig.Jacobian_stochiometric_coef _, _ + | Ode_loggers_sig.Expr _, _ + | Ode_loggers_sig.Init _, _ + | Ode_loggers_sig.Initbis _, _ + | Ode_loggers_sig.Concentration _, _ + | Ode_loggers_sig.Deriv _, _ + | Ode_loggers_sig.Obs _, _ + | Ode_loggers_sig.Jacobian _, _ + | Ode_loggers_sig.Jacobian_var _, _ + | Ode_loggers_sig.MaxStep, _ + | Ode_loggers_sig.InitialStep, _ + | Ode_loggers_sig.AbsTol, _ + | Ode_loggers_sig.RelTol, _ + | Ode_loggers_sig.N_rules, _ + | Ode_loggers_sig.N_ode_var, _ + | Ode_loggers_sig.N_max_stoc_coef, _ + | Ode_loggers_sig.N_var, _ + | Ode_loggers_sig.N_obs, _ + | Ode_loggers_sig.N_rows, _ + | Ode_loggers_sig.Tmp, _ + | Ode_loggers_sig.Time_scale_factor, _ + | Ode_loggers_sig.NonNegative, _ + | Ode_loggers_sig.Current_time, _ -> + ()) + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let associate_nrows logger = - match - Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.Matlab | Loggers.Octave -> let () = - print_list logger - [ - "nrows = length(vt)"^(instruction_sep logger); - ] - in + print_list logger [ "nrows = length(vt)" ^ instruction_sep logger ] + in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let associate_t logger n = - match - Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.Matlab | Loggers.Octave -> - let () = Ode_loggers_sig.fprintf logger "t = y(%i)%s" n (instruction_sep logger) in + let () = + Ode_loggers_sig.fprintf logger "t = y(%i)%s" n (instruction_sep logger) + in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let init_time logger n = - match - Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.Matlab | Loggers.Octave -> - let () = Ode_loggers_sig.fprintf logger "y(%i) = t%s" n (instruction_sep logger) in + let () = + Ode_loggers_sig.fprintf logger "y(%i) = t%s" n (instruction_sep logger) + in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let inc_symbol logger string varrhs = - match Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab | Loggers.Octave - | Loggers.Maple | Loggers.Mathematica -> + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave | Loggers.Maple | Loggers.Mathematica -> Printf.sprintf "%s%s%s" (affect_symbol logger) varrhs string - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> "" - -let increment ?init_mode:(init_mode=false) ?comment:(comment="") string_of_var_id logger logger_err variable alg_expr network = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab | Loggers.Octave - | Loggers.Maple | Loggers.Mathematica -> - begin - let varlhs = Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger variable in - let varrhs = Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger variable in - let () = - Ode_loggers_sig.fprintf logger "%s%s" varlhs (inc_symbol logger "+" varrhs) - in - let () = - print_alg_expr - ~parenthesis_mode:In_sum ~init_mode string_of_var_id logger logger_err - alg_expr network in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = if comment = "" then () else Ode_loggers_sig.fprintf logger " " in - let () = print_comment logger comment in - let () = Ode_loggers_sig.print_newline logger in - () - end - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () + | Loggers.SBML | Loggers.DOTNET | Loggers.Json | Loggers.DOT | Loggers.GEPHI + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + "" -let apply_correct string_of_var correct var = +let increment ?(init_mode = false) ?(comment = "") string_of_var_id logger + logger_err variable alg_expr network = + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave | Loggers.Maple | Loggers.Mathematica -> + let varlhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + variable + in + let varrhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + variable + in + let () = + Ode_loggers_sig.fprintf logger "%s%s" varlhs + (inc_symbol logger "+" varrhs) + in + let () = + print_alg_expr ~parenthesis_mode:In_sum ~init_mode string_of_var_id logger + logger_err alg_expr network + in + let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in + let () = + if comment = "" then + () + else + Ode_loggers_sig.fprintf logger " " + in + let () = print_comment logger comment in + let () = Ode_loggers_sig.print_newline logger in + () + | Loggers.SBML | Loggers.DOTNET | Loggers.Json | Loggers.DOT | Loggers.GEPHI + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + +let apply_correct string_of_var correct var = let var_string = string_of_var var in - match - correct - with + match correct with | Nil | Div 1 | Mul 1 -> var_string - | Div i -> var_string^"/"^(string_of_int i) - | Mul i -> (string_of_int i)^"*"^var_string + | Div i -> var_string ^ "/" ^ string_of_int i + | Mul i -> string_of_int i ^ "*" ^ var_string let apply_empty correct = - match - correct - with + match correct with | Nil | Div 1 | Mul 1 -> "" - | Div i -> "/"^(string_of_int i) - | Mul i -> "*"^(string_of_int i) - + | Div i -> "/" ^ string_of_int i + | Mul i -> "*" ^ string_of_int i let correct_rates logger ~nauto_in_lhs ~nocc bool = - if nauto_in_lhs = nocc - then + if nauto_in_lhs = nocc then bool - else - if nocc = 1 then + else if nocc = 1 then ( let () = - if bool - then + if bool then Ode_loggers_sig.fprintf logger "/%i" nauto_in_lhs else Ode_loggers_sig.fprintf logger "1/%i" nauto_in_lhs in true - else if nauto_in_lhs = 1 - then + ) else if nauto_in_lhs = 1 then ( let () = - if bool - then + if bool then Ode_loggers_sig.fprintf logger "*%i" nocc else Ode_loggers_sig.fprintf logger "%i" nocc in true - else + ) else ( let () = - if bool - then + if bool then Ode_loggers_sig.fprintf logger "*%i/%i" nocc nauto_in_lhs else Ode_loggers_sig.fprintf logger "%i/%i" nocc nauto_in_lhs in true + ) -let gen string logger var_species ~nauto_in_species ~nauto_in_lhs ~nocc var_rate var_list = +let gen string logger var_species ~nauto_in_species ~nauto_in_lhs ~nocc var_rate + var_list = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab | Loggers.Octave - | Loggers.Maple | Loggers.Mathematica -> - begin - let varlhs = Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger var_species in - let varrhs = Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger var_species in - let () = - Ode_loggers_sig.fprintf logger "%s%s" varlhs (inc_symbol logger string varrhs) in - let bool = - if nauto_in_species = 1 - then false - else - let () = Ode_loggers_sig.fprintf logger "%i" nauto_in_species in - true - in - let bool = correct_rates logger ~nauto_in_lhs ~nocc bool in - let () = - if bool - then - Ode_loggers_sig.fprintf logger "*" - in - let () = - Ode_loggers_sig.fprintf - logger "%s" - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger var_rate) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - ( - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger) correct var)) - var_list - in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = Ode_loggers_sig.print_newline logger in - () - end - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () - + match format with + | Loggers.Matlab | Loggers.Octave | Loggers.Maple | Loggers.Mathematica -> + let varlhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + var_species + in + let varrhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + var_species + in + let () = + Ode_loggers_sig.fprintf logger "%s%s" varlhs + (inc_symbol logger string varrhs) + in + let bool = + if nauto_in_species = 1 then + false + else ( + let () = Ode_loggers_sig.fprintf logger "%i" nauto_in_species in + true + ) + in + let bool = correct_rates logger ~nauto_in_lhs ~nocc bool in + let () = if bool then Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + var_rate) + in + let () = + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger) + correct var)) + var_list + in + let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in + let () = Ode_loggers_sig.print_newline logger in + () + | Loggers.SBML | Loggers.DOTNET | Loggers.Json | Loggers.DOT | Loggers.GEPHI + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let consume = gen "-" let produce = gen "+" -let gen_deriv - string logger var_species ~nauto_in_species ~nauto_in_lhs ~nocc var_rate var_list dep = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab | Loggers.Octave -> - begin - let () = - Mods.IntSet.iter - (fun dt -> - let var_dt_lhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.LHS - logger - (Ode_loggers_sig.variable_of_derived_variable - var_species dt) - in - let var_dt_rhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS +let gen_deriv string logger var_species ~nauto_in_species ~nauto_in_lhs ~nocc + var_rate var_list dep = + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave -> + let () = + Mods.IntSet.iter + (fun dt -> + let var_dt_lhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + (Ode_loggers_sig.variable_of_derived_variable var_species dt) + in + let var_dt_rhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + (Ode_loggers_sig.variable_of_derived_variable var_species dt) + in + let () = + Ode_loggers_sig.fprintf logger "%s%s%s%s" var_dt_lhs + (affect_symbol logger) var_dt_rhs string + in + let bool = + if nauto_in_species = 1 then + false + else ( + let () = Ode_loggers_sig.fprintf logger "%i" nauto_in_species in + true + ) + in + let bool = correct_rates logger ~nauto_in_lhs ~nocc bool in + let () = if bool then Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger - (Ode_loggers_sig.variable_of_derived_variable - var_species dt) - in - let () = - Ode_loggers_sig.fprintf - logger "%s%s%s%s" var_dt_lhs (affect_symbol logger) var_dt_rhs string - in - let bool = - if nauto_in_species = 1 - then false - else - let () = Ode_loggers_sig.fprintf logger "%i" nauto_in_species in - true - in - let bool = correct_rates logger ~nauto_in_lhs ~nocc bool in - let () = - if bool - then - Ode_loggers_sig.fprintf logger "*" - in - let () = - Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger - (Ode_loggers_sig.variable_of_derived_variable - var_rate dt )) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger) - correct - (Ode_loggers_sig.Concentration var))) - var_list - in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = Ode_loggers_sig.print_newline logger in - () + (Ode_loggers_sig.variable_of_derived_variable var_rate dt)) + in + let () = + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable + ~side:Ode_loggers_sig.RHS logger) + correct (Ode_loggers_sig.Concentration var))) + var_list + in + let () = + Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) + in + let () = Ode_loggers_sig.print_newline logger in + ()) + dep + in + let rec aux tail suffix = + match tail with + | [] -> () + | (h, correct) :: t -> + let var_dt_lhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + (Ode_loggers_sig.variable_of_derived_variable var_species h) + in + let var_dt_rhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + (Ode_loggers_sig.variable_of_derived_variable var_species h) + in + let () = + Ode_loggers_sig.fprintf logger "%s=%s%s" var_dt_lhs var_dt_rhs string + in + let bool = + if nauto_in_species = 1 then + false + else ( + let () = Ode_loggers_sig.fprintf logger "%i" nauto_in_species in + true ) - dep - in - let rec aux tail suffix = - match tail with - | [] -> () - | (h,correct)::t -> - begin - let var_dt_lhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.LHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_species h) - in - let var_dt_rhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_species h) - in - let () = Ode_loggers_sig.fprintf logger "%s=%s%s" var_dt_lhs var_dt_rhs string in - let bool = - if nauto_in_species = 1 - then false - else - let () = Ode_loggers_sig.fprintf logger "%i" nauto_in_species in - true - in - let bool = correct_rates logger ~nauto_in_lhs ~nocc bool in - let () = - if bool - then - Ode_loggers_sig.fprintf logger "*" - in - let () = - Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger var_rate) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger) - correct - (Ode_loggers_sig.Concentration var))) - (List.rev suffix) - in - let () = - Ode_loggers_sig.fprintf logger "%s" (apply_empty correct) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger) - correct (Ode_loggers_sig.Concentration var))) - (List.rev t) - in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = Ode_loggers_sig.print_newline logger in - aux t ((h,correct)::suffix) - end - in aux var_list [] - end - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () - + in + let bool = correct_rates logger ~nauto_in_lhs ~nocc bool in + let () = if bool then Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + var_rate) + in + let () = + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger) + correct (Ode_loggers_sig.Concentration var))) + (List.rev suffix) + in + let () = Ode_loggers_sig.fprintf logger "%s" (apply_empty correct) in + let () = + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger) + correct (Ode_loggers_sig.Concentration var))) + (List.rev t) + in + let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in + let () = Ode_loggers_sig.print_newline logger in + aux t ((h, correct) :: suffix) + in + aux var_list [] + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let consume_jac = gen_deriv "-" let produce_jac = gen_deriv "+" -let update_token logger var_token ~nauto_in_lhs ~nocc var_rate stoc_coef var_list = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab | Loggers.Octave -> - begin - let var_lhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.LHS logger var_token - in - let var_rhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger var_token - in - let () = - Ode_loggers_sig.fprintf logger "%s%s%s+" var_lhs (affect_symbol logger) var_rhs - in - let bool = correct_rates logger ~nauto_in_lhs ~nocc false in - let () = - if bool - then - Ode_loggers_sig.fprintf logger "*" - in - let () = - Ode_loggers_sig.fprintf - logger "%s" - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger var_rate) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger) correct var)) - var_list - in - let () = Ode_loggers_sig.fprintf logger "*" in - let () = - Ode_loggers_sig.fprintf - logger "%s" - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger stoc_coef) - in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = Ode_loggers_sig.print_newline logger in - () - end - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () - - -let update_token_jac - logger var_token ~nauto_in_lhs ~nocc - var_rate var_stoc var_list dep_rate ~dep_mixture ~dep_token = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab | Loggers.Octave -> - begin - (* We differentiate according to the rule rate *) - let () = - Mods.IntSet.iter +let update_token logger var_token ~nauto_in_lhs ~nocc var_rate stoc_coef + var_list = + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave -> + let var_lhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + var_token + in + let var_rhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + var_token + in + let () = + Ode_loggers_sig.fprintf logger "%s%s%s+" var_lhs (affect_symbol logger) + var_rhs + in + let bool = correct_rates logger ~nauto_in_lhs ~nocc false in + let () = if bool then Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + var_rate) + in + let () = + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger) + correct var)) + var_list + in + let () = Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + stoc_coef) + in + let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in + let () = Ode_loggers_sig.print_newline logger in + () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + +let update_token_jac logger var_token ~nauto_in_lhs ~nocc var_rate var_stoc + var_list dep_rate ~dep_mixture ~dep_token = + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave -> + (* We differentiate according to the rule rate *) + let () = + Mods.IntSet.iter (fun dt -> - let var_dt_lhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.LHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_token dt) - in - let var_dt_rhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.LHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_token dt) - in - let () = - Ode_loggers_sig.fprintf - logger "%s%s%s+" - var_dt_lhs (affect_symbol logger) var_dt_rhs - in - let bool = correct_rates logger ~nauto_in_lhs ~nocc false in - let () = - if bool - then - Ode_loggers_sig.fprintf logger "*" - in - let () = - Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger - (Ode_loggers_sig.variable_of_derived_variable var_rate dt)) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger) - correct - (Ode_loggers_sig.Concentration var))) - var_list - in - let () = Ode_loggers_sig.fprintf logger "*" in - let () = - Ode_loggers_sig.fprintf - logger "%s" (Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS logger var_stoc) - in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = Ode_loggers_sig.print_newline logger in - ()) + let var_dt_lhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + (Ode_loggers_sig.variable_of_derived_variable var_token dt) + in + let var_dt_rhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + (Ode_loggers_sig.variable_of_derived_variable var_token dt) + in + let () = + Ode_loggers_sig.fprintf logger "%s%s%s+" var_dt_lhs + (affect_symbol logger) var_dt_rhs + in + let bool = correct_rates logger ~nauto_in_lhs ~nocc false in + let () = if bool then Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger + (Ode_loggers_sig.variable_of_derived_variable var_rate dt)) + in + let () = + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable + ~side:Ode_loggers_sig.RHS logger) + correct (Ode_loggers_sig.Concentration var))) + var_list + in + let () = Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger var_stoc) + in + let () = + Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) + in + let () = Ode_loggers_sig.print_newline logger in + ()) dep_rate + in + let () = + let aux_deriv dt = + let dt_id = dt in + let var_dt_lhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + (Ode_loggers_sig.variable_of_derived_variable var_token dt_id) + in + let var_dt_rhs = + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + (Ode_loggers_sig.variable_of_derived_variable var_token dt_id) + in + let () = + Ode_loggers_sig.fprintf logger "%s%s%s+" var_dt_lhs + (affect_symbol logger) var_dt_rhs + in + let bool = correct_rates logger ~nauto_in_lhs ~nocc false in + let () = if bool then Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + var_rate) + in + let () = + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger) + correct (Ode_loggers_sig.Concentration var))) + var_list + in + let () = Ode_loggers_sig.fprintf logger "*" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + (Ode_loggers_sig.variable_of_derived_variable var_stoc dt)) + in + let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in + let () = Ode_loggers_sig.print_newline logger in + () in - let () = - let aux_deriv dt = - let dt_id = dt in + (* we differentiate according to the token coefficient *) + let () = Mods.IntSet.iter aux_deriv dep_mixture in + Mods.IntSet.iter aux_deriv dep_token + in + let () = + (* we differentiate according to the species *) + let rec aux tail suffix = + match tail with + | [] -> () + | (h, correct) :: t -> let var_dt_lhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.LHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_token dt_id) + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.LHS logger + (Ode_loggers_sig.variable_of_derived_variable var_token h) in let var_dt_rhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_token dt_id) + Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger + (Ode_loggers_sig.variable_of_derived_variable var_token h) in let () = - Ode_loggers_sig.fprintf - logger "%s%s%s+" var_dt_lhs - (affect_symbol logger) - var_dt_rhs + Ode_loggers_sig.fprintf logger "%s=%s+" var_dt_lhs var_dt_rhs in let bool = correct_rates logger ~nauto_in_lhs ~nocc false in + let () = if bool then Ode_loggers_sig.fprintf logger "*" in let () = - if bool - then - Ode_loggers_sig.fprintf logger "*" + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger var_rate) in let () = - Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger var_rate) + List.iter + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable + ~side:Ode_loggers_sig.RHS logger) + correct (Ode_loggers_sig.Concentration var))) + (List.rev suffix) in let () = List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger) - correct - (Ode_loggers_sig.Concentration var))) - var_list + (fun (var, correct) -> + Ode_loggers_sig.fprintf logger "*%s" + (apply_correct + (Ode_loggers_sig.string_of_variable + ~side:Ode_loggers_sig.RHS logger) + correct (Ode_loggers_sig.Concentration var))) + (List.rev tail) in let () = Ode_loggers_sig.fprintf logger "*" in let () = Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger - (Ode_loggers_sig.variable_of_derived_variable var_stoc dt)) + (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS + logger var_stoc) + in + let () = + Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in let () = Ode_loggers_sig.print_newline logger in - () - in - (* we differentiate according to the token coefficient *) - let () = Mods.IntSet.iter aux_deriv dep_mixture in - Mods.IntSet.iter aux_deriv dep_token - in - let () = (* we differentiate according to the species *) - let rec aux tail suffix = - match tail with - | [] -> () - | (h,correct)::t -> - begin - let var_dt_lhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.LHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_token h) - in - let var_dt_rhs = - Ode_loggers_sig.string_of_variable - ~side:Ode_loggers_sig.RHS - logger - (Ode_loggers_sig.variable_of_derived_variable var_token h) - in - let () = Ode_loggers_sig.fprintf logger "%s=%s+" var_dt_lhs var_dt_rhs in - let bool = correct_rates logger ~nauto_in_lhs ~nocc false in - let () = - if bool - then - Ode_loggers_sig.fprintf logger "*" - in - let () = - Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger var_rate) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger) - correct - (Ode_loggers_sig.Concentration var))) - (List.rev suffix) - in - let () = - List.iter - (fun (var,correct) -> - Ode_loggers_sig.fprintf logger "*%s" - (apply_correct - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger) - correct - (Ode_loggers_sig.Concentration var))) - (List.rev tail) - in - let () = Ode_loggers_sig.fprintf logger "*" in - let () = - Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_variable ~side:Ode_loggers_sig.RHS logger var_stoc) - in - let () = Ode_loggers_sig.fprintf logger "%s" (instruction_sep logger) in - let () = Ode_loggers_sig.print_newline logger in - aux t ((h,correct)::suffix) - end - in aux var_list [] + aux t ((h, correct) :: suffix) in - () - end - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> () - + aux var_list [] + in + () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let print_options ~compute_jacobian ~pos ~nodevar logger = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab - | Loggers.Octave -> + match format with + | Loggers.Matlab | Loggers.Octave -> let get_range () = - let _ = Ode_loggers_sig.fprintf logger " 'NonNegative', [" in + let _ = + Ode_loggers_sig.fprintf logger " 'NonNegative', [" + in let l = Tools.get_interval_list pos 1 nodevar in let _ = List.fold_left - (fun bool (a,b) -> - let () = - if bool then - Ode_loggers_sig.fprintf logger "," - in - let () = Ode_loggers_sig.fprintf logger "%i:1:%i" a b in - true) + (fun bool (a, b) -> + let () = if bool then Ode_loggers_sig.fprintf logger "," in + let () = Ode_loggers_sig.fprintf logger "%i:1:%i" a b in + true) false l in let () = Ode_loggers_sig.fprintf logger "]" in () in let () = - if compute_jacobian - then + if compute_jacobian then ( let () = print_list logger [ @@ -2301,7 +2093,9 @@ let print_options ~compute_jacobian ~pos ~nodevar logger = ] in let () = get_range () in - let () = Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) in + let () = + Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) + in let () = Ode_loggers_sig.print_newline logger in let () = print_list logger @@ -2311,209 +2105,172 @@ let print_options ~compute_jacobian ~pos ~nodevar logger = " 'AbsTol', abstol, ..."; " 'InitialStep', initialstep, ..."; " 'MaxStep', maxstep, ..."; - " 'Jacobian', @ode_jacobian)"^(instruction_sep logger); + " 'Jacobian', @ode_jacobian)" + ^ instruction_sep logger; "end"; ] - in () - else + in + () + ) else ( let () = print_list logger - [ "if nonnegative "; + [ + "if nonnegative "; " options = odeset('RelTol', reltol, ..."; " 'AbsTol', abstol, ..."; " 'InitialStep', initialstep, ..."; - " 'MaxStep', maxstep, ...";] + " 'MaxStep', maxstep, ..."; + ] in let () = get_range () in - let () = Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) in + let () = + Ode_loggers_sig.fprintf logger ")%s" (instruction_sep logger) + in let () = Ode_loggers_sig.print_newline logger in let () = print_list logger - [ "else"; + [ + "else"; " options = odeset('RelTol', reltol, ..."; " 'AbsTol', abstol, ..."; " 'InitialStep', initialstep, ..."; - " 'MaxStep', maxstep)"^(instruction_sep logger); - "end" + " 'MaxStep', maxstep)" ^ instruction_sep logger; + "end"; ] - in () + in + () + ) in let () = Ode_loggers_sig.print_newline logger in () - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let start_time logger float = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab - | Loggers.Octave -> - let () = Ode_loggers_sig.fprintf logger "t = %f%s" float (instruction_sep logger) in - Ode_loggers_sig.print_newline logger - | Loggers.SBML | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () - -let declare_init ?comment:(comment="") logger i = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab - | Loggers.Octave -> + match format with + | Loggers.Matlab | Loggers.Octave -> let () = - Ode_loggers_sig.fprintf logger - "Init(%i) = init(%i); " i i + Ode_loggers_sig.fprintf logger "t = %f%s" float (instruction_sep logger) in + Ode_loggers_sig.print_newline logger + | Loggers.SBML | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + +let declare_init ?(comment = "") logger i = + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave -> + let () = Ode_loggers_sig.fprintf logger "Init(%i) = init(%i); " i i in let () = print_comment logger comment in Ode_loggers_sig.print_newline logger - | Loggers.SBML | Loggers.DOTNET - | Loggers.Maple | Loggers.Mathematica - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () + | Loggers.SBML | Loggers.DOTNET | Loggers.Maple | Loggers.Mathematica + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let print_license_check logger = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab - | Loggers.Octave -> - let () = print_list logger + match format with + | Loggers.Matlab | Loggers.Octave -> + let () = + print_list logger [ - "uiIsOctave = false"^(instruction_sep logger); - "uiIsMatlab = false"^(instruction_sep logger); - "LIC = license('inuse')"^(instruction_sep logger); + "uiIsOctave = false" ^ instruction_sep logger; + "uiIsMatlab = false" ^ instruction_sep logger; + "LIC = license('inuse')" ^ instruction_sep logger; "for elem = 1:numel(LIC)"; " envStr = LIC(elem).feature"; " if strcmpi(envStr,'octave')"; - " LICname=envStr"^(instruction_sep logger); - " uiIsOctave = true"^(instruction_sep logger); + " LICname=envStr" ^ instruction_sep logger; + " uiIsOctave = true" ^ instruction_sep logger; " break"; " end"; " if strcmpi(envStr,'matlab')"; " LICname=envStr"; - " uiIsMatlab = true"^(instruction_sep logger); + " uiIsMatlab = true" ^ instruction_sep logger; " break"; " end"; "end"; ] - in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () + in + Ode_loggers_sig.print_newline logger + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let print_integrate ~nobs ~nodevar logger = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab - | Loggers.Octave -> + match format with + | Loggers.Matlab | Loggers.Octave -> let () = print_list logger [ "if nonnegative"; " if uiIsMatlab"; - " soln = ode15s(@ode_aux,[tinit tend],ode_init(),options)"^(instruction_sep logger); - " soln.y=soln.y'"^(instruction_sep logger); - " vt = soln.x"^(instruction_sep logger); - " vy = soln.y"^(instruction_sep logger); + " soln = ode15s(@ode_aux,[tinit tend],ode_init(),options)" + ^ instruction_sep logger; + " soln.y=soln.y'" ^ instruction_sep logger; + " vt = soln.x" ^ instruction_sep logger; + " vy = soln.y" ^ instruction_sep logger; " elseif uiIsOctave"; - " [vt,vy] = ode45(@ode_aux,[tinit tend],ode_init(),options)"^(instruction_sep logger); + " [vt,vy] = ode45(@ode_aux,[tinit tend],ode_init(),options)" + ^ instruction_sep logger; " end"; "else"; " if uiIsMatlab"; - " soln = ode15s(@ode_aux,[tinit tend],ode_init(),options)"^(instruction_sep logger); - " soln.y=soln.y'"^(instruction_sep logger); - " vt = soln.x"^(instruction_sep logger); - " vy = soln.y"^(instruction_sep logger); + " soln = ode15s(@ode_aux,[tinit tend],ode_init(),options)" + ^ instruction_sep logger; + " soln.y=soln.y'" ^ instruction_sep logger; + " vt = soln.x" ^ instruction_sep logger; + " vy = soln.y" ^ instruction_sep logger; " elseif uiIsOctave"; - " soln = ode45(@ode_aux,[tinit tend],ode_init(),options)"^(instruction_sep logger); - " vt = soln.x"^(instruction_sep logger); - " vy = soln.y"^(instruction_sep logger); + " soln = ode45(@ode_aux,[tinit tend],ode_init(),options)" + ^ instruction_sep logger; + " vt = soln.x" ^ instruction_sep logger; + " vy = soln.y" ^ instruction_sep logger; " end"; - "end"^(instruction_sep logger) + "end" ^ instruction_sep logger; ] in let () = Ode_loggers_sig.print_newline logger in () | Loggers.Maple -> - let () = - Ode_loggers_sig.fprintf logger - "sol :=" - in - let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger " dsolve(" - in - let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger " {" - in + let () = Ode_loggers_sig.fprintf logger "sol :=" in + let () = Ode_loggers_sig.print_newline logger in + let () = Ode_loggers_sig.fprintf logger " dsolve(" in + let () = Ode_loggers_sig.print_newline logger in + let () = Ode_loggers_sig.fprintf logger " {" in let () = Ode_loggers_sig.print_newline logger in let () = repeat (fun second_time k -> - let sep = if second_time then ", " else "" in - let () = - Ode_loggers_sig.fprintf logger - "%s" sep - in - let () = - Ode_loggers_sig.print_newline logger + let sep = + if second_time then + ", " + else + "" in + let () = Ode_loggers_sig.fprintf logger "%s" sep in + let () = Ode_loggers_sig.print_newline logger in let () = Ode_loggers_sig.fprintf logger " diff(y%i(t),t) = dydt%i(t)," k k in + let () = Ode_loggers_sig.print_newline logger in let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger - " y%i(0) = init%i" - k k + Ode_loggers_sig.fprintf logger " y%i(0) = init%i" k k in ()) - (nodevar-1) + (nodevar - 1) in let () = Ode_loggers_sig.print_newline logger in let () = Ode_loggers_sig.fprintf logger " }," in @@ -2522,78 +2279,68 @@ let print_integrate ~nobs ~nodevar logger = let () = repeat (fun second_time k -> - let sep = if second_time then ", " else "" in + let sep = + if second_time then + ", " + else + "" + in let () = Ode_loggers_sig.fprintf logger "%s" sep in let () = Ode_loggers_sig.print_newline logger in let () = Ode_loggers_sig.fprintf logger " y%i(t)" k in ()) - (nodevar-1) + (nodevar - 1) in let () = Ode_loggers_sig.print_newline logger in let () = Ode_loggers_sig.fprintf logger " }," in let () = Ode_loggers_sig.print_newline logger in - let () = Ode_loggers_sig.fprintf logger " numeric, range=tinit..tend):" in - () - | Loggers.Mathematica -> - let () = - Ode_loggers_sig.fprintf logger - "sol =" - in - let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger " NDSolve[" - in - let () = - Ode_loggers_sig.print_newline logger - in let () = - Ode_loggers_sig.fprintf logger " {" + Ode_loggers_sig.fprintf logger " numeric, range=tinit..tend):" in + () + | Loggers.Mathematica -> + let () = Ode_loggers_sig.fprintf logger "sol =" in + let () = Ode_loggers_sig.print_newline logger in + let () = Ode_loggers_sig.fprintf logger " NDSolve[" in + let () = Ode_loggers_sig.print_newline logger in + let () = Ode_loggers_sig.fprintf logger " {" in let () = Ode_loggers_sig.print_newline logger in let () = repeat (fun second_time k -> - let sep = if second_time then ", " else "" in - let () = - Ode_loggers_sig.fprintf logger - "%s" sep - in - let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger - " y%i'[t] == dydt%i[t]," k k - in - let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger - " y%i[0] == init%i" - k k - in - ()) - (nodevar-1) + let sep = + if second_time then + ", " + else + "" + in + let () = Ode_loggers_sig.fprintf logger "%s" sep in + let () = Ode_loggers_sig.print_newline logger in + let () = + Ode_loggers_sig.fprintf logger " y%i'[t] == dydt%i[t]," k k + in + let () = Ode_loggers_sig.print_newline logger in + let () = + Ode_loggers_sig.fprintf logger " y%i[0] == init%i" k k + in + ()) + (nodevar - 1) in let () = repeat (fun second_time k -> - let sep = if nodevar>1 || second_time then ", " else "" in - let () = - Ode_loggers_sig.fprintf logger - "%s" sep - in - let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger - " o%i[t] == obs%i[t]" k k - in - ()) + let sep = + if nodevar > 1 || second_time then + ", " + else + "" + in + let () = Ode_loggers_sig.fprintf logger "%s" sep in + let () = Ode_loggers_sig.print_newline logger in + let () = + Ode_loggers_sig.fprintf logger " o%i[t] == obs%i[t]" k k + in + ()) nobs in let () = Ode_loggers_sig.print_newline logger in @@ -2603,29 +2350,31 @@ let print_integrate ~nobs ~nodevar logger = let () = repeat (fun second_time k -> - let sep = if second_time then ", " else "" in - let () = Ode_loggers_sig.fprintf logger "%s" sep in - let () = Ode_loggers_sig.print_newline logger in - let () = Ode_loggers_sig.fprintf logger " y%i" k in - ()) - (nodevar-1) + let sep = + if second_time then + ", " + else + "" + in + let () = Ode_loggers_sig.fprintf logger "%s" sep in + let () = Ode_loggers_sig.print_newline logger in + let () = Ode_loggers_sig.fprintf logger " y%i" k in + ()) + (nodevar - 1) in let () = repeat (fun second_time k -> - let sep = if nodevar>1 || second_time then ", " else "" in - let () = - Ode_loggers_sig.fprintf logger - "%s" sep - in - let () = - Ode_loggers_sig.print_newline logger - in - let () = - Ode_loggers_sig.fprintf logger - " o%i" k - in - ()) + let sep = + if nodevar > 1 || second_time then + ", " + else + "" + in + let () = Ode_loggers_sig.fprintf logger "%s" sep in + let () = Ode_loggers_sig.print_newline logger in + let () = Ode_loggers_sig.fprintf logger " o%i" k in + ()) nobs in let () = Ode_loggers_sig.print_newline logger in @@ -2634,79 +2383,63 @@ let print_integrate ~nobs ~nodevar logger = let () = Ode_loggers_sig.fprintf logger " {t,tinit,tend}];" in let () = Ode_loggers_sig.print_newline logger in () - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () + | Loggers.SBML | Loggers.DOTNET | Loggers.Json | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let print_interpolate logger = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab - | Loggers.Octave -> + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave -> let () = print_list logger [ - "n_points = floor ((tend-tinit)/"^(Ode_loggers_sig.string_of_array_name Ode_loggers_sig.Period_t_points)^")+1"^(instruction_sep logger); - "t = linspace(tinit, tend, n_points)"^(instruction_sep logger); - "obs = zeros(nrows,nobs)"^(instruction_sep logger); + "n_points = floor ((tend-tinit)/" + ^ Ode_loggers_sig.string_of_array_name Ode_loggers_sig.Period_t_points + ^ ")+1" ^ instruction_sep logger; + "t = linspace(tinit, tend, n_points)" ^ instruction_sep logger; + "obs = zeros(nrows,nobs)" ^ instruction_sep logger; ""; "for j=1:nrows"; " for i=1:nodevar"; - " z(i)=vy(i,j)"^(instruction_sep logger); + " z(i)=vy(i,j)" ^ instruction_sep logger; " end"; - " h=ode_obs(z)"^(instruction_sep logger); + " h=ode_obs(z)" ^ instruction_sep logger; " for i=1:nobs"; - " obs(j,i)=h(i)"^(instruction_sep logger); + " obs(j,i)=h(i)" ^ instruction_sep logger; " end"; "end"; "if nobs==1"; - " y = interp1(vt, obs, t, 'pchip')'"^(instruction_sep logger); + " y = interp1(vt, obs, t, 'pchip')'" ^ instruction_sep logger; "else"; - " y = interp1(vt, obs, t, 'pchip')"^(instruction_sep logger); - "end" + " y = interp1(vt, obs, t, 'pchip')" ^ instruction_sep logger; + "end"; ] in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica -> - () - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () - -let print_dump_plots ~nobs ~data_file ~command_line ~titles logger = + | Loggers.Maple | Loggers.Mathematica -> () + | Loggers.SBML | Loggers.DOTNET | Loggers.Json | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + +let print_dump_plots ~nobs ~data_file ~command_line ~titles logger = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab - | Loggers.Octave -> + match format with + | Loggers.Matlab | Loggers.Octave -> let () = print_list logger [ - "filename = '"^data_file^"'"^(instruction_sep logger); - "fid = fopen (filename,'w')"^(instruction_sep logger); - "fprintf(fid,'# "^command_line^"\\n')"; - "fprintf(fid,'# ')"] + "filename = '" ^ data_file ^ "'" ^ instruction_sep logger; + "fid = fopen (filename,'w')" ^ instruction_sep logger; + "fprintf(fid,'# " ^ command_line ^ "\\n')"; + "fprintf(fid,'# ')"; + ] in let () = print_list logger (List.rev_map - (fun x -> "fprintf(fid,'"^x^(csv_sep logger )^"')") + (fun x -> "fprintf(fid,'" ^ x ^ csv_sep logger ^ "')") (List.rev titles)) in let () = @@ -2715,182 +2448,156 @@ let print_dump_plots ~nobs ~data_file ~command_line ~titles logger = "fprintf(fid,'\\n')"; "for j=1:n_points"; " for i=1:nobs"; - " fprintf(fid,'%f"^(csv_sep logger )^"',y(j,i))"^(instruction_sep logger); + " fprintf(fid,'%f" ^ csv_sep logger ^ "',y(j,i))" + ^ instruction_sep logger; " end"; - " fprintf(fid,'\\n')"^(instruction_sep logger); + " fprintf(fid,'\\n')" ^ instruction_sep logger; "end"; - "fclose(fid)"^(instruction_sep logger)] - in Ode_loggers_sig.print_newline logger + "fclose(fid)" ^ instruction_sep logger; + ] + in + Ode_loggers_sig.print_newline logger | Loggers.Maple -> let () = print_list logger [ - "fid := fopen (\""^data_file^"\",WRITE)"^(instruction_sep logger); - "fprintf(fid,\"# "^command_line^"\\n\")"^(instruction_sep logger); - "fprintf(fid,\"# \")"^(instruction_sep logger)] + "fid := fopen (\"" ^ data_file ^ "\",WRITE)" ^ instruction_sep logger; + "fprintf(fid,\"# " ^ command_line ^ "\\n\")" ^ instruction_sep logger; + "fprintf(fid,\"# \")" ^ instruction_sep logger; + ] in let () = print_list logger (List.rev_map - (fun x -> "fprintf(fid,\""^x^(csv_sep logger )^"\")"^(instruction_sep logger)) + (fun x -> + "fprintf(fid,\"" ^ x ^ csv_sep logger ^ "\")" + ^ instruction_sep logger) (List.rev titles)) in let () = print_list logger [ - "fprintf(fid,\"\\n\")"^(instruction_sep logger); - ("for j from tinit to tend by "^(Ode_loggers_sig.string_of_array_name - Ode_loggers_sig.Period_t_points)^" do");] + "fprintf(fid,\"\\n\")" ^ instruction_sep logger; + "for j from tinit to tend by " + ^ Ode_loggers_sig.string_of_array_name Ode_loggers_sig.Period_t_points + ^ " do"; + ] in let () = repeat (fun _ k -> - let () = - Ode_loggers_sig.fprintf - logger - (" fprintf(fid,\"%%f%s\",eval(obs%i(t),sol(j)))%s") - (csv_sep logger) - k - (instruction_sep logger) in - Ode_loggers_sig.print_newline logger) + let () = + Ode_loggers_sig.fprintf logger + " fprintf(fid,\"%%f%s\",eval(obs%i(t),sol(j)))%s" + (csv_sep logger) k (instruction_sep logger) + in + Ode_loggers_sig.print_newline logger) nobs in let () = print_list logger [ - " fprintf(fid,\"\\n\")"^(instruction_sep logger); - "end"^(instruction_sep logger); - "fclose(fid)"^(instruction_sep logger)] + " fprintf(fid,\"\\n\")" ^ instruction_sep logger; + "end" ^ instruction_sep logger; + "fclose(fid)" ^ instruction_sep logger; + ] in Ode_loggers_sig.print_newline logger - | Loggers.Mathematica -> - let () = - print_list logger - [ - "fid = OpenWrite[NotebookDirectory[]<>\""^data_file^"\"]"^(instruction_sep logger); - "WriteString[fid, \"# "^command_line^"\\n\"]"^(instruction_sep logger); - "WriteString[fid, \"# \"]"^(instruction_sep logger)] - in - let () = - print_list logger - (List.rev_map - (fun x -> "WriteString[fid, \""^x^(csv_sep logger )^"\"]"^(instruction_sep logger)) - (List.rev titles)) - in - let () = - print_list logger - [ - "WriteString[fid, \"\\n\"]"^(instruction_sep logger) - ] - in - let () = - Ode_loggers_sig.fprintf logger - "For[j=tinit,j - let () = - Ode_loggers_sig.fprintf - logger - " WriteString[fid, (o%i /. First[sol])[j], \" \"]%s" k - (instruction_sep logger) - in - let () = Ode_loggers_sig.print_newline logger in - ()) - nobs - in - let () = - Ode_loggers_sig.fprintf - logger - " WriteString[fid, \"\\n\"]%s" (instruction_sep logger) - in - let () = - Ode_loggers_sig.fprintf logger - ")];" - in - let () = + | Loggers.Mathematica -> + let () = + print_list logger + [ + "fid = OpenWrite[NotebookDirectory[]<>\"" ^ data_file ^ "\"]" + ^ instruction_sep logger; + "WriteString[fid, \"# " ^ command_line ^ "\\n\"]" + ^ instruction_sep logger; + "WriteString[fid, \"# \"]" ^ instruction_sep logger; + ] + in + let () = + print_list logger + (List.rev_map + (fun x -> + "WriteString[fid, \"" ^ x ^ csv_sep logger ^ "\"]" + ^ instruction_sep logger) + (List.rev titles)) + in + let () = + print_list logger [ "WriteString[fid, \"\\n\"]" ^ instruction_sep logger ] + in + let () = Ode_loggers_sig.fprintf logger "For[j=tinit,j + let () = + Ode_loggers_sig.fprintf logger + " WriteString[fid, (o%i /. First[sol])[j], \" \"]%s" k + (instruction_sep logger) + in + let () = Ode_loggers_sig.print_newline logger in + ()) + nobs + in + let () = + Ode_loggers_sig.fprintf logger " WriteString[fid, \"\\n\"]%s" + (instruction_sep logger) + in + let () = Ode_loggers_sig.fprintf logger ")];" in + let () = Ode_loggers_sig.print_newline logger in + let () = print_list logger [ "Close[fid]" ^ instruction_sep logger ] in Ode_loggers_sig.print_newline logger - in - let () = - print_list logger - ["Close[fid]"^(instruction_sep logger)] - in - Ode_loggers_sig.print_newline logger - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () - + | Loggers.SBML | Loggers.DOTNET | Loggers.Json | Loggers.DOT | Loggers.GEPHI + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let open_procedure logger name name' arg = let format = Ode_loggers_sig.get_encoding_format logger in - match - format - with - | Loggers.Matlab - | Loggers.Octave -> + match format with + | Loggers.Matlab | Loggers.Octave -> let () = Ode_loggers_sig.fprintf logger "function %s=%s(" name name' in let _ = List.fold_left (fun bool s -> - let () = - Ode_loggers_sig.fprintf logger "%s%s" (if bool then "," else "") s - in true) - false - arg + let () = + Ode_loggers_sig.fprintf logger "%s%s" + (if bool then + "," + else + "") + s + in + true) + false arg in let () = Ode_loggers_sig.fprintf logger ")" in Ode_loggers_sig.print_newline logger - | Loggers.Maple | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () - -let return _ _ = () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () + +let return _ _ = () + let close_procedure logger = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.Matlab - | Loggers.Octave -> + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave -> let () = Ode_loggers_sig.fprintf logger "end" in Ode_loggers_sig.print_newline logger - | Loggers.Maple - | Loggers.Mathematica - | Loggers.SBML | Loggers.DOTNET - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.Matrix | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () + | Loggers.Maple | Loggers.Mathematica | Loggers.SBML | Loggers.DOTNET + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.Matrix | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let launch_main logger = - match - Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.Octave -> - let () = Ode_loggers_sig.fprintf logger "main()%s" (instruction_sep logger) in + let () = + Ode_loggers_sig.fprintf logger "main()%s" (instruction_sep logger) + in Ode_loggers_sig.print_newline logger | Loggers.SBML -> let () = Ode_loggers_sig.fprintf logger "" in @@ -2898,35 +2605,17 @@ let launch_main logger = let () = Ode_loggers_sig.fprintf logger "" in let () = Ode_loggers_sig.print_newline logger in () - | Loggers.DOTNET - | Loggers.Matlab - | Loggers.Mathematica - | Loggers.Maple - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph - - | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> () + | Loggers.DOTNET | Loggers.Matlab | Loggers.Mathematica | Loggers.Maple + | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + () let smash_reactions mode _parameters = match mode with | Loggers.DOTNET -> true - | Loggers.Octave - | Loggers.SBML - | Loggers.Matlab - | Loggers.Mathematica - | Loggers.Maple - | Loggers.Json - | Loggers.DOT | Loggers.GEPHI - | Loggers.Matrix - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS -> false + | Loggers.Octave | Loggers.SBML | Loggers.Matlab | Loggers.Mathematica + | Loggers.Maple | Loggers.Json | Loggers.DOT | Loggers.GEPHI | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS -> + false diff --git a/core/odes/ode_loggers.mli b/core/odes/ode_loggers.mli index 8284e37fdc..b8c98f2c1b 100644 --- a/core/odes/ode_loggers.mli +++ b/core/odes/ode_loggers.mli @@ -16,11 +16,9 @@ * under the terms of the GNU Library General Public License *) type correct = Div of int | Mul of int | Nil +type options = Comment of string -type options = - | Comment of string - -val print_ode_preamble: +val print_ode_preamble : Ode_loggers_sig.t -> (Ode_loggers_sig.t -> unit) -> may_be_not_time_homogeneous:bool -> @@ -28,86 +26,164 @@ val print_ode_preamble: rule_rate_convention:Remanent_parameters_sig.rate_convention -> ?reaction_rate_convention:Remanent_parameters_sig.rate_convention -> ?filter_in:Loggers.encoding list option -> - ?filter_out:Loggers.encoding list -> unit -> + ?filter_out:Loggers.encoding list -> + unit -> unit -val declare_global: Ode_loggers_sig.t -> Ode_loggers_sig.variable -> unit -val print_options: compute_jacobian:bool -> pos:(int -> bool) -> nodevar:int -> Ode_loggers_sig.t -> unit -val print_license_check: Ode_loggers_sig.t -> unit -val print_integrate: nobs:int -> nodevar:int -> Ode_loggers_sig.t -> unit -val print_interpolate: Ode_loggers_sig.t -> unit -val print_dump_plots: nobs:int -> data_file:string -> command_line:string -> titles:string list -> Ode_loggers_sig.t -> unit +val declare_global : Ode_loggers_sig.t -> Ode_loggers_sig.variable -> unit -val initialize: +val print_options : + compute_jacobian:bool -> + pos:(int -> bool) -> nodevar:int -> - Ode_loggers_sig.t -> Ode_loggers_sig.variable -> unit -val associate: + Ode_loggers_sig.t -> + unit + +val print_license_check : Ode_loggers_sig.t -> unit +val print_integrate : nobs:int -> nodevar:int -> Ode_loggers_sig.t -> unit +val print_interpolate : Ode_loggers_sig.t -> unit + +val print_dump_plots : + nobs:int -> + data_file:string -> + command_line:string -> + titles:string list -> + Ode_loggers_sig.t -> + unit + +val initialize : + nodevar:int -> Ode_loggers_sig.t -> Ode_loggers_sig.variable -> unit + +val associate : propagate_constants:bool -> - ?init_mode:bool -> ?comment:string -> + ?init_mode:bool -> + ?comment:string -> (int -> string) -> - Ode_loggers_sig.t -> Ode_loggers_sig.t -> Loggers.t -> - Ode_loggers_sig.variable -> - (Ode_loggers_sig.ode_var_id,Ode_loggers_sig.ode_var_id) Alg_expr.e Locality.annot -> (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t -> unit -val increment: - ?init_mode:bool -> ?comment:string -> (int -> string) -> - Ode_loggers_sig.t -> Loggers.t -> - Ode_loggers_sig.variable -> - (Ode_loggers_sig.ode_var_id, - Ode_loggers_sig.ode_var_id) Alg_expr.e Locality.annot -> (Ode_loggers_sig.ode_var_id,Ode_loggers_sig.ode_var_id) Network_handler.t -> unit -val associate_nrows: Ode_loggers_sig.t -> unit -val associate_t: Ode_loggers_sig.t -> int -> unit -val init_time: Ode_loggers_sig.t -> int -> unit -val start_time: Ode_loggers_sig.t -> float -> unit -val declare_init: ?comment:string -> Ode_loggers_sig.t -> int -> unit - -val associate_nonnegative: Ode_loggers_sig.t -> bool -> unit -val show_time_advance: Ode_loggers_sig.t -> unit -val launch_main: Ode_loggers_sig.t -> unit - -val consume: Ode_loggers_sig.t -> Ode_loggers_sig.variable -> nauto_in_species:int -> nauto_in_lhs:int -> nocc:int -> Ode_loggers_sig.variable -> (Ode_loggers_sig.variable * correct) list -> unit -val produce: Ode_loggers_sig.t -> Ode_loggers_sig.variable -> nauto_in_species:int -> nauto_in_lhs:int -> nocc:int -> Ode_loggers_sig.variable -> (Ode_loggers_sig.variable * correct) list -> unit -val consume_jac: Ode_loggers_sig.t -> Ode_loggers_sig.variable -> nauto_in_species:int -> nauto_in_lhs:int -> nocc:int -> Ode_loggers_sig.variable -> (int * correct) list -> Mods.IntSet.t -> unit -val produce_jac: Ode_loggers_sig.t -> Ode_loggers_sig.variable -> nauto_in_species:int -> nauto_in_lhs:int -> nocc:int -> Ode_loggers_sig.variable -> (int * correct) list -> Mods.IntSet.t -> unit -val update_token_jac: + Ode_loggers_sig.t -> + Ode_loggers_sig.t -> + Loggers.t -> + Ode_loggers_sig.variable -> + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e + Loc.annoted -> + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t -> + unit + +val increment : + ?init_mode:bool -> + ?comment:string -> + (int -> string) -> + Ode_loggers_sig.t -> + Loggers.t -> + Ode_loggers_sig.variable -> + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e + Loc.annoted -> + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t -> + unit + +val associate_nrows : Ode_loggers_sig.t -> unit +val associate_t : Ode_loggers_sig.t -> int -> unit +val init_time : Ode_loggers_sig.t -> int -> unit +val start_time : Ode_loggers_sig.t -> float -> unit +val declare_init : ?comment:string -> Ode_loggers_sig.t -> int -> unit +val associate_nonnegative : Ode_loggers_sig.t -> bool -> unit +val show_time_advance : Ode_loggers_sig.t -> unit +val launch_main : Ode_loggers_sig.t -> unit + +val consume : + Ode_loggers_sig.t -> + Ode_loggers_sig.variable -> + nauto_in_species:int -> + nauto_in_lhs:int -> + nocc:int -> + Ode_loggers_sig.variable -> + (Ode_loggers_sig.variable * correct) list -> + unit + +val produce : + Ode_loggers_sig.t -> + Ode_loggers_sig.variable -> + nauto_in_species:int -> + nauto_in_lhs:int -> + nocc:int -> + Ode_loggers_sig.variable -> + (Ode_loggers_sig.variable * correct) list -> + unit + +val consume_jac : Ode_loggers_sig.t -> Ode_loggers_sig.variable -> + nauto_in_species:int -> nauto_in_lhs:int -> nocc:int -> Ode_loggers_sig.variable -> - Ode_loggers_sig.variable -> (Ode_loggers_sig.ode_var_id * correct) list -> + (int * correct) list -> + Mods.IntSet.t -> + unit + +val produce_jac : + Ode_loggers_sig.t -> + Ode_loggers_sig.variable -> + nauto_in_species:int -> + nauto_in_lhs:int -> + nocc:int -> + Ode_loggers_sig.variable -> + (int * correct) list -> + Mods.IntSet.t -> + unit + +val update_token_jac : + Ode_loggers_sig.t -> + Ode_loggers_sig.variable -> + nauto_in_lhs:int -> + nocc:int -> + Ode_loggers_sig.variable -> + Ode_loggers_sig.variable -> + (Ode_loggers_sig.ode_var_id * correct) list -> Mods.IntSet.t -> dep_mixture:Mods.IntSet.t -> dep_token:Mods.IntSet.t -> unit -val update_token: - Ode_loggers_sig.t -> Ode_loggers_sig.variable -> - nauto_in_lhs:int -> nocc:int -> Ode_loggers_sig.variable -> - Ode_loggers_sig.variable -> (Ode_loggers_sig.variable * correct) list -> +val update_token : + Ode_loggers_sig.t -> + Ode_loggers_sig.variable -> + nauto_in_lhs:int -> + nocc:int -> + Ode_loggers_sig.variable -> + Ode_loggers_sig.variable -> + (Ode_loggers_sig.variable * correct) list -> unit -val print_newline: - Ode_loggers_sig.t -> unit +val print_newline : Ode_loggers_sig.t -> unit -val print_comment: +val print_comment : ?breakline:bool -> Ode_loggers_sig.t -> ?filter_in:Loggers.encoding list option -> ?filter_out:Loggers.encoding list -> - string -> unit + string -> + unit + +val open_procedure : + Ode_loggers_sig.t -> string -> string -> string list -> unit -val open_procedure: Ode_loggers_sig.t -> string -> string -> string list -> unit -val return: Ode_loggers_sig.t -> string -> unit -val close_procedure: Ode_loggers_sig.t -> unit +val return : Ode_loggers_sig.t -> string -> unit +val close_procedure : Ode_loggers_sig.t -> unit -val smash_reactions: Loggers.encoding -> Remanent_parameters_sig.parameters -> bool -val print_alg_expr_few_parenthesis: +val smash_reactions : + Loggers.encoding -> Remanent_parameters_sig.parameters -> bool + +val print_alg_expr_few_parenthesis : ?init_mode:bool -> (int -> string) -> Ode_loggers_sig.t -> Loggers.t -> - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e Locality.annot -> - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t - -> unit + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e + Loc.annoted -> + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t -> + unit -val is_time: (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e Locality.annot -> bool +val is_time : + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e + Loc.annoted -> + bool diff --git a/core/odes/ode_loggers_sig.ml b/core/odes/ode_loggers_sig.ml index 5756bf7d17..085d3bea6e 100644 --- a/core/odes/ode_loggers_sig.ml +++ b/core/odes/ode_loggers_sig.ml @@ -77,43 +77,43 @@ let string_of_array_name var = | Current_time -> "t" | Time_scale_factor -> "t_correct_dimmension" +module StringMap = Map.Make (struct + type t = string -module StringMap = Map.Make (struct type t = string let compare = compare end) -module VarOrd = -struct + let compare = compare +end) + +module VarOrd = struct type t = variable + let compare = compare end -module VarMap = Map.Make(VarOrd) -module VarSet = Set.Make(VarOrd) -type t = - { - logger: Loggers.t; - env: (ode_var_id,ode_var_id) Alg_expr.e Locality.annot VarMap.t ref ; - id_map: int StringMap.t ref ; - fresh_meta_id: int ref ; - fresh_reaction_id: int ref; - fresh_obs_id: int ref; - const: VarSet.t ref; - id_of_parameters: string VarMap.t ref; - dangerous_parameters: VarSet.t ref ; - idset: Mods.StringSet.t ref ; - csv_sep: string; - } +module VarMap = Map.Make (VarOrd) +module VarSet = Set.Make (VarOrd) + +type t = { + logger: Loggers.t; + env: (ode_var_id, ode_var_id) Alg_expr.e Loc.annoted VarMap.t ref; + id_map: int StringMap.t ref; + fresh_meta_id: int ref; + fresh_reaction_id: int ref; + fresh_obs_id: int ref; + const: VarSet.t ref; + id_of_parameters: string VarMap.t ref; + dangerous_parameters: VarSet.t ref; + idset: Mods.StringSet.t ref; + csv_sep: string; +} let lift f a = f a.logger - let get_encoding_format t = lift Loggers.get_encoding_format t let fprintf t = lift Loggers.fprintf t let print_newline t = lift Loggers.print_newline t let print_breakable_hint t = lift Loggers.print_breakable_hint t let flush_buffer t fmt = lift Loggers.flush_buffer t fmt let flush_logger t = lift Loggers.flush_logger t - let formatter_of_logger t = lift Loggers.formatter_of_logger t - - let string_of_un_op t = lift Loggers_string_of_op.string_of_un_op t let string_of_bin_op t = lift Loggers_string_of_op.string_of_bin_op t let string_of_compare_op t = lift Loggers_string_of_op.string_of_compare_op t @@ -122,9 +122,9 @@ let string_of_bin_bool_op t = lift Loggers_string_of_op.string_of_bin_bool_op t let extend_logger ~csv_sep logger = { - logger = logger ; - id_map = ref StringMap.empty ; - fresh_meta_id = ref 1 ; + logger; + id_map = ref StringMap.empty; + fresh_meta_id = ref 1; fresh_reaction_id = ref 1; fresh_obs_id = ref 1; env = ref VarMap.empty; @@ -132,37 +132,32 @@ let extend_logger ~csv_sep logger = id_of_parameters = ref VarMap.empty; dangerous_parameters = ref VarSet.empty; idset = ref Mods.StringSet.empty; - csv_sep ; + csv_sep; } -let odeFileName = - begin - List.fold_left - (fun map (key,value) -> - Loggers.FormatMap.add key (ref value) map) - Loggers.FormatMap.empty - [ - Octave, "ode.m"; - Matlab, "ode.m"; - DOTNET, "network.net"; - SBML, "network.xml"; - Maple, "ode.mws"; - Mathematica, "ode.nb" ; - ] - end +let odeFileName = + List.fold_left + (fun map (key, value) -> Loggers.FormatMap.add key (ref value) map) + Loggers.FormatMap.empty + [ + Octave, "ode.m"; + Matlab, "ode.m"; + DOTNET, "network.net"; + SBML, "network.xml"; + Maple, "ode.mws"; + Mathematica, "ode.nb"; + ] let get_odeFileName backend = - try - Loggers.FormatMap.find backend odeFileName - with - Not_found -> + try Loggers.FormatMap.find backend odeFileName + with Not_found -> let output = ref "" in let _ = Loggers.FormatMap.add backend output odeFileName in output let set_odeFileName backend name = let reference = get_odeFileName backend in - reference:=name + reference := name let set_ode ~mode f = set_odeFileName mode f let get_ode ~mode = !(get_odeFileName mode) @@ -179,37 +174,21 @@ let string_of_variable_octave var = | Initbis int | Concentration int | Deriv int -> - Printf.sprintf "%s(%i)" - (string_of_array_name var) int - | Jacobian_rate (int1,int2) - | Jacobian_rated (int1,int2) - | Jacobian_rateun (int1,int2) - | Jacobian_rateund (int1,int2) - | Jacobian (int1,int2) - | Jacobian_var (int1,int2) - | Stochiometric_coef (int1,int2) -> - Printf.sprintf "%s(%i,%i)" - (string_of_array_name var) int1 int2 - | Jacobian_stochiometric_coef (int1,int2,int3) -> - Printf.sprintf "%s(%i,%i,%i)" - (string_of_array_name var) int1 int2 int3 - | MaxStep - | InitialStep - | AbsTol - | RelTol - | Tinit - | Tend - | NonNegative - | Period_t_points - | N_ode_var - | N_var - | N_obs - | N_rules - | N_rows - | N_max_stoc_coef - | Tmp - | Current_time - | Time_scale_factor -> string_of_array_name var + Printf.sprintf "%s(%i)" (string_of_array_name var) int + | Jacobian_rate (int1, int2) + | Jacobian_rated (int1, int2) + | Jacobian_rateun (int1, int2) + | Jacobian_rateund (int1, int2) + | Jacobian (int1, int2) + | Jacobian_var (int1, int2) + | Stochiometric_coef (int1, int2) -> + Printf.sprintf "%s(%i,%i)" (string_of_array_name var) int1 int2 + | Jacobian_stochiometric_coef (int1, int2, int3) -> + Printf.sprintf "%s(%i,%i,%i)" (string_of_array_name var) int1 int2 int3 + | MaxStep | InitialStep | AbsTol | RelTol | Tinit | Tend | NonNegative + | Period_t_points | N_ode_var | N_var | N_obs | N_rules | N_rows + | N_max_stoc_coef | Tmp | Current_time | Time_scale_factor -> + string_of_array_name var type side = LHS | RHS @@ -219,8 +198,7 @@ let rem_underscore s = let string_of_variable_mathematica ~side var = let side_ext = - match side - with + match side with | LHS -> "_" | RHS -> "" in @@ -233,39 +211,17 @@ let string_of_variable_mathematica ~side var = | Concentration int | Deriv int | Expr int -> - Printf.sprintf "%s%i[t%s]" - (string_of_array_name var) int side_ext - | Stochiometric_coef (int1,int2) -> - Printf.sprintf "%s%i_%i[t%s]" - (string_of_array_name var) int1 int2 side_ext - | Init int - | Initbis int -> - Printf.sprintf "%s%i" - (string_of_array_name var) int - | Jacobian_rate _ - | Jacobian_rated _ - | Jacobian_rateun _ - | Jacobian_rateund _ - | Jacobian _ - | Jacobian_var _ - | Jacobian_stochiometric_coef _ -> "" - | NonNegative - | Tinit - | Tend - | MaxStep - | InitialStep - | AbsTol - | RelTol - | Period_t_points - | N_ode_var - | N_var - | N_obs - | N_rules - | N_rows - | N_max_stoc_coef - | Tmp - | Current_time - | Time_scale_factor -> + Printf.sprintf "%s%i[t%s]" (string_of_array_name var) int side_ext + | Stochiometric_coef (int1, int2) -> + Printf.sprintf "%s%i_%i[t%s]" (string_of_array_name var) int1 int2 side_ext + | Init int | Initbis int -> + Printf.sprintf "%s%i" (string_of_array_name var) int + | Jacobian_rate _ | Jacobian_rated _ | Jacobian_rateun _ | Jacobian_rateund _ + | Jacobian _ | Jacobian_var _ | Jacobian_stochiometric_coef _ -> + "" + | NonNegative | Tinit | Tend | MaxStep | InitialStep | AbsTol | RelTol + | Period_t_points | N_ode_var | N_var | N_obs | N_rules | N_rows + | N_max_stoc_coef | Tmp | Current_time | Time_scale_factor -> rem_underscore (string_of_array_name var) let string_of_variable_maple var = @@ -278,77 +234,40 @@ let string_of_variable_maple var = | Concentration int | Deriv int | Expr int -> - Printf.sprintf "%s%i(t)" - (string_of_array_name var) int - | Init int - | Initbis int -> - Printf.sprintf "%s%i" - (string_of_array_name var) int - | Stochiometric_coef (int1,int2) -> - Printf.sprintf "%s%i_%i" - (string_of_array_name var) int1 int2 - | Jacobian_rate _ - | Jacobian_rated _ - | Jacobian_rateun _ - | Jacobian_rateund _ - | Jacobian _ - | Jacobian_var _ - | Jacobian_stochiometric_coef _ -> "" - | NonNegative - | Tinit - | Tend - | MaxStep - | InitialStep - | AbsTol - | RelTol - | Period_t_points - | N_ode_var - | N_var - | N_obs - | N_rules - | N_rows - | N_max_stoc_coef - | Tmp - | Current_time - | Time_scale_factor -> - (string_of_array_name var) - + Printf.sprintf "%s%i(t)" (string_of_array_name var) int + | Init int | Initbis int -> + Printf.sprintf "%s%i" (string_of_array_name var) int + | Stochiometric_coef (int1, int2) -> + Printf.sprintf "%s%i_%i" (string_of_array_name var) int1 int2 + | Jacobian_rate _ | Jacobian_rated _ | Jacobian_rateun _ | Jacobian_rateund _ + | Jacobian _ | Jacobian_var _ | Jacobian_stochiometric_coef _ -> + "" + | NonNegative | Tinit | Tend | MaxStep | InitialStep | AbsTol | RelTol + | Period_t_points | N_ode_var | N_var | N_obs | N_rules | N_rows + | N_max_stoc_coef | Tmp | Current_time | Time_scale_factor -> + string_of_array_name var let string_of_variable ~side loggers variable = - match - Loggers.get_encoding_format loggers.logger - with - | Loggers.Matlab - | Loggers.Octave -> - string_of_variable_octave variable - | Loggers.Mathematica -> - string_of_variable_mathematica ~side variable - | Loggers.Maple -> - string_of_variable_maple variable - | Loggers.Matrix - | Loggers.HTML_Graph - | Loggers.Js_Graph - | Loggers.HTML - | Loggers.HTML_Tabular - | Loggers.DOT - | Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS - | Loggers.SBML - | Loggers.DOTNET - | Loggers.GEPHI - | Loggers.Json -> "" + match Loggers.get_encoding_format loggers.logger with + | Loggers.Matlab | Loggers.Octave -> string_of_variable_octave variable + | Loggers.Mathematica -> string_of_variable_mathematica ~side variable + | Loggers.Maple -> string_of_variable_maple variable + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular + | Loggers.XLS | Loggers.SBML | Loggers.DOTNET | Loggers.GEPHI | Loggers.Json + -> + "" let variable_of_derived_variable var id = match var with - | Rate int -> Jacobian_rate (int,id) - | Rated int -> Jacobian_rated (int,id) - | Rateun int -> Jacobian_rateun (int,id) - | Rateund int -> Jacobian_rateund (int,id) + | Rate int -> Jacobian_rate (int, id) + | Rated int -> Jacobian_rated (int, id) + | Rateun int -> Jacobian_rateun (int, id) + | Rateund int -> Jacobian_rateund (int, id) | Expr int -> Jacobian_var (int, id) | Concentration int -> Jacobian (int, id) - | Stochiometric_coef (int1,int2) -> - Jacobian_stochiometric_coef (int1,int2,id) + | Stochiometric_coef (int1, int2) -> + Jacobian_stochiometric_coef (int1, int2, id) | NonNegative -> assert false | Obs _ -> assert false | Init _ -> assert false @@ -378,84 +297,71 @@ let variable_of_derived_variable var id = | Current_time -> assert false | Time_scale_factor -> assert false +let get_expr t v = try Some (VarMap.find v !(t.env)) with Not_found -> None -let get_expr t v = - try - Some (VarMap.find v (!(t.env))) - with - | Not_found -> - None - - let set_dangerous_global_parameter_name t var = - t.dangerous_parameters := VarSet.add var (!(t.dangerous_parameters)) +let set_dangerous_global_parameter_name t var = + t.dangerous_parameters := VarSet.add var !(t.dangerous_parameters) let forbidden_char c = match c with - '*' | '+' | '-' | '(' | ')' -> true + | '*' | '+' | '-' | '(' | ')' -> true | _ -> false - let has_forbidden_char t string = - (match get_encoding_format t - with - DOTNET -> true - | Matrix | HTML_Graph | Js_Graph | HTML | HTML_Tabular | DOT | TXT | TXT_Tabular | XLS | GEPHI - | Octave | Matlab | Maple | Mathematica | Json | SBML -> false) +let has_forbidden_char t string = + (match get_encoding_format t with + | DOTNET -> true + | Matrix | HTML_Graph | Js_Graph | HTML | HTML_Tabular | DOT | TXT + | TXT_Tabular | XLS | GEPHI | Octave | Matlab | Maple | Mathematica | Json + | SBML -> + false) && let rec aux k n = - if k=n then false - else forbidden_char (string.[k]) || aux (k+1) n + if k = n then + false + else + forbidden_char string.[k] || aux (k + 1) n in aux 0 (String.length string) - let flag_dangerous t id string = - if has_forbidden_char t string - then - set_dangerous_global_parameter_name t id +let flag_dangerous t id string = + if has_forbidden_char t string then set_dangerous_global_parameter_name t id let set_expr t v expr = let const = Alg_expr.is_constant expr in let () = if not const then - t.const := VarSet.remove v (!(t.const)) + t.const := VarSet.remove v !(t.const) else - t.const := VarSet.add v (!(t.const)) + t.const := VarSet.add v !(t.const) in - t.env := VarMap.add v expr (!(t.env)) + t.env := VarMap.add v expr !(t.env) -let is_const t v = - VarSet.mem v (!(t.const)) +let is_const t v = VarSet.mem v !(t.const) let get_fresh_reaction_id t = let output = !(t.fresh_reaction_id) in - let () = t.fresh_reaction_id:=succ output in + let () = t.fresh_reaction_id := succ output in output let get_id_of_global_parameter t var = - try - VarMap.find var (!(t.id_of_parameters)) - with - Not_found -> "" + try VarMap.find var !(t.id_of_parameters) with Not_found -> "" let set_id_of_global_parameter t var id = - let () = t.id_of_parameters := VarMap.add var id (!(t.id_of_parameters)) in + let () = t.id_of_parameters := VarMap.add var id !(t.id_of_parameters) in flag_dangerous t var id let rec allocate_fresh_name t name potential_suffix = - if Mods.StringSet.mem name (!(t.idset)) - then - allocate_fresh_name t (name^potential_suffix) potential_suffix + if Mods.StringSet.mem name !(t.idset) then + allocate_fresh_name t (name ^ potential_suffix) potential_suffix else name let allocate t name = - let () = t.idset := Mods.StringSet.add name (!(t.idset)) in + let () = t.idset := Mods.StringSet.add name !(t.idset) in () -let is_dangerous_ode_variable t var = - VarSet.mem var (!(t.dangerous_parameters)) - +let is_dangerous_ode_variable t var = VarSet.mem var !(t.dangerous_parameters) let get_fresh_meta_id logger = Tools.get_ref logger.fresh_meta_id let get_fresh_obs_id logger = Tools.get_ref logger.fresh_obs_id - let csv_sep logger = logger.csv_sep let lift t = t.logger diff --git a/core/odes/ode_loggers_sig.mli b/core/odes/ode_loggers_sig.mli index c18c44cad4..f129e4fed3 100644 --- a/core/odes/ode_loggers_sig.mli +++ b/core/odes/ode_loggers_sig.mli @@ -1,5 +1,4 @@ type side = LHS | RHS - type ode_var_id = int type variable = @@ -39,52 +38,45 @@ type variable = | Time_scale_factor | NonNegative -val int_of_ode_var_id: ode_var_id -> int -val string_of_array_name: variable -> string - - +val int_of_ode_var_id : ode_var_id -> int +val string_of_array_name : variable -> string type t -val extend_logger: csv_sep:string -> Loggers.t -> t -val get_encoding_format: t -> Loggers.encoding -val fprintf: t -> ('a, Format.formatter, unit) format -> 'a -val print_newline: t -> unit -val print_breakable_hint: t -> unit -val flush_buffer: t -> Format.formatter -> unit -val flush_logger: t -> unit - -val has_forbidden_char: t -> string -> bool -val formatter_of_logger: t -> Format.formatter option - - -val string_of_un_op: t -> Operator.un_alg_op -> string -val string_of_bin_op: t -> Operator.bin_alg_op -> string -val string_of_compare_op: t -> Operator.compare_op -> string -val string_of_un_bool_op: t -> Operator.un_bool_op -> string -val string_of_bin_bool_op: t -> Operator.bin_bool_op -> string - -val get_expr: t -> variable -> (ode_var_id,ode_var_id) Alg_expr.e Locality.annot option -val set_expr: t -> variable -> (ode_var_id,ode_var_id) Alg_expr.e Locality.annot -> unit -val is_const: t -> variable -> bool - -val get_fresh_obs_id: t -> int -val get_fresh_reaction_id: t -> int -val get_fresh_meta_id: t -> int -val set_id_of_global_parameter: t -> variable -> string -> unit -val get_id_of_global_parameter: t -> variable -> string -val is_dangerous_ode_variable: t -> variable -> bool -val flag_dangerous: t -> variable -> string -> unit -val allocate_fresh_name: t -> string -> string -> string -val allocate: t -> string -> unit - - +val extend_logger : csv_sep:string -> Loggers.t -> t +val get_encoding_format : t -> Loggers.encoding +val fprintf : t -> ('a, Format.formatter, unit) format -> 'a +val print_newline : t -> unit +val print_breakable_hint : t -> unit +val flush_buffer : t -> Format.formatter -> unit +val flush_logger : t -> unit +val has_forbidden_char : t -> string -> bool +val formatter_of_logger : t -> Format.formatter option +val string_of_un_op : t -> Operator.un_alg_op -> string +val string_of_bin_op : t -> Operator.bin_alg_op -> string +val string_of_compare_op : t -> Operator.compare_op -> string +val string_of_un_bool_op : t -> Operator.un_bool_op -> string +val string_of_bin_bool_op : t -> Operator.bin_bool_op -> string + +val get_expr : + t -> variable -> (ode_var_id, ode_var_id) Alg_expr.e Loc.annoted option + +val set_expr : + t -> variable -> (ode_var_id, ode_var_id) Alg_expr.e Loc.annoted -> unit + +val is_const : t -> variable -> bool +val get_fresh_obs_id : t -> int +val get_fresh_reaction_id : t -> int +val get_fresh_meta_id : t -> int +val set_id_of_global_parameter : t -> variable -> string -> unit +val get_id_of_global_parameter : t -> variable -> string +val is_dangerous_ode_variable : t -> variable -> bool +val flag_dangerous : t -> variable -> string -> unit +val allocate_fresh_name : t -> string -> string -> string +val allocate : t -> string -> unit val set_ode : mode:Loggers.encoding -> string -> unit val get_ode : mode:Loggers.encoding -> string - - -val string_of_variable: side:side -> t -> variable -> string -val variable_of_derived_variable: variable -> ode_var_id -> variable -val csv_sep: t -> string - -val lift: t -> Loggers.t +val string_of_variable : side:side -> t -> variable -> string +val variable_of_derived_variable : variable -> ode_var_id -> variable +val csv_sep : t -> string +val lift : t -> Loggers.t diff --git a/core/odes/odes.ml b/core/odes/odes.ml index ee7c634437..1d2dc79965 100644 --- a/core/odes/odes.ml +++ b/core/odes/odes.ml @@ -5,43 +5,48 @@ let local_trace = false -let debug ~debugMode s = - if local_trace || debugMode - then Format.kfprintf (fun f -> Format.pp_print_break f 0 0) +let debug ~debug_mode s = + if local_trace || debug_mode then + Format.kfprintf + (fun f -> Format.pp_print_break f 0 0) Format.err_formatter s - else Format.ifprintf Format.err_formatter s + else + Format.ifprintf Format.err_formatter s -module Make(I:Symmetry_interface_sig.Interface) = - -struct +module Make (I : Symmetry_interface_sig.Interface) = struct type connected_component_id = int + let fst_cc_id = 1 let next_cc_id = succ - module Store = - SetMap.Make - (struct - type t = - I.rule_id_with_mode * connected_component_id * I.connected_component - let compare (a,b,c) (a',b',c') = - let x = compare (a,b) (a',b') in - if x <> 0 then x else I.compare_connected_component c c' - let print a ((r,ar,dir),cc_id,cc) = - let () = - Format.fprintf a - "Component_wise:(%a,%s,%s,%i,%a)" - I.print_rule_id r - (match ar with Rule_modes.Usual -> "@" - | Rule_modes.Unary | Rule_modes.Unary_refinement - -> "(1)") - (match dir with Rule_modes.Direct -> "->" | Rule_modes.Op -> "<-") - cc_id - (I.print_connected_component ?compil:None) cc - in - let () = I.print_rule_id a r in - let () = Format.fprintf a "cc_id: %i \n" cc_id in - I.print_connected_component ?compil:None a cc - end) + module Store = SetMap.Make (struct + type t = + I.rule_id_with_mode * connected_component_id * I.connected_component + + let compare (a, b, c) (a', b', c') = + let x = compare (a, b) (a', b') in + if x <> 0 then + x + else + I.compare_connected_component c c' + + let print a ((r, ar, dir), cc_id, cc) = + let () = + Format.fprintf a "Component_wise:(%a,%s,%s,%i,%a)" I.print_rule_id r + (match ar with + | Rule_modes.Usual -> "@" + | Rule_modes.Unary | Rule_modes.Unary_refinement -> "(1)") + (match dir with + | Rule_modes.Direct -> "->" + | Rule_modes.Op -> "<-") + cc_id + (I.print_connected_component ?compil:None) + cc + in + let () = I.print_rule_id a r in + let () = Format.fprintf a "cc_id: %i \n" cc_id in + I.print_connected_component ?compil:None a cc + end) module StoreMap = Store.Map @@ -50,52 +55,52 @@ struct type var_id = id type obs_id = id type rule_id = id + let fst_id = 1 let next_id id = id + 1 type ode_var = | Noccurrences of I.canonic_species - | Nembed of I.canonic_species | Token of int | Dummy + | Nembed of I.canonic_species + | Token of int + | Dummy type lhs_decl = Init_decl | Var_decl of string | Init_value of ode_var - module VarSetMap = - SetMap.Make - (struct - type t = ode_var - let compare = compare - let print log x = - match x with - | Nembed x | Noccurrences x -> I.print_canonic_species log x - | Token x -> Format.fprintf log "%i" x - | Dummy -> () - end) + module VarSetMap = SetMap.Make (struct + type t = ode_var + + let compare = compare + + let print log x = + match x with + | Nembed x | Noccurrences x -> I.print_canonic_species log x + | Token x -> Format.fprintf log "%i" x + | Dummy -> () + end) + module VarSet = VarSetMap.Set module VarMap = VarSetMap.Map type 'a decl = - | Var of - var_id * string option * ('a,int) Alg_expr.e Locality.annot - | Init_expr of - var_id * ('a,int) Alg_expr.e Locality.annot * ode_var_id list + | Var of var_id * string option * ('a, int) Alg_expr.e Loc.annoted + | Init_expr of var_id * ('a, int) Alg_expr.e Loc.annoted * ode_var_id list | Dummy_decl let var_id_of_decl decl = match decl with - | Var (a,_,_) -> a - | Init_expr (a,_,_) -> a + | Var (a, _, _) -> a + | Init_expr (a, _, _) -> a | Dummy_decl -> fst_id - type enriched_rule = - { - comment: string; - rule_id_with_mode: (rule_id*Rule_modes.arity*Rule_modes.direction); - rule: I.rule ; - lhs: I.pattern ; - lhs_cc: - (connected_component_id * I.connected_component) list ; - divide_rate_by: int; - } + type enriched_rule = { + comment: string; + rule_id_with_mode: rule_id * Rule_modes.arity * Rule_modes.direction; + rule: I.rule; + lhs: I.pattern; + lhs_cc: (connected_component_id * I.connected_component) list; + divide_rate_by: int; + } let get_comment e = e.comment let get_rule_id_with_mode e = e.rule_id_with_mode @@ -105,103 +110,93 @@ struct let get_divide_rate_by e = e.divide_rate_by let rule_id_of e = - let (a,_,_) = e.rule_id_with_mode in a + let a, _, _ = e.rule_id_with_mode in + a let arity_of e = - let (_,a,_) = e.rule_id_with_mode in a + let _, a, _ = e.rule_id_with_mode in + a let direction_of e = - let (_,_,a) = e.rule_id_with_mode in a + let _, _, a = e.rule_id_with_mode in + a - let var_of_rate (rule_id,arity,direction) = - match arity,direction with - | Rule_modes.Usual,Rule_modes.Direct -> Ode_loggers_sig.Rate rule_id - | (Rule_modes.Unary | Rule_modes.Unary_refinement), Rule_modes.Direct -> Ode_loggers_sig.Rateun rule_id - | Rule_modes.Usual,Rule_modes.Op -> Ode_loggers_sig.Rated rule_id - | (Rule_modes.Unary | Rule_modes.Unary_refinement), Rule_modes.Op -> Ode_loggers_sig.Rateund rule_id + let var_of_rate (rule_id, arity, direction) = + match arity, direction with + | Rule_modes.Usual, Rule_modes.Direct -> Ode_loggers_sig.Rate rule_id + | (Rule_modes.Unary | Rule_modes.Unary_refinement), Rule_modes.Direct -> + Ode_loggers_sig.Rateun rule_id + | Rule_modes.Usual, Rule_modes.Op -> Ode_loggers_sig.Rated rule_id + | (Rule_modes.Unary | Rule_modes.Unary_refinement), Rule_modes.Op -> + Ode_loggers_sig.Rateund rule_id - let var_of_rule rule = - var_of_rate rule.rule_id_with_mode + let var_of_rule rule = var_of_rate rule.rule_id_with_mode let var_of_stoch rule n = let rule_id, _, _ = rule.rule_id_with_mode in Ode_loggers_sig.Stochiometric_coef (rule_id, n) - type ('a,'b) network = - { - rules : enriched_rule list ; - cc_to_rules : (enriched_rule * int) list I.ObsMap.t ; - cc_to_embedding_to_current_species : I.embedding list I.ObsMap.t ; - updated_cc_to_embedding_to_current_species : I.connected_component list ; - - ode_variables : VarSet.t ; - reactions: - ((id list * id list * (id Locality.annot) list * enriched_rule) * int) - list ; - ode_vars_tab: ode_var Mods.DynArray.t ; - id_of_ode_var: ode_var_id VarMap.t ; - fresh_ode_var_id: ode_var_id ; - - species_tab: (I.chemical_species*int) Mods.DynArray.t ; - - cache: I.cache ; - - varmap: var_id Mods.IntMap.t ; - tokenmap: ode_var_id Mods.IntMap.t ; - - fresh_var_id: var_id ; - var_declaration: 'a decl list ; - - n_rules: int ; - - obs: (obs_id * ('a,'b) Alg_expr.e Locality.annot) list ; - n_obs: int ; - time_homogeneous_obs: bool option ; - time_homogeneous_vars: bool option ; - time_homogeneous_rates: bool option ; - symmetries: Symmetries.symmetries option; - sym_reduction: Symmetries.reduction ; - max_stoch_coef: int; - fictitious_species: id option; - has_empty_lhs: bool option; - has_time_reaction: bool option; - } + type ('a, 'b) network = { + rules: enriched_rule list; + cc_to_rules: (enriched_rule * int) list I.ObsMap.t; + cc_to_embedding_to_current_species: I.embedding list I.ObsMap.t; + updated_cc_to_embedding_to_current_species: I.connected_component list; + ode_variables: VarSet.t; + reactions: + ((id list * id list * id Loc.annoted list * enriched_rule) * int) list; + ode_vars_tab: ode_var Mods.DynArray.t; + id_of_ode_var: ode_var_id VarMap.t; + fresh_ode_var_id: ode_var_id; + species_tab: (I.chemical_species * int) Mods.DynArray.t; + cache: I.cache; + varmap: var_id Mods.IntMap.t; + tokenmap: ode_var_id Mods.IntMap.t; + fresh_var_id: var_id; + var_declaration: 'a decl list; + n_rules: int; + obs: (obs_id * ('a, 'b) Alg_expr.e Loc.annoted) list; + n_obs: int; + time_homogeneous_obs: bool option; + time_homogeneous_vars: bool option; + time_homogeneous_rates: bool option; + symmetries: Symmetries.symmetries option; + sym_reduction: Symmetries.reduction; + max_stoch_coef: int; + fictitious_species: id option; + has_empty_lhs: bool option; + has_time_reaction: bool option; + } let get_data network = - network.n_rules, - begin - List.length (network.reactions) - - (match network.has_time_reaction - with Some true -> 1 | None | Some false -> 0) - end, - begin - (VarSet.fold - (fun a n -> - match a with Nembed _ | Noccurrences _ -> n+1 - | Token _ | Dummy -> n) - network.ode_variables - 0) - - (match network.has_empty_lhs with - None | Some false -> 0 - | Some true -> 1) - end + ( network.n_rules, + (List.length network.reactions + - + match network.has_time_reaction with + | Some true -> 1 + | None | Some false -> 0), + VarSet.fold + (fun a n -> + match a with + | Nembed _ | Noccurrences _ -> n + 1 + | Token _ | Dummy -> n) + network.ode_variables 0 + - + match network.has_empty_lhs with + | None | Some false -> 0 + | Some true -> 1 ) let may_be_time_homogeneous_gen a = - match - a - with + match a with | Some false -> false | Some true | None -> true let may_be_not_time_homogeneous_gen a = - match - a - with - | Some false | None -> true - | Some true -> false + match a with + | Some false | None -> true + | Some true -> false let var_may_be_not_time_homogeneous network = - may_be_not_time_homogeneous_gen network.time_homogeneous_vars + may_be_not_time_homogeneous_gen network.time_homogeneous_vars let obs_may_be_not_time_homogeneous network = var_may_be_not_time_homogeneous network @@ -216,68 +211,65 @@ struct || may_be_not_time_homogeneous_gen network.time_homogeneous_obs let get_fresh_var_id network = network.fresh_var_id - let get_last_var_id network = network.fresh_var_id-1 + let get_last_var_id network = network.fresh_var_id - 1 + let inc_fresh_var_id network = - {network with fresh_var_id = next_id network.fresh_var_id} - let get_fresh_ode_var_id network = network.fresh_ode_var_id - let get_last_ode_var_id network = network.fresh_ode_var_id-1 - let inc_fresh_ode_var_id network = - {network with fresh_ode_var_id = next_id network.fresh_ode_var_id} - let get_fresh_obs_id network = network.n_obs - let last_fresh_obs_id network = network.n_obs-1 - let inc_fresh_obs_id network = - {network with n_obs = next_id network.n_obs} + { network with fresh_var_id = next_id network.fresh_var_id } + let get_fresh_ode_var_id network = network.fresh_ode_var_id + let get_last_ode_var_id network = network.fresh_ode_var_id - 1 - let fold_left_swap f a b = - List.fold_left - (fun a b -> f b a) - b a + let inc_fresh_ode_var_id network = + { network with fresh_ode_var_id = next_id network.fresh_ode_var_id } + let get_fresh_obs_id network = network.n_obs + let last_fresh_obs_id network = network.n_obs - 1 + let inc_fresh_obs_id network = { network with n_obs = next_id network.n_obs } + let fold_left_swap f a b = List.fold_left (fun a b -> f b a) b a let get_compil = I.get_compil - let get_preprocessed_ast = I.get_preprocessed_ast let get_ast = I.get_ast let to_ast = I.to_ast let preprocess = I.preprocess let reset compil network = - {network with - ode_variables = VarSet.empty ; - ode_vars_tab = Mods.DynArray.create 0 Dummy ; - id_of_ode_var = VarMap.empty ; - species_tab = Mods.DynArray.create 0 - (I.dummy_chemical_species compil,1) ; - cache = I.empty_cache compil ; - fresh_ode_var_id = fst_id ; - fresh_var_id = fst_id ; - varmap = Mods.IntMap.empty ; - tokenmap = Mods.IntMap.empty ; + { + network with + ode_variables = VarSet.empty; + ode_vars_tab = Mods.DynArray.create 0 Dummy; + id_of_ode_var = VarMap.empty; + species_tab = Mods.DynArray.create 0 (I.dummy_chemical_species compil, 1); + cache = I.empty_cache compil; + fresh_ode_var_id = fst_id; + fresh_var_id = fst_id; + varmap = Mods.IntMap.empty; + tokenmap = Mods.IntMap.empty; var_declaration = []; - obs = [] ; - n_obs = 1 ; - time_homogeneous_vars = None ; - time_homogeneous_obs = None ; - time_homogeneous_rates = None ; - (* symmetries = None ; - sym_reduction = Symmetries.Ground ;*) + obs = []; + n_obs = 1; + time_homogeneous_vars = None; + time_homogeneous_obs = None; + time_homogeneous_rates = None; + (* symmetries = None ; + sym_reduction = Symmetries.Ground ;*) } let add_embed_to_current_species cc embed network = - let _old,network = - match I.ObsMap.get cc network.cc_to_embedding_to_current_species - with - | [] -> [], - {network with - updated_cc_to_embedding_to_current_species = cc::network.updated_cc_to_embedding_to_current_species} - | _::_ as old -> old,network + let _old, network = + match I.ObsMap.get cc network.cc_to_embedding_to_current_species with + | [] -> + ( [], + { + network with + updated_cc_to_embedding_to_current_species = + cc :: network.updated_cc_to_embedding_to_current_species; + } ) + | _ :: _ as old -> old, network in let cc_to_embedding_to_current_species = I.ObsMap.add cc embed network.cc_to_embedding_to_current_species in - {network - with - cc_to_embedding_to_current_species} + { network with cc_to_embedding_to_current_species } let get_embed_to_current_species cc network = I.ObsMap.get cc network.cc_to_embedding_to_current_species @@ -288,9 +280,8 @@ struct let cc_to_embedding_to_current_species = List.fold_left (fun cc_to_embedding_to_current_species k -> - I.ObsMap.reset k cc_to_embedding_to_current_species) - network.cc_to_embedding_to_current_species - l + I.ObsMap.reset k cc_to_embedding_to_current_species) + network.cc_to_embedding_to_current_species l in { network with @@ -300,31 +291,30 @@ struct let init compil = { - rules = [] ; + rules = []; cc_to_rules = I.ObsMap.empty []; cc_to_embedding_to_current_species = I.ObsMap.empty []; updated_cc_to_embedding_to_current_species = []; - reactions = [] ; - ode_variables = VarSet.empty ; - ode_vars_tab = Mods.DynArray.create 0 Dummy ; - id_of_ode_var = VarMap.empty ; - species_tab = Mods.DynArray.create 0 - (I.dummy_chemical_species compil,1) ; - cache = I.empty_cache compil ; - fresh_ode_var_id = fst_id ; - fresh_var_id = fst_id ; - varmap = Mods.IntMap.empty ; - tokenmap = Mods.IntMap.empty ; + reactions = []; + ode_variables = VarSet.empty; + ode_vars_tab = Mods.DynArray.create 0 Dummy; + id_of_ode_var = VarMap.empty; + species_tab = Mods.DynArray.create 0 (I.dummy_chemical_species compil, 1); + cache = I.empty_cache compil; + fresh_ode_var_id = fst_id; + fresh_var_id = fst_id; + varmap = Mods.IntMap.empty; + tokenmap = Mods.IntMap.empty; var_declaration = []; - n_rules = 0 ; - obs = [] ; - n_obs = 1 ; - time_homogeneous_vars = None ; - time_homogeneous_obs = None ; - time_homogeneous_rates = None ; - symmetries = None ; - sym_reduction = Symmetries.Ground ; - max_stoch_coef = 0 ; + n_rules = 0; + obs = []; + n_obs = 1; + time_homogeneous_vars = None; + time_homogeneous_obs = None; + time_homogeneous_rates = None; + symmetries = None; + sym_reduction = Symmetries.Ground; + max_stoch_coef = 0; fictitious_species = None; has_empty_lhs = None; has_time_reaction = None; @@ -364,15 +354,13 @@ struct let to_nocc = lift to_nocc_correct let to_var compil expr auto = - if I.internal_meaning_is_nembeddings compil - then + if I.internal_meaning_is_nembeddings compil then to_nembed compil expr auto else to_nocc compil expr auto let species_to_var compil species = - if I.internal_meaning_is_nembeddings compil - then + if I.internal_meaning_is_nembeddings compil then Nembed species else Noccurrences species @@ -385,104 +373,100 @@ struct let add_new_var var network = let () = - Mods.DynArray.set - network.ode_vars_tab - (get_fresh_ode_var_id network) - var + Mods.DynArray.set network.ode_vars_tab (get_fresh_ode_var_id network) var in let network = - { network - with - ode_variables = VarSet.add var network.ode_variables ; - id_of_ode_var = VarMap.add var network.fresh_ode_var_id network.id_of_ode_var ; + { + network with + ode_variables = VarSet.add var network.ode_variables; + id_of_ode_var = + VarMap.add var network.fresh_ode_var_id network.id_of_ode_var; } in - inc_fresh_ode_var_id network, - get_fresh_ode_var_id network + inc_fresh_ode_var_id network, get_fresh_ode_var_id network let add_ficitious_species network = - let network = {network with fictitious_species = Some (get_fresh_ode_var_id network)} in + let network = + { network with fictitious_species = Some (get_fresh_ode_var_id network) } + in let network = inc_fresh_ode_var_id network in network - let add_new_canonic_species ~debugMode compil canonic species network = + let add_new_canonic_species ~debug_mode compil canonic species network = let () = - Mods.DynArray.set - network.species_tab + Mods.DynArray.set network.species_tab (get_fresh_ode_var_id network) - (species, I.nbr_automorphisms_in_chemical_species ~debugMode species) + (species, I.nbr_automorphisms_in_chemical_species ~debug_mode species) in let var = species_to_var compil canonic in add_new_var var network let add_new_token token network = let network, id = add_new_var (Token token) network in - {network with tokenmap = Mods.IntMap.add token id network.tokenmap}, - id + { network with tokenmap = Mods.IntMap.add token id network.tokenmap }, id let enrich_rule cache compil rule rule_id_with_mode = let lhs = I.lhs compil rule_id_with_mode rule in - let _succ_last_cc_id,lhs_cc = + let _succ_last_cc_id, lhs_cc = List.fold_left - (fun (counter,list) cc -> - (next_cc_id counter, - (counter,cc)::list)) - (fst_cc_id,[]) + (fun (counter, list) cc -> next_cc_id counter, (counter, cc) :: list) + (fst_cc_id, []) (List.rev (I.connected_components_of_patterns lhs)) in let cache, divide_rate_by = I.divide_rule_rate_by cache compil rule (* to do, check if we do not compute it many times *) in - cache, - { - comment = I.rate_name compil rule rule_id_with_mode ; - rule_id_with_mode = rule_id_with_mode ; - rule = rule ; - lhs = lhs ; - lhs_cc = lhs_cc ; - divide_rate_by = divide_rate_by ; - } - + ( cache, + { + comment = I.rate_name compil rule rule_id_with_mode; + rule_id_with_mode; + rule; + lhs; + lhs_cc; + divide_rate_by; + } ) let add_embedding_list key lembed store = - let old_list = - StoreMap.find_default [] key store - in - let new_list = - fold_left_swap (fun a b -> a::b) - lembed - old_list - in + let old_list = StoreMap.find_default [] key store in + let new_list = fold_left_swap (fun a b -> a :: b) lembed old_list in StoreMap.add key new_list store let translate_canonic_species compil canonic species remanent = - let debugMode = I.debug_mode compil in + let debug_mode = I.debug_mode compil in let var = species_to_var compil canonic in - let id_opt = - VarMap.find_option - var - (snd remanent).id_of_ode_var in - match - id_opt - with + let id_opt = VarMap.find_option var (snd remanent).id_of_ode_var in + match id_opt with | None -> - let () = debug ~debugMode "A NEW SPECIES IS DISCOVERED @." in - let () = debug ~debugMode "canonic form: %a@." - (fun x -> I.print_canonic_species ~compil x) canonic in - let () = debug ~debugMode "species: %a@.@." - (fun x -> I.print_chemical_species ~compil x) species in + let () = debug ~debug_mode "A NEW SPECIES IS DISCOVERED @." in + let () = + debug ~debug_mode "canonic form: %a@." + (fun x -> I.print_canonic_species ~compil x) + canonic + in + let () = + debug ~debug_mode "species: %a@.@." + (fun x -> I.print_chemical_species ~compil x) + species + in let to_be_visited, network = remanent in - let network, id = add_new_canonic_species - ~debugMode compil canonic species network in - (species::to_be_visited,network), id + let network, id = + add_new_canonic_species ~debug_mode compil canonic species network + in + (species :: to_be_visited, network), id | Some i -> - let () = debug ~debugMode "ALREADY SEEN SPECIES @." in - let () = debug ~debugMode "canonic form: %a@." - (fun x -> I.print_canonic_species ~compil x) canonic in - let () = debug ~debugMode "species: %a@.@." - (fun x -> I.print_chemical_species ~compil x) species in - remanent,i + let () = debug ~debug_mode "ALREADY SEEN SPECIES @." in + let () = + debug ~debug_mode "canonic form: %a@." + (fun x -> I.print_canonic_species ~compil x) + canonic + in + let () = + debug ~debug_mode "species: %a@.@." + (fun x -> I.print_chemical_species ~compil x) + species + in + remanent, i let representative parameters compil network species = match network.sym_reduction with @@ -493,20 +477,18 @@ struct I.get_representative parameters compil cache network.sym_reduction species in - {network with cache = cache}, species + { network with cache }, species let translate_species parameters compil species remanent = let network, species = representative parameters compil (snd remanent) species in let remanent = fst remanent, network in - translate_canonic_species compil - (I.canonic_form species) species remanent + translate_canonic_species compil (I.canonic_form species) species remanent let translate_token token remanent = let id_opt = - VarMap.find_option - (Token token) (snd remanent).id_of_ode_var + VarMap.find_option (Token token) (snd remanent).id_of_ode_var in match id_opt with | None -> @@ -520,365 +502,302 @@ struct representative parameters compil (snd remanent) species in let remanent = fst remanent, network in - translate_canonic_species compil - (I.canonic_form species) species remanent + translate_canonic_species compil (I.canonic_form species) species remanent let petrify_species_list parameters compil l remanent = fold_left_swap - (fun species (remanent,l) -> - let remanent, i = - petrify_species parameters compil species remanent - in - remanent,(i::l)) - l - (remanent,[]) + (fun species (remanent, l) -> + let remanent, i = petrify_species parameters compil species remanent in + remanent, i :: l) + l (remanent, []) - let petrify_mixture parameters compil mixture (acc,network) = - let cache,species = - I.connected_components_of_mixture - compil network.cache mixture + let petrify_mixture parameters compil mixture (acc, network) = + let cache, species = + I.connected_components_of_mixture compil network.cache mixture in - petrify_species_list parameters compil species (acc,{network with cache = cache}) + petrify_species_list parameters compil species (acc, { network with cache }) let add_to_prefix_list connected_component key prefix_list store acc = - let list_embeddings = - StoreMap.find_default [] key store - in + let list_embeddings = StoreMap.find_default [] key store in List.fold_left (fun new_list prefix -> - List.fold_left - (fun new_list (embedding,chemical_species) -> - ((connected_component,embedding,chemical_species)::prefix)::new_list) - new_list - list_embeddings - ) + List.fold_left + (fun new_list (embedding, chemical_species) -> + ((connected_component, embedding, chemical_species) :: prefix) + :: new_list) + new_list list_embeddings) acc prefix_list - - let count_in_connected_component_fwd target compil network - connected_component = - network, VarMap.fold - (fun vars id alg -> - match vars with - | Token _ | Dummy -> alg - | Nembed _ | Noccurrences _ -> - let from = - match vars with - | Token _ | Dummy -> assert false - | Nembed _ -> from_nembed compil - | Noccurrences _ -> from_nocc compil - in - let (species,nauto) = Mods.DynArray.get network.species_tab id in - let n_embs = - List.length - (I.find_embeddings compil connected_component species) in - if n_embs = 0 then alg - else - let species = Locality.dummy_annot (Alg_expr.KAPPA_INSTANCE id) in - let term = - target compil - (from - (Alg_expr.mult (Alg_expr.int n_embs) species) - nauto) - nauto - in - if fst alg = Alg_expr.CONST Nbr.zero then term - else Alg_expr.add alg term - ) - network.id_of_ode_var - (Alg_expr.const Nbr.zero) + let count_in_connected_component_fwd target compil network connected_component + = + ( network, + VarMap.fold + (fun vars id alg -> + match vars with + | Token _ | Dummy -> alg + | Nembed _ | Noccurrences _ -> + let from = + match vars with + | Token _ | Dummy -> assert false + | Nembed _ -> from_nembed compil + | Noccurrences _ -> from_nocc compil + in + let species, nauto = Mods.DynArray.get network.species_tab id in + let n_embs = + List.length (I.find_embeddings compil connected_component species) + in + if n_embs = 0 then + alg + else ( + let species = Loc.annot_with_dummy (Alg_expr.KAPPA_INSTANCE id) in + let term = + target compil + (from (Alg_expr.mult (Alg_expr.int n_embs) species) nauto) + nauto + in + if fst alg = Alg_expr.CONST Nbr.zero then + term + else + Alg_expr.add alg term + )) + network.id_of_ode_var (Alg_expr.const Nbr.zero) ) let count_in_connected_component_bwd target parameters compil network connected_component = let cache = network.cache in - let cache,(w,l) = - I.equiv_class_of_pattern parameters - compil - cache - network.sym_reduction + let cache, (w, l) = + I.equiv_class_of_pattern parameters compil cache network.sym_reduction connected_component in - let network = {network with cache = cache} in + let network = { network with cache } in let term network h wh = let network, expr = count_in_connected_component_fwd target compil network h in - network, - Alg_expr.div (Alg_expr.mult (Alg_expr.int wh) expr) (Alg_expr.int w) + ( network, + Alg_expr.div (Alg_expr.mult (Alg_expr.int wh) expr) (Alg_expr.int w) ) in - let rec aux list (network,expr) = + let rec aux list (network, expr) = match list with - | [] -> network,expr - | (h,w)::tail -> + | [] -> network, expr + | (h, w) :: tail -> let network, term = term network h w in - aux tail (network,(Alg_expr.add term expr)) + aux tail (network, Alg_expr.add term expr) in match l with | [] -> network, Alg_expr.int 0 - | (h,w)::tail -> aux tail (term network h w) - - let nembed_of_connected_component - parameters compil network - connected_component = - match network.sym_reduction with - | Symmetries.Ground | Symmetries.Forward _ -> - count_in_connected_component_fwd to_nembed - compil network connected_component - | Symmetries.Backward _ -> - count_in_connected_component_bwd to_nembed - parameters compil network connected_component - - let nocc_of_connected_component - parameters compil network + | (h, w) :: tail -> aux tail (term network h w) + + let nembed_of_connected_component parameters compil network connected_component = match network.sym_reduction with | Symmetries.Ground | Symmetries.Forward _ -> - count_in_connected_component_fwd to_nocc - compil network connected_component + count_in_connected_component_fwd to_nembed compil network + connected_component + | Symmetries.Backward _ -> + count_in_connected_component_bwd to_nembed parameters compil network + connected_component + + let nocc_of_connected_component parameters compil network connected_component + = + match network.sym_reduction with + | Symmetries.Ground | Symmetries.Forward _ -> + count_in_connected_component_fwd to_nocc compil network + connected_component | Symmetries.Backward _ -> - count_in_connected_component_bwd to_nocc - parameters compil network connected_component + count_in_connected_component_bwd to_nocc parameters compil network + connected_component let rec convert_alg_expr parameter compil network alg = - match - alg - with - | Alg_expr.BIN_ALG_OP (op, arg1, arg2 ),loc -> - let network, output1 = - convert_alg_expr parameter compil network arg1 - in - let network, output2 = - convert_alg_expr parameter compil network arg2 - in - network, (Alg_expr.BIN_ALG_OP (op, output1, output2),loc) - | Alg_expr.UN_ALG_OP (op, arg),loc -> + match alg with + | Alg_expr.BIN_ALG_OP (op, arg1, arg2), loc -> + let network, output1 = convert_alg_expr parameter compil network arg1 in + let network, output2 = convert_alg_expr parameter compil network arg2 in + network, (Alg_expr.BIN_ALG_OP (op, output1, output2), loc) + | Alg_expr.UN_ALG_OP (op, arg), loc -> let network, output = convert_alg_expr parameter compil network arg in - network, (Alg_expr.UN_ALG_OP (op, output),loc) + network, (Alg_expr.UN_ALG_OP (op, output), loc) | Alg_expr.KAPPA_INSTANCE cc, _loc -> - begin - let f x network = - Array.fold_left - (fun (network,expr) h -> - let network,expr' = - nocc_of_connected_component parameter compil network h - in - network, - Alg_expr.mult - expr - expr') - (network,Alg_expr.const Nbr.one) - x - in - match cc with - | [] -> network, Alg_expr.const Nbr.zero - | head::tail -> - List.fold_left - (fun (network,acc) l -> - let network, expr = f l network in - network, - Alg_expr.add acc expr) - (f head network) - tail - end + let f x network = + Array.fold_left + (fun (network, expr) h -> + let network, expr' = + nocc_of_connected_component parameter compil network h + in + network, Alg_expr.mult expr expr') + (network, Alg_expr.const Nbr.one) + x + in + (match cc with + | [] -> network, Alg_expr.const Nbr.zero + | head :: tail -> + List.fold_left + (fun (network, acc) l -> + let network, expr = f l network in + network, Alg_expr.add acc expr) + (f head network) tail) | Alg_expr.TOKEN_ID id, loc -> - let id = snd (translate_token id ([],network)) in + let id = snd (translate_token id ([], network)) in network, (Alg_expr.TOKEN_ID id, loc) - | ( Alg_expr.ALG_VAR _ - | Alg_expr.CONST _ - | Alg_expr.STATE_ALG_OP _),_ as a -> network, a - | Alg_expr.IF (cond,yes,no),pos -> + | ((Alg_expr.ALG_VAR _ | Alg_expr.CONST _ | Alg_expr.STATE_ALG_OP _), _) as + a -> + network, a + | Alg_expr.IF (cond, yes, no), pos -> let network, outputb = convert_bool_expr parameter compil network cond in let network, outputyes = convert_alg_expr parameter compil network yes in let network, outputno = convert_alg_expr parameter compil network no in - network, - (Alg_expr.IF (outputb, - outputyes, - outputno),pos) - | Alg_expr.DIFF_TOKEN(expr,dt),pos -> - let network, output = - convert_alg_expr parameter compil network expr - in - network, - (Alg_expr.DIFF_TOKEN (output,dt),pos) - | Alg_expr.DIFF_KAPPA_INSTANCE(_expr,_dt),pos -> + network, (Alg_expr.IF (outputb, outputyes, outputno), pos) + | Alg_expr.DIFF_TOKEN (expr, dt), pos -> + let network, output = convert_alg_expr parameter compil network expr in + network, (Alg_expr.DIFF_TOKEN (output, dt), pos) + | Alg_expr.DIFF_KAPPA_INSTANCE (_expr, _dt), pos -> raise (ExceptionDefn.Internal_Error - ("Cannot translate partial derivative",pos)) - + ("Cannot translate partial derivative", pos)) and convert_bool_expr parameter compil network = function - | (Alg_expr.TRUE | Alg_expr.FALSE),_ as a -> network, a - | Alg_expr.COMPARE_OP (op,a,b),pos -> + | ((Alg_expr.TRUE | Alg_expr.FALSE), _) as a -> network, a + | Alg_expr.COMPARE_OP (op, a, b), pos -> let network, outputa = convert_alg_expr parameter compil network a in let network, outputb = convert_alg_expr parameter compil network b in - network, (Alg_expr.COMPARE_OP (op, outputa, outputb),pos) - | Alg_expr.BIN_BOOL_OP (op,a,b),pos -> + network, (Alg_expr.COMPARE_OP (op, outputa, outputb), pos) + | Alg_expr.BIN_BOOL_OP (op, a, b), pos -> let network, outputa = convert_bool_expr parameter compil network a in let network, outputb = convert_bool_expr parameter compil network b in - network, (Alg_expr.BIN_BOOL_OP (op,outputa,outputb),pos) - | Alg_expr.UN_BOOL_OP (op,a),pos -> + network, (Alg_expr.BIN_BOOL_OP (op, outputa, outputb), pos) + | Alg_expr.UN_BOOL_OP (op, a), pos -> let network, outputa = convert_bool_expr parameter compil network a in - network, (Alg_expr.UN_BOOL_OP (op,outputa),pos) + network, (Alg_expr.UN_BOOL_OP (op, outputa), pos) - let add_reaction ?max_size - parameters compil enriched_rule embedding_forest mixture remanent = - let debugMode = I.debug_mode compil in + let add_reaction ?max_size parameters compil enriched_rule embedding_forest + mixture remanent = + let debug_mode = I.debug_mode compil in let rule = enriched_rule.rule in - let _ = debug ~debugMode "REACTANTS\n" in + let _ = debug ~debug_mode "REACTANTS\n" in let remanent, reactants = - petrify_mixture parameters compil mixture remanent in - let _ = debug ~debugMode "PRODUCT\n" in + petrify_mixture parameters compil mixture remanent + in + let _ = debug ~debug_mode "PRODUCT\n" in let products = I.apply compil rule embedding_forest mixture in let list, network = remanent in - let cache, bool = - I.valid_mixture compil network.cache ?max_size products - in - let network = {network with cache = cache} in + let cache, bool = I.valid_mixture compil network.cache ?max_size products in + let network = { network with cache } in let remanent = list, network in - if bool then + if bool then ( let tokens = I.token_vector rule in let remanent, products = - petrify_mixture parameters compil products remanent in + petrify_mixture parameters compil products remanent + in let remanent, tokens = List.fold_left - (fun (remanent, tokens) (_,b) -> - let remanent, id = translate_token b remanent in - remanent,(Locality.dummy_annot id)::tokens) - (remanent,[]) - tokens + (fun (remanent, tokens) (_, b) -> + let remanent, id = translate_token b remanent in + remanent, Loc.annot_with_dummy id :: tokens) + (remanent, []) tokens in let to_be_visited, network = remanent in let network = { network with reactions = - ((List.rev reactants, List.rev products, List.rev tokens, - enriched_rule),1)::network.reactions + ( ( List.rev reactants, + List.rev products, + List.rev tokens, + enriched_rule ), + 1 ) + :: network.reactions; } in to_be_visited, network - else + ) else remanent let initial_network ?max_size parameters compil network initial_states rules = - let network = {network with has_empty_lhs = Some false} in - let debugMode = I.debug_mode compil in - let l,network = + let network = { network with has_empty_lhs = Some false } in + let debug_mode = I.debug_mode compil in + let l, network = List.fold_left (fun remanent enriched_rule -> - match enriched_rule.lhs_cc with - | [] -> - begin - let _, embed, mixture = I.disjoint_union compil [] in - let () = debug ~debugMode "add new reaction" in - let l,network = remanent in - let remanent = l,{network with has_empty_lhs = Some true} in - add_reaction ?max_size parameters compil enriched_rule embed mixture remanent - end - | _::_ -> remanent - ) + match enriched_rule.lhs_cc with + | [] -> + let _, embed, mixture = I.disjoint_union compil [] in + let () = debug ~debug_mode "add new reaction" in + let l, network = remanent in + let remanent = l, { network with has_empty_lhs = Some true } in + add_reaction ?max_size parameters compil enriched_rule embed mixture + remanent + | _ :: _ -> remanent) (List.fold_left (fun remanent species -> - fst (translate_species parameters compil species - remanent)) - ([], network) - initial_states) rules + fst (translate_species parameters compil species remanent)) + ([], network) initial_states) + rules in - if not (I.do_we_allow_empty_lhs compil) - then + if not (I.do_we_allow_empty_lhs compil) then ( match network.has_empty_lhs with - | None -> - failwith "Internal error" - | Some true -> - l,add_ficitious_species network - | Some false -> - l,network - else - l,network - - let compare_reaction - (react,prod,token,enriched_rule) - (react',prod',token',enriched_rule') - = + | None -> failwith "Internal error" + | Some true -> l, add_ficitious_species network + | Some false -> l, network + ) else + l, network + + let compare_reaction (react, prod, token, enriched_rule) + (react', prod', token', enriched_rule') = let cmp = compare (rule_id_of enriched_rule) (rule_id_of enriched_rule') in - if cmp = 0 - then + if cmp = 0 then ( let cmp = compare react react' in - if cmp = 0 - then + if cmp = 0 then ( let cmp = compare prod prod' in - if cmp = 0 - then + if cmp = 0 then compare token token' else cmp - else + ) else cmp - else + ) else cmp - let compare_extended_reaction a b = - compare_reaction (fst a) (fst b) - + let compare_extended_reaction a b = compare_reaction (fst a) (fst b) - let compute_reactions ?max_size ~smash_reactions parameters compil network rules initial_states = + let compute_reactions ?max_size ~smash_reactions parameters compil network + rules initial_states = (* Let us annotate the rules with cc decomposition *) - let debugMode = I.debug_mode compil in + let debug_mode = I.debug_mode compil in let n_rules = List.length rules in let cache = network.cache in let cache, max_coef, rules_rev = List.fold_left (fun (cache, max_coef, list) rule -> - let cache, modes = - I.valid_modes cache compil rule - in - let max_coef = max max_coef (List.length (I.token_vector rule)) in - let a,b = - List.fold_left - (fun (cache, list) mode -> - let cache, elt = - enrich_rule cache compil rule mode in - cache, - elt::list) - (cache, list) modes - in - a, max_coef, b) - ((cache:I.cache), network.max_stoch_coef, []) + let cache, modes = I.valid_modes cache compil rule in + let max_coef = max max_coef (List.length (I.token_vector rule)) in + let a, b = + List.fold_left + (fun (cache, list) mode -> + let cache, elt = enrich_rule cache compil rule mode in + cache, elt :: list) + (cache, list) modes + in + a, max_coef, b) + ((cache : I.cache), network.max_stoch_coef, []) (List.rev rules) in let obsmap = network.cc_to_rules in let obsmap = List.fold_left (fun obsmap ext_rule -> - let cc_list = ext_rule.lhs_cc in - List.fold_left - (fun obs_map (cc_id,cc) -> - I.ObsMap.add cc (ext_rule,cc_id) obs_map - ) - obsmap - cc_list) - obsmap - rules_rev - in - let network = - {network - with cache = cache ; - max_stoch_coef = max_coef; - } + let cc_list = ext_rule.lhs_cc in + List.fold_left + (fun obs_map (cc_id, cc) -> + I.ObsMap.add cc (ext_rule, cc_id) obs_map) + obsmap cc_list) + obsmap rules_rev in + let network = { network with cache; max_stoch_coef = max_coef } in let rules = List.rev rules_rev in let to_be_visited, network = - initial_network ?max_size - parameters compil network initial_states rules - in - let network = - { - network with - n_rules = n_rules; - rules = rules; - cc_to_rules = obsmap - } + initial_network ?max_size parameters compil network initial_states rules in + let network = { network with n_rules; rules; cc_to_rules = obsmap } in let store = StoreMap.empty in (* store maps each cc in the lhs of a rule to the list of embedding between this cc and a pattern in set\to_be_visited @@ -886,435 +805,403 @@ struct let rec aux to_be_visited network store = match to_be_visited with | [] -> network - | new_species::to_be_visited -> + | new_species :: to_be_visited -> let network = clean_embed_to_current_species network in - let () = debug ~debugMode "@[@[test for the new species:@ %a@]" - (fun x -> I.print_chemical_species ~compil x) new_species + let () = + debug ~debug_mode "@[@[test for the new species:@ %a@]" + (fun x -> I.print_chemical_species ~compil x) + new_species in (* add in store the embeddings from cc of lhs to new_species, for unary application of binary rule, the dictionary of species is updated, and the reaction entered directly *) - let store, to_be_visited, network = + let store, to_be_visited, network = let all_ccs = I.find_all_embeddings compil new_species in List.fold_left - (fun - (store_old_embeddings, to_be_visited, network) - (cc,embed) -> - let pairs_rule_pos = - I.ObsMap.get cc network.cc_to_rules - in + (fun (store_old_embeddings, to_be_visited, network) (cc, embed) -> + let pairs_rule_pos = I.ObsMap.get cc network.cc_to_rules in List.fold_left (fun (store_old_embeddings, to_be_visited, network) - (enriched_rule,pos) -> - + (enriched_rule, pos) -> (* regular application of tules, we store the - embeddings*) - let () = debug ~debugMode - "@[test for rule %i at pos %i (Aut:%i)@[%a@]" - (rule_id_of enriched_rule) pos - enriched_rule.divide_rate_by - (I.print_rule ~compil) enriched_rule.rule - in - match arity_of enriched_rule with - | Rule_modes.Usual | Rule_modes.Unary_refinement -> - begin - let () = debug ~debugMode "regular case" in - let store_new_embeddings = - (*List.fold_left - (fun store (cc_id,cc) -> - let () = debug ~debugMode "find embeddings" in - let lembed = - I.find_embeddings compil cc new_species - in - add_embedding_list - (enriched_rule.rule_id_with_mode,cc_id,cc) - (List.rev_map (fun a -> a,new_species) - (List.rev lembed)) - store - ) StoreMap.empty enriched_rule.lhs_cc*) - add_embedding_list - (enriched_rule.rule_id_with_mode,pos,cc) - [embed,new_species] StoreMap.empty - in - let (), store_all_embeddings = - StoreMap.map2_with_logs - (fun _ a _ _ _ -> a) - () - () - (fun _ _ b -> (),b) - (fun _ _ b -> (),b) - (fun _ _ b c -> - (), - List.fold_left (fun list elt -> elt::list) - b c) - store_old_embeddings - store_new_embeddings + embeddings*) + let () = + debug ~debug_mode + "@[test for rule %i at pos %i (Aut:%i)@[%a@]" + (rule_id_of enriched_rule) pos + enriched_rule.divide_rate_by (I.print_rule ~compil) + enriched_rule.rule in - (* compute the embedding betwen lhs and tuple of - species that contain at least one occurence of - new_species *) - let dump_store store = - if local_trace || debugMode - then - StoreMap.iter - (fun ((a,ar,dir),id,b) c -> - let () = - debug ~debugMode - "@[* rule:%i %s %s cc:%i:@[%a@]:" a - (match ar with - Rule_modes.Usual -> "@" - | Rule_modes.Unary_refinement - | Rule_modes.Unary -> "(1)") - (match dir with - Rule_modes.Direct -> "->" - | Rule_modes.Op -> "<-") - id - (I.print_connected_component ~compil) - b + match arity_of enriched_rule with + | Rule_modes.Usual | Rule_modes.Unary_refinement -> + let () = debug ~debug_mode "regular case" in + let store_new_embeddings = + (*List.fold_left + (fun store (cc_id,cc) -> + let () = debug ~debug_mode "find embeddings" in + let lembed = + I.find_embeddings compil cc new_species in - let () = - List.iter (fun (_, b) -> - debug ~debugMode "%a" - (fun x -> I.print_chemical_species - ~compil x) b) c - in - let () = debug ~debugMode "@]" in - () - ) - store - in - let () = debug ~debugMode "new embeddings" in - let () = dump_store store_new_embeddings in - let _,new_embedding_list = - List.fold_left - (fun (partial_emb_list, - partial_emb_list_with_new_species) - (cc_id,cc) -> - (* First case, we complete with an - embedding towards the new_species *) - let label = - enriched_rule.rule_id_with_mode,cc_id,cc - in - let partial_emb_list_with_new_species = - add_to_prefix_list cc label - partial_emb_list - store_new_embeddings - (add_to_prefix_list cc label - partial_emb_list_with_new_species - store_all_embeddings []) - in - let partial_emb_list = - add_to_prefix_list cc - label partial_emb_list - store_old_embeddings [] - in - partial_emb_list, - partial_emb_list_with_new_species - ) - ([[]], []) enriched_rule.lhs_cc - in - (* compute the corresponding rhs, and put the new - species in the working list, and store the - corrsponding reactions *) - let to_be_visited, network = - List.fold_left - (fun remanent list -> - let () = debug ~debugMode "compute one refinement" in - let () = debug ~debugMode "disjoint union @[%a@]" - (Pp.list Pp.space - (fun f (_,_,s) -> - I.print_chemical_species ~compil - f s)) - list - in - let _, embed,mixture = - I.disjoint_union compil list in - let () = - debug ~debugMode "add new reaction" - in - add_reaction ?max_size - parameters compil enriched_rule embed - mixture remanent) - (to_be_visited,network) - new_embedding_list - in - let () = debug ~debugMode "@]" in - store_all_embeddings,to_be_visited,network - end - | Rule_modes.Unary -> - begin - (* unary application of binary rules *) - let () = debug ~debugMode "unary case" in - let network = - add_embed_to_current_species - cc embed network - in - let emb_list_list_opt = - let rec aux list output = - match list with - | [] -> Some output - | (cc_id,cc)::tail -> - let emb_list = - if cc_id = pos then [embed] - else - get_embed_to_current_species cc network - in - begin - match emb_list with + add_embedding_list + (enriched_rule.rule_id_with_mode,cc_id,cc) + (List.rev_map (fun a -> a,new_species) + (List.rev lembed)) + store + ) StoreMap.empty enriched_rule.lhs_cc*) + add_embedding_list + (enriched_rule.rule_id_with_mode, pos, cc) + [ embed, new_species ] + StoreMap.empty + in + let (), store_all_embeddings = + StoreMap.map2_with_logs + (fun _ a _ _ _ -> a) + () () + (fun _ _ b -> (), b) + (fun _ _ b -> (), b) + (fun _ _ b c -> + (), List.fold_left (fun list elt -> elt :: list) b c) + store_old_embeddings store_new_embeddings + in + (* compute the embedding betwen lhs and tuple of + species that contain at least one occurence of + new_species *) + let dump_store store = + if local_trace || debug_mode then + StoreMap.iter + (fun ((a, ar, dir), id, b) c -> + let () = + debug ~debug_mode + "@[* rule:%i %s %s cc:%i:@[%a@]:" a + (match ar with + | Rule_modes.Usual -> "@" + | Rule_modes.Unary_refinement | Rule_modes.Unary + -> + "(1)") + (match dir with + | Rule_modes.Direct -> "->" + | Rule_modes.Op -> "<-") + id + (I.print_connected_component ~compil) + b + in + let () = + List.iter + (fun (_, b) -> + debug ~debug_mode "%a" + (fun x -> + I.print_chemical_species ~compil x) + b) + c + in + let () = debug ~debug_mode "@]" in + ()) + store + in + let () = debug ~debug_mode "new embeddings" in + let () = dump_store store_new_embeddings in + let _, new_embedding_list = + List.fold_left + (fun ( partial_emb_list, + partial_emb_list_with_new_species ) (cc_id, cc) -> + (* First case, we complete with an + embedding towards the new_species *) + let label = + enriched_rule.rule_id_with_mode, cc_id, cc + in + let partial_emb_list_with_new_species = + add_to_prefix_list cc label partial_emb_list + store_new_embeddings + (add_to_prefix_list cc label + partial_emb_list_with_new_species + store_all_embeddings []) + in + let partial_emb_list = + add_to_prefix_list cc label partial_emb_list + store_old_embeddings [] + in + partial_emb_list, partial_emb_list_with_new_species) + ([ [] ], []) enriched_rule.lhs_cc + in + (* compute the corresponding rhs, and put the new + species in the working list, and store the + corrsponding reactions *) + let to_be_visited, network = + List.fold_left + (fun remanent list -> + let () = debug ~debug_mode "compute one refinement" in + let () = + debug ~debug_mode "disjoint union @[%a@]" + (Pp.list Pp.space (fun f (_, _, s) -> + I.print_chemical_species ~compil f s)) + list + in + let _, embed, mixture = + I.disjoint_union compil list + in + let () = debug ~debug_mode "add new reaction" in + add_reaction ?max_size parameters compil enriched_rule + embed mixture remanent) + (to_be_visited, network) new_embedding_list + in + let () = debug ~debug_mode "@]" in + store_all_embeddings, to_be_visited, network + | Rule_modes.Unary -> + (* unary application of binary rules *) + let () = debug ~debug_mode "unary case" in + let network = + add_embed_to_current_species cc embed network + in + let emb_list_list_opt = + let rec aux list output = + match list with + | [] -> Some output + | (cc_id, cc) :: tail -> + let emb_list = + if cc_id = pos then + [ embed ] + else + get_embed_to_current_species cc network + in + (match emb_list with | [] -> None - | _::_ -> aux tail (emb_list::output) - end + | _ :: _ -> aux tail (emb_list :: output)) + in + aux enriched_rule.lhs_cc [] in - aux enriched_rule.lhs_cc [] - in - let (to_be_visited,network) = - match emb_list_list_opt with - | Some l -> - let lembed,mix = - I.compose_embeddings_unary_binary compil - enriched_rule.lhs l new_species in - fold_left_swap - (fun embed remanent -> - let () = - debug ~debugMode "add new reaction (unary)" - in - let embed = - add_reaction ?max_size - parameters compil enriched_rule embed mix remanent in - let () = - debug ~debugMode "end new reaction (unary)" - in - embed - ) - lembed - (to_be_visited, network) - | None -> (to_be_visited, network) - in - let () = debug ~debugMode "@]" in - store_old_embeddings, to_be_visited, network - end) + let to_be_visited, network = + match emb_list_list_opt with + | Some l -> + let lembed, mix = + I.compose_embeddings_unary_binary compil + enriched_rule.lhs l new_species + in + fold_left_swap + (fun embed remanent -> + let () = + debug ~debug_mode "add new reaction (unary)" + in + let embed = + add_reaction ?max_size parameters compil + enriched_rule embed mix remanent + in + let () = + debug ~debug_mode "end new reaction (unary)" + in + embed) + lembed (to_be_visited, network) + | None -> to_be_visited, network + in + let () = debug ~debug_mode "@]" in + store_old_embeddings, to_be_visited, network) (store_old_embeddings, to_be_visited, network) - pairs_rule_pos - ) + pairs_rule_pos) (store, to_be_visited, network) all_ccs in - let () = debug ~debugMode "@]" in + let () = debug ~debug_mode "@]" in aux to_be_visited network store in let network = aux to_be_visited network store in - let network = - if smash_reactions - then - begin - let normalised_reactions_list = - List.fold_left - (fun store_list ((react, products, token_vector ,enrich_rule),nocc) -> - let sorted_reactants = List.sort compare react in - let sorted_products = List.sort compare products in - let sorted_token_vector = List.sort compare token_vector in - ((sorted_reactants, sorted_products, sorted_token_vector, - enrich_rule),nocc) :: store_list - ) [] network.reactions - in - let sorted_reactions_list = - List.sort compare_extended_reaction normalised_reactions_list - in - let smashed_list = - Tools.smash_duplicate_in_ordered_list - compare_reaction - sorted_reactions_list - in - {network with reactions = smashed_list} - end - else + let network = + if smash_reactions then ( + let normalised_reactions_list = + List.fold_left + (fun store_list ((react, products, token_vector, enrich_rule), nocc) -> + let sorted_reactants = List.sort compare react in + let sorted_products = List.sort compare products in + let sorted_token_vector = List.sort compare token_vector in + ( ( sorted_reactants, + sorted_products, + sorted_token_vector, + enrich_rule ), + nocc ) + :: store_list) + [] network.reactions + in + let sorted_reactions_list = + List.sort compare_extended_reaction normalised_reactions_list + in + let smashed_list = + Tools.smash_duplicate_in_ordered_list compare_reaction + sorted_reactions_list + in + { network with reactions = smashed_list } + ) else network in let network = match I.reaction_rate_convention compil with | None | Some Remanent_parameters_sig.No_correction -> network | Some Remanent_parameters_sig.Biochemist - | Some Remanent_parameters_sig.Common -> + | Some Remanent_parameters_sig.Common -> let reactions = network.reactions in let reactions = List.rev_map - (fun (reaction,nocc) -> - let (reactants,products,_,_) = reaction in - let correct = - Tools.get_product_image_occ_2 1 (fun i j -> i*j) (fun i j -> Tools.fact (min i j)) - reactants products - in - (reaction,nocc*correct)) - (List.rev reactions) in - {network with reactions = reactions} - | Some Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + (fun (reaction, nocc) -> + let reactants, products, _, _ = reaction in + let correct = + Tools.get_product_image_occ_2 1 + (fun i j -> i * j) + (fun i j -> Tools.fact (min i j)) + reactants products + in + reaction, nocc * correct) + (List.rev reactions) + in + { network with reactions } + | Some Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> let reactions = network.reactions in let reactions = List.rev_map - (fun (reaction,nocc) -> - let (reactants,_products,_,_) = reaction in - let correct = - Tools.get_product_image_occ 1 - (fun i j -> i*j) (fun i -> Tools.fact i) - reactants - in - (reaction,nocc*correct)) - (List.rev reactions) in - {network with reactions = reactions} - in - let () = debug ~debugMode "@]@." in + (fun (reaction, nocc) -> + let reactants, _products, _, _ = reaction in + let correct = + Tools.get_product_image_occ 1 + (fun i j -> i * j) + (fun i -> Tools.fact i) + reactants + in + reaction, nocc * correct) + (List.rev reactions) + in + { network with reactions } + in + let () = debug ~debug_mode "@]@." in network let convert_tokens compil network = Tools.recti - (fun network a -> - snd (fst (translate_token a ([],network)))) - network - (I.nb_tokens compil) - - let species_of_species_id network = - (fun i -> Mods.DynArray.get network.species_tab i) + (fun network a -> snd (fst (translate_token a ([], network)))) + network (I.nb_tokens compil) + let species_of_species_id network i = Mods.DynArray.get network.species_tab i let get_reactions network = network.reactions let convert_initial_state parameters compil intro network = - let b,c = intro in + let b, c = intro in let network, expr_init = - convert_alg_expr parameters compil network (Locality.dummy_annot b) - in - expr_init, - match I.token_vector_of_init c with - | [] -> - let m = I.mixture_of_init compil c in - let cache', cc = - I.connected_components_of_mixture compil network.cache m - in - let network = {network with cache = cache'} in - List.fold_left - (fun (network, acc) x -> - let (_, n'), v = - translate_species parameters compil x ([],network) - in - n', v :: acc) - (network,[]) (List.rev cc) - | l -> - List.fold_right (fun (_,token) (network,acc) -> - let (_,n'), v = - translate_token token ([],network) - in - n', v :: acc) l (network,[]) + convert_alg_expr parameters compil network (Loc.annot_with_dummy b) + in + ( expr_init, + match I.token_vector_of_init c with + | [] -> + let m = I.mixture_of_init compil c in + let cache', cc = + I.connected_components_of_mixture compil network.cache m + in + let network = { network with cache = cache' } in + List.fold_left + (fun (network, acc) x -> + let (_, n'), v = + translate_species parameters compil x ([], network) + in + n', v :: acc) + (network, []) (List.rev cc) + | l -> + List.fold_right + (fun (_, token) (network, acc) -> + let (_, n'), v = translate_token token ([], network) in + n', v :: acc) + l (network, []) ) - let translate_token token network = - snd (translate_token token ([],network)) + let translate_token token network = snd (translate_token token ([], network)) let convert_var_def parameters compil network variable_def = - let a,b = variable_def in - a,convert_alg_expr parameters compil network b + let a, b = variable_def in + a, convert_alg_expr parameters compil network b let convert_var_defs parameters compil network = let list_var = I.get_variables compil in let init = I.get_init compil in let list, network = Tools.array_fold_lefti - (fun i (list,network) def -> - let a,(network,b) = convert_var_def parameters compil network def in - (Var (get_fresh_var_id network,Some a,b))::list, - inc_fresh_var_id - {network with - varmap = - Mods.IntMap.add i - (get_fresh_var_id network) network.varmap}) - ([],network) - list_var - in - let init_tab = - Mods.DynArray.make (get_fresh_ode_var_id network) [] - in + (fun i (list, network) def -> + let a, (network, b) = convert_var_def parameters compil network def in + ( Var (get_fresh_var_id network, Some a, b) :: list, + inc_fresh_var_id + { + network with + varmap = + Mods.IntMap.add i (get_fresh_var_id network) network.varmap; + } )) + ([], network) list_var + in + let init_tab = Mods.DynArray.make (get_fresh_ode_var_id network) [] in let add i j = - Mods.DynArray.set - init_tab - i - (j::(Mods.DynArray.get init_tab i)) + Mods.DynArray.set init_tab i (j :: Mods.DynArray.get init_tab i) in let list, network = List.fold_left - (fun (list,network) def -> - let b,(network,c) = - convert_initial_state parameters compil def network in - let () = - List.iter - (fun id -> add id (get_fresh_var_id network)) - c - in - (Init_expr (network.fresh_var_id,b,c))::list, - (inc_fresh_var_id network) - ) - (list,network) - init + (fun (list, network) def -> + let b, (network, c) = + convert_initial_state parameters compil def network + in + let () = List.iter (fun id -> add id (get_fresh_var_id network)) c in + ( Init_expr (network.fresh_var_id, b, c) :: list, + inc_fresh_var_id network )) + (list, network) init in let size = List.length list in - let npred = - Mods.DynArray.create (get_fresh_var_id network) 0 - in - let lsucc = - Mods.DynArray.create (get_fresh_var_id network) [] - in + let npred = Mods.DynArray.create (get_fresh_var_id network) 0 in + let lsucc = Mods.DynArray.create (get_fresh_var_id network) [] in let dec_tab = Mods.DynArray.create network.fresh_var_id - (Dummy_decl,None,Alg_expr.const Nbr.zero) + (Dummy_decl, None, Alg_expr.const Nbr.zero) in let add_succ i j = - let () = - Mods.DynArray.set npred j (1+(Mods.DynArray.get npred j)) in - let () = - Mods.DynArray.set lsucc i (j::(Mods.DynArray.get lsucc i)) in + let () = Mods.DynArray.set npred j (1 + Mods.DynArray.get npred j) in + let () = Mods.DynArray.set lsucc i (j :: Mods.DynArray.get lsucc i) in () in let rec aux_alg id expr = match fst expr with | Alg_expr.CONST _ -> () - | Alg_expr.BIN_ALG_OP (_,a,b) -> (aux_alg id a;aux_alg id b) - | (Alg_expr.UN_ALG_OP (_,a) - | Alg_expr.DIFF_KAPPA_INSTANCE (a,_) - | Alg_expr.DIFF_TOKEN (a,_)) -> aux_alg id a + | Alg_expr.BIN_ALG_OP (_, a, b) -> + aux_alg id a; + aux_alg id b + | Alg_expr.UN_ALG_OP (_, a) + | Alg_expr.DIFF_KAPPA_INSTANCE (a, _) + | Alg_expr.DIFF_TOKEN (a, _) -> + aux_alg id a | Alg_expr.STATE_ALG_OP _ -> () - | Alg_expr.IF (cond,yes,no) -> - aux_bool id cond; aux_alg id yes; aux_alg id no + | Alg_expr.IF (cond, yes, no) -> + aux_bool id cond; + aux_alg id yes; + aux_alg id no | Alg_expr.TOKEN_ID id' -> let list = Mods.DynArray.get init_tab id' in List.iter (fun id'' -> add_succ id id'') list - | Alg_expr.KAPPA_INSTANCE (id':ode_var_id) -> + | Alg_expr.KAPPA_INSTANCE (id' : ode_var_id) -> let list = Mods.DynArray.get init_tab id' in List.iter (fun id'' -> add_succ id id'') list | Alg_expr.ALG_VAR id' -> let id_opt = Mods.IntMap.find_option id' network.varmap in - begin - match id_opt with + (match id_opt with | Some id'' -> add_succ id id'' - | None -> () - end + | None -> ()) and aux_bool id = function - | (Alg_expr.TRUE | Alg_expr.FALSE),_ -> () - | Alg_expr.COMPARE_OP (_,a,b),_ -> - aux_alg id a; aux_alg id b - | Alg_expr.UN_BOOL_OP (_,a),_ -> - aux_bool id a - | Alg_expr.BIN_BOOL_OP (_,a,b),_ -> - aux_bool id a; aux_bool id b + | (Alg_expr.TRUE | Alg_expr.FALSE), _ -> () + | Alg_expr.COMPARE_OP (_, a, b), _ -> + aux_alg id a; + aux_alg id b + | Alg_expr.UN_BOOL_OP (_, a), _ -> aux_bool id a + | Alg_expr.BIN_BOOL_OP (_, a, b), _ -> + aux_bool id a; + aux_bool id b in let () = List.iter (fun decl -> - match decl - with - | Dummy_decl -> () - | Init_expr (id,b,_) -> - let () = Mods.DynArray.set dec_tab id (decl,None,b) - in aux_alg id b - | Var (id,a,b) -> - let () = Mods.DynArray.set dec_tab id (decl,a,b) in - aux_alg id b) + match decl with + | Dummy_decl -> () + | Init_expr (id, b, _) -> + let () = Mods.DynArray.set dec_tab id (decl, None, b) in + aux_alg id b + | Var (id, a, b) -> + let () = Mods.DynArray.set dec_tab id (decl, a, b) in + aux_alg id b) list in let top_sort = @@ -1322,75 +1209,72 @@ struct let l = Mods.DynArray.get lsucc k in List.fold_left (fun to_be_visited j -> - let old = Mods.DynArray.get npred j in - let () = Mods.DynArray.set npred j (old-1) in - if old = 1 then j::to_be_visited else to_be_visited) + let old = Mods.DynArray.get npred j in + let () = Mods.DynArray.set npred j (old - 1) in + if old = 1 then + j :: to_be_visited + else + to_be_visited) to_be_visited l in let to_be_visited = let rec aux k l = - if k < fst_id - then l - else - if Mods.DynArray.get npred k = 0 - then - aux (k-1) (k::l) + if k < fst_id then + l + else if Mods.DynArray.get npred k = 0 then + aux (k - 1) (k :: l) else - aux (k-1) l + aux (k - 1) l in - aux (network.fresh_var_id-1) [] + aux (network.fresh_var_id - 1) [] in let rec aux to_be_visited l = match to_be_visited with | [] -> List.rev l - | h::t -> aux (clean h t) (h::l) + | h :: t -> aux (clean h t) (h :: l) in let l = aux to_be_visited [] in let l = List.rev_map (fun x -> - let decl,_,_ = Mods.DynArray.get dec_tab x in decl - ) l - in l + let decl, _, _ = Mods.DynArray.get dec_tab x in + decl) + l + in + l in let size' = List.length top_sort in - if size' = size - then - {network with var_declaration = top_sort} - else + if size' = size then + { network with var_declaration = top_sort } + else ( let () = Format.fprintf Format.std_formatter "Circular dependencies\n" in assert false + ) + let convert_one_obs parameters obs network = + let a, b = obs in + a, convert_alg_expr parameters b network -let convert_one_obs parameters obs network = - let a,b = obs in - a,convert_alg_expr parameters b network - -let convert_obs parameters compil network = - let list_obs = I.get_obs compil in - let network = - List.fold_left - (fun network obs -> - let network,expr_obs = - convert_alg_expr parameters compil network - (Locality.dummy_annot obs) - in - inc_fresh_obs_id - {network with - obs = (get_fresh_obs_id network, - expr_obs) - ::network.obs}) - network - list_obs - in - {network with - obs = List.rev network.obs; - n_obs = network.n_obs - 1} - + let convert_obs parameters compil network = + let list_obs = I.get_obs compil in + let network = + List.fold_left + (fun network obs -> + let network, expr_obs = + convert_alg_expr parameters compil network + (Loc.annot_with_dummy obs) + in + inc_fresh_obs_id + { + network with + obs = (get_fresh_obs_id network, expr_obs) :: network.obs; + }) + network list_obs + in + { network with obs = List.rev network.obs; n_obs = network.n_obs - 1 } let build_time_var network = - if may_be_not_time_homogeneous network - then + if may_be_not_time_homogeneous network then Some (get_last_ode_var_id network) else None @@ -1399,180 +1283,164 @@ let convert_obs parameters compil network = let cache = network.cache in let cache, list = List.fold_left - (fun (cache,list) (_,r) -> - let b = I.mixture_of_init compil r in - let cache', acc = - I.connected_components_of_mixture compil cache b - in - cache', List.rev_append acc list) - (cache,[]) list - in - {network with cache = cache}, list - - type ('a,'b) rate = ('a,'b) Alg_expr.e Locality.annot - type ('a,'b) stoc = int * ('a,'b) Alg_expr.e Locality.annot - type ('a,'b) coef = R of ('a,'b) rate | S of ('a,'b) stoc - - type ('a,'b) sort_rules_and_decl = - { - const_decl_set : Mods.StringSet.t ; - const_decl: 'a decl list ; - var_decl: 'a decl list ; - init: 'a decl list ; - const_rate : - (enriched_rule * ('a,'b) coef list) list ; - var_rate : - (enriched_rule * ('a,'b) coef list) list ; - } + (fun (cache, list) (_, r) -> + let b = I.mixture_of_init compil r in + let cache', acc = I.connected_components_of_mixture compil cache b in + cache', List.rev_append acc list) + (cache, []) list + in + { network with cache }, list + + type ('a, 'b) rate = ('a, 'b) Alg_expr.e Loc.annoted + type ('a, 'b) stoc = int * ('a, 'b) Alg_expr.e Loc.annoted + type ('a, 'b) coef = R of ('a, 'b) rate | S of ('a, 'b) stoc + + type ('a, 'b) sort_rules_and_decl = { + const_decl_set: Mods.StringSet.t; + const_decl: 'a decl list; + var_decl: 'a decl list; + init: 'a decl list; + const_rate: (enriched_rule * ('a, 'b) coef list) list; + var_rate: (enriched_rule * ('a, 'b) coef list) list; + } let init_sort_rules_and_decl = { - const_decl_set = Mods.StringSet.empty ; - const_decl = [] ; - var_decl = [] ; - const_rate = [] ; - var_rate = [] ; - init = [] ; + const_decl_set = Mods.StringSet.empty; + const_decl = []; + var_decl = []; + const_rate = []; + var_rate = []; + init = []; } let split_var_declaration network sort_rules_and_decls = let decl = List.fold_left (fun sort_decls decl -> - match decl with - | Dummy_decl - | Var (_,None,_) - | Init_expr _ -> - { - sort_decls - with - init = decl::sort_decls.init} - | Var (_id,Some a,b) -> - if Alg_expr.is_constant b - then - { - sort_decls - with - const_decl_set = Mods.StringSet.add a sort_decls.const_decl_set ; - const_decl = decl::sort_decls.const_decl - } - else - { - sort_decls - with - var_decl = - decl::sort_decls.var_decl - }) - sort_rules_and_decls - network.var_declaration - in - {decl - with - const_decl = List.rev decl.const_decl ; - var_decl = List.rev decl.var_decl ; - init = List.rev decl.init} - - let flatten_rate (id,mode,direct) = + match decl with + | Dummy_decl | Var (_, None, _) | Init_expr _ -> + { sort_decls with init = decl :: sort_decls.init } + | Var (_id, Some a, b) -> + if Alg_expr.is_constant b then + { + sort_decls with + const_decl_set = Mods.StringSet.add a sort_decls.const_decl_set; + const_decl = decl :: sort_decls.const_decl; + } + else + { sort_decls with var_decl = decl :: sort_decls.var_decl }) + sort_rules_and_decls network.var_declaration + in + { + decl with + const_decl = List.rev decl.const_decl; + var_decl = List.rev decl.var_decl; + init = List.rev decl.init; + } + + let flatten_rate (id, mode, direct) = match mode with - | Rule_modes.Unary | Rule_modes.Usual -> (id,mode,direct) - | Rule_modes.Unary_refinement -> (id,Rule_modes.Unary,direct) + | Rule_modes.Unary | Rule_modes.Usual -> id, mode, direct + | Rule_modes.Unary_refinement -> id, Rule_modes.Unary, direct - let flatten_coef (id,_mode,direct) = id,Rule_modes.Usual, direct + let flatten_coef (id, _mode, direct) = id, Rule_modes.Usual, direct let split_rules parameters compil network sort_rules_and_decls = let rate_set = Rule_modes.RuleModeIdSet.empty in let coef_set = Rule_modes.RuleModeIdSet.empty in let network, sort, _ = List.fold_left - (fun (network,sort_rules, (rate_set,coef_set)) enriched_rule -> - if Rule_modes.RuleModeIdSet.mem - (flatten_rate enriched_rule.rule_id_with_mode) - rate_set - then (network,sort_rules, (rate_set,coef_set)) - else - let rate = - I.rate - compil enriched_rule.rule enriched_rule.rule_id_with_mode - in - match rate with - | None -> network, sort_rules, (rate_set, coef_set) - | Some rate -> - let rate_set = - Rule_modes.RuleModeIdSet.add - (flatten_rate enriched_rule.rule_id_with_mode) - rate_set - in - let const_list = [] in - let var_list = [] in - let network,rate = - convert_alg_expr parameters compil network rate - in - let network, const_list, var_list = - if Alg_expr.is_constant rate - then - network, (R rate)::const_list, var_list - else - network, const_list, (R rate)::var_list - in - let network, const_list, var_list, coef_set = - if Rule_modes.RuleModeIdSet.mem - (flatten_coef enriched_rule.rule_id_with_mode) - coef_set - then - network, const_list, var_list, coef_set - else - let coef_set = - Rule_modes.RuleModeIdSet.add - (flatten_coef enriched_rule.rule_id_with_mode) - coef_set - in - let vector = - I.token_vector enriched_rule.rule - in - let network, const_list, var_list, _ = - List.fold_left - (fun (network, const_list, var_list, n) (expr,_) -> - let network, rate = - convert_alg_expr parameters compil network expr in - if Alg_expr.is_constant rate - then network, (S (n,rate))::const_list, var_list, n+1 - else network, const_list, (S (n,rate))::var_list, n+1 - ) - (network, const_list, var_list, 1) - vector - in - network, const_list, var_list, coef_set - in - let sort_rules = - match const_list with - | [] -> sort_rules - | _::_ -> - { - sort_rules - with const_rate = - (enriched_rule, - const_list)::sort_rules.const_rate - } - in - let sort_rules = - match var_list with - | [] -> sort_rules - | _::_ -> - { - sort_rules - with var_rate = - (enriched_rule, - var_list)::sort_rules.var_rate - } - in - network, sort_rules, (rate_set,coef_set)) + (fun (network, sort_rules, (rate_set, coef_set)) enriched_rule -> + if + Rule_modes.RuleModeIdSet.mem + (flatten_rate enriched_rule.rule_id_with_mode) + rate_set + then + network, sort_rules, (rate_set, coef_set) + else ( + let rate = + I.rate compil enriched_rule.rule enriched_rule.rule_id_with_mode + in + match rate with + | None -> network, sort_rules, (rate_set, coef_set) + | Some rate -> + let rate_set = + Rule_modes.RuleModeIdSet.add + (flatten_rate enriched_rule.rule_id_with_mode) + rate_set + in + let const_list = [] in + let var_list = [] in + let network, rate = + convert_alg_expr parameters compil network rate + in + let network, const_list, var_list = + if Alg_expr.is_constant rate then + network, R rate :: const_list, var_list + else + network, const_list, R rate :: var_list + in + let network, const_list, var_list, coef_set = + if + Rule_modes.RuleModeIdSet.mem + (flatten_coef enriched_rule.rule_id_with_mode) + coef_set + then + network, const_list, var_list, coef_set + else ( + let coef_set = + Rule_modes.RuleModeIdSet.add + (flatten_coef enriched_rule.rule_id_with_mode) + coef_set + in + let vector = I.token_vector enriched_rule.rule in + let network, const_list, var_list, _ = + List.fold_left + (fun (network, const_list, var_list, n) (expr, _) -> + let network, rate = + convert_alg_expr parameters compil network expr + in + if Alg_expr.is_constant rate then + network, S (n, rate) :: const_list, var_list, n + 1 + else + network, const_list, S (n, rate) :: var_list, n + 1) + (network, const_list, var_list, 1) + vector + in + network, const_list, var_list, coef_set + ) + in + let sort_rules = + match const_list with + | [] -> sort_rules + | _ :: _ -> + { + sort_rules with + const_rate = + (enriched_rule, const_list) :: sort_rules.const_rate; + } + in + let sort_rules = + match var_list with + | [] -> sort_rules + | _ :: _ -> + { + sort_rules with + var_rate = (enriched_rule, var_list) :: sort_rules.var_rate; + } + in + network, sort_rules, (rate_set, coef_set) + )) (network, sort_rules_and_decls, (rate_set, coef_set)) network.rules in - network, - {sort - with const_rate = List.rev sort.const_rate ; - var_rate = List.rev sort.var_rate} + ( network, + { + sort with + const_rate = List.rev sort.const_rate; + var_rate = List.rev sort.var_rate; + } ) let split_rules_and_decl parameters compil network = split_rules parameters compil network @@ -1582,172 +1450,156 @@ let convert_obs parameters compil network = let rules = network.rules in List.for_all (fun rule -> - let rate_opt = - I.rate compil rule.rule rule.rule_id_with_mode - in - match rate_opt with - | None -> true - | Some rate -> Alg_expr.is_time_homogeneous rate) + let rate_opt = I.rate compil rule.rule rule.rule_id_with_mode in + match rate_opt with + | None -> true + | Some rate -> Alg_expr.is_time_homogeneous rate) rules let time_homogeneity_of_vars network = let vars_decl = network.var_declaration in List.for_all (fun decl -> - match decl with - | Dummy_decl | Init_expr _ -> true - | Var (_,_,expr) -> Alg_expr.is_time_homogeneous expr) + match decl with + | Dummy_decl | Init_expr _ -> true + | Var (_, _, expr) -> Alg_expr.is_time_homogeneous expr) vars_decl let time_homogeneity_of_obs network = let obs = network.obs in - List.for_all - (fun (_,expr) -> Alg_expr.is_time_homogeneous expr) - obs + List.for_all (fun (_, expr) -> Alg_expr.is_time_homogeneous expr) obs let check_time_homogeneity ~ignore_obs compil network = - {network - with - time_homogeneous_vars = - Some (time_homogeneity_of_vars network) ; + { + network with + time_homogeneous_vars = Some (time_homogeneity_of_vars network); time_homogeneous_obs = - Some ( - if ignore_obs then true - else - time_homogeneity_of_obs network) ; - time_homogeneous_rates = - Some (time_homogeneity_of_rates compil network) } + Some + (if ignore_obs then + true + else + time_homogeneity_of_obs network); + time_homogeneous_rates = Some (time_homogeneity_of_rates compil network); + } - let network_from_compil ?max_size ~smash_reactions ~ignore_obs parameters compil network = + let network_from_compil ?max_size ~smash_reactions ~ignore_obs parameters + compil network = let () = Format.printf "+ generate the network... @." in let rules = I.get_rules compil in let () = Format.printf "\t -initial states @." in let network, initial_state = species_of_initial_state compil network (I.get_init compil) in - let () = - Format.printf "\t -saturating the set of molecular species @." - in + let () = Format.printf "\t -saturating the set of molecular species @." in let network = - compute_reactions ?max_size ~smash_reactions parameters compil network rules initial_state + compute_reactions ?max_size ~smash_reactions parameters compil network + rules initial_state in let () = Format.printf "\t -tokens @." in let network = convert_tokens compil network in let () = Format.printf "\t -variables @." in let network = convert_var_defs parameters compil network in let () = Format.printf "\t -observables @." in - let network = convert_obs parameters compil network in + let network = convert_obs parameters compil network in let () = Format.printf "\t -check time homogeneity @." in - let network = - check_time_homogeneity ~ignore_obs compil network - in + let network = check_time_homogeneity ~ignore_obs compil network in network let handler_init = { - Network_handler.int_of_obs = (fun i -> i) ; - Network_handler.int_of_kappa_instance = (fun i -> i) ; - Network_handler.int_of_token_id = (fun i -> i) ; + Network_handler.int_of_obs = (fun i -> i); + Network_handler.int_of_kappa_instance = (fun i -> i); + Network_handler.int_of_token_id = (fun i -> i); } let handler_expr network = { Network_handler.int_of_obs = - (fun s -> Mods.IntMap.find_default s s network.varmap) ; - Network_handler.int_of_kappa_instance = (fun i -> i) ; + (fun s -> Mods.IntMap.find_default s s network.varmap); + Network_handler.int_of_kappa_instance = (fun i -> i); Network_handler.int_of_token_id = (fun i -> i); } let string_of_var_id ?compil ?init_mode t id = I.string_of_var_id ?compil ?init_mode (Ode_loggers_sig.lift t) id - let increment ~propagate_constants - is_zero ?(init_mode=false) ?(comment="") string_of_var logger logger_buffer logger_err x = - if is_zero x - then - Ode_loggers.associate ~propagate_constants ~init_mode ~comment string_of_var logger logger_buffer logger_err (Ode_loggers_sig.Init x) + let increment ~propagate_constants is_zero ?(init_mode = false) + ?(comment = "") string_of_var logger logger_buffer logger_err x = + if is_zero x then + Ode_loggers.associate ~propagate_constants ~init_mode ~comment + string_of_var logger logger_buffer logger_err (Ode_loggers_sig.Init x) else - Ode_loggers.increment ~init_mode ~comment string_of_var logger logger_err (Ode_loggers_sig.Init x) + Ode_loggers.increment ~init_mode ~comment string_of_var logger logger_err + (Ode_loggers_sig.Init x) - let affect_var ~propagate_constants is_zero ?init_mode:(init_mode=false) - logger logger_buffer logger_err compil network decl = + let affect_var ~propagate_constants is_zero ?(init_mode = false) logger + logger_buffer logger_err compil network decl = let handler_expr = handler_expr network in match decl with | Dummy_decl -> () | Init_expr (id', expr, list) -> - begin - match list with - | [] -> () - | [a] -> - let species, n = species_of_species_id network a in - let expr = to_var compil (from_nocc compil expr n) n in - let comment = - Format.asprintf "%a" - (fun log -> - I.print_chemical_species ~compil log ) - species - in - increment ~propagate_constants - is_zero ~init_mode ~comment - (string_of_var_id ~compil ~init_mode logger) logger logger_buffer logger_err a expr + (match list with + | [] -> () + | [ a ] -> + let species, n = species_of_species_id network a in + let expr = to_var compil (from_nocc compil expr n) n in + let comment = + Format.asprintf "%a" + (fun log -> I.print_chemical_species ~compil log) + species + in + increment ~propagate_constants is_zero ~init_mode ~comment + (string_of_var_id ~compil ~init_mode logger) + logger logger_buffer logger_err a expr handler_expr + | _ -> + let () = + Ode_loggers.associate ~propagate_constants ~init_mode + (string_of_var_id ~compil ~init_mode logger) + logger logger_buffer logger_err (Ode_loggers_sig.Expr id') expr handler_expr - | _ -> - let () = Ode_loggers.associate ~propagate_constants - ~init_mode + in + List.iter + (fun id -> + let n = snd (species_of_species_id network id) in + let expr = + to_var compil + (from_nocc compil + (Loc.annot_with_dummy (Alg_expr.ALG_VAR id')) + n) + n + in + increment ~propagate_constants is_zero (string_of_var_id ~compil ~init_mode logger) - logger logger_buffer logger_err - (Ode_loggers_sig.Expr id') expr - handler_expr - in - List.iter - (fun id -> - let n = - snd (species_of_species_id network id) - in - let expr = - to_var compil - (from_nocc compil - (Locality.dummy_annot (Alg_expr.ALG_VAR id')) - n) n in - increment ~propagate_constants - is_zero (string_of_var_id ~compil ~init_mode logger) - logger logger_buffer logger_err - ~init_mode id expr - handler_init) - list - end - | Var (id,comment,expr) -> + logger logger_buffer logger_err ~init_mode id expr handler_init) + list) + | Var (id, comment, expr) -> let expr = if Sbml_backend.is_dotnet logger then - Sbml_backend.propagate_dangerous_var_names_in_alg_expr - logger handler_expr expr - else expr + Sbml_backend.propagate_dangerous_var_names_in_alg_expr logger + handler_expr expr + else + expr in - Ode_loggers.associate ?comment ~propagate_constants - ~init_mode (string_of_var_id ~compil ~init_mode logger) - logger logger_buffer logger_err - (Ode_loggers_sig.Expr id) expr handler_expr + Ode_loggers.associate ?comment ~propagate_constants ~init_mode + (string_of_var_id ~compil ~init_mode logger) + logger logger_buffer logger_err (Ode_loggers_sig.Expr id) expr + handler_expr let get_dep ?time_var dep_map expr _network = - Alg_expr_extra.dep - ?time_var + Alg_expr_extra.dep ?time_var (Mods.IntSet.empty, Mods.IntSet.empty) - (fun a (b,c) -> Mods.IntSet.add a b,c) - (fun a (b,c) -> b, Mods.IntSet.add a c) - (fun (a,b) (c,d) -> - Mods.IntSet.union a c, - Mods.IntSet.union b d) + (fun a (b, c) -> Mods.IntSet.add a b, c) + (fun a (b, c) -> b, Mods.IntSet.add a c) + (fun (a, b) (c, d) -> Mods.IntSet.union a c, Mods.IntSet.union b d) (fun id -> - match - Mods.IntMap.find_option (succ id) dep_map - with - | Some set -> set - | None -> Mods.IntSet.empty,Mods.IntSet.empty) + match Mods.IntMap.find_option (succ id) dep_map with + | Some set -> set + | None -> Mods.IntSet.empty, Mods.IntSet.empty) expr - module V = - struct + module V = struct type t = Ode_loggers_sig.variable + let compare = compare let print _ _ = () end @@ -1755,218 +1607,176 @@ let convert_obs parameters compil network = module VSetMap = SetMap.Make (V) module VMAP = VSetMap.Map - let affect_deriv_var - ~propagate_constants - _is_zero logger logger_buffer logger_err compil network decl dep - = + let affect_deriv_var ~propagate_constants _is_zero logger logger_buffer + logger_err compil network decl dep = let time_var = build_time_var network in let handler_expr = handler_expr network in match decl with - | Dummy_decl - | Init_expr _ -> dep - | Var (id,_comment,expr) -> + | Dummy_decl | Init_expr _ -> dep + | Var (id, _comment, expr) -> let dep_var = get_dep ?time_var dep expr network in let dep = Mods.IntMap.add id dep_var dep in let () = Mods.IntSet.iter (fun dt -> - let expr = - Alg_expr_extra.simplify - (Alg_expr_extra.diff_mixture ?time_var expr dt) - in - Ode_loggers.associate - ~propagate_constants - ~init_mode:false - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - (Ode_loggers_sig.variable_of_derived_variable - (Ode_loggers_sig.Expr id) dt) - expr handler_expr) + let expr = + Alg_expr_extra.simplify + (Alg_expr_extra.diff_mixture ?time_var expr dt) + in + Ode_loggers.associate ~propagate_constants ~init_mode:false + (string_of_var_id ~compil logger) + logger logger_buffer logger_err + (Ode_loggers_sig.variable_of_derived_variable + (Ode_loggers_sig.Expr id) dt) + expr handler_expr) (fst dep_var) in let () = Mods.IntSet.iter (fun dt -> let expr = - Alg_expr_extra.simplify - (Alg_expr_extra.diff_token expr dt) + Alg_expr_extra.simplify (Alg_expr_extra.diff_token expr dt) in - Ode_loggers.associate - ~propagate_constants - ~init_mode:false - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - (Ode_loggers_sig.variable_of_derived_variable - (Ode_loggers_sig.Expr id) dt) - expr handler_expr) + Ode_loggers.associate ~propagate_constants ~init_mode:false + (string_of_var_id ~compil logger) + logger logger_buffer logger_err + (Ode_loggers_sig.variable_of_derived_variable + (Ode_loggers_sig.Expr id) dt) + expr handler_expr) (snd dep_var) in dep - let affect_deriv_gen - ~propagate_constants - dep_var logger logger_buffer logger_err compil var rate network dep = - let time_var = build_time_var network in - let handler_expr = handler_expr network in - let dep_set = get_dep ?time_var dep_var rate network in - let dep = VMAP.add var dep_set dep in - let () = - Mods.IntSet.iter - (fun dt -> - let expr = - Alg_expr_extra.simplify - (Alg_expr_extra.diff_mixture ?time_var rate dt) - in - Ode_loggers.associate - ~propagate_constants - ~init_mode:false - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - (Ode_loggers_sig.variable_of_derived_variable - var dt) - expr handler_expr) - (fst dep_set) - in - let () = - Mods.IntSet.iter - (fun dt -> - let expr = - Alg_expr_extra.simplify - (Alg_expr_extra.diff_token rate dt) - in - Ode_loggers.associate - ~propagate_constants - ~init_mode:false - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - (Ode_loggers_sig.variable_of_derived_variable - var dt) - expr handler_expr) - (snd dep_set) - in - dep - - let affect_deriv_rate - dep_var logger logger_buffer logger_err compil rule rate network dep - = - affect_deriv_gen - dep_var logger logger_buffer logger_err compil (var_of_rule rule) rate network dep - - let affect_deriv_stoch - dep_var logger logger_buffer logger_err compil rule n coef network dep - = - affect_deriv_gen - dep_var logger logger_buffer logger_err compil (var_of_stoch rule n) coef network dep + let affect_deriv_gen ~propagate_constants dep_var logger logger_buffer + logger_err compil var rate network dep = + let time_var = build_time_var network in + let handler_expr = handler_expr network in + let dep_set = get_dep ?time_var dep_var rate network in + let dep = VMAP.add var dep_set dep in + let () = + Mods.IntSet.iter + (fun dt -> + let expr = + Alg_expr_extra.simplify + (Alg_expr_extra.diff_mixture ?time_var rate dt) + in + Ode_loggers.associate ~propagate_constants ~init_mode:false + (string_of_var_id ~compil logger) + logger logger_buffer logger_err + (Ode_loggers_sig.variable_of_derived_variable var dt) + expr handler_expr) + (fst dep_set) + in + let () = + Mods.IntSet.iter + (fun dt -> + let expr = + Alg_expr_extra.simplify (Alg_expr_extra.diff_token rate dt) + in + Ode_loggers.associate ~propagate_constants ~init_mode:false + (string_of_var_id ~compil logger) + logger logger_buffer logger_err + (Ode_loggers_sig.variable_of_derived_variable var dt) + expr handler_expr) + (snd dep_set) + in + dep + + let affect_deriv_rate dep_var logger logger_buffer logger_err compil rule rate + network dep = + affect_deriv_gen dep_var logger logger_buffer logger_err compil + (var_of_rule rule) rate network dep + + let affect_deriv_stoch dep_var logger logger_buffer logger_err compil rule n + coef network dep = + affect_deriv_gen dep_var logger logger_buffer logger_err compil + (var_of_stoch rule n) coef network dep let fresh_is_zero network = - let is_zero = - Mods.DynArray.create (get_fresh_ode_var_id network) true in + let is_zero = Mods.DynArray.create (get_fresh_ode_var_id network) true in let is_zero x = - if Mods.DynArray.get is_zero x - then + if Mods.DynArray.get is_zero x then ( let () = Mods.DynArray.set is_zero x false in true - else + ) else false - in is_zero + in + is_zero let declare_rates_global_gen g logger network = - let do_it f = - Ode_loggers.declare_global logger (g (f network.n_rules) 1) - in + let do_it f = Ode_loggers.declare_global logger (g (f network.n_rules) 1) in let () = do_it (fun x -> Ode_loggers_sig.Rate x) in let () = do_it (fun x -> Ode_loggers_sig.Rated x) in let () = do_it (fun x -> Ode_loggers_sig.Rateun x) in let () = do_it (fun x -> Ode_loggers_sig.Rateund x) in - let () = do_it (fun x -> - Ode_loggers_sig.Stochiometric_coef (x,network.max_stoch_coef)) in + let () = + do_it (fun x -> + Ode_loggers_sig.Stochiometric_coef (x, network.max_stoch_coef)) + in let () = match Ode_loggers_sig.get_encoding_format logger with - | Loggers.Octave | Loggers.Matlab -> - Ode_loggers.print_newline logger - | Loggers.Mathematica | Loggers.GEPHI - | Loggers.Maple | Loggers.SBML | Loggers.DOTNET - | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS - | Loggers.Matrix | Loggers.DOT | Loggers.HTML - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML_Tabular - | Loggers.Json -> () + | Loggers.Octave | Loggers.Matlab -> Ode_loggers.print_newline logger + | Loggers.Mathematica | Loggers.GEPHI | Loggers.Maple | Loggers.SBML + | Loggers.DOTNET | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS + | Loggers.Matrix | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.HTML_Tabular | Loggers.Json -> + () in () let declare_rates_global logger network = - declare_rates_global_gen - (fun a _ -> a) - logger - network + declare_rates_global_gen (fun a _ -> a) logger network let declare_jacobian_rates_global logger network = - declare_rates_global_gen - Ode_loggers_sig.variable_of_derived_variable - logger network - + declare_rates_global_gen Ode_loggers_sig.variable_of_derived_variable logger + network let breakline = true let good_step ~step logger = - match Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.Mathematica | Loggers.Maple -> step = 2 - | Loggers.Matlab | Loggers.Octave - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph - | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS - | Loggers.SBML | Loggers.DOTNET | Loggers.GEPHI - | Loggers.Json -> step=1 - + | Loggers.Matlab | Loggers.Octave | Loggers.Matrix | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS | Loggers.SBML + | Loggers.DOTNET | Loggers.GEPHI | Loggers.Json -> + step = 1 let is_step_one ~step = step = 1 let is_step_two ~step = step = 2 - let export_main_gen - ~propagate_constants - ~initial_step - ~max_step - ~reltol - ~abstol - ~nonnegative - ~step - ~compute_jacobian - ~command_line ~command_line_quotes ?(data_file="data.csv") - ?(init_t=0.) - ~max_t ?(plot_period=1.) - logger logger_buffer (logger_err:Loggers.t) compil network - split = + let export_main_gen ~propagate_constants ~initial_step ~max_step ~reltol + ~abstol ~nonnegative ~step ~compute_jacobian ~command_line + ~command_line_quotes ?(data_file = "data.csv") ?(init_t = 0.) ~max_t + ?(plot_period = 1.) logger logger_buffer (logger_err : Loggers.t) compil + network split = let is_zero = fresh_is_zero network in let nodevar = get_last_ode_var_id network in let nobs = get_fresh_obs_id network in let handler_expr = handler_expr network in let () = - if good_step ~step logger - then + if good_step ~step logger then Ode_loggers.open_procedure logger "main" "main" [] in let command_line_closure logger = - let () = Ode_loggers.print_comment ~breakline - logger "command line: " + let () = Ode_loggers.print_comment ~breakline logger "command line: " in + let () = + Ode_loggers.print_comment ~breakline logger + (" " ^ command_line_quotes) in - let () = Ode_loggers.print_comment ~breakline logger - (" "^command_line_quotes) in () + () in let count = I.what_do_we_count compil in let rule_rate_convention = I.rule_rate_convention compil in - let reaction_rate_convention = - I.reaction_rate_convention compil in - let may_be_not_time_homogeneous = - may_be_not_time_homogeneous network - in + let reaction_rate_convention = I.reaction_rate_convention compil in + let may_be_not_time_homogeneous = may_be_not_time_homogeneous network in (*---------------------------------------------------------------*) let () = - if is_step_one ~step - then + if is_step_one ~step then ( let () = - Ode_loggers.print_ode_preamble ~may_be_not_time_homogeneous - ~count ~rule_rate_convention ?reaction_rate_convention logger command_line_closure () + Ode_loggers.print_ode_preamble ~may_be_not_time_homogeneous ~count + ~rule_rate_convention ?reaction_rate_convention logger + command_line_closure () in let () = Ode_loggers.print_newline logger in (*---------------------------------------------------------------*) @@ -1975,317 +1785,289 @@ let convert_obs parameters compil network = in let () = Sbml_backend.line_dotnet_or_sbml logger_buffer logger_err in let () = - let () = - if propagate_constants - then () - else - Sbml_backend.open_box_dotnet logger_buffer logger_err "begin parameters" - in - let () = Sbml_backend.line_dotnet logger_buffer logger_err in - (*---------------------------------------------------------------*) - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) logger - logger_buffer logger_err Ode_loggers_sig.Tinit (Alg_expr.float init_t) - handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) logger - logger_buffer logger_err Ode_loggers_sig.Tend - (Alg_expr.float max_t) - handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err Ode_loggers_sig.InitialStep - (Alg_expr.float initial_step) handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err Ode_loggers_sig.MaxStep - (Alg_expr.float max_step) handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err Ode_loggers_sig.RelTol - (Alg_expr.float reltol) handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err Ode_loggers_sig.AbsTol - (Alg_expr.float abstol) handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err Ode_loggers_sig.Period_t_points - (Alg_expr.float plot_period) handler_expr - in - let () = - Ode_loggers.associate_nonnegative logger_buffer nonnegative in - let () = Ode_loggers.print_newline logger_buffer in - let () = - Ode_loggers.declare_global logger_buffer Ode_loggers_sig.N_ode_var - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - Ode_loggers_sig.N_ode_var - (Alg_expr.int nodevar) - handler_expr - in - let () = - Ode_loggers.declare_global logger_buffer - Ode_loggers_sig.N_max_stoc_coef - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - Ode_loggers_sig.N_max_stoc_coef - (Alg_expr.int network.max_stoch_coef) - handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - Ode_loggers_sig.N_var - (Alg_expr.int (get_last_var_id network)) - handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - Ode_loggers_sig.N_obs - (Alg_expr.int network.n_obs) - handler_expr - in - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - Ode_loggers_sig.N_rules - (Alg_expr.int network.n_rules) - handler_expr - in - let () = Ode_loggers.print_newline logger_buffer in - let () = - Ode_loggers.declare_global - logger_buffer - (Ode_loggers_sig.Expr network.fresh_var_id) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Expr network.fresh_var_id) - in - let () = - Ode_loggers.declare_global logger_buffer - (Ode_loggers_sig.Init network.fresh_ode_var_id) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Init network.fresh_ode_var_id) - in - let () = declare_rates_global logger_buffer network in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Stochiometric_coef - (network.n_rules,network.max_stoch_coef)) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Rate network.n_rules) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Rated network.n_rules) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Rateun network.n_rules) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Rateund network.n_rules) - in - (*---------------------------------------------------------------*) - let () = - if compute_jacobian - then - let () = - Ode_loggers.declare_global - logger_buffer - (Ode_loggers_sig.Jacobian_var - (network.fresh_ode_var_id,network.fresh_ode_var_id)) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Jacobian_var - (network.fresh_ode_var_id,network.fresh_ode_var_id)) - in - let () = declare_jacobian_rates_global logger_buffer network in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Jacobian_rate - (network.n_rules,network.fresh_ode_var_id)) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Jacobian_rated - (network.n_rules,network.fresh_ode_var_id)) - in - let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Jacobian_rateun - (network.n_rules,network.fresh_ode_var_id)) - in + let () = + if propagate_constants then + () + else + Sbml_backend.open_box_dotnet logger_buffer logger_err + "begin parameters" + in + let () = Sbml_backend.line_dotnet logger_buffer logger_err in + (*---------------------------------------------------------------*) + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.Tinit + (Alg_expr.float init_t) handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.Tend + (Alg_expr.float max_t) handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.InitialStep + (Alg_expr.float initial_step) + handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.MaxStep + (Alg_expr.float max_step) handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.RelTol + (Alg_expr.float reltol) handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.AbsTol + (Alg_expr.float abstol) handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.Period_t_points + (Alg_expr.float plot_period) + handler_expr + in + let () = + Ode_loggers.associate_nonnegative logger_buffer nonnegative + in + let () = Ode_loggers.print_newline logger_buffer in + let () = + Ode_loggers.declare_global logger_buffer Ode_loggers_sig.N_ode_var + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.N_ode_var + (Alg_expr.int nodevar) handler_expr + in + let () = + Ode_loggers.declare_global logger_buffer + Ode_loggers_sig.N_max_stoc_coef + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.N_max_stoc_coef + (Alg_expr.int network.max_stoch_coef) + handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.N_var + (Alg_expr.int (get_last_var_id network)) + handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.N_obs + (Alg_expr.int network.n_obs) + handler_expr + in + let () = + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err Ode_loggers_sig.N_rules + (Alg_expr.int network.n_rules) + handler_expr + in + let () = Ode_loggers.print_newline logger_buffer in + let () = + Ode_loggers.declare_global logger_buffer + (Ode_loggers_sig.Expr network.fresh_var_id) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Expr network.fresh_var_id) + in + let () = + Ode_loggers.declare_global logger_buffer + (Ode_loggers_sig.Init network.fresh_ode_var_id) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Init network.fresh_ode_var_id) + in + let () = declare_rates_global logger_buffer network in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Stochiometric_coef + (network.n_rules, network.max_stoch_coef)) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Rate network.n_rules) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Rated network.n_rules) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Rateun network.n_rules) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Rateund network.n_rules) + in + (*---------------------------------------------------------------*) + let () = + if compute_jacobian then ( + let () = + Ode_loggers.declare_global logger_buffer + (Ode_loggers_sig.Jacobian_var + (network.fresh_ode_var_id, network.fresh_ode_var_id)) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Jacobian_var + (network.fresh_ode_var_id, network.fresh_ode_var_id)) + in + let () = declare_jacobian_rates_global logger_buffer network in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Jacobian_rate + (network.n_rules, network.fresh_ode_var_id)) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Jacobian_rated + (network.n_rules, network.fresh_ode_var_id)) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Jacobian_rateun + (network.n_rules, network.fresh_ode_var_id)) + in + let () = + Ode_loggers.initialize ~nodevar logger_buffer + (Ode_loggers_sig.Jacobian_rateund + (network.n_rules, network.fresh_ode_var_id)) + in + () + ) + in + (*---------------------------------------------------------------*) + let () = Ode_loggers.print_newline logger_buffer in + let () = Ode_loggers.start_time logger_buffer init_t in + let () = Ode_loggers.print_newline logger_buffer in + (*---------------------------------------------------------------*) + let () = + if may_be_not_time_homogeneous then ( + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.SBML | Loggers.Octave | Loggers.Matlab | Loggers.DOTNET + -> let () = - Ode_loggers.initialize - ~nodevar logger_buffer - (Ode_loggers_sig.Jacobian_rateund - (network.n_rules,network.fresh_ode_var_id)) - in - () - in - (*---------------------------------------------------------------*) - let () = Ode_loggers.print_newline logger_buffer in - let () = Ode_loggers.start_time logger_buffer init_t in - let () = Ode_loggers.print_newline logger_buffer in - (*---------------------------------------------------------------*) - let () = - if may_be_not_time_homogeneous - then - match Ode_loggers_sig.get_encoding_format logger with - | Loggers.SBML | Loggers.Octave | Loggers.Matlab | - Loggers.DOTNET -> - let () = - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - (Ode_loggers_sig.Init (get_last_ode_var_id network)) - (Locality.dummy_annot - (Alg_expr.STATE_ALG_OP - Operator.TIME_VAR)) - handler_init - in - Sbml_backend.print_parameters - (fun x -> string_of_var_id x) + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) logger logger_buffer logger_err - Ode_loggers_sig.Time_scale_factor Nbr.one; - Sbml_backend.line_dotnet logger logger_err - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph - | Loggers.HTML | Loggers.GEPHI - | Loggers.HTML_Tabular| Loggers.DOT| Loggers.TXT - | Loggers.TXT_Tabular - | Loggers.XLS| Loggers.Maple| Loggers.Mathematica| Loggers.Json - -> + (Ode_loggers_sig.Init (get_last_ode_var_id network)) + (Loc.annot_with_dummy + (Alg_expr.STATE_ALG_OP Operator.TIME_VAR)) + handler_init + in + Sbml_backend.print_parameters + (fun x -> string_of_var_id x) + logger logger_buffer logger_err + Ode_loggers_sig.Time_scale_factor Nbr.one; + Sbml_backend.line_dotnet logger logger_err + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.GEPHI | Loggers.HTML_Tabular + | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS + | Loggers.Maple | Loggers.Mathematica | Loggers.Json -> () - else () - in - (*---------------------------------------------------------------*) - let () = - List.iter - (affect_var ~propagate_constants is_zero logger logger_buffer - logger_err ~init_mode:true - compil network) - network.var_declaration - in - let () = Ode_loggers.print_newline logger_buffer in - let () = - List.iter - (fun (rule,coefs) -> - List.iter - (fun coef -> + ) else + () + in + (*---------------------------------------------------------------*) + let () = + List.iter + (affect_var ~propagate_constants is_zero logger logger_buffer + logger_err ~init_mode:true compil network) + network.var_declaration + in + let () = Ode_loggers.print_newline logger_buffer in + let () = + List.iter + (fun (rule, coefs) -> + List.iter + (fun coef -> + match coef with + | R rate -> + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + ~comment:rule.comment logger logger_buffer logger_err + (var_of_rate rule.rule_id_with_mode) + rate handler_expr + | S (n, stoc) -> + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger_buffer logger_err + (Ode_loggers_sig.Stochiometric_coef + ( (let a, _, _ = rule.rule_id_with_mode in + a), + n )) + stoc handler_expr) + coefs) + split.const_rate + in + let () = + Sbml_backend.do_dotnet logger logger_err (fun logger logger_err -> + List.iter + (fun (rule, coefs) -> + List.iter + (fun coef -> match coef with | R rate -> - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - ~comment:rule.comment logger logger_buffer - logger_err - (var_of_rate rule.rule_id_with_mode) rate handler_expr - | S (n,stoc) -> - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger_buffer logger_err - (Ode_loggers_sig.Stochiometric_coef - ((let a,_,_ = rule.rule_id_with_mode in a) , n)) - stoc - handler_expr) - coefs - ) - split.const_rate - in - let () = - Sbml_backend.do_dotnet - logger logger_err - (fun logger logger_err -> - List.iter - (fun (rule,coefs) -> - List.iter - (fun coef -> - match coef with - | R rate -> - begin - match - Sbml_backend.eval_const_alg_expr logger - handler_expr rate - with - | Some _ -> - (* if not propagate_constants then*) - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - ~comment:rule.comment logger - logger_buffer - logger_err - (var_of_rate rule.rule_id_with_mode) - rate - handler_expr - | None -> - let () = - Sbml_backend.warn_expr - rate - "DOTNET backend does not support non-constant rates for rules: cowardly replacing it with 1" - logger logger_err - in - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - ~comment:rule.comment logger logger_buffer - logger_err - (var_of_rate rule.rule_id_with_mode) - (Alg_expr.CONST Nbr.one,snd rate) - handler_expr - end - | S _ -> ()) - coefs - ) - split.var_rate) - in - (*---------------------------------------------------------------*) + (match + Sbml_backend.eval_const_alg_expr logger + handler_expr rate + with + | Some _ -> + (* if not propagate_constants then*) + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + ~comment:rule.comment logger logger_buffer + logger_err + (var_of_rate rule.rule_id_with_mode) + rate handler_expr + | None -> + let () = + Sbml_backend.warn_expr rate + "DOTNET backend does not support non-constant \ + rates for rules: cowardly replacing it with 1" + logger logger_err + in + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + ~comment:rule.comment logger logger_buffer + logger_err + (var_of_rate rule.rule_id_with_mode) + (Alg_expr.CONST Nbr.one, snd rate) + handler_expr) + | S _ -> ()) + coefs) + split.var_rate) + in + (*---------------------------------------------------------------*) let () = Sbml_backend.close_box logger_buffer logger_err "listOfParameters" in let () = - if propagate_constants - then () + if propagate_constants then + () else Sbml_backend.close_box_dotnet logger_buffer logger_err "end parameters" @@ -2293,52 +2075,51 @@ let convert_obs parameters compil network = () in - (*---------------------------------------------------------------*) + (*---------------------------------------------------------------*) let () = Ode_loggers.print_newline logger in let () = Ode_loggers.print_license_check logger in let () = Ode_loggers.print_newline logger in let pos i = - match Mods.DynArray.get network.ode_vars_tab i - with + match Mods.DynArray.get network.ode_vars_tab i with | Nembed _ | Noccurrences _ -> true | Token _ | Dummy -> false in let nodevar = network.fresh_ode_var_id - 1 in - let () = Ode_loggers.print_options ~compute_jacobian ~pos ~nodevar logger in + let () = + Ode_loggers.print_options ~compute_jacobian ~pos ~nodevar logger + in let () = Ode_loggers.print_newline logger in () + ) in (*---------------------------------------------------------------*) (*Get titles*) let titles = I.get_obs_titles compil in let () = - if good_step ~step logger - then + if good_step ~step logger then ( let () = Ode_loggers.print_integrate ~nobs ~nodevar logger in let () = Ode_loggers.print_newline logger in let () = Ode_loggers.associate_nrows logger in - let () = - Ode_loggers.initialize - ~nodevar logger - Ode_loggers_sig.Tmp - in + let () = Ode_loggers.initialize ~nodevar logger Ode_loggers_sig.Tmp in let () = Ode_loggers.print_newline logger in let () = Ode_loggers.print_interpolate logger in let () = Ode_loggers.print_newline logger in let () = - Ode_loggers.print_dump_plots ~nobs ~data_file ~command_line ~titles logger + Ode_loggers.print_dump_plots ~nobs ~data_file ~command_line ~titles + logger in let () = Ode_loggers.print_newline logger in () + ) in (*---------------------------------------------------------------*) let () = - if is_step_one ~step - then + if is_step_one ~step then ( let () = Ode_loggers.close_procedure logger in let () = Ode_loggers.print_newline logger in let () = Ode_loggers.print_newline logger in () + ) in (*---------------------------------------------------------------*) let () = Ode_loggers.print_newline logger in @@ -2347,44 +2128,33 @@ let convert_obs parameters compil network = let export_main = export_main_gen ~step:1 let export_main_follow_up = export_main_gen ~step:2 - let export_dydt - ~propagate_constants ~show_time_advance - logger logger_err compil network split = + let export_dydt ~propagate_constants ~show_time_advance logger logger_err + compil network split = let nodevar = get_last_ode_var_id network in let is_zero = fresh_is_zero network in let label = "listOfReactions" in let label_dotnet = "begin reactions" in - let () = Ode_loggers.open_procedure logger "dydt" "ode_aux" ["t";"y"] in + let () = Ode_loggers.open_procedure logger "dydt" "ode_aux" [ "t"; "y" ] in (*------------------------------------------------*) - let () = - if show_time_advance - then - Ode_loggers.show_time_advance logger - in + let () = if show_time_advance then Ode_loggers.show_time_advance logger in let () = Sbml_backend.open_box logger logger_err label in let () = Sbml_backend.line_dotnet_or_sbml logger logger_err in let () = Sbml_backend.line_dotnet logger logger_err in let () = Sbml_backend.open_box_dotnet logger logger_err label_dotnet in let () = Sbml_backend.line_dotnet logger logger_err in let () = Ode_loggers.print_newline logger in - let () = - Ode_loggers.declare_global logger Ode_loggers_sig.N_ode_var - in + let () = Ode_loggers.declare_global logger Ode_loggers_sig.N_ode_var in let () = Ode_loggers.declare_global logger Ode_loggers_sig.N_max_stoc_coef in - let () = - Ode_loggers.declare_global logger (Ode_loggers_sig.Expr 1) - in + let () = Ode_loggers.declare_global logger (Ode_loggers_sig.Expr 1) in let () = declare_rates_global logger network in let () = - if not - (Sbml_backend.is_dotnet logger) - then + if not (Sbml_backend.is_dotnet logger) then ( let () = List.iter - (affect_var ~propagate_constants - is_zero logger logger logger_err ~init_mode:false compil network) + (affect_var ~propagate_constants is_zero logger logger logger_err + ~init_mode:false compil network) split.var_decl in let () = Ode_loggers.print_newline logger in @@ -2392,289 +2162,255 @@ let convert_obs parameters compil network = let () = List.iter (fun (rule, coefs) -> - List.iter - (fun coef -> - match coef with - | R rate -> - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger logger_err - (var_of_rule rule) rate (handler_expr network) - | S (n, stoc) -> - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger logger_err - (Ode_loggers_sig.Stochiometric_coef - ((let a,_,_ = rule.rule_id_with_mode in a), n)) - stoc - (handler_expr network)) - coefs) + List.iter + (fun coef -> + match coef with + | R rate -> + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger logger_err (var_of_rule rule) rate + (handler_expr network) + | S (n, stoc) -> + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger logger_err + (Ode_loggers_sig.Stochiometric_coef + ( (let a, _, _ = rule.rule_id_with_mode in + a), + n )) + stoc (handler_expr network)) + coefs) split.var_rate in let () = Ode_loggers.print_newline logger in () + ) in - let () = - Ode_loggers.initialize - ~nodevar logger (Ode_loggers_sig.Deriv 1) - in + let () = Ode_loggers.initialize ~nodevar logger (Ode_loggers_sig.Deriv 1) in (*------------------------------------------------*) let do_it f l reactants enriched_rule nocc = List.iter (fun species -> - let nauto_in_species = - if I.do_we_count_in_embeddings compil - then - snd - (species_of_species_id network species) - else 1 - in - let nauto_in_lhs = enriched_rule.divide_rate_by in - f - logger (Ode_loggers_sig.Deriv species) - ~nauto_in_species ~nauto_in_lhs ~nocc - (var_of_rule enriched_rule) reactants) + let nauto_in_species = + if I.do_we_count_in_embeddings compil then + snd (species_of_species_id network species) + else + 1 + in + let nauto_in_lhs = enriched_rule.divide_rate_by in + f logger (Ode_loggers_sig.Deriv species) ~nauto_in_species + ~nauto_in_lhs ~nocc + (var_of_rule enriched_rule) + reactants) l in let () = List.iter - (fun ((reactants, products, token_vector, enriched_rule),nocc) -> - (*each reaction will be computed here*) - let add_factor l = - if I.do_we_count_in_embeddings compil - then - List.rev_map - (fun x -> - let nauto = - snd (species_of_species_id network x) - in - (x, nauto)) (List.rev l) - else - List.rev_map (fun x -> (x,1)) (List.rev l) - in - let reactants' = add_factor reactants in - let products' = add_factor products in - let () = - if I.do_we_prompt_reactions compil - then - let rule_string = - Format.asprintf "%a" (I.print_rule_name ~compil) - enriched_rule.rule - in - let tokens_prod = I.token_vector enriched_rule.rule in - let dump_token_list fmt list = - let _ = - List.fold_left - (fun bool ((alg,_),k) -> - let prefix = if bool then ", " else " | " in + (fun ((reactants, products, token_vector, enriched_rule), nocc) -> + (*each reaction will be computed here*) + let add_factor l = + if I.do_we_count_in_embeddings compil then + List.rev_map + (fun x -> + let nauto = snd (species_of_species_id network x) in + x, nauto) + (List.rev l) + else + List.rev_map (fun x -> x, 1) (List.rev l) + in + let reactants' = add_factor reactants in + let products' = add_factor products in + let () = + if I.do_we_prompt_reactions compil then ( + let rule_string = + Format.asprintf "%a" + (I.print_rule_name ~compil) + enriched_rule.rule + in + let tokens_prod = I.token_vector enriched_rule.rule in + let dump_token_list fmt list = + let _ = + List.fold_left + (fun bool ((alg, _), k) -> + let prefix = + if bool then + ", " + else + " | " + in let () = - Format.fprintf fmt "%s%a %a" - prefix + Format.fprintf fmt "%s%a %a" prefix (Alg_expr.print (fun fmt mixture -> - let () = Format.fprintf fmt "|" in - let _ = - List.fold_left - (Array.fold_left - (fun bool connected_component -> - let prefix = - if bool - then " , " else "" - in - let () = - Format.fprintf - fmt - "%s%a" - prefix - (I.print_connected_component - ~compil) - connected_component - in true) - ) false mixture - in - let () = Format.fprintf fmt "|" in - ()) - (I.print_token ~compil) - (fun fmt var_id -> - Format.fprintf fmt "%s" - (string_of_var_id - ~compil logger (succ var_id))) - ) - alg - (I.print_token ~compil) + let () = Format.fprintf fmt "|" in + let _ = + List.fold_left + (Array.fold_left + (fun bool connected_component -> + let prefix = + if bool then + " , " + else + "" + in + let () = + Format.fprintf fmt "%s%a" prefix + (I.print_connected_component ~compil) + connected_component + in + true)) + false mixture + in + let () = Format.fprintf fmt "|" in + ()) + (I.print_token ~compil) + (fun fmt var_id -> + Format.fprintf fmt "%s" + (string_of_var_id ~compil logger (succ var_id)))) + alg (I.print_token ~compil) k + in + true) + false (List.rev list) + in + () + in + (*----------------------------------------------*) + (*print rule in commend format *) + let () = Ode_loggers.print_newline logger in + let () = + Ode_loggers.print_comment ~breakline logger + ("rule : " ^ rule_string) + in + let dump fmt list = + let compil = I.with_dot_and_plus compil in + let _ = + List.fold_left + (fun bool k -> + let prefix = + if bool then + Kade_backend.Utils.print_agent_sep_plus + (I.symbol_table compil) + else + Pp.empty + in + let species_string = + Format.asprintf "%a" + (fun log id -> + I.print_chemical_species ~compil log + (fst (Mods.DynArray.get network.species_tab id))) k - in true - ) false (List.rev list) - in () - in - (*----------------------------------------------*) - (*print rule in commend format *) - let () = Ode_loggers.print_newline logger in - let () = - Ode_loggers.print_comment ~breakline logger - ("rule : "^rule_string) - in - let dump fmt list = - let compil = I.with_dot_and_plus compil in - let _ = - List.fold_left - (fun bool k -> - let prefix = if bool then - Kade_backend.Utils.print_agent_sep_plus - (I.symbol_table compil) - else Pp.empty - in - let species_string = - Format.asprintf "%a" - (fun log id -> - I.print_chemical_species - ~compil log - (fst - (Mods.DynArray.get - network.species_tab id))) - k - in - let () = - Format.fprintf fmt "%t%s" - prefix - species_string - in - true) - false - (List.rev list) - in () - in - (*----------------------------------------------*) - match Ode_loggers_sig.get_encoding_format logger with - | Loggers.Matlab | Loggers.Octave - | Loggers.SBML - | Loggers.Mathematica | Loggers.Maple -> - let s = Format.asprintf - "reaction: %a -> %a%a" - dump reactants - dump products - dump_token_list - tokens_prod - in - Ode_loggers.print_comment ~breakline logger s - | Loggers.DOTNET -> - let s = Format.asprintf - "%a -> %a%a" - dump - reactants - dump - products - dump_token_list - tokens_prod - in - Ode_loggers.print_comment ~breakline logger s - | Loggers.Matrix | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS - | Loggers.DOT | Loggers.HTML - | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.GEPHI - | Loggers.HTML_Tabular | Loggers.Json -> () - - in - (*------------------------------------------*) - (*one reaction*) - let () = - Sbml_backend.dump_sbml_reaction - ~propagate_constants - Ode_loggers.print_alg_expr_few_parenthesis - (string_of_var_id ~compil logger) - get_rule - (fun a -> - let (a,_,_) = a.rule_id_with_mode in a) - I.print_rule_name - (Some compil) - logger - logger_err - (handler_expr network) - reactants' - products' - token_vector - enriched_rule - (var_of_rule enriched_rule) - enriched_rule.divide_rate_by - nocc - network.fictitious_species - in - let () = - match - Ode_loggers_sig.formatter_of_logger logger - with - | None -> () - | Some fmt -> - let () = - Loggers.flush_and_clean logger_err fmt - in () - in - let reactants' = - List.rev_map - (fun x -> - let nauto = snd - (species_of_species_id network x) - in - (Ode_loggers_sig.Concentration x, - to_nocc_correct compil nauto)) - (List.rev reactants) - in - let nauto_in_lhs = enriched_rule.divide_rate_by in - let () = Ode_loggers.print_newline logger in - (*------------------------------------------*) - let () = - do_it Ode_loggers.consume reactants reactants' - enriched_rule nocc - in - let () = - do_it Ode_loggers.produce products reactants' - enriched_rule nocc - in - (*------------------------------------------*) - let _ = - List.fold_left - (fun n (token,_) -> - let () = - Ode_loggers.update_token - logger - (Ode_loggers_sig.Deriv token) + in + let () = + Format.fprintf fmt "%t%s" prefix species_string + in + true) + false (List.rev list) + in + () + in + (*----------------------------------------------*) + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.Matlab | Loggers.Octave | Loggers.SBML + | Loggers.Mathematica | Loggers.Maple -> + let s = + Format.asprintf "reaction: %a -> %a%a" dump reactants dump + products dump_token_list tokens_prod + in + Ode_loggers.print_comment ~breakline logger s + | Loggers.DOTNET -> + let s = + Format.asprintf "%a -> %a%a" dump reactants dump products + dump_token_list tokens_prod + in + Ode_loggers.print_comment ~breakline logger s + | Loggers.Matrix | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS + | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.GEPHI | Loggers.HTML_Tabular + | Loggers.Json -> + () + ) + in + + (*------------------------------------------*) + (*one reaction*) + let () = + Sbml_backend.dump_sbml_reaction ~propagate_constants + Ode_loggers.print_alg_expr_few_parenthesis + (string_of_var_id ~compil logger) + get_rule + (fun a -> + let a, _, _ = a.rule_id_with_mode in + a) + I.print_rule_name (Some compil) logger logger_err + (handler_expr network) reactants' products' token_vector + enriched_rule + (var_of_rule enriched_rule) + enriched_rule.divide_rate_by nocc network.fictitious_species + in + let () = + match Ode_loggers_sig.formatter_of_logger logger with + | None -> () + | Some fmt -> + let () = Loggers.flush_and_clean logger_err fmt in + () + in + let reactants' = + List.rev_map + (fun x -> + let nauto = snd (species_of_species_id network x) in + Ode_loggers_sig.Concentration x, to_nocc_correct compil nauto) + (List.rev reactants) + in + let nauto_in_lhs = enriched_rule.divide_rate_by in + let () = Ode_loggers.print_newline logger in + (*------------------------------------------*) + let () = + do_it Ode_loggers.consume reactants reactants' enriched_rule nocc + in + let () = + do_it Ode_loggers.produce products reactants' enriched_rule nocc + in + (*------------------------------------------*) + let _ = + List.fold_left + (fun n (token, _) -> + let () = + Ode_loggers.update_token logger (Ode_loggers_sig.Deriv token) ~nauto_in_lhs ~nocc (var_of_rule enriched_rule) (var_of_stoch enriched_rule n) reactants' - in n+1) - 1 token_vector - in () - ) network.reactions + in + n + 1) + 1 token_vector + in + ()) + network.reactions in (*------------------------------------------------------------*) (* Derivative of time is equal to 1 *) let network = - if may_be_not_time_homogeneous network - then - if Sbml_backend.is_dotnet logger - then - let s = "DOTNET backend does not support time dependent expressions\n" in - let () = Printf.printf "%s" s in - let () = - Sbml_backend.print_comment - logger - logger_err - s + if may_be_not_time_homogeneous network then + if Sbml_backend.is_dotnet logger then ( + let s = + "DOTNET backend does not support time dependent expressions\n" in + let () = Printf.printf "%s" s in + let () = Sbml_backend.print_comment logger logger_err s in network - else + ) else ( let () = Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) logger logger logger_err - (Ode_loggers_sig.Deriv - (get_last_ode_var_id network)) + (string_of_var_id ~compil logger) + logger logger logger_err + (Ode_loggers_sig.Deriv (get_last_ode_var_id network)) (Alg_expr.const Nbr.one) (handler_expr network) in - let network = {network with has_time_reaction = Some true } in + let network = { network with has_time_reaction = Some true } in let () = Ode_loggers.print_newline logger in let () = Sbml_backend.time_advance logger logger_err in network + ) else network in @@ -2683,12 +2419,9 @@ let convert_obs parameters compil network = let label_close = "end reactions" in let () = Sbml_backend.close_box_dotnet logger logger_err label_close in let () = - match - Ode_loggers_sig.formatter_of_logger logger - with + match Ode_loggers_sig.formatter_of_logger logger with | None -> () - | Some fmt -> - Loggers.flush_and_clean logger_err fmt + | Some fmt -> Loggers.flush_and_clean logger_err fmt in let () = Ode_loggers.print_newline logger in let () = Ode_loggers.print_newline logger in @@ -2697,305 +2430,248 @@ let convert_obs parameters compil network = let export_jac ~propagate_constants logger logger_err compil network split = let nodevar = get_last_ode_var_id network in match Ode_loggers_sig.get_encoding_format logger with - | Loggers.Matrix | Loggers.TXT - | Loggers.Maple | Loggers.Mathematica - | Loggers.GEPHI - | Loggers.TXT_Tabular | Loggers.XLS - | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph | Loggers.Js_Graph - | Loggers.HTML_Tabular | Loggers.Json - | Loggers.SBML | Loggers.DOTNET -> () - | Loggers.Matlab | Loggers.Octave -> + | Loggers.Matrix | Loggers.TXT | Loggers.Maple | Loggers.Mathematica + | Loggers.GEPHI | Loggers.TXT_Tabular | Loggers.XLS | Loggers.DOT + | Loggers.HTML | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML_Tabular | Loggers.Json | Loggers.SBML | Loggers.DOTNET -> + () + | Loggers.Matlab | Loggers.Octave -> let is_zero = fresh_is_zero network in let label = "listOfReactions" in let () = - Ode_loggers.open_procedure logger "jac" "ode_jacobian" ["t";"y";] + Ode_loggers.open_procedure logger "jac" "ode_jacobian" [ "t"; "y" ] in let () = Ode_loggers.print_newline logger in - let () = - Ode_loggers.declare_global logger (Ode_loggers_sig.N_ode_var) - in + let () = Ode_loggers.declare_global logger Ode_loggers_sig.N_ode_var in let () = Ode_loggers.declare_global logger Ode_loggers_sig.N_max_stoc_coef in let () = - Ode_loggers.declare_global logger (Ode_loggers_sig.Jacobian_var (1,1)) - in - let () = - Ode_loggers.declare_global logger (Ode_loggers_sig.Expr 1) - in - let () = - declare_rates_global logger network - in - let () = - declare_jacobian_rates_global logger network + Ode_loggers.declare_global logger (Ode_loggers_sig.Jacobian_var (1, 1)) in + let () = Ode_loggers.declare_global logger (Ode_loggers_sig.Expr 1) in + let () = declare_rates_global logger network in + let () = declare_jacobian_rates_global logger network in let () = List.iter (affect_var ~propagate_constants is_zero logger logger logger_err - ~init_mode:false compil network) split.var_decl in + ~init_mode:false compil network) + split.var_decl + in let () = Ode_loggers.print_newline logger in let () = List.iter - (fun (rule,coef_list) -> - List.iter - (fun coef -> - match coef with - | R rate -> + (fun (rule, coef_list) -> + List.iter + (fun coef -> + match coef with + | R rate -> Ode_loggers.associate ~propagate_constants (string_of_var_id ~compil logger) - logger logger logger_err - (var_of_rule rule) - rate (handler_expr network) - | S (n,rate) -> - Ode_loggers.associate ~propagate_constants - (string_of_var_id ~compil logger) - logger logger logger_err - (var_of_stoch rule n) - rate (handler_expr network) - ) - coef_list) + logger logger logger_err (var_of_rule rule) rate + (handler_expr network) + | S (n, rate) -> + Ode_loggers.associate ~propagate_constants + (string_of_var_id ~compil logger) + logger logger logger_err (var_of_stoch rule n) rate + (handler_expr network)) + coef_list) split.var_rate in let dep_var = List.fold_left (fun dep var -> - affect_deriv_var ~propagate_constants - is_zero logger logger logger_err compil network var dep) - Mods.IntMap.empty - split.var_decl + affect_deriv_var ~propagate_constants is_zero logger logger + logger_err compil network var dep) + Mods.IntMap.empty split.var_decl in let () = Ode_loggers.print_newline logger in let dep_rates = List.fold_left - (fun dep (rule,coef_list) -> - List.fold_left - (fun dep coef -> - match coef with - | R rate -> - affect_deriv_rate ~propagate_constants - dep_var - logger logger logger_err compil - rule rate network - dep - | S (n,rate) -> - affect_deriv_stoch ~propagate_constants - dep_var - logger logger logger_err compil - rule n rate network - dep) - dep coef_list - ) - VMAP.empty - split.var_rate + (fun dep (rule, coef_list) -> + List.fold_left + (fun dep coef -> + match coef with + | R rate -> + affect_deriv_rate ~propagate_constants dep_var logger logger + logger_err compil rule rate network dep + | S (n, rate) -> + affect_deriv_stoch ~propagate_constants dep_var logger logger + logger_err compil rule n rate network dep) + dep coef_list) + VMAP.empty split.var_rate in let () = Ode_loggers.print_newline logger in let do_it f l dep_set reactants enriched_rule nocc = List.iter (fun species -> - let nauto_in_species = - if I.do_we_count_in_embeddings compil - then - snd - (species_of_species_id network species) - else 1 - in - let nauto_in_lhs = enriched_rule.divide_rate_by in - f - logger (Ode_loggers_sig.Concentration species) - ~nauto_in_species ~nauto_in_lhs ~nocc - (var_of_rule enriched_rule) - reactants - dep_set) + let nauto_in_species = + if I.do_we_count_in_embeddings compil then + snd (species_of_species_id network species) + else + 1 + in + let nauto_in_lhs = enriched_rule.divide_rate_by in + f logger (Ode_loggers_sig.Concentration species) ~nauto_in_species + ~nauto_in_lhs ~nocc + (var_of_rule enriched_rule) + reactants dep_set) l in let () = - Ode_loggers.initialize - ~nodevar logger + Ode_loggers.initialize ~nodevar logger (Ode_loggers_sig.Jacobian - (network.fresh_ode_var_id,network.fresh_ode_var_id)) + (network.fresh_ode_var_id, network.fresh_ode_var_id)) in let () = List.iter - (fun ((reactants, products, token_vector, enriched_rule),nocc) -> - let dep_set = - match - VMAP.find_option - (var_of_rule enriched_rule) dep_rates - with - | Some set -> set - | None -> (Mods.IntSet.empty,Mods.IntSet.empty) - in - let dep_set_rate = - Mods.IntSet.union - (fst dep_set) - (snd dep_set) - in - let () = - if I.do_we_prompt_reactions compil - then - let rule_string = - Format.asprintf - "%a" (I.print_rule_name ~compil) - enriched_rule.rule - in - let tokens_prod = I.token_vector enriched_rule.rule in - let dump_token_list fmt list = - let _ = - List.fold_left - (fun bool ((alg,_),k) -> - let prefix = if bool then ", " else " | " in - let () = - Format.fprintf fmt "%s%a %a" - prefix - ( - Alg_expr.print - (fun fmt mixture -> - let () = Format.fprintf fmt "|" in - let - _ = - List.fold_left - ( - Array.fold_left - (fun bool connected_component -> - let prefix = - if bool then " , " - else "" in - let () = - Format.fprintf - fmt - "%s%a" - prefix - (I.print_connected_component ~compil) - connected_component - in true) - ) - false mixture - in - let () = Format.fprintf fmt "|" in - ()) - (I.print_token ~compil) - (fun fmt var_id -> - Format.fprintf fmt "%s" - (string_of_var_id - ~compil logger (succ var_id))) - ) - alg - (I.print_token ~compil) - k - in true - ) false (List.rev list) - in () - in - (*--------------------------------------------------*) - (*print rule in a comment format*) - let () = Ode_loggers.print_newline logger in - let () = - Ode_loggers.print_comment ~breakline logger - ("rule : "^rule_string) - in - let dump fmt list = - let compil = I.with_dot_and_plus compil in - let _ = - List.fold_left - (fun bool k -> - let prefix = - if bool then - Kade_backend.Utils.print_agent_sep_plus - (I.symbol_table compil) - else - Pp.empty - in - let species_string = - Format.asprintf "%a" - (fun log id -> - I.print_chemical_species - ~compil log - (fst - (Mods.DynArray.get - network.species_tab id))) - k - in - let () = - Format.fprintf fmt "%t%s" - prefix - species_string - in - true) - false - (List.rev list) - in () - in - let s = - Format.asprintf - "reaction: %a -> %a%a" - dump - reactants - dump - products - dump_token_list - tokens_prod - in - let () = Ode_loggers.print_comment ~breakline logger s in - () - in - (*--------------------------------------------------*) - let reactants' = - List.rev_map - (fun x -> - let nauto = snd - (species_of_species_id network x) - in - (x, - to_nocc_correct compil nauto)) - (List.rev reactants) - in - let nauto_in_lhs = enriched_rule.divide_rate_by in - let () = Ode_loggers.print_newline logger in - let () = - do_it - Ode_loggers.consume_jac - reactants - dep_set_rate - reactants' - enriched_rule - nocc - in - let () = - do_it - Ode_loggers.produce_jac - products - dep_set_rate - reactants' - enriched_rule - nocc - in - let _ = - List.fold_left - (fun n (token,_loc) -> - let dep_set_token_expr = - match - VMAP.find_option - (var_of_stoch enriched_rule n) dep_rates - with - | Some set -> set - | None -> (Mods.IntSet.empty,Mods.IntSet.empty) - in - let () = - Ode_loggers.update_token_jac - logger - (Ode_loggers_sig.Concentration token) - ~nauto_in_lhs ~nocc - (var_of_rule enriched_rule) - (var_of_stoch enriched_rule n) - reactants' - dep_set_rate - ~dep_mixture:(fst dep_set_token_expr) - ~dep_token:(snd dep_set_token_expr) - in n+1 - ) - 1 token_vector - in () - ) network.reactions + (fun ((reactants, products, token_vector, enriched_rule), nocc) -> + let dep_set = + match VMAP.find_option (var_of_rule enriched_rule) dep_rates with + | Some set -> set + | None -> Mods.IntSet.empty, Mods.IntSet.empty + in + let dep_set_rate = Mods.IntSet.union (fst dep_set) (snd dep_set) in + let () = + if I.do_we_prompt_reactions compil then ( + let rule_string = + Format.asprintf "%a" + (I.print_rule_name ~compil) + enriched_rule.rule + in + let tokens_prod = I.token_vector enriched_rule.rule in + let dump_token_list fmt list = + let _ = + List.fold_left + (fun bool ((alg, _), k) -> + let prefix = + if bool then + ", " + else + " | " + in + let () = + Format.fprintf fmt "%s%a %a" prefix + (Alg_expr.print + (fun fmt mixture -> + let () = Format.fprintf fmt "|" in + let _ = + List.fold_left + (Array.fold_left + (fun bool connected_component -> + let prefix = + if bool then + " , " + else + "" + in + let () = + Format.fprintf fmt "%s%a" prefix + (I.print_connected_component + ~compil) + connected_component + in + true)) + false mixture + in + let () = Format.fprintf fmt "|" in + ()) + (I.print_token ~compil) + (fun fmt var_id -> + Format.fprintf fmt "%s" + (string_of_var_id ~compil logger + (succ var_id)))) + alg (I.print_token ~compil) k + in + true) + false (List.rev list) + in + () + in + (*--------------------------------------------------*) + (*print rule in a comment format*) + let () = Ode_loggers.print_newline logger in + let () = + Ode_loggers.print_comment ~breakline logger + ("rule : " ^ rule_string) + in + let dump fmt list = + let compil = I.with_dot_and_plus compil in + let _ = + List.fold_left + (fun bool k -> + let prefix = + if bool then + Kade_backend.Utils.print_agent_sep_plus + (I.symbol_table compil) + else + Pp.empty + in + let species_string = + Format.asprintf "%a" + (fun log id -> + I.print_chemical_species ~compil log + (fst (Mods.DynArray.get network.species_tab id))) + k + in + let () = + Format.fprintf fmt "%t%s" prefix species_string + in + true) + false (List.rev list) + in + () + in + let s = + Format.asprintf "reaction: %a -> %a%a" dump reactants dump + products dump_token_list tokens_prod + in + let () = Ode_loggers.print_comment ~breakline logger s in + () + ) + in + (*--------------------------------------------------*) + let reactants' = + List.rev_map + (fun x -> + let nauto = snd (species_of_species_id network x) in + x, to_nocc_correct compil nauto) + (List.rev reactants) + in + let nauto_in_lhs = enriched_rule.divide_rate_by in + let () = Ode_loggers.print_newline logger in + let () = + do_it Ode_loggers.consume_jac reactants dep_set_rate reactants' + enriched_rule nocc + in + let () = + do_it Ode_loggers.produce_jac products dep_set_rate reactants' + enriched_rule nocc + in + let _ = + List.fold_left + (fun n (token, _loc) -> + let dep_set_token_expr = + match + VMAP.find_option (var_of_stoch enriched_rule n) dep_rates + with + | Some set -> set + | None -> Mods.IntSet.empty, Mods.IntSet.empty + in + let () = + Ode_loggers.update_token_jac logger + (Ode_loggers_sig.Concentration token) ~nauto_in_lhs ~nocc + (var_of_rule enriched_rule) + (var_of_stoch enriched_rule n) + reactants' dep_set_rate + ~dep_mixture:(fst dep_set_token_expr) + ~dep_token:(snd dep_set_token_expr) + in + n + 1) + 1 token_vector + in + ()) + network.reactions in (* Derivative of time is equal to 1 *) let () = Ode_loggers.close_procedure logger in @@ -3012,19 +2688,15 @@ let convert_obs parameters compil network = let () = Sbml_backend.line_dotnet_or_sbml logger logger_err in let () = Sbml_backend.open_box_dotnet logger logger_err label_dotnet in let () = Sbml_backend.line_dotnet logger logger_err in - let () = - Ode_loggers.open_procedure logger "Init" "ode_init" [] in + let () = Ode_loggers.open_procedure logger "Init" "ode_init" [] in let () = Ode_loggers.print_newline logger in - let () = - Ode_loggers.declare_global logger Ode_loggers_sig.N_ode_var - in + let () = Ode_loggers.declare_global logger Ode_loggers_sig.N_ode_var in let () = Ode_loggers.declare_global logger (Ode_loggers_sig.Init (get_last_ode_var_id network)) in let () = - Ode_loggers.initialize - ~nodevar logger + Ode_loggers.initialize ~nodevar logger (Ode_loggers_sig.Initbis (get_last_ode_var_id network)) in let () = Ode_loggers.print_newline logger in @@ -3036,92 +2708,86 @@ let convert_obs parameters compil network = && may_be_not_time_homogeneous network then () - else - let id, comment, units = - if may_be_not_time_homogeneous network && - k = get_fresh_ode_var_id network - 1 - then "time", "t", Some "substance" - else + else ( + let id, comment, units = + if + may_be_not_time_homogeneous network + && k = get_fresh_ode_var_id network - 1 + then + "time", "t", Some "substance" + else ( match network.fictitious_species with - | Some id when id=k -> - (string_of_int k), - "I()", - Some "" + | Some id when id = k -> string_of_int k, "I()", Some "" | Some _ | None -> let variable = Mods.DynArray.get network.ode_vars_tab k in - begin - match variable with - | Dummy -> "dummy", "", None - | Token id -> - begin - match Ode_loggers_sig.get_encoding_format logger with - | Loggers.SBML -> - "t"^(string_of_int k), - Format.asprintf "%a" - (fun log id -> - I.print_token ~compil log id) id, - (Some "substance") - | Loggers.DOTNET -> - (string_of_int k), - Format.asprintf "%a" - (fun log id -> - I.print_token ~compil log id) id, - (Some "substance") - | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph - | Loggers.GEPHI - | Loggers.Js_Graph - | Loggers.HTML_Tabular | Loggers.Json | Loggers.Maple - | Loggers.Mathematica | Loggers.Matlab | Loggers.Matrix - | Loggers.Octave | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS - -> "", Format.asprintf "%a" - (fun log k -> I.print_chemical_species ~compil log - (fst - (Mods.DynArray.get network.species_tab k)) - ) k, None - end - | Nembed _ | Noccurrences _ -> - match Ode_loggers_sig.get_encoding_format logger with - | Loggers.SBML -> - "s"^(string_of_int k), + (match variable with + | Dummy -> "dummy", "", None + | Token id -> + (match Ode_loggers_sig.get_encoding_format logger with + | Loggers.SBML -> + ( "t" ^ string_of_int k, + Format.asprintf "%a" + (fun log id -> I.print_token ~compil log id) + id, + Some "substance" ) + | Loggers.DOTNET -> + ( string_of_int k, + Format.asprintf "%a" + (fun log id -> I.print_token ~compil log id) + id, + Some "substance" ) + | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph + | Loggers.GEPHI | Loggers.Js_Graph | Loggers.HTML_Tabular + | Loggers.Json | Loggers.Maple | Loggers.Mathematica + | Loggers.Matlab | Loggers.Matrix | Loggers.Octave | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS -> + ( "", + Format.asprintf "%a" + (fun log k -> + I.print_chemical_species ~compil log + (fst (Mods.DynArray.get network.species_tab k))) + k, + None )) + | Nembed _ | Noccurrences _ -> + (match Ode_loggers_sig.get_encoding_format logger with + | Loggers.SBML -> + ( "s" ^ string_of_int k, + Format.asprintf "%a" + (fun log k -> + I.print_chemical_species ~compil log + (fst (Mods.DynArray.get network.species_tab k))) + k, + Some "substance" ) + | Loggers.DOTNET -> + let compil = I.to_dotnet compil in + ( string_of_int k, Format.asprintf "%a" - (fun log k -> I.print_chemical_species ~compil log - (fst - (Mods.DynArray.get network.species_tab k)) - ) k, Some "substance" - | Loggers.DOTNET -> - let compil = I.to_dotnet compil in - (string_of_int k), + (fun log k -> + I.print_chemical_species ~compil log + (fst (Mods.DynArray.get network.species_tab k))) + k, + Some "" ) + | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph + | Loggers.HTML_Tabular | Loggers.Json | Loggers.Js_Graph + | Loggers.Maple | Loggers.GEPHI | Loggers.Mathematica + | Loggers.Matlab | Loggers.Matrix | Loggers.Octave | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS -> + ( "", Format.asprintf "%a" - (fun log k -> I.print_chemical_species ~compil - log - (fst (Mods.DynArray.get network.species_tab k)) - ) k, Some "" - | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph - | Loggers.HTML_Tabular | Loggers.Json | Loggers.Js_Graph - | Loggers.Maple | Loggers.GEPHI - | Loggers.Mathematica | Loggers.Matlab | Loggers.Matrix - | Loggers.Octave | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS - -> "", Format.asprintf "%a" - (fun log k -> I.print_chemical_species ~compil log - (fst - (Mods.DynArray.get network.species_tab k)) - ) k, None - end + (fun log k -> + I.print_chemical_species ~compil log + (fst (Mods.DynArray.get network.species_tab k))) + k, + None ))) + ) in let () = Ode_loggers.declare_init ~comment logger k in let () = - Sbml_backend.dump_initial_species - ?units - logger - logger_err - (handler_expr network) - k - comment - id + Sbml_backend.dump_initial_species ?units logger logger_err + (handler_expr network) k comment id in aux (next_id k) + ) in let () = aux fst_id in let () = Ode_loggers.close_procedure logger in @@ -3135,121 +2801,107 @@ let convert_obs parameters compil network = let export_obs ~propagate_constants logger logger_err compil network split = let nodevar = get_last_ode_var_id network in let is_zero = fresh_is_zero network in - let () = - Ode_loggers.open_procedure logger "obs" "ode_obs" ["y"] in + let () = Ode_loggers.open_procedure logger "obs" "ode_obs" [ "y" ] in (* add t *) let () = Ode_loggers.print_newline logger in + let () = Ode_loggers.declare_global logger Ode_loggers_sig.N_obs in + let () = Ode_loggers.declare_global logger (Ode_loggers_sig.Expr 1) in let () = - Ode_loggers.declare_global logger Ode_loggers_sig.N_obs - in - let () = - Ode_loggers.declare_global logger (Ode_loggers_sig.Expr 1) - in - let () = - Ode_loggers.initialize - ~nodevar logger - (Ode_loggers_sig.Obs (network.n_obs)) + Ode_loggers.initialize ~nodevar logger (Ode_loggers_sig.Obs network.n_obs) in let () = Ode_loggers.print_newline logger in let () = - if obs_may_be_not_time_homogeneous network - then Ode_loggers.associate_t logger - (get_last_ode_var_id network) - else () + if obs_may_be_not_time_homogeneous network then + Ode_loggers.associate_t logger (get_last_ode_var_id network) + else + () in let titles = I.get_obs_titles compil in let () = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.DOTNET - | Loggers.Matlab | Loggers.Octave -> + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.DOTNET | Loggers.Matlab | Loggers.Octave -> List.iter - (affect_var ~propagate_constants is_zero logger logger logger_err ~init_mode:false compil - network) split.var_decl - | Loggers.Mathematica | Loggers.Maple - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML - | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT - | Loggers.TXT_Tabular | Loggers.XLS - | Loggers.SBML - | Loggers.Json - | Loggers.GEPHI - -> () + (affect_var ~propagate_constants is_zero logger logger logger_err + ~init_mode:false compil network) + split.var_decl + | Loggers.Mathematica | Loggers.Maple | Loggers.Matrix + | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular + | Loggers.XLS | Loggers.SBML | Loggers.Json | Loggers.GEPHI -> + () in let () = - if Sbml_backend.is_dotnet logger && - List.for_all - (fun (_id,expr) -> Ode_loggers.is_time expr) - network.obs - then (* No observable in the model *) + if + Sbml_backend.is_dotnet logger + && List.for_all + (fun (_id, expr) -> Ode_loggers.is_time expr) + network.obs + then + (* No observable in the model *) () - else + else ( let () = - Sbml_backend.do_dotnet logger logger_err - (fun log _ -> Ode_loggers.print_newline log) + Sbml_backend.do_dotnet logger logger_err (fun log _ -> + Ode_loggers.print_newline log) in let () = - Sbml_backend.open_box_dotnet logger logger_err - "begin groups" + Sbml_backend.open_box_dotnet logger logger_err "begin groups" in let () = - Sbml_backend.do_dotnet logger logger_err - (fun log _ -> Ode_loggers.print_newline log) + Sbml_backend.do_dotnet logger logger_err (fun log _ -> + Ode_loggers.print_newline log) in let () = Loggers.print_newline logger_err in let titles = List.fold_left - (fun titles (id,expr) -> - match titles with - | comment::tail -> - let () = - Ode_loggers.associate - ~comment ~propagate_constants - (string_of_var_id ~compil logger) - logger logger logger_err - (Ode_loggers_sig.Obs id) expr (handler_expr network) - in tail - | [] -> - let () = - Loggers.fprintf logger_err "Internal error, more obs than obs labels" - in titles ) + (fun titles (id, expr) -> + match titles with + | comment :: tail -> + let () = + Ode_loggers.associate ~comment ~propagate_constants + (string_of_var_id ~compil logger) + logger logger logger_err (Ode_loggers_sig.Obs id) expr + (handler_expr network) + in + tail + | [] -> + let () = + Loggers.fprintf logger_err + "Internal error, more obs than obs labels" + in + titles) titles network.obs in let () = - if not (titles = []) - then - Loggers.fprintf logger_err "Internal error, less obs than obs labels" + if not (titles = []) then + Loggers.fprintf logger_err + "Internal error, less obs than obs labels" in - let () = if Sbml_backend.is_dotnet logger then - Sbml_backend.close_box_dotnet logger logger_err - "end groups" + let () = + if Sbml_backend.is_dotnet logger then + Sbml_backend.close_box_dotnet logger logger_err "end groups" in let () = Ode_loggers.print_newline logger in () + ) in let () = Ode_loggers.close_procedure logger in let () = Ode_loggers.print_newline logger in let () = Ode_loggers.print_newline logger in () - let export_network - ~command_line ~command_line_quotes ?data_file ?init_t ~max_t - ?plot_period - ?compute_jacobian:(compute_jacobian=true) - ?propagate_constants:(propagate_constants=false) - ?show_time_advance:(show_time_advance=false) - ?nonnegative:(nonnegative=false) - ?initial_step:(initial_step=0.000001) - ?max_step:(max_step=0.02) - ?abstol:(abstol=0.001) - ?reltol:(reltol=0.001) - parameters logger logger_buffer (logger_err:Loggers.t) compil network = + let export_network ~command_line ~command_line_quotes ?data_file ?init_t + ~max_t ?plot_period ?(compute_jacobian = true) + ?(propagate_constants = false) ?(show_time_advance = false) + ?(nonnegative = false) ?(initial_step = 0.000001) ?(max_step = 0.02) + ?(abstol = 0.001) ?(reltol = 0.001) parameters logger logger_buffer + (logger_err : Loggers.t) compil network = let network = - if may_be_not_time_homogeneous network - then + if may_be_not_time_homogeneous network then (* add a spurious variable for time *) inc_fresh_ode_var_id network - else network + else + network in let network, sorted_rules_and_decl = split_rules_and_decl parameters compil network @@ -3257,141 +2909,107 @@ let convert_obs parameters compil network = let () = Format.printf "+ exporting the network... @." in let () = Format.printf "\t -main function @." in let () = - export_main - ~propagate_constants - ~compute_jacobian ~command_line ~command_line_quotes ?data_file ?init_t - ~max_t ~nonnegative ~initial_step ~max_step ~abstol ~reltol ?plot_period - logger - logger_buffer - logger_err - compil network sorted_rules_and_decl + export_main ~propagate_constants ~compute_jacobian ~command_line + ~command_line_quotes ?data_file ?init_t ~max_t ~nonnegative + ~initial_step ~max_step ~abstol ~reltol ?plot_period logger + logger_buffer logger_err compil network sorted_rules_and_decl in let () = Format.printf "\t -initial state @." in let () = export_init logger logger_err compil network in let () = - match - Ode_loggers_sig.formatter_of_logger logger - with + match Ode_loggers_sig.formatter_of_logger logger with | None -> () | Some fmt -> let () = Ode_loggers_sig.flush_buffer logger_buffer fmt in - Loggers.flush_and_clean logger_err fmt + Loggers.flush_and_clean logger_err fmt in let () = Format.printf "\t -ode system @." in let network = - export_dydt ~propagate_constants ~show_time_advance logger logger_err compil network sorted_rules_and_decl + export_dydt ~propagate_constants ~show_time_advance logger logger_err + compil network sorted_rules_and_decl in let () = - if compute_jacobian then + if compute_jacobian then ( let () = Format.printf "\t -jacobian @." in let () = - export_jac ~propagate_constants logger logger_err compil network sorted_rules_and_decl + export_jac ~propagate_constants logger logger_err compil network + sorted_rules_and_decl in () + ) in let () = Format.printf "\t -observables @." in let () = - export_obs - ~propagate_constants logger logger_err compil network sorted_rules_and_decl + export_obs ~propagate_constants logger logger_err compil network + sorted_rules_and_decl in let () = Ode_loggers.launch_main logger in let () = - export_main_follow_up - ~propagate_constants - ~nonnegative ~initial_step ~max_step ~reltol ~abstol ~compute_jacobian ~command_line ~command_line_quotes ?data_file ?init_t - ~max_t ?plot_period - logger logger_buffer logger_err compil network sorted_rules_and_decl + export_main_follow_up ~propagate_constants ~nonnegative ~initial_step + ~max_step ~reltol ~abstol ~compute_jacobian ~command_line + ~command_line_quotes ?data_file ?init_t ~max_t ?plot_period logger + logger_buffer logger_err compil network sorted_rules_and_decl in network let get_reactions network = let list = get_reactions network in - List.rev_map - (fun ((a,b,c,d),n)-> ((a,b,c,d.rule),n)) - (List.rev list) - -(*********************) -(*compute symmetries *) -(*********************) - -let compute_symmetries_from_model parameters compil network - contact_map = - (********************************************************) - (*initial_states*) - let network, chemical_species = - species_of_initial_state compil network (I.get_init compil) - in - (********************************************************) - let cache = network.cache in - let cache, symmetries = - I.detect_symmetries - parameters - compil - cache - chemical_species - contact_map - in - let network = - { - network with - cache = cache; - symmetries = Some symmetries } - in - network - -let set_to_forward_symmetries_from_model network = - match network.symmetries - with - | None -> - {network with sym_reduction = Symmetries.Ground} - | Some sym -> - begin - match sym.Symmetries.rules_and_alg_expr with - | None -> {network with sym_reduction = Symmetries.Ground} - | Some sym -> {network with sym_reduction = Symmetries.Forward sym} - end - - -let set_to_backward_symmetries_from_model network = - match network.symmetries - with - | None -> - {network with sym_reduction = Symmetries.Ground } - | Some sym -> - begin - match sym.Symmetries.rules_and_initial_states - with - | None -> - {network with sym_reduction = Symmetries.Ground } - | Some sym -> - {network with sym_reduction = Symmetries.Backward sym } - end - -let print_symmetries parameters compil network = - match network.symmetries with - | None -> () - | Some sym -> - I.print_symmetries - parameters - compil - sym - -let init_bwd_bisim_info network = - match network.sym_reduction with - | Symmetries.Backward red -> Some (I.init_bwd_bisim_info red) - | Symmetries.Forward _ | Symmetries.Ground -> None - -let _ = is_step_two -let _ = Init_decl -let _ = Var_decl "" -let _ = Init_value Dummy -let _ = var_id_of_decl -let _ = direction_of -let _ = may_be_time_homogeneous_gen -let _ = is_known_variable -let _ = last_fresh_obs_id -let _ = nembed_of_connected_component -let _ = translate_token -let _ = convert_one_obs + List.rev_map (fun ((a, b, c, d), n) -> (a, b, c, d.rule), n) (List.rev list) + + (*********************) + (*compute symmetries *) + (*********************) + let compute_symmetries_from_model parameters compil network contact_map = + (********************************************************) + (*initial_states*) + let network, chemical_species = + species_of_initial_state compil network (I.get_init compil) + in + (********************************************************) + let cache = network.cache in + let cache, symmetries = + I.detect_symmetries parameters compil cache chemical_species contact_map + in + let network = { network with cache; symmetries = Some symmetries } in + network + + let set_to_forward_symmetries_from_model network = + match network.symmetries with + | None -> { network with sym_reduction = Symmetries.Ground } + | Some sym -> + (match sym.Symmetries.rules_and_alg_expr with + | None -> { network with sym_reduction = Symmetries.Ground } + | Some sym -> { network with sym_reduction = Symmetries.Forward sym }) + + let set_to_backward_symmetries_from_model network = + match network.symmetries with + | None -> { network with sym_reduction = Symmetries.Ground } + | Some sym -> + (match sym.Symmetries.rules_and_initial_states with + | None -> { network with sym_reduction = Symmetries.Ground } + | Some sym -> { network with sym_reduction = Symmetries.Backward sym }) + + let print_symmetries parameters compil network = + match network.symmetries with + | None -> () + | Some sym -> I.print_symmetries parameters compil sym + + let init_bwd_bisim_info network = + match network.sym_reduction with + | Symmetries.Backward red -> Some (I.init_bwd_bisim_info red) + | Symmetries.Forward _ | Symmetries.Ground -> None + + let _ = is_step_two + let _ = Init_decl + let _ = Var_decl "" + let _ = Init_value Dummy + let _ = var_id_of_decl + let _ = direction_of + let _ = may_be_time_homogeneous_gen + let _ = is_known_variable + let _ = last_fresh_obs_id + let _ = nembed_of_connected_component + let _ = translate_token + let _ = convert_one_obs end diff --git a/core/odes/odes.mli b/core/odes/odes.mli index a0cb5be5d5..d194476da5 100644 --- a/core/odes/odes.mli +++ b/core/odes/odes.mli @@ -2,100 +2,117 @@ * Creation: 15/07/2016 * Last modification: Time-stamp: *) -module Make(I:Symmetry_interface_sig.Interface) : -sig +module Make (I : Symmetry_interface_sig.Interface) : sig type ode_var_id - type ('a,'b) network + type ('a, 'b) network type enriched_rule type rule_id type connected_component_id - val get_preprocessed_ast: Run_cli_args.t -> I.preprocessed_ast - val get_ast: Run_cli_args.t -> I.ast - val to_ast: I.ast -> Ast.parsing_compil - val preprocess: Run_cli_args.t -> I.ast -> I.preprocessed_ast + val get_preprocessed_ast : Run_cli_args.t -> I.preprocessed_ast + val get_ast : Run_cli_args.t -> I.ast + val to_ast : I.ast -> Ast.parsing_compil + val preprocess : Run_cli_args.t -> I.ast -> I.preprocessed_ast val get_compil : - debugMode:bool ->dotnet:bool -> + debug_mode:bool -> + dotnet:bool -> ?bwd_bisim:LKappa_group_action.bwd_bisim_info -> rule_rate_convention:Remanent_parameters_sig.rate_convention -> ?reaction_rate_convention:Remanent_parameters_sig.rate_convention -> - show_reactions:bool -> count:Ode_args.count -> + show_reactions:bool -> + count:Ode_args.count -> internal_meaning:Ode_args.count -> - compute_jacobian:bool -> Run_cli_args.t -> I.preprocessed_ast -> I.compil + compute_jacobian:bool -> + Run_cli_args.t -> + I.preprocessed_ast -> + I.compil - val init: I.compil -> (ode_var_id,Ode_loggers_sig.ode_var_id) network - val reset: I.compil -> (ode_var_id,Ode_loggers_sig.ode_var_id) network -> (ode_var_id,Ode_loggers_sig.ode_var_id) network + val init : I.compil -> (ode_var_id, Ode_loggers_sig.ode_var_id) network - val network_from_compil: + val reset : + I.compil -> + (ode_var_id, Ode_loggers_sig.ode_var_id) network -> + (ode_var_id, Ode_loggers_sig.ode_var_id) network + + val network_from_compil : ?max_size:int -> smash_reactions:bool -> ignore_obs:bool -> Remanent_parameters_sig.parameters -> I.compil -> - (ode_var_id,Ode_loggers_sig.ode_var_id) network -> - (ode_var_id,Ode_loggers_sig.ode_var_id) network - - val get_reactions: - ('a,'b) network -> - ((ode_var_id list * ode_var_id list * - ode_var_id Locality.annot list * I.rule)*int) list + (ode_var_id, Ode_loggers_sig.ode_var_id) network -> + (ode_var_id, Ode_loggers_sig.ode_var_id) network - val export_network: - command_line:string -> command_line_quotes:string -> - ?data_file:string -> ?init_t:float -> max_t:float -> ?plot_period:float -> + val get_reactions : + ('a, 'b) network -> + ((ode_var_id list * ode_var_id list * ode_var_id Loc.annoted list * I.rule) + * int) + list + + val export_network : + command_line:string -> + command_line_quotes:string -> + ?data_file:string -> + ?init_t:float -> + max_t:float -> + ?plot_period:float -> ?compute_jacobian:bool -> ?propagate_constants:bool -> ?show_time_advance:bool -> - ?nonnegative:bool -> ?initial_step:float -> ?max_step:float -> - ?abstol:float -> ?reltol:float -> + ?nonnegative:bool -> + ?initial_step:float -> + ?max_step:float -> + ?abstol:float -> + ?reltol:float -> Remanent_parameters_sig.parameters -> - Ode_loggers_sig.t -> Ode_loggers_sig.t -> Loggers.t -> + Ode_loggers_sig.t -> + Ode_loggers_sig.t -> + Loggers.t -> I.compil -> - (ode_var_id, Ode_loggers_sig.ode_var_id) network -> - (ode_var_id, Ode_loggers_sig.ode_var_id) network + (ode_var_id, Ode_loggers_sig.ode_var_id) network -> + (ode_var_id, Ode_loggers_sig.ode_var_id) network - val get_comment: enriched_rule -> string + val get_comment : enriched_rule -> string - val get_rule_id_with_mode: enriched_rule -> rule_id * Rule_modes.arity * Rule_modes.direction + val get_rule_id_with_mode : + enriched_rule -> rule_id * Rule_modes.arity * Rule_modes.direction val get_rule : enriched_rule -> I.rule - val get_lhs : enriched_rule -> I.pattern val get_lhs_cc : - enriched_rule -> - (connected_component_id * I.connected_component) list + enriched_rule -> (connected_component_id * I.connected_component) list val get_divide_rate_by : enriched_rule -> int (*rules*) - - val compute_symmetries_from_model: + val compute_symmetries_from_model : Remanent_parameters_sig.parameters -> I.compil -> (ode_var_id, Ode_loggers_sig.ode_var_id) network -> Public_data.contact_map -> (ode_var_id, Ode_loggers_sig.ode_var_id) network - val set_to_backward_symmetries_from_model: + + val set_to_backward_symmetries_from_model : (ode_var_id, Ode_loggers_sig.ode_var_id) network -> (ode_var_id, Ode_loggers_sig.ode_var_id) network - val set_to_forward_symmetries_from_model: + val set_to_forward_symmetries_from_model : (ode_var_id, Ode_loggers_sig.ode_var_id) network -> (ode_var_id, Ode_loggers_sig.ode_var_id) network - val print_symmetries: + val print_symmetries : Remanent_parameters_sig.parameters -> - I.compil -> (ode_var_id, Ode_loggers_sig.ode_var_id) network - -> unit - - val get_data: + I.compil -> (ode_var_id, Ode_loggers_sig.ode_var_id) network -> - int * int * int + unit + + val get_data : + (ode_var_id, Ode_loggers_sig.ode_var_id) network -> int * int * int - val init_bwd_bisim_info: + val init_bwd_bisim_info : (ode_var_id, Ode_loggers_sig.ode_var_id) network -> LKappa_group_action.bwd_bisim_info option end diff --git a/core/odes/sbml_backend.ml b/core/odes/sbml_backend.ml index 943bfc5b3d..9456673af5 100644 --- a/core/odes/sbml_backend.ml +++ b/core/odes/sbml_backend.ml @@ -1,33 +1,30 @@ -let print_comment logger_fmt logger_buf (s:string) : unit = - match Ode_loggers_sig.get_encoding_format logger_fmt - with +let print_comment logger_fmt logger_buf (s : string) : unit = + match Ode_loggers_sig.get_encoding_format logger_fmt with | Loggers.DOTNET -> let () = Loggers.fprintf logger_buf "# %s" s in - let () = Loggers.print_newline logger_buf in () + let () = Loggers.print_newline logger_buf in + () | Loggers.SBML -> let () = Loggers.fprintf logger_buf "" s in - let () = Loggers.print_newline logger_buf in () - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular | Loggers.GEPHI - | Loggers.XLS | Loggers.Octave | Loggers.Mathematica + let () = Loggers.print_newline logger_buf in + () + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular + | Loggers.GEPHI | Loggers.XLS | Loggers.Octave | Loggers.Mathematica | Loggers.Matlab | Loggers.Maple | Loggers.Json -> () let warn_with_pos __POS__ loc m logger logger_err = - let (a,b,c,d) = __POS__ in - let s = Printf.sprintf "%s%s %s %i %i %i" loc m a b c d in + let a, b, c, d = __POS__ in + let s = Printf.sprintf "%s%s %s %i %i %i" loc m a b c d in let () = Printf.printf "%s\n" s in - let () = - print_comment - logger logger_err s - in () + let () = print_comment logger logger_err s in + () let warn_without_pos loc m logger logger_err = let s = Printf.sprintf "%s%s" loc m in let () = Printf.printf "%s\n" s in - let () = - print_comment logger logger_err s - in + let () = print_comment logger logger_err s in () let warn ?pos loc m logger logger_err = @@ -36,94 +33,72 @@ let warn ?pos loc m logger logger_err = | Some pos -> warn_with_pos pos loc m logger logger_err let warn_expr ?pos expr m logger logger_err = - let loc = Locality.to_string (snd expr) in + let loc = Loc.to_string (snd expr) in warn ?pos loc m logger logger_err let do_sbml logger logger_err f = -match - Ode_loggers_sig.get_encoding_format logger -with -| Loggers.SBML -> - f logger logger_err -| Loggers.DOTNET -| Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular -| Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular -| Loggers.XLS | Loggers.Octave | Loggers.Mathematica | Loggers.GEPHI -| Loggers.Matlab | Loggers.Maple | Loggers.Json -> () + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.SBML -> f logger logger_err + | Loggers.DOTNET | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Octave | Loggers.Mathematica + | Loggers.GEPHI | Loggers.Matlab | Loggers.Maple | Loggers.Json -> + () let do_dotnet logger logger_err f = - match - Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.DOTNET -> f logger logger_err - | Loggers.SBML - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS | Loggers.Octave | Loggers.Mathematica | Loggers.GEPHI - | Loggers.Matlab | Loggers.Maple | Loggers.Json -> () + | Loggers.SBML | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Octave | Loggers.Mathematica + | Loggers.GEPHI | Loggers.Matlab | Loggers.Maple | Loggers.Json -> + () let is_dotnet logger = - match - Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.DOTNET -> true - | Loggers.SBML - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS | Loggers.Octave | Loggers.Mathematica | Loggers.GEPHI - | Loggers.Matlab | Loggers.Maple | Loggers.Json -> false + | Loggers.SBML | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Octave | Loggers.Mathematica + | Loggers.GEPHI | Loggers.Matlab | Loggers.Maple | Loggers.Json -> + false let is_sbml logger = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.SBML -> true - | Loggers.DOTNET - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS | Loggers.Octave | Loggers.Mathematica | Loggers.GEPHI - | Loggers.Matlab | Loggers.Maple | Loggers.Json -> false - -let is_dotnet_or_sbml logger = - match - Ode_loggers_sig.get_encoding_format logger - with - | Loggers.DOTNET + match Ode_loggers_sig.get_encoding_format logger with | Loggers.SBML -> true - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular + | Loggers.DOTNET | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph + | Loggers.HTML | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT + | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Octave | Loggers.Mathematica + | Loggers.GEPHI | Loggers.Matlab | Loggers.Maple | Loggers.Json -> + false + +let is_dotnet_or_sbml logger = + match Ode_loggers_sig.get_encoding_format logger with + | Loggers.DOTNET | Loggers.SBML -> true + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Octave | Loggers.Mathematica | Loggers.GEPHI - | Loggers.Matlab | Loggers.Maple | Loggers.Json -> false + | Loggers.Matlab | Loggers.Maple | Loggers.Json -> + false let do_dotnet_or_sbml logger logger_err f = - if is_dotnet_or_sbml logger - then - f logger logger_err + if is_dotnet_or_sbml logger then f logger logger_err let do_not_sbml logger logger_err f = - if not (is_sbml logger) - then - f logger logger_err + if not (is_sbml logger) then f logger logger_err let do_not_dotnet logger logger_err f = - if not (is_dotnet logger) - then - f logger logger_err + if not (is_dotnet logger) then f logger logger_err let do_neither_dotnet_nor_sbml logger logger_err f = - if not (is_dotnet_or_sbml logger) - then - f logger logger_err + if not (is_dotnet_or_sbml logger) then f logger logger_err -let lift0 f = - (fun logger _ -> f logger) -let lift1 f = - (fun logger _ s -> f logger s) +let lift0 f logger _ = f logger +let lift1 f logger _ s = f logger s let print_sbml logger logger_err s = do_sbml logger logger_err - (lift0 (fun logger -> - Ode_loggers_sig.fprintf logger "%s" s)) + (lift0 (fun logger -> Ode_loggers_sig.fprintf logger "%s" s)) let print_dotnet logger logger_err s = do_dotnet logger logger_err @@ -135,151 +110,126 @@ let break_dotnet_or_sbml logger logger_err = (lift0 Ode_loggers_sig.print_breakable_hint) let line_dotnet_or_sbml logger logger_err = - do_dotnet_or_sbml logger logger_err - (lift0 Ode_loggers_sig.print_newline) + do_dotnet_or_sbml logger logger_err (lift0 Ode_loggers_sig.print_newline) let line_dotnet logger logger_err = - do_dotnet logger logger_err - (lift0 Ode_loggers_sig.print_newline) + do_dotnet logger logger_err (lift0 Ode_loggers_sig.print_newline) let line_sbml logger logger_err = - do_sbml logger logger_err - (lift0 Ode_loggers_sig.print_newline) + do_sbml logger logger_err (lift0 Ode_loggers_sig.print_newline) let extend s = - if s="" || String.sub s 0 1 = " " then s else " "^s + if s = "" || String.sub s 0 1 = " " then + s + else + " " ^ s -let open_box ?options:(options=fun () -> "") logger logger_err label = - print_sbml logger logger_err ("<"^label^(extend (options ()))^">"); +let open_box ?(options = fun () -> "") logger logger_err label = + print_sbml logger logger_err ("<" ^ label ^ extend (options ()) ^ ">"); break_dotnet_or_sbml logger logger_err -let open_box_dotnet - ?options_dotnet:(options_dotnet=fun () -> "") logger logger_err label - = - print_dotnet - logger logger_err (label^(extend (options_dotnet ()))); +let open_box_dotnet ?(options_dotnet = fun () -> "") logger logger_err label = + print_dotnet logger logger_err (label ^ extend (options_dotnet ())); break_dotnet_or_sbml logger logger_err let close_box logger logger_err label = - print_sbml logger logger_err (""); + print_sbml logger logger_err (""); line_sbml logger logger_err let close_box_dotnet logger logger_err label = - print_dotnet logger logger_err label ; + print_dotnet logger logger_err label; line_dotnet logger logger_err -let single_box ?options:(options=fun () -> "") logger logger_err label = +let single_box ?(options = fun () -> "") logger logger_err label = let () = do_sbml logger logger_err (fun logger logger_err -> let () = - print_sbml logger logger_err ("<"^label^(extend (options ()))^"/>") + print_sbml logger logger_err ("<" ^ label ^ extend (options ()) ^ "/>") in line_dotnet_or_sbml logger logger_err) in let () = do_dotnet logger logger_err (fun logger logger_err -> - let () = - print_dotnet logger logger_err (label^(extend (options ()))) - in - line_dotnet_or_sbml logger logger_err ) + let () = print_dotnet logger logger_err (label ^ extend (options ())) in + line_dotnet_or_sbml logger logger_err) in () let potential_break break logger logger_err = - if break - then + if break then line_dotnet_or_sbml logger logger_err else break_dotnet_or_sbml logger logger_err -let add_box ?break:(break=false) - ?options:(options=fun () -> "") - ?options_dotnet:(options_dotnet=fun () -> "") - logger - logger_err - label_sbml label_dotnet +let add_box ?(break = false) ?(options = fun () -> "") + ?(options_dotnet = fun () -> "") logger logger_err label_sbml label_dotnet cont = let () = - do_sbml logger logger_err - (fun logger logger_err -> + do_sbml logger logger_err (fun logger logger_err -> let () = open_box ~options logger logger_err label_sbml in let () = potential_break break logger logger_err in let () = do_sbml logger logger_err cont in let () = close_box logger logger_err label_sbml in ()) in - do_dotnet logger logger_err - (fun logger logger_err -> + do_dotnet logger logger_err (fun logger logger_err -> let () = open_box_dotnet ~options_dotnet logger logger_err label_dotnet in let () = do_dotnet logger logger_err cont in let () = close_box_dotnet logger logger_err label_dotnet in ()) -let add_box_in_sbml_only - ?break:(break=false) ?options:(options=fun () -> "") - logger logger_err label cont = +let add_box_in_sbml_only ?(break = false) ?(options = fun () -> "") logger + logger_err label cont = let () = - do_sbml logger logger_err - (fun logger logger_err -> - add_box ~break ~options logger logger_err label "" cont) + do_sbml logger logger_err (fun logger logger_err -> + add_box ~break ~options logger logger_err label "" cont) in - let () = do_dotnet logger logger_err cont in () + let () = do_dotnet logger logger_err cont in + () let clean_variable_id = - String.map - (function - | '(' -> '_' - | ')' -> ' ' - | x -> x ) + String.map (function + | '(' -> '_' + | ')' -> ' ' + | x -> x) let string_in_comment s = let s = String.map - (fun x -> - match x with - | '\'' -> ' ' - | _ -> x ) - s + (fun x -> + match x with + | '\'' -> ' ' + | _ -> x) + s in let size = String.length s in let rec aux k s = - if k+1=size - then Bytes.to_string s - else + if k + 1 = size then + Bytes.to_string s + else ( let () = - if Bytes.get s k ='-' && Bytes.get s (k+1) = '-' - then + if Bytes.get s k = '-' && Bytes.get s (k + 1) = '-' then Bytes.set s k ' ' in - aux (k+1) s - in aux 0 (Bytes.of_string s) + aux (k + 1) s + ) + in + aux 0 (Bytes.of_string s) let string_of_variable logger string_of_var_id variable = match variable with - | Ode_loggers_sig.Expr i -> - string_of_var_id logger i - | Ode_loggers_sig.Concentration i -> "s"^(string_of_int i) - | Ode_loggers_sig.Init _ - | Ode_loggers_sig.Initbis _ - | Ode_loggers_sig.Deriv _ - | Ode_loggers_sig.Obs _ - | Ode_loggers_sig.Jacobian _ - | Ode_loggers_sig.Jacobian_var _ - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.Tend - | Ode_loggers_sig.Period_t_points - | Ode_loggers_sig.N_rules - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.Tmp -> Ode_loggers_sig.string_of_array_name variable + | Ode_loggers_sig.Expr i -> string_of_var_id logger i + | Ode_loggers_sig.Concentration i -> "s" ^ string_of_int i + | Ode_loggers_sig.Init _ | Ode_loggers_sig.Initbis _ | Ode_loggers_sig.Deriv _ + | Ode_loggers_sig.Obs _ | Ode_loggers_sig.Jacobian _ + | Ode_loggers_sig.Jacobian_var _ | Ode_loggers_sig.Tinit + | Ode_loggers_sig.Tend | Ode_loggers_sig.Period_t_points + | Ode_loggers_sig.N_rules | Ode_loggers_sig.N_ode_var | Ode_loggers_sig.N_var + | Ode_loggers_sig.N_obs | Ode_loggers_sig.N_rows + | Ode_loggers_sig.N_max_stoc_coef | Ode_loggers_sig.InitialStep + | Ode_loggers_sig.NonNegative | Ode_loggers_sig.MaxStep + | Ode_loggers_sig.RelTol | Ode_loggers_sig.AbsTol | Ode_loggers_sig.Tmp -> + Ode_loggers_sig.string_of_array_name variable | Ode_loggers_sig.Current_time -> "t" | Ode_loggers_sig.Time_scale_factor -> "t_scale_factor" | Ode_loggers_sig.Rate int -> @@ -306,101 +256,66 @@ let string_of_variable logger string_of_var_id variable = Ode_loggers_sig.allocate_fresh_name logger s "_" else s - | Ode_loggers_sig.Stochiometric_coef (int1,int2) -> + | Ode_loggers_sig.Stochiometric_coef (int1, int2) -> Printf.sprintf "stoc%i.%i" int1 int2 | Ode_loggers_sig.Jacobian_stochiometric_coef _ - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rateund _ -> + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rated _ + | Ode_loggers_sig.Jacobian_rateun _ | Ode_loggers_sig.Jacobian_rateund _ -> raise (ExceptionDefn.Internal_Error - ("SBML does not support differentiation",Locality.dummy)) + ("SBML does not support differentiation", Loc.dummy)) let unit_of_variable variable = match variable with - | Ode_loggers_sig.Period_t_points - | Ode_loggers_sig.Tinit - | Ode_loggers_sig.InitialStep - | Ode_loggers_sig.MaxStep - | Ode_loggers_sig.Tend -> Some "time" - | Ode_loggers_sig.Current_time - | Ode_loggers_sig.RelTol - | Ode_loggers_sig.AbsTol - | Ode_loggers_sig.Obs _ - | Ode_loggers_sig.Init _ - | Ode_loggers_sig.Concentration _ - | Ode_loggers_sig.Stochiometric_coef _ - | Ode_loggers_sig.Initbis _ -> Some "substance" + | Ode_loggers_sig.Period_t_points | Ode_loggers_sig.Tinit + | Ode_loggers_sig.InitialStep | Ode_loggers_sig.MaxStep | Ode_loggers_sig.Tend + -> + Some "time" + | Ode_loggers_sig.Current_time | Ode_loggers_sig.RelTol + | Ode_loggers_sig.AbsTol | Ode_loggers_sig.Obs _ | Ode_loggers_sig.Init _ + | Ode_loggers_sig.Concentration _ | Ode_loggers_sig.Stochiometric_coef _ + | Ode_loggers_sig.Initbis _ -> + Some "substance" | Ode_loggers_sig.Time_scale_factor -> Some "time_per_substance" - | Ode_loggers_sig.NonNegative - | Ode_loggers_sig.Expr _ - | Ode_loggers_sig.Deriv _ - | Ode_loggers_sig.Jacobian _ - | Ode_loggers_sig.Jacobian_var _ - | Ode_loggers_sig.Rate _ - | Ode_loggers_sig.Rated _ - | Ode_loggers_sig.Rateun _ - | Ode_loggers_sig.Rateund _ - | Ode_loggers_sig.Jacobian_stochiometric_coef _ - | Ode_loggers_sig.Jacobian_rate _ - | Ode_loggers_sig.Jacobian_rated _ - | Ode_loggers_sig.Jacobian_rateun _ - | Ode_loggers_sig.Jacobian_rateund _ - | Ode_loggers_sig.N_rules - | Ode_loggers_sig.N_ode_var - | Ode_loggers_sig.N_var - | Ode_loggers_sig.N_obs - | Ode_loggers_sig.N_rows - | Ode_loggers_sig.N_max_stoc_coef - | Ode_loggers_sig.Tmp -> None + | Ode_loggers_sig.NonNegative | Ode_loggers_sig.Expr _ + | Ode_loggers_sig.Deriv _ | Ode_loggers_sig.Jacobian _ + | Ode_loggers_sig.Jacobian_var _ | Ode_loggers_sig.Rate _ + | Ode_loggers_sig.Rated _ | Ode_loggers_sig.Rateun _ + | Ode_loggers_sig.Rateund _ | Ode_loggers_sig.Jacobian_stochiometric_coef _ + | Ode_loggers_sig.Jacobian_rate _ | Ode_loggers_sig.Jacobian_rated _ + | Ode_loggers_sig.Jacobian_rateun _ | Ode_loggers_sig.Jacobian_rateund _ + | Ode_loggers_sig.N_rules | Ode_loggers_sig.N_ode_var | Ode_loggers_sig.N_var + | Ode_loggers_sig.N_obs | Ode_loggers_sig.N_rows + | Ode_loggers_sig.N_max_stoc_coef | Ode_loggers_sig.Tmp -> + None let meta_id_of_logger logger = - "CMD"^(string_of_int (Ode_loggers_sig.get_fresh_meta_id logger)) + "CMD" ^ string_of_int (Ode_loggers_sig.get_fresh_meta_id logger) let dotnet_id_of_logger logger = - (string_of_int (Ode_loggers_sig.get_fresh_meta_id logger)) + string_of_int (Ode_loggers_sig.get_fresh_meta_id logger) -let print_parameters - string_of_var_id logger logger_buffer logger_err variable expr = +let print_parameters string_of_var_id logger logger_buffer logger_err variable + expr = let unit_string = - match - unit_of_variable variable - with + match unit_of_variable variable with | None -> "" - | Some x -> " units=\""^x^"\"" + | Some x -> " units=\"" ^ x ^ "\"" in let id = string_of_variable logger string_of_var_id variable in - let () = Ode_loggers_sig.set_id_of_global_parameter logger variable id in + let () = Ode_loggers_sig.set_id_of_global_parameter logger variable id in let () = - do_sbml logger logger_err - (fun logger logger_err -> - single_box - logger_buffer - logger_err - "parameter" - ~options:(fun () -> - Format.sprintf - "metaid=\"%s\" id=\"%s\" value=\"%s\"%s" - (meta_id_of_logger logger) - id - (Nbr.to_string expr) - unit_string) - ) + do_sbml logger logger_err (fun logger logger_err -> + single_box logger_buffer logger_err "parameter" ~options:(fun () -> + Format.sprintf "metaid=\"%s\" id=\"%s\" value=\"%s\"%s" + (meta_id_of_logger logger) id (Nbr.to_string expr) unit_string)) in let () = - do_dotnet logger logger_err - (fun logger logger_err -> - single_box - logger_buffer - logger_err - "" - ~options:(fun () -> - Format.sprintf - "%s %s %s" - (dotnet_id_of_logger logger) - id - (Nbr.to_string expr))) + do_dotnet logger logger_err (fun logger logger_err -> + single_box logger_buffer logger_err "" ~options:(fun () -> + Format.sprintf "%s %s %s" + (dotnet_id_of_logger logger) + id (Nbr.to_string expr))) in () @@ -416,268 +331,222 @@ let unsome expr_opt = let rec eval_init_alg_expr logger network_handler alg_expr = match fst alg_expr with - | Alg_expr.CONST x -> x + | Alg_expr.CONST x -> x | Alg_expr.ALG_VAR x -> let id = network_handler.Network_handler.int_of_obs x in let expr_opt = Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) in eval_init_alg_expr logger network_handler (unsome expr_opt) | Alg_expr.KAPPA_INSTANCE x -> - let id = network_handler.Network_handler.int_of_kappa_instance x in + let id = network_handler.Network_handler.int_of_kappa_instance x in let expr_opt = Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Init id) in eval_init_alg_expr logger network_handler (unsome expr_opt) | Alg_expr.TOKEN_ID x -> let id = network_handler.Network_handler.int_of_token_id x in let expr_opt = Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Init id) in eval_init_alg_expr logger network_handler (unsome expr_opt) - | Alg_expr.STATE_ALG_OP (Operator.TMAX_VAR) -> + | Alg_expr.STATE_ALG_OP Operator.TMAX_VAR -> let expr_opt = Ode_loggers_sig.get_expr logger Ode_loggers_sig.Tend in eval_init_alg_expr logger network_handler (unsome expr_opt) | Alg_expr.STATE_ALG_OP - ( Operator.CPUTIME - | Operator.TIME_VAR - | Operator.EVENT_VAR - | Operator.EMAX_VAR - | Operator.NULL_EVENT_VAR ) -> Nbr.zero + ( Operator.CPUTIME | Operator.TIME_VAR | Operator.EVENT_VAR + | Operator.EMAX_VAR | Operator.NULL_EVENT_VAR ) -> + Nbr.zero | Alg_expr.BIN_ALG_OP (op, a, b) -> - Nbr.of_bin_alg_op - op + Nbr.of_bin_alg_op op (eval_init_alg_expr logger network_handler a) (eval_init_alg_expr logger network_handler b) | Alg_expr.UN_ALG_OP (op, a) -> - Nbr.of_un_alg_op - op - (eval_init_alg_expr logger network_handler a) + Nbr.of_un_alg_op op (eval_init_alg_expr logger network_handler a) | Alg_expr.IF (cond, yes, no) -> - if eval_init_bool_expr logger network_handler cond - then + if eval_init_bool_expr logger network_handler cond then eval_init_alg_expr logger network_handler yes else eval_init_alg_expr logger network_handler no - | (Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _) -> + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ -> raise (ExceptionDefn.Internal_Error - ("SBML does not support differentiation",snd alg_expr)) + ("SBML does not support differentiation", snd alg_expr)) + and eval_init_bool_expr logger network_handler expr = match fst expr with | Alg_expr.TRUE -> true | Alg_expr.FALSE -> false - | Alg_expr.COMPARE_OP (op,a,b) -> + | Alg_expr.COMPARE_OP (op, a, b) -> Nbr.of_compare_op op (eval_init_alg_expr logger network_handler a) (eval_init_alg_expr logger network_handler b) - | Alg_expr.UN_BOOL_OP (Operator.NOT,a) -> - not - (eval_init_bool_expr logger network_handler a) - | Alg_expr.BIN_BOOL_OP (op,a,b) -> + | Alg_expr.UN_BOOL_OP (Operator.NOT, a) -> + not (eval_init_bool_expr logger network_handler a) + | Alg_expr.BIN_BOOL_OP (op, a, b) -> of_bool_op op (eval_init_bool_expr logger network_handler a) (eval_init_bool_expr logger network_handler b) let rec propagate_def_in_alg_expr_p p logger network_handler alg_expr = match alg_expr with - | Alg_expr.CONST _,_ - | Alg_expr.TOKEN_ID _,_ - | Alg_expr.KAPPA_INSTANCE _,_ -> alg_expr - | Alg_expr.ALG_VAR x,loc -> + | Alg_expr.CONST _, _ | Alg_expr.TOKEN_ID _, _ | Alg_expr.KAPPA_INSTANCE _, _ + -> + alg_expr + | Alg_expr.ALG_VAR x, loc -> let id = network_handler.Network_handler.int_of_obs x in let expr_opt = Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) in let expr = unsome expr_opt in - if p logger id x expr - then - fst (propagate_def_in_alg_expr_p p logger network_handler expr),loc - else alg_expr - | Alg_expr.STATE_ALG_OP (Operator.TMAX_VAR),loc -> + if p logger id x expr then + fst (propagate_def_in_alg_expr_p p logger network_handler expr), loc + else + alg_expr + | Alg_expr.STATE_ALG_OP Operator.TMAX_VAR, loc -> let expr_opt = Ode_loggers_sig.get_expr logger Ode_loggers_sig.Tend in - fst (propagate_def_in_alg_expr_p p logger network_handler (unsome expr_opt)),loc - | Alg_expr.STATE_ALG_OP - ( Operator.CPUTIME - | Operator.TIME_VAR - | Operator.EVENT_VAR - | Operator.EMAX_VAR - | Operator.NULL_EVENT_VAR ),loc -> - Alg_expr.CONST Nbr.zero,loc - | Alg_expr.BIN_ALG_OP (op, a, b),loc -> - Alg_expr.BIN_ALG_OP ( - op, - (propagate_def_in_alg_expr_p p logger network_handler a), - (propagate_def_in_alg_expr_p p logger network_handler b)),loc - | Alg_expr.UN_ALG_OP (op, a),loc -> - Alg_expr.UN_ALG_OP ( - op, - (propagate_def_in_alg_expr_p p logger network_handler a)),loc - | Alg_expr.IF (cond, yes, no),loc -> - Alg_expr.IF - (propagate_def_in_bool_expr_p p logger network_handler cond, - propagate_def_in_alg_expr_p p logger network_handler yes, - propagate_def_in_alg_expr_p p logger network_handler no), loc - | (Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),pos -> + ( fst + (propagate_def_in_alg_expr_p p logger network_handler (unsome expr_opt)), + loc ) + | ( Alg_expr.STATE_ALG_OP + ( Operator.CPUTIME | Operator.TIME_VAR | Operator.EVENT_VAR + | Operator.EMAX_VAR | Operator.NULL_EVENT_VAR ), + loc ) -> + Alg_expr.CONST Nbr.zero, loc + | Alg_expr.BIN_ALG_OP (op, a, b), loc -> + ( Alg_expr.BIN_ALG_OP + ( op, + propagate_def_in_alg_expr_p p logger network_handler a, + propagate_def_in_alg_expr_p p logger network_handler b ), + loc ) + | Alg_expr.UN_ALG_OP (op, a), loc -> + ( Alg_expr.UN_ALG_OP + (op, propagate_def_in_alg_expr_p p logger network_handler a), + loc ) + | Alg_expr.IF (cond, yes, no), loc -> + ( Alg_expr.IF + ( propagate_def_in_bool_expr_p p logger network_handler cond, + propagate_def_in_alg_expr_p p logger network_handler yes, + propagate_def_in_alg_expr_p p logger network_handler no ), + loc ) + | (Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _), pos -> raise (ExceptionDefn.Internal_Error - ("SBML does not support differentiation",pos)) + ("SBML does not support differentiation", pos)) + and propagate_def_in_bool_expr_p p logger network_handler expr = match expr with - | Alg_expr.TRUE,_ - | Alg_expr.FALSE,_ -> expr - | Alg_expr.COMPARE_OP (op,a,b),loc -> - Alg_expr.COMPARE_OP - (op, - (propagate_def_in_alg_expr_p p logger network_handler a), - (propagate_def_in_alg_expr_p p logger network_handler b)), - loc - | Alg_expr.BIN_BOOL_OP (op,a,b),loc -> - Alg_expr.BIN_BOOL_OP - (op, - (propagate_def_in_bool_expr_p p logger network_handler a), - (propagate_def_in_bool_expr_p p logger network_handler b)), - loc - | Alg_expr.UN_BOOL_OP (op,a),loc -> - Alg_expr.UN_BOOL_OP - (op, - (propagate_def_in_bool_expr_p p logger network_handler a)), - loc + | Alg_expr.TRUE, _ | Alg_expr.FALSE, _ -> expr + | Alg_expr.COMPARE_OP (op, a, b), loc -> + ( Alg_expr.COMPARE_OP + ( op, + propagate_def_in_alg_expr_p p logger network_handler a, + propagate_def_in_alg_expr_p p logger network_handler b ), + loc ) + | Alg_expr.BIN_BOOL_OP (op, a, b), loc -> + ( Alg_expr.BIN_BOOL_OP + ( op, + propagate_def_in_bool_expr_p p logger network_handler a, + propagate_def_in_bool_expr_p p logger network_handler b ), + loc ) + | Alg_expr.UN_BOOL_OP (op, a), loc -> + ( Alg_expr.UN_BOOL_OP + (op, propagate_def_in_bool_expr_p p logger network_handler a), + loc ) let propagate_dep_in_alg_expr a b c = - propagate_def_in_alg_expr_p (fun _ _ _ _ -> true ) a b c + propagate_def_in_alg_expr_p (fun _ _ _ _ -> true) a b c let propagate_dangerous_var_names_in_alg_expr a b c = if is_dotnet a then propagate_def_in_alg_expr_p - (fun logger id _ _ -> - Ode_loggers_sig.is_dangerous_ode_variable logger - ((Ode_loggers_sig.Expr id))) + (fun logger id _ _ -> + Ode_loggers_sig.is_dangerous_ode_variable logger + (Ode_loggers_sig.Expr id)) a b c - else c + else + c let rec eval_const_alg_expr logger network_handler alg_expr = match fst alg_expr with | Alg_expr.CONST x -> Some x - | Alg_expr.TOKEN_ID _ - | Alg_expr.KAPPA_INSTANCE _ -> None + | Alg_expr.TOKEN_ID _ | Alg_expr.KAPPA_INSTANCE _ -> None | Alg_expr.ALG_VAR x -> let id = network_handler.Network_handler.int_of_obs x in let expr_opt = Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) in eval_const_alg_expr logger network_handler (unsome expr_opt) - | Alg_expr.STATE_ALG_OP (Operator.TMAX_VAR) -> + | Alg_expr.STATE_ALG_OP Operator.TMAX_VAR -> let expr_opt = Ode_loggers_sig.get_expr logger Ode_loggers_sig.Tend in eval_const_alg_expr logger network_handler (unsome expr_opt) | Alg_expr.STATE_ALG_OP - ( Operator.CPUTIME - | Operator.TIME_VAR - | Operator.EVENT_VAR - | Operator.EMAX_VAR - | Operator.NULL_EVENT_VAR ) -> Some (Nbr.zero) + ( Operator.CPUTIME | Operator.TIME_VAR | Operator.EVENT_VAR + | Operator.EMAX_VAR | Operator.NULL_EVENT_VAR ) -> + Some Nbr.zero | Alg_expr.BIN_ALG_OP (op, a, b) -> - let const_a_opt = - eval_const_alg_expr logger network_handler a - in - let const_b_opt = - eval_const_alg_expr logger network_handler b - in - begin - match const_a_opt, const_b_opt with - | None, _ | _,None -> None - | Some a, Some b -> - Some (Nbr.of_bin_alg_op op a b) - end + let const_a_opt = eval_const_alg_expr logger network_handler a in + let const_b_opt = eval_const_alg_expr logger network_handler b in + (match const_a_opt, const_b_opt with + | None, _ | _, None -> None + | Some a, Some b -> Some (Nbr.of_bin_alg_op op a b)) | Alg_expr.UN_ALG_OP (op, a) -> - let const_a_opt = - eval_const_alg_expr logger network_handler a - in - begin - match const_a_opt with - | None -> None - | Some a -> - Some (Nbr.of_un_alg_op op a ) - end + let const_a_opt = eval_const_alg_expr logger network_handler a in + (match const_a_opt with + | None -> None + | Some a -> Some (Nbr.of_un_alg_op op a)) | Alg_expr.IF (cond, yes, no) -> - let const_cond_opt = - eval_const_bool_expr logger network_handler cond - in - begin - match const_cond_opt with - | None -> None - | Some true -> - eval_const_alg_expr logger network_handler yes - | Some false -> - eval_const_alg_expr logger network_handler no - end - | (Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _) -> + let const_cond_opt = eval_const_bool_expr logger network_handler cond in + (match const_cond_opt with + | None -> None + | Some true -> eval_const_alg_expr logger network_handler yes + | Some false -> eval_const_alg_expr logger network_handler no) + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ -> raise (ExceptionDefn.Internal_Error - ("SBML does not support differentiation",snd alg_expr)) + ("SBML does not support differentiation", snd alg_expr)) + and eval_const_bool_expr logger network_handler expr = match fst expr with | Alg_expr.TRUE -> Some true | Alg_expr.FALSE -> Some false - | Alg_expr.COMPARE_OP (op,a,b) -> - let const_a_opt = - eval_const_alg_expr logger network_handler a - in - let const_b_opt = - eval_const_alg_expr logger network_handler b - in - begin - match const_a_opt, const_b_opt with - | None, _ | _, None -> None - | Some a, Some b -> - Some (Nbr.of_compare_op op a b) - end - | Alg_expr.UN_BOOL_OP (Operator.NOT,a) -> + | Alg_expr.COMPARE_OP (op, a, b) -> + let const_a_opt = eval_const_alg_expr logger network_handler a in + let const_b_opt = eval_const_alg_expr logger network_handler b in + (match const_a_opt, const_b_opt with + | None, _ | _, None -> None + | Some a, Some b -> Some (Nbr.of_compare_op op a b)) + | Alg_expr.UN_BOOL_OP (Operator.NOT, a) -> Option_util.map not (eval_const_bool_expr logger network_handler a) - | Alg_expr.BIN_BOOL_OP (op,a,b) -> - let const_a_opt = - eval_const_bool_expr logger network_handler a - in - let const_b_opt = - eval_const_bool_expr logger network_handler b - in - begin - match const_a_opt, const_b_opt with - | None, _ | _, None -> None - | Some a, Some b -> - begin - match op with - | Operator.AND -> Some (a && b) - | Operator.OR -> Some (a || b) - end - end + | Alg_expr.BIN_BOOL_OP (op, a, b) -> + let const_a_opt = eval_const_bool_expr logger network_handler a in + let const_b_opt = eval_const_bool_expr logger network_handler b in + (match const_a_opt, const_b_opt with + | None, _ | _, None -> None + | Some a, Some b -> + (match op with + | Operator.AND -> Some (a && b) + | Operator.OR -> Some (a || b))) let rec get_last_alias logger network_handler x = let id = network_handler.Network_handler.int_of_obs x in let expr_opt = Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) in - match fst (unsome expr_opt) - with - | Alg_expr.ALG_VAR x' when x<>x' - && not (Ode_loggers_sig.is_dangerous_ode_variable logger (Ode_loggers_sig.Expr (network_handler.Network_handler.int_of_obs x'))) -> + match fst (unsome expr_opt) with + | Alg_expr.ALG_VAR x' + when x <> x' + && not + (Ode_loggers_sig.is_dangerous_ode_variable logger + (Ode_loggers_sig.Expr + (network_handler.Network_handler.int_of_obs x'))) -> get_last_alias logger network_handler x' - | Alg_expr.ALG_VAR _ - | Alg_expr.CONST _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.STATE_ALG_OP _ - | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ - | Alg_expr.IF _ - | (Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _) -> x - + | Alg_expr.ALG_VAR _ | Alg_expr.CONST _ | Alg_expr.TOKEN_ID _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.STATE_ALG_OP _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.DIFF_TOKEN _ -> + x let print_int logger logger_err n = let () = do_sbml logger logger_err (lift0 (fun logger -> - Ode_loggers_sig.fprintf logger " %i " n - )) + Ode_loggers_sig.fprintf logger " %i " n)) in do_dotnet logger logger_err (lift0 (fun logger -> Ode_loggers_sig.fprintf logger "%i" n)) let print_nbr logger logger_err nbr = match nbr with - | Nbr.I n -> print_int logger logger_err n + | Nbr.I n -> print_int logger logger_err n | Nbr.I64 n -> print_int logger logger_err (Int64.to_int n) | Nbr.F f -> let () = @@ -688,87 +557,66 @@ let print_nbr logger logger_err nbr = do_dotnet logger logger_err (lift0 (fun logger -> Ode_loggers_sig.fprintf logger "%g" f)) -let print_ci logger logger_err ci= +let print_ci logger logger_err ci = let () = - do_sbml logger logger_err - (fun logger _ -> - Ode_loggers_sig.fprintf logger "%s" - ci) + do_sbml logger logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger "%s" ci) in - do_dotnet logger logger_err - (fun logger _ -> - Ode_loggers_sig.fprintf logger "%s" ci) + do_dotnet logger logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger "%s" ci) let print_ci_with_id logger logger_err ci id = let () = - do_sbml logger logger_err - (fun logger _ -> - Ode_loggers_sig.fprintf logger "%s%i" - ci id) + do_sbml logger logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger "%s%i" ci id) in - do_dotnet logger logger_err - (fun logger _ -> - Ode_loggers_sig.fprintf logger "%i" id) + do_dotnet logger logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger "%i" id) let rec print_alg_expr_in_sbml string_of_var_id logger logger_err - (alg_expr: - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) - Alg_expr.e Locality.annot - ) (network: - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) - Network_handler.t) - = + (alg_expr : + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e + Loc.annoted) + (network : + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t) + = match fst alg_expr with - | Alg_expr.CONST nbr -> - print_nbr logger logger_err nbr + | Alg_expr.CONST nbr -> print_nbr logger logger_err nbr | Alg_expr.ALG_VAR x -> - if Alg_expr.is_constant alg_expr then + if Alg_expr.is_constant alg_expr then ( (* TODO Jérome: This is dead code ([alg_expr] = [ALG_VAR _, _] and [is_constant (ALG_VAR _,_)] = false) please have a look *) let () = print_ci logger logger_err - (Ode_loggers_sig.get_id_of_global_parameter - logger (Ode_loggers_sig.Expr (network.Network_handler.int_of_obs x))) + (Ode_loggers_sig.get_id_of_global_parameter logger + (Ode_loggers_sig.Expr (network.Network_handler.int_of_obs x))) in - do_dotnet logger logger_err - (fun _ logger_err -> - let pos = Some __POS__ in - warn_expr ?pos alg_expr "not handled yet, todo" logger logger_err - ) - else - begin - let id = - network.Network_handler.int_of_obs x - in - match - Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) - with - | Some expr -> - if Alg_expr.is_constant expr - then - let () = - do_sbml logger logger_err - (lift0 (fun logger -> - Ode_loggers_sig.fprintf logger " %s " - (string_of_var_id id))) - in - do_dotnet logger logger_err + do_dotnet logger logger_err (fun _ logger_err -> + let pos = Some __POS__ in + warn_expr ?pos alg_expr "not handled yet, todo" logger logger_err) + ) else ( + let id = network.Network_handler.int_of_obs x in + match Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) with + | Some expr -> + if Alg_expr.is_constant expr then ( + let () = + do_sbml logger logger_err (lift0 (fun logger -> - Ode_loggers_sig.fprintf logger "%s" + Ode_loggers_sig.fprintf logger " %s " (string_of_var_id id))) - else - (*if expr is not a constant in case of - DOTNET gives warning*) - (* let () = - do_sbml logger logger_err - (fun logger logger_err ->*) - print_alg_expr_in_sbml - string_of_var_id - logger - logger_err - expr - network (* + in + do_dotnet logger logger_err + (lift0 (fun logger -> + Ode_loggers_sig.fprintf logger "%s" (string_of_var_id id))) + ) else + (*if expr is not a constant in case of + DOTNET gives warning*) + (* let () = + do_sbml logger logger_err + (fun logger logger_err ->*) + print_alg_expr_in_sbml string_of_var_id logger logger_err expr network + (* in let () = do_dotnet logger logger_err @@ -783,309 +631,267 @@ let rec print_alg_expr_in_sbml string_of_var_id logger logger_err (fun logger logger_err -> print_nbr logger logger_err Nbr.one )*) - | None -> - Ode_loggers_sig.fprintf logger "TODO:v%i" id - end + | None -> Ode_loggers_sig.fprintf logger "TODO:v%i" id + ) | Alg_expr.KAPPA_INSTANCE x -> let () = - do_sbml logger logger_err - (fun logger _logger_err -> - Ode_loggers_sig.fprintf logger "s%i" - (network.Network_handler.int_of_kappa_instance x)) + do_sbml logger logger_err (fun logger _logger_err -> + Ode_loggers_sig.fprintf logger "s%i" + (network.Network_handler.int_of_kappa_instance x)) in - do_dotnet logger logger_err - (fun _logger logger_err -> - let () = - warn_expr - alg_expr - ("DOTNET backend does not support kappa expression in rates for rules: cowardly replacing it with 0") - logger - logger_err - in - print_nbr logger logger_err Nbr.zero) + do_dotnet logger logger_err (fun _logger logger_err -> + let () = + warn_expr alg_expr + "DOTNET backend does not support kappa expression in rates for \ + rules: cowardly replacing it with 0" + logger logger_err + in + print_nbr logger logger_err Nbr.zero) | Alg_expr.TOKEN_ID x -> let () = - do_sbml logger logger_err - (fun logger logger_err -> - print_ci_with_id logger logger_err "t" - (network.Network_handler.int_of_token_id x)) + do_sbml logger logger_err (fun logger logger_err -> + print_ci_with_id logger logger_err "t" + (network.Network_handler.int_of_token_id x)) in - do_dotnet logger logger_err - (fun _logger logger_err -> - let () = - warn_expr - alg_expr - ("DOTNET backend does not support token values in rates for rules: cowardly replacing it with 0") - logger - logger_err - in - print_nbr logger logger_err Nbr.zero) - | Alg_expr.STATE_ALG_OP (Operator.TMAX_VAR) -> - print_ci logger logger_err "tend" - | Alg_expr.STATE_ALG_OP (Operator.CPUTIME) -> - print_nbr logger logger_err (Nbr.zero) - | Alg_expr.STATE_ALG_OP (Operator.TIME_VAR) -> + do_dotnet logger logger_err (fun _logger logger_err -> + let () = + warn_expr alg_expr + "DOTNET backend does not support token values in rates for rules: \ + cowardly replacing it with 0" + logger logger_err + in + print_nbr logger logger_err Nbr.zero) + | Alg_expr.STATE_ALG_OP Operator.TMAX_VAR -> print_ci logger logger_err "tend" + | Alg_expr.STATE_ALG_OP Operator.CPUTIME -> + print_nbr logger logger_err Nbr.zero + | Alg_expr.STATE_ALG_OP Operator.TIME_VAR -> let () = do_sbml logger logger_err (fun logger _ -> Ode_loggers_sig.fprintf logger "%stimet_scale_factor" - (Ode_loggers_sig.string_of_bin_op logger - Operator.MULT) - ) + (Ode_loggers_sig.string_of_bin_op logger Operator.MULT)) in let () = - do_dotnet logger logger_err - (fun _logger logger_err -> - let pos = Some __POS__ in - warn_expr ?pos alg_expr "Internal error" logger logger_err - ) + do_dotnet logger logger_err (fun _logger logger_err -> + let pos = Some __POS__ in + warn_expr ?pos alg_expr "Internal error" logger logger_err) in () - | Alg_expr.STATE_ALG_OP (Operator.EVENT_VAR) -> + | Alg_expr.STATE_ALG_OP Operator.EVENT_VAR -> print_nbr logger logger_err Nbr.zero - | Alg_expr.STATE_ALG_OP (Operator.EMAX_VAR) -> + | Alg_expr.STATE_ALG_OP Operator.EMAX_VAR -> print_ci logger logger_err "event_max" - | Alg_expr.STATE_ALG_OP (Operator.NULL_EVENT_VAR) -> + | Alg_expr.STATE_ALG_OP Operator.NULL_EVENT_VAR -> print_nbr logger logger_err Nbr.zero | Alg_expr.BIN_ALG_OP (op, a, b) -> let string_op = Ode_loggers_sig.string_of_bin_op logger op in let () = - do_sbml logger logger_err - (fun logger logger_err -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - let () = - print_alg_expr_in_sbml string_of_var_id logger logger_err a network - in - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err b network - in - let () = Ode_loggers_sig.fprintf logger "" in - () - ) + do_sbml logger logger_err (fun logger logger_err -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = Ode_loggers_sig.fprintf logger "%s" string_op in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err a network + in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err b network + in + let () = Ode_loggers_sig.fprintf logger "" in + ()) in let () = - do_dotnet - logger logger_err - (fun logger logger_err -> - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err a network - in - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err b network - in - () - ) + do_dotnet logger logger_err (fun logger logger_err -> + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err a network + in + let () = Ode_loggers_sig.fprintf logger "%s" string_op in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err b network + in + ()) in () | Alg_expr.UN_ALG_OP (op, a) -> let string_op = Ode_loggers_sig.string_of_un_op logger op in let () = - do_sbml logger logger_err - (fun logger logger_err -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err a network - in - let () = Ode_loggers_sig.fprintf logger "" in - ()) + do_sbml logger logger_err (fun logger logger_err -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = Ode_loggers_sig.fprintf logger "%s" string_op in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err a network + in + let () = Ode_loggers_sig.fprintf logger "" in + ()) in let () = - do_dotnet logger logger_err - (fun logger logger_err -> - let () = Ode_loggers_sig.fprintf logger "%s" string_op in - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err a network - in - () - ) - in () + do_dotnet logger logger_err (fun logger logger_err -> + let () = Ode_loggers_sig.fprintf logger "%s" string_op in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err a network + in + ()) + in + () | Alg_expr.IF (cond, yes, no) -> let () = - do_sbml logger logger_err - (fun logger logger_err -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = Ode_loggers_sig.fprintf logger "" in - let () = - print_bool_expr_in_sbml - string_of_var_id logger logger_err cond network - in - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err yes network - in - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err no network - in - let () = Ode_loggers_sig.fprintf logger "" in - ()) + do_sbml logger logger_err (fun logger logger_err -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = Ode_loggers_sig.fprintf logger "" in + let () = + print_bool_expr_in_sbml string_of_var_id logger logger_err cond + network + in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err yes + network + in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err no network + in + let () = Ode_loggers_sig.fprintf logger "" in + ()) in - do_dotnet logger logger_err - (fun _logger logger_err -> - let pos = Some __POS__ in - warn_expr ?pos alg_expr "Conditionals are not allowed in DOTNET backend" logger logger_err - ) - | (Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _) -> + do_dotnet logger logger_err (fun _logger logger_err -> + let pos = Some __POS__ in + warn_expr ?pos alg_expr "Conditionals are not allowed in DOTNET backend" + logger logger_err) + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ -> raise (ExceptionDefn.Internal_Error - ("SBML does not support differentiation",snd alg_expr)) -and - print_bool_expr_in_sbml string_of_var_id logger logger_err cond network = + ("SBML does not support differentiation", snd alg_expr)) + +and print_bool_expr_in_sbml string_of_var_id logger logger_err cond network = let () = - do_sbml logger logger_err - (fun logger logger_err -> - match fst cond with - | Alg_expr.TRUE -> Ode_loggers_sig.fprintf logger "" - | Alg_expr.FALSE -> Ode_loggers_sig.fprintf logger "" - | Alg_expr.COMPARE_OP (op,a,b) -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = - Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_compare_op logger op) in - let () = - print_alg_expr_in_sbml - string_of_var_id logger logger_err a network - in - let () = - print_alg_expr_in_sbml string_of_var_id logger logger_err b - network in - let () = Ode_loggers_sig.fprintf logger "" in - () - | Alg_expr.BIN_BOOL_OP (op,a,b) -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_bin_bool_op logger op) in - let () = - print_bool_expr_in_sbml - string_of_var_id logger logger_err a network - in - let () = - print_bool_expr_in_sbml - string_of_var_id logger logger_err b network - in - let () = Ode_loggers_sig.fprintf logger "" in - () - | Alg_expr.UN_BOOL_OP (op,a) -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = Ode_loggers_sig.fprintf logger "%s" - (Ode_loggers_sig.string_of_un_bool_op logger op) in - let () = - print_bool_expr_in_sbml - string_of_var_id logger logger_err a network - in - let () = Ode_loggers_sig.fprintf logger "" in - ()) + do_sbml logger logger_err (fun logger logger_err -> + match fst cond with + | Alg_expr.TRUE -> Ode_loggers_sig.fprintf logger "" + | Alg_expr.FALSE -> Ode_loggers_sig.fprintf logger "" + | Alg_expr.COMPARE_OP (op, a, b) -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_compare_op logger op) + in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err a network + in + let () = + print_alg_expr_in_sbml string_of_var_id logger logger_err b network + in + let () = Ode_loggers_sig.fprintf logger "" in + () + | Alg_expr.BIN_BOOL_OP (op, a, b) -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_bin_bool_op logger op) + in + let () = + print_bool_expr_in_sbml string_of_var_id logger logger_err a network + in + let () = + print_bool_expr_in_sbml string_of_var_id logger logger_err b network + in + let () = Ode_loggers_sig.fprintf logger "" in + () + | Alg_expr.UN_BOOL_OP (op, a) -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = + Ode_loggers_sig.fprintf logger "%s" + (Ode_loggers_sig.string_of_un_bool_op logger op) + in + let () = + print_bool_expr_in_sbml string_of_var_id logger logger_err a network + in + let () = Ode_loggers_sig.fprintf logger "" in + ()) in - do_dotnet logger logger_err - (fun _logger logger_err -> - let pos = Some __POS__ in - warn_expr ?pos cond "Boolean expressions are not allowed in DOTNET backend" logger logger_err - ) - + do_dotnet logger logger_err (fun _logger logger_err -> + let pos = Some __POS__ in + warn_expr ?pos cond + "Boolean expressions are not allowed in DOTNET backend" logger + logger_err) let rec substance_expr_in_sbml logger - (alg_expr: - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) - Alg_expr.e Locality.annot - ) (network: - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t) - = + (alg_expr : + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e + Loc.annoted) + (network : + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t) + = match fst alg_expr with | Alg_expr.CONST _ - | Alg_expr.STATE_ALG_OP (Operator.CPUTIME) - | Alg_expr.STATE_ALG_OP (Operator.EVENT_VAR) - | Alg_expr.STATE_ALG_OP (Operator.NULL_EVENT_VAR) -> + | Alg_expr.STATE_ALG_OP Operator.CPUTIME + | Alg_expr.STATE_ALG_OP Operator.EVENT_VAR + | Alg_expr.STATE_ALG_OP Operator.NULL_EVENT_VAR -> Mods.StringSet.empty | Alg_expr.ALG_VAR x -> if Alg_expr.is_constant alg_expr then (* TODO Jérome: This is dead code, please have a look *) Mods.StringSet.singleton - (Ode_loggers_sig.get_id_of_global_parameter - logger (Ode_loggers_sig.Expr (network.Network_handler.int_of_obs x))) - else begin - let id = - network.Network_handler.int_of_obs x - in - match - Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) - with - | Some expr -> - substance_expr_in_sbml - logger - expr - network - | None ->(* TO DO *) + (Ode_loggers_sig.get_id_of_global_parameter logger + (Ode_loggers_sig.Expr (network.Network_handler.int_of_obs x))) + else ( + let id = network.Network_handler.int_of_obs x in + match Ode_loggers_sig.get_expr logger (Ode_loggers_sig.Expr id) with + | Some expr -> substance_expr_in_sbml logger expr network + | None -> + (* TO DO *) Mods.StringSet.empty - end + ) | Alg_expr.KAPPA_INSTANCE x -> Mods.StringSet.singleton - ("s"^(string_of_int (network.Network_handler.int_of_kappa_instance x))) + ("s" ^ string_of_int (network.Network_handler.int_of_kappa_instance x)) | Alg_expr.TOKEN_ID x -> Mods.StringSet.singleton - ("t"^(string_of_int (network.Network_handler.int_of_token_id x))) - | Alg_expr.STATE_ALG_OP (Operator.TMAX_VAR) -> - Mods.StringSet.singleton "tend" - | Alg_expr.STATE_ALG_OP (Operator.TIME_VAR) -> - Mods.StringSet.singleton "time" - | Alg_expr.STATE_ALG_OP (Operator.EMAX_VAR) -> + ("t" ^ string_of_int (network.Network_handler.int_of_token_id x)) + | Alg_expr.STATE_ALG_OP Operator.TMAX_VAR -> Mods.StringSet.singleton "tend" + | Alg_expr.STATE_ALG_OP Operator.TIME_VAR -> Mods.StringSet.singleton "time" + | Alg_expr.STATE_ALG_OP Operator.EMAX_VAR -> Mods.StringSet.singleton "event_max" | Alg_expr.BIN_ALG_OP (_op, a, b) -> Mods.StringSet.union (substance_expr_in_sbml logger a network) (substance_expr_in_sbml logger b network) - | Alg_expr.UN_ALG_OP (_op, a) -> - substance_expr_in_sbml logger a network + | Alg_expr.UN_ALG_OP (_op, a) -> substance_expr_in_sbml logger a network | Alg_expr.IF (cond, yes, no) -> Mods.StringSet.union (substance_bool_expr_in_sbml logger cond network) (Mods.StringSet.union (substance_expr_in_sbml logger yes network) (substance_expr_in_sbml logger no network)) - | (Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _) -> + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ -> raise (ExceptionDefn.Internal_Error - ("SBML does not support differentiation",snd alg_expr)) -and - substance_bool_expr_in_sbml logger cond network = + ("SBML does not support differentiation", snd alg_expr)) + +and substance_bool_expr_in_sbml logger cond network = match fst cond with - | Alg_expr.TRUE - | Alg_expr.FALSE -> Mods.StringSet.empty - | Alg_expr.COMPARE_OP (_,a,b) -> + | Alg_expr.TRUE | Alg_expr.FALSE -> Mods.StringSet.empty + | Alg_expr.COMPARE_OP (_, a, b) -> Mods.StringSet.union (substance_expr_in_sbml logger a network) (substance_expr_in_sbml logger b network) - | Alg_expr.BIN_BOOL_OP (_,a,b) -> + | Alg_expr.BIN_BOOL_OP (_, a, b) -> Mods.StringSet.union (substance_bool_expr_in_sbml logger a network) (substance_bool_expr_in_sbml logger b network) - | Alg_expr.UN_BOOL_OP (_,a) -> - substance_bool_expr_in_sbml logger a network + | Alg_expr.UN_BOOL_OP (_, a) -> substance_bool_expr_in_sbml logger a network let rec maybe_time_dependent_alg_expr_in_sbml logger - (alg_expr: - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) - Alg_expr.e Locality.annot - ) (network: - (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t) - = + (alg_expr : + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Alg_expr.e + Loc.annoted) + (network : + (Ode_loggers_sig.ode_var_id, Ode_loggers_sig.ode_var_id) Network_handler.t) + = match fst alg_expr with | Alg_expr.CONST (Nbr.I _) | Alg_expr.CONST (Nbr.I64 _) - | Alg_expr.CONST (Nbr.F _) -> false - | Alg_expr.ALG_VAR _x -> + | Alg_expr.CONST (Nbr.F _) -> false - (* TODO Jérome: please check that! All this commented code was dead code - but it is very suspicious... (signed pirbo) *) + | Alg_expr.ALG_VAR _x -> false + (* TODO Jérome: please check that! All this commented code was dead code + but it is very suspicious... (signed pirbo) *) (* begin let id = network.Network_handler.int_of_obs x @@ -1100,47 +906,50 @@ let rec maybe_time_dependent_alg_expr_in_sbml logger network | None -> false end*) - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.STATE_ALG_OP (Operator.TMAX_VAR) - | Alg_expr.STATE_ALG_OP (Operator.CPUTIME) -> false - | Alg_expr.STATE_ALG_OP (Operator.TIME_VAR) -> true - | Alg_expr.STATE_ALG_OP (Operator.EVENT_VAR) - | Alg_expr.STATE_ALG_OP (Operator.EMAX_VAR) - | Alg_expr.STATE_ALG_OP (Operator.NULL_EVENT_VAR) -> false + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ + | Alg_expr.STATE_ALG_OP Operator.TMAX_VAR + | Alg_expr.STATE_ALG_OP Operator.CPUTIME -> + false + | Alg_expr.STATE_ALG_OP Operator.TIME_VAR -> true + | Alg_expr.STATE_ALG_OP Operator.EVENT_VAR + | Alg_expr.STATE_ALG_OP Operator.EMAX_VAR + | Alg_expr.STATE_ALG_OP Operator.NULL_EVENT_VAR -> + false | Alg_expr.BIN_ALG_OP (_, a, b) -> maybe_time_dependent_alg_expr_in_sbml logger a network || maybe_time_dependent_alg_expr_in_sbml logger b network | Alg_expr.UN_ALG_OP (_, a) - | Alg_expr.DIFF_KAPPA_INSTANCE (a,_) - | Alg_expr.DIFF_TOKEN (a,_) -> + | Alg_expr.DIFF_KAPPA_INSTANCE (a, _) + | Alg_expr.DIFF_TOKEN (a, _) -> maybe_time_dependent_alg_expr_in_sbml logger a network | Alg_expr.IF (cond, yes, no) -> maybe_time_dependent_bool_expr_in_sbml logger cond network - || - maybe_time_dependent_alg_expr_in_sbml logger yes network - || - maybe_time_dependent_alg_expr_in_sbml logger no network -and - maybe_time_dependent_bool_expr_in_sbml logger cond network = + || maybe_time_dependent_alg_expr_in_sbml logger yes network + || maybe_time_dependent_alg_expr_in_sbml logger no network + +and maybe_time_dependent_bool_expr_in_sbml logger cond network = match fst cond with - | Alg_expr.TRUE - | Alg_expr.FALSE -> false - | Alg_expr.COMPARE_OP (_op,a,b) -> + | Alg_expr.TRUE | Alg_expr.FALSE -> false + | Alg_expr.COMPARE_OP (_op, a, b) -> maybe_time_dependent_alg_expr_in_sbml logger a network || maybe_time_dependent_alg_expr_in_sbml logger b network - | Alg_expr.BIN_BOOL_OP (_op,a,b) -> + | Alg_expr.BIN_BOOL_OP (_op, a, b) -> maybe_time_dependent_bool_expr_in_sbml logger a network || maybe_time_dependent_bool_expr_in_sbml logger b network - | Alg_expr.UN_BOOL_OP (_op,a) -> + | Alg_expr.UN_BOOL_OP (_op, a) -> maybe_time_dependent_bool_expr_in_sbml logger a network let break = true let replace_space_with_underscore = - String.map (fun c -> if c=' ' then '_' else c) - -let dump_initial_species ?units loggers logger_err network_handler k name species = + String.map (fun c -> + if c = ' ' then + '_' + else + c) + +let dump_initial_species ?units loggers logger_err network_handler k name + species = let expr = match Ode_loggers_sig.get_expr loggers (Ode_loggers_sig.Init k) with | Some a -> a @@ -1154,652 +963,563 @@ let dump_initial_species ?units loggers logger_err network_handler k name specie let concentration = eval_init_alg_expr loggers network_handler expr in let s = Format.sprintf - "metaid=\"%s\" id=\"%s\" name=\"%s\" compartment=\"default\" initialAmount=\"%s\" substanceUnits=\"%s\"" + "metaid=\"%s\" id=\"%s\" name=\"%s\" compartment=\"default\" \ + initialAmount=\"%s\" substanceUnits=\"%s\"" (meta_id_of_logger loggers) - species - name + species name (Nbr.to_string concentration) units in let s_dotnet = - Format.sprintf - "%s %s %s" - species - name - (Nbr.to_string concentration) + Format.sprintf "%s %s %s" species name (Nbr.to_string concentration) in let () = do_sbml loggers logger_err (fun loggers logger_err -> - single_box ~options:(fun () -> s) loggers logger_err "species" - ) + single_box ~options:(fun () -> s) loggers logger_err "species") in let () = do_dotnet loggers logger_err (fun loggers logger_err -> - single_box ~options:(fun () -> s_dotnet) loggers logger_err "" - ) + single_box ~options:(fun () -> s_dotnet) loggers logger_err "") in () -let dump_species_reference ?dotnet_sep:(dotnet_sep="") loggers logger_err species i = +let dump_species_reference ?(dotnet_sep = "") loggers logger_err species i = let s = - Format.sprintf - "metaid=\"%s\" species=\"s%i\"%s" + Format.sprintf "metaid=\"%s\" species=\"s%i\"%s" (meta_id_of_logger loggers) species - (if i=1 then "" else " stoichiometry=\""^(string_of_int i)^"\"") + (if i = 1 then + "" + else + " stoichiometry=\"" ^ string_of_int i ^ "\"") in let () = do_sbml loggers logger_err (fun loggers logger_err -> - single_box ~options:(fun () -> s) loggers logger_err "speciesReference" - ) + single_box ~options:(fun () -> s) loggers logger_err "speciesReference") in let () = - do_dotnet loggers logger_err (fun loggers _ -> + do_dotnet loggers logger_err (fun loggers _ -> let rec aux k = - let () = - Ode_loggers_sig.fprintf loggers "%i" species - in - if k>=i then () - else + let () = Ode_loggers_sig.fprintf loggers "%i" species in + if k >= i then + () + else ( let () = Ode_loggers_sig.fprintf loggers "%s" dotnet_sep in - aux (k+1) + aux (k + 1) + ) in - aux 1 - ) + aux 1) in () -let add map (id,sym) = +let add map (id, sym) = let old = - match - Mods.IntMap.find_option id map - with - | Some (i,_) -> i + match Mods.IntMap.find_option id map with + | Some (i, _) -> i | None -> 0 in - Mods.IntMap.add id ((succ old),sym) map - -let dump_list_of_species_reference - loggers - logger_err - ?dotnet_sep:(dotnet_sep="") - list - = - let map = - List.fold_left - add - Mods.IntMap.empty - list - in + Mods.IntMap.add id (succ old, sym) map + +let dump_list_of_species_reference loggers logger_err ?(dotnet_sep = "") list = + let map = List.fold_left add Mods.IntMap.empty list in let _ = List.fold_left - (fun bool (s,(i,j)) -> - let () = - if bool then - do_dotnet loggers logger_err - (fun logger _ -> Ode_loggers_sig.fprintf logger "%s" dotnet_sep) - in - let () = dump_species_reference ~dotnet_sep loggers logger_err s (i*j) in - (* check what to do when stochiometric coefficients are bigger than 1*) - true - ) - false - (Mods.IntMap.bindings map) - in () - -let dump_pair logger logger_err (t,i) = - if i = 1 then - let () = - Ode_loggers_sig.fprintf logger " s%i " t - in + (fun bool (s, (i, j)) -> + let () = + if bool then + do_dotnet loggers logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger "%s" dotnet_sep) + in + let () = + dump_species_reference ~dotnet_sep loggers logger_err s (i * j) + in + (* check what to do when stochiometric coefficients are bigger than 1*) + true) + false (Mods.IntMap.bindings map) + in + () + +let dump_pair logger logger_err (t, i) = + if i = 1 then ( + let () = Ode_loggers_sig.fprintf logger " s%i " t in () - else + ) else ( let () = - add_box ~break logger logger_err "apply" "" - (fun logger _ -> - let () = Ode_loggers_sig.fprintf logger "" in - Ode_loggers_sig.fprintf logger " s%i %i " t i) + add_box ~break logger logger_err "apply" "" (fun logger _ -> + let () = Ode_loggers_sig.fprintf logger "" in + Ode_loggers_sig.fprintf logger + " s%i %i " t i) in () + ) let maybe_time_dependent logger network var_rule = - match - Ode_loggers_sig.get_encoding_format logger - with + match Ode_loggers_sig.get_encoding_format logger with | Loggers.SBML -> - let expr_opt = - Ode_loggers_sig.get_expr logger var_rule in + let expr_opt = Ode_loggers_sig.get_expr logger var_rule in let expr = unsome expr_opt in maybe_time_dependent_alg_expr_in_sbml logger expr network - | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML | Loggers.HTML_Tabular - | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular + | Loggers.Matrix | Loggers.HTML_Graph | Loggers.Js_Graph | Loggers.HTML + | Loggers.HTML_Tabular | Loggers.DOT | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS | Loggers.Octave | Loggers.Mathematica | Loggers.GEPHI - | Loggers.Matlab | Loggers.Maple | Loggers.Json | Loggers.DOTNET -> false + | Loggers.Matlab | Loggers.Maple | Loggers.Json | Loggers.DOTNET -> + false let can_be_cast f = let s = Nbr.to_string (Nbr.F f) in - s.[(String.length s)-1] = '.' + s.[String.length s - 1] = '.' let promote nbr = - match nbr with Nbr.F f when can_be_cast f -> Nbr.I (int_of_float f) - | Nbr.I _ | Nbr.F _ | Nbr.I64 _ -> nbr - + match nbr with + | Nbr.F f when can_be_cast f -> Nbr.I (int_of_float f) + | Nbr.I _ | Nbr.F _ | Nbr.I64 _ -> nbr -let dump_kinetic_law - ~propagate_constants - string_of_var_id logger logger_err network reactants var_rule correct nocc = +let dump_kinetic_law ~propagate_constants string_of_var_id logger logger_err + network reactants var_rule correct nocc = let () = - do_dotnet logger logger_err - (fun logger logger_err -> - begin - let expr_opt = - Ode_loggers_sig.get_expr logger var_rule in - let expr = unsome expr_opt in - let f logger = - let dump_constant = - match eval_const_alg_expr logger network expr with - | None -> - let () = - warn_expr - expr - ("DOTNET backend does not support non-constant rates for rules: cowardly replacing it with "^( - string_of_variable - logger + do_dotnet logger logger_err (fun logger logger_err -> + let expr_opt = Ode_loggers_sig.get_expr logger var_rule in + let expr = unsome expr_opt in + let f logger = + let dump_constant = + match eval_const_alg_expr logger network expr with + | None -> + let () = + warn_expr expr + ("DOTNET backend does not support non-constant rates for \ + rules: cowardly replacing it with " + ^ string_of_variable logger + (fun _logger var -> + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + logger logger_err + in + fun logger -> + Ode_loggers_sig.fprintf logger "%s" + (string_of_variable logger + (fun _logger var -> + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + | Some cst -> + let cst = promote cst in + if propagate_constants then + fun logger -> + Ode_loggers_sig.fprintf logger "%s" (Nbr.to_string cst) + else ( + match expr with + | Alg_expr.ALG_VAR var_id, _ -> + let var_id = get_last_alias logger network var_id in + let s = + string_of_var_id (network.Network_handler.int_of_obs var_id) + in + if Ode_loggers_sig.has_forbidden_char logger s then + (* MAKE A CLEANER TEST *) + fun logger -> + Ode_loggers_sig.fprintf logger "%s" + (string_of_variable logger + (fun _logger var -> + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + else + fun logger -> + Ode_loggers_sig.fprintf logger "%s" + (string_of_var_id + (network.Network_handler.int_of_obs var_id)) + | ( ( Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.IF _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ | Alg_expr.DIFF_TOKEN _ + | Alg_expr.CONST _ ), + _ ) -> + fun logger -> + Ode_loggers_sig.fprintf logger "%s" + (string_of_variable logger (fun _logger var -> - string_of_int - (network.Network_handler.int_of_kappa_instance - var)) - var_rule)) - logger - logger_err - in - (fun logger -> - Ode_loggers_sig.fprintf logger "%s" - (string_of_variable - logger - (fun _logger var -> string_of_int - (network.Network_handler.int_of_kappa_instance - var)) - var_rule)) - | Some cst -> - begin - let cst = promote cst in - if propagate_constants - then - (fun logger -> Ode_loggers_sig.fprintf logger "%s" (Nbr.to_string cst)) - else - match - expr - with - | Alg_expr.ALG_VAR var_id,_ -> - let var_id = get_last_alias logger network var_id in - let s = string_of_var_id - (network.Network_handler.int_of_obs var_id) - in - if Ode_loggers_sig.has_forbidden_char logger s then - (* MAKE A CLEANER TEST *) - - (fun logger -> - Ode_loggers_sig.fprintf logger "%s" - (string_of_variable - logger - (fun _logger var -> string_of_int - (network.Network_handler.int_of_kappa_instance - var)) - var_rule)) - else - (fun logger -> - Ode_loggers_sig.fprintf logger "%s" - (string_of_var_id - (network.Network_handler.int_of_obs var_id))) - | ( Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ - | Alg_expr.IF _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ | Alg_expr.DIFF_TOKEN _ - | Alg_expr.CONST _), _ -> - (fun logger -> - Ode_loggers_sig.fprintf logger "%s" - (string_of_variable - logger - (fun _logger var -> string_of_int - (network.Network_handler.int_of_kappa_instance - var)) - var_rule)) - end - in - if correct = nocc - then - dump_constant logger - else - if correct = 1 - then - let () = Ode_loggers_sig.fprintf logger "%i*" nocc in - let () = dump_constant logger in - let () = Ode_loggers_sig.print_newline logger in - () - else - if nocc=1 then - let () = Ode_loggers_sig.fprintf logger "%g*" (1./.(float_of_int correct)) in - let () = dump_constant logger in - let () = Ode_loggers_sig.print_newline logger in - () - else - let () = Ode_loggers_sig.fprintf logger "%g*" ((float_of_int nocc)/.(float_of_int correct)) in - let () = dump_constant logger in - let () = Ode_loggers_sig.print_newline logger in - () - in f logger - (*match reactants with - | [] -> - f logger - | _::_ -> - add_box ~break logger "apply" "" - (fun logger -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = f logger in - let rec aux list = - match list with - [] -> () - | [t] -> - dump_pair logger t - | t::q -> - add_box ~break logger "apply" "" - (fun logger -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = dump_pair logger t in - aux q) - in aux reactants - )*) - end - ) + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + ) + in + if correct = nocc then + dump_constant logger + else if correct = 1 then ( + let () = Ode_loggers_sig.fprintf logger "%i*" nocc in + let () = dump_constant logger in + let () = Ode_loggers_sig.print_newline logger in + () + ) else if nocc = 1 then ( + let () = + Ode_loggers_sig.fprintf logger "%g*" (1. /. float_of_int correct) + in + let () = dump_constant logger in + let () = Ode_loggers_sig.print_newline logger in + () + ) else ( + let () = + Ode_loggers_sig.fprintf logger "%g*" + (float_of_int nocc /. float_of_int correct) + in + let () = dump_constant logger in + let () = Ode_loggers_sig.print_newline logger in + () + ) + in + f logger + (*match reactants with + | [] -> + f logger + | _::_ -> + add_box ~break logger "apply" "" + (fun logger -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = f logger in + let rec aux list = + match list with + [] -> () + | [t] -> + dump_pair logger t + | t::q -> + add_box ~break logger "apply" "" + (fun logger -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = dump_pair logger t in + aux q) + in aux reactants + )*)) in - do_sbml logger logger_err - (fun logger _ -> - begin - let expr_opt = - Ode_loggers_sig.get_expr logger var_rule in - let expr = unsome expr_opt in - let f logger = - if Alg_expr.is_constant expr - then - if correct = nocc - then - Ode_loggers_sig.fprintf logger " %s " - (string_of_variable - logger - (fun _logger var -> string_of_int - (network.Network_handler.int_of_kappa_instance var)) - var_rule) - else - if nocc = 1 then - add_box ~break logger logger_err "apply" "" - (fun logger _ -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = - Ode_loggers_sig.fprintf logger - " %s %i " - (string_of_variable - logger - (fun _logger var -> string_of_int - (network.Network_handler.int_of_kappa_instance - var)) - var_rule) - correct - in - let () = Ode_loggers_sig.print_newline logger in - () - ) - else if correct=1 - then - add_box ~break logger logger_err "apply" "" - (fun logger _ -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = - Ode_loggers_sig.fprintf logger - " %i %s " - nocc - (string_of_variable - logger - (fun _logger var -> string_of_int - (network.Network_handler.int_of_kappa_instance - var)) - var_rule) - in - let () = Ode_loggers_sig.print_newline logger in - () - ) - else - add_box ~break logger logger_err "apply" "" - (fun logger _ -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = - Ode_loggers_sig.fprintf logger - " %i %s %i " - nocc - (string_of_variable - logger - (fun _logger var -> string_of_int - (network.Network_handler.int_of_kappa_instance - var)) - var_rule) - correct - in - let () = Ode_loggers_sig.print_newline logger in - () - ) - else - let expr = - if correct = nocc - then expr - else - if nocc = 1 - then - Alg_expr.div expr (Alg_expr.int correct) - else if correct = 1 - then - Alg_expr.mult (Alg_expr.int nocc) expr - else - Alg_expr.div - (Alg_expr.mult (Alg_expr.int nocc) expr) - (Alg_expr.int correct) - in - print_alg_expr_in_sbml - string_of_var_id logger logger_err expr network - in - match reactants with - | [] -> - f logger - | _::_ -> - add_box ~break logger logger_err "apply" "" - (fun logger _ -> + do_sbml logger logger_err (fun logger _ -> + let expr_opt = Ode_loggers_sig.get_expr logger var_rule in + let expr = unsome expr_opt in + let f logger = + if Alg_expr.is_constant expr then + if correct = nocc then + Ode_loggers_sig.fprintf logger " %s " + (string_of_variable logger + (fun _logger var -> + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + else if nocc = 1 then + add_box ~break logger logger_err "apply" "" (fun logger _ -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = + Ode_loggers_sig.fprintf logger + " %s %i " + (string_of_variable logger + (fun _logger var -> + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + correct + in + let () = Ode_loggers_sig.print_newline logger in + ()) + else if correct = 1 then + add_box ~break logger logger_err "apply" "" (fun logger _ -> let () = Ode_loggers_sig.fprintf logger "" in - let () = f logger in - let rec aux list = - match list with - [] -> () - | [t] -> - dump_pair logger logger_err t - | t::q -> - add_box ~break logger logger_err "apply" "" - (fun logger logger_err -> - let () = Ode_loggers_sig.fprintf logger "" in - let () = dump_pair logger logger_err t in - aux q) - in aux reactants - ) - end - ) + let () = + Ode_loggers_sig.fprintf logger + " %i %s " nocc + (string_of_variable logger + (fun _logger var -> + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + in + let () = Ode_loggers_sig.print_newline logger in + ()) + else + add_box ~break logger logger_err "apply" "" (fun logger _ -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = + Ode_loggers_sig.fprintf logger + " %i %s %i " + nocc + (string_of_variable logger + (fun _logger var -> + string_of_int + (network.Network_handler.int_of_kappa_instance var)) + var_rule) + correct + in + let () = Ode_loggers_sig.print_newline logger in + ()) + else ( + let expr = + if correct = nocc then + expr + else if nocc = 1 then + Alg_expr.div expr (Alg_expr.int correct) + else if correct = 1 then + Alg_expr.mult (Alg_expr.int nocc) expr + else + Alg_expr.div + (Alg_expr.mult (Alg_expr.int nocc) expr) + (Alg_expr.int correct) + in + print_alg_expr_in_sbml string_of_var_id logger logger_err expr network + ) + in + match reactants with + | [] -> f logger + | _ :: _ -> + add_box ~break logger logger_err "apply" "" (fun logger _ -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = f logger in + let rec aux list = + match list with + | [] -> () + | [ t ] -> dump_pair logger logger_err t + | t :: q -> + add_box ~break logger logger_err "apply" "" + (fun logger logger_err -> + let () = Ode_loggers_sig.fprintf logger "" in + let () = dump_pair logger logger_err t in + aux q) + in + aux reactants)) let negative_part expr = - Locality.dummy_annot + Loc.annot_with_dummy (Alg_expr.UN_ALG_OP - (Operator.UMINUS, - Locality.dummy_annot - (Alg_expr.BIN_ALG_OP(Operator.MIN, - Locality.dummy_annot( - Alg_expr.CONST (Nbr.zero)),expr)))) + ( Operator.UMINUS, + Loc.annot_with_dummy + (Alg_expr.BIN_ALG_OP + ( Operator.MIN, + Loc.annot_with_dummy (Alg_expr.CONST Nbr.zero), + expr )) )) let positive_part expr = - Locality.dummy_annot - (Alg_expr.BIN_ALG_OP(Operator.MAX, - Locality.dummy_annot( - Alg_expr.CONST (Nbr.zero)),expr)) + Loc.annot_with_dummy + (Alg_expr.BIN_ALG_OP + (Operator.MAX, Loc.annot_with_dummy (Alg_expr.CONST Nbr.zero), expr)) -let dump_token_vector convert logger logger_err network_handler rule_id token_vector = +let dump_token_vector convert logger logger_err network_handler rule_id + token_vector = let () = - do_sbml logger logger_err - (fun logger _ -> + do_sbml logger logger_err (fun logger _ -> let _ = List.fold_left - (fun n (id,_) -> - let expr_opt = - Ode_loggers_sig.get_expr logger - (Ode_loggers_sig.Stochiometric_coef (rule_id,n)) - in - let expr = unsome expr_opt in - let stochiometry_opt = - eval_const_alg_expr logger network_handler (convert expr) - in - let () = - match stochiometry_opt with - | None -> - let () = - warn_expr - expr - "Expressions for token consumption/production should be constants: cowardly replace it with 0\n" - logger - logger_err - in - () - | Some x when Nbr.is_zero x -> () - | Some x -> - let s = - Format.sprintf - "metaid=\"%s\" species=\"t%i\"%s" - (meta_id_of_logger logger) - id - (if Nbr.is_equal x (Nbr.I 1) then "" else - " stoichiometry=\""^(Nbr.to_string - x)^"\"") - in - single_box ~options:(fun () -> s) logger logger_err - "speciesReference" - in - n+1) - 1 - token_vector + (fun n (id, _) -> + let expr_opt = + Ode_loggers_sig.get_expr logger + (Ode_loggers_sig.Stochiometric_coef (rule_id, n)) + in + let expr = unsome expr_opt in + let stochiometry_opt = + eval_const_alg_expr logger network_handler (convert expr) + in + let () = + match stochiometry_opt with + | None -> + let () = + warn_expr expr + "Expressions for token consumption/production should be \ + constants: cowardly replace it with 0\n" + logger logger_err + in + () + | Some x when Nbr.is_zero x -> () + | Some x -> + let s = + Format.sprintf "metaid=\"%s\" species=\"t%i\"%s" + (meta_id_of_logger logger) id + (if Nbr.is_equal x (Nbr.I 1) then + "" + else + " stoichiometry=\"" ^ Nbr.to_string x ^ "\"") + in + single_box + ~options:(fun () -> s) + logger logger_err "speciesReference" + in + n + 1) + 1 token_vector in ()) in let () = - do_dotnet logger logger_err - (fun logger logger_err -> - match token_vector with - | [] -> () - | _::_ -> - let expr_opt = - Ode_loggers_sig.get_expr logger - (Ode_loggers_sig.Stochiometric_coef (rule_id,1)) - in - let expr = unsome expr_opt in - warn_expr - expr - "Rules with tokens are not allowed in DOTNET output: cowardly ignoring them" - logger - logger_err - ) - in () - -let has_good_token_token_vector - convert logger network_handler rule_id token_vector = + do_dotnet logger logger_err (fun logger logger_err -> + match token_vector with + | [] -> () + | _ :: _ -> + let expr_opt = + Ode_loggers_sig.get_expr logger + (Ode_loggers_sig.Stochiometric_coef (rule_id, 1)) + in + let expr = unsome expr_opt in + warn_expr expr + "Rules with tokens are not allowed in DOTNET output: cowardly \ + ignoring them" + logger logger_err) + in + () + +let has_good_token_token_vector convert logger network_handler rule_id + token_vector = let rec aux n l = match l with | [] -> false - | _::tail -> - begin - let expr_opt = - Ode_loggers_sig.get_expr logger - (Ode_loggers_sig.Stochiometric_coef (rule_id,n)) - in - let stochiometry_opt = - eval_const_alg_expr logger network_handler (convert (unsome expr_opt)) - in - match stochiometry_opt with - | None -> aux (n+1) tail - | Some x when Nbr.is_zero x -> aux (n+1) tail - | Some _ -> true - end - in aux 1 token_vector + | _ :: tail -> + let expr_opt = + Ode_loggers_sig.get_expr logger + (Ode_loggers_sig.Stochiometric_coef (rule_id, n)) + in + let stochiometry_opt = + eval_const_alg_expr logger network_handler (convert (unsome expr_opt)) + in + (match stochiometry_opt with + | None -> aux (n + 1) tail + | Some x when Nbr.is_zero x -> aux (n + 1) tail + | Some _ -> true) + in + aux 1 token_vector let has_reactants_in_token_vector logger network_handler rule_id token_vector = - has_good_token_token_vector - negative_part logger network_handler rule_id token_vector + has_good_token_token_vector negative_part logger network_handler rule_id + token_vector let has_products_in_token_vector logger network_handler rule_id token_vector = - has_good_token_token_vector - positive_part logger network_handler rule_id token_vector - -let dump_products_of_token_vector - logger logger_err network_handler rule_id token_vector = - do_dotnet_or_sbml logger logger_err - (fun logger logger_err -> - dump_token_vector - positive_part logger logger_err network_handler rule_id token_vector - ) - -let dump_reactants_of_token_vector - logger logger_err network_handler rule_id token_vector = - do_dotnet_or_sbml logger logger_err - (fun logger logger_err -> - dump_token_vector - negative_part logger logger_err network_handler rule_id token_vector - ) - -let dump_sbml_reaction - ~propagate_constants - _print_expr - string_of_var_id - get_rule - get_rule_id - print_rule_name - compil - logger - logger_err - network - reactants - products + has_good_token_token_vector positive_part logger network_handler rule_id token_vector - enriched_rule - var_rule - correct - nocc - fictitious - = + +let dump_products_of_token_vector logger logger_err network_handler rule_id + token_vector = + do_dotnet_or_sbml logger logger_err (fun logger logger_err -> + dump_token_vector positive_part logger logger_err network_handler rule_id + token_vector) + +let dump_reactants_of_token_vector logger logger_err network_handler rule_id + token_vector = + do_dotnet_or_sbml logger logger_err (fun logger logger_err -> + dump_token_vector negative_part logger logger_err network_handler rule_id + token_vector) + +let dump_sbml_reaction ~propagate_constants _print_expr string_of_var_id + get_rule get_rule_id print_rule_name compil logger logger_err network + reactants products token_vector enriched_rule var_rule correct nocc + fictitious = let dotnet_sep = "," in let reaction_id = Ode_loggers_sig.get_fresh_reaction_id logger in - let label_reaction = "reaction" in + let label_reaction = "reaction" in let label = "" in let label_list_of_reactants = "listOfReactants" in let label_list_of_products = "listOfProducts" in let label_list_of_mods = "listOfModifiers" in let rule_id = get_rule_id enriched_rule in let reactants, products = - if reactants=[] && is_dotnet logger - then - begin - match fictitious with - | None -> failwith "Internal error" - | Some id -> (id,1)::reactants, List.rev ((id,1)::(List.rev products)) - end - else + if reactants = [] && is_dotnet logger then ( + match fictitious with + | None -> failwith "Internal error" + | Some id -> (id, 1) :: reactants, List.rev ((id, 1) :: List.rev products) + ) else reactants, products in let token_vector = - if is_dotnet logger - then - begin - match token_vector with - | [] -> token_vector - | _::_ -> - let expr_opt = - Ode_loggers_sig.get_expr logger - (Ode_loggers_sig.Stochiometric_coef (rule_id,1)) - in - let expr = unsome expr_opt in - let () = - warn_expr - expr - "Rules with tokens are not allowed in DOTNET output: cowardl ignoring them" - logger - logger_err - in - [] - end - else + if is_dotnet logger then ( + match token_vector with + | [] -> token_vector + | _ :: _ -> + let expr_opt = + Ode_loggers_sig.get_expr logger + (Ode_loggers_sig.Stochiometric_coef (rule_id, 1)) + in + let expr = unsome expr_opt in + let () = + warn_expr expr + "Rules with tokens are not allowed in DOTNET output: cowardl \ + ignoring them" + logger logger_err + in + [] + ) else token_vector in - let options = - (fun () -> - Format.asprintf - "id=\"re%i\" name=\"%a\" reversible=\"false\" fast=\"false\"" - reaction_id (print_rule_name ?compil) (get_rule enriched_rule) - ) + let options () = + Format.asprintf + "id=\"re%i\" name=\"%a\" reversible=\"false\" fast=\"false\"" reaction_id + (print_rule_name ?compil) (get_rule enriched_rule) in let () = add_box_in_sbml_only ~options ~break logger logger_err label_reaction (fun logger logger_err -> - let () = - do_dotnet logger logger_err - (fun logger _ -> - Ode_loggers_sig.fprintf logger "%i " reaction_id) - in - let () = - if reactants = [] && - not (has_reactants_in_token_vector logger network - rule_id token_vector) - then () - else - let () = - add_box_in_sbml_only ~break logger logger_err - label_list_of_reactants - (fun logger logger_err -> - let () = - dump_list_of_species_reference ~dotnet_sep - logger logger_err reactants - in - let () = - dump_reactants_of_token_vector - logger logger_err network rule_id token_vector - in - () - ) - in - let () = - do_dotnet logger logger_err - (fun logger _ -> Ode_loggers_sig.fprintf logger " ") - in - () - in - let () = - if products = [] && - not (has_products_in_token_vector logger network rule_id - token_vector) - then () - else - let () = - add_box_in_sbml_only - ~break logger logger_err - label_list_of_products - (fun logger logger_err -> - let () = - dump_list_of_species_reference ~dotnet_sep - logger logger_err products in - let () = - dump_products_of_token_vector - logger logger_err - network rule_id token_vector - in - ()) - in - let () = - do_dotnet - logger logger_err - (fun logger _ -> Ode_loggers_sig.fprintf logger " ") - in - () - in - let expr_opt = Ode_loggers_sig.get_expr logger var_rule in - let expr = unsome expr_opt in - let modifiers = substance_expr_in_sbml logger expr network in - let modifiers = - List.fold_left - (fun set (a,_) -> - Mods.StringSet.remove ("s"^(string_of_int a)) set) - modifiers - reactants - in - (* + let () = + do_dotnet logger logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger "%i " reaction_id) + in + let () = + if + reactants = [] + && not + (has_reactants_in_token_vector logger network rule_id + token_vector) + then + () + else ( + let () = + add_box_in_sbml_only ~break logger logger_err + label_list_of_reactants (fun logger logger_err -> + let () = + dump_list_of_species_reference ~dotnet_sep logger logger_err + reactants + in + let () = + dump_reactants_of_token_vector logger logger_err network + rule_id token_vector + in + ()) + in + let () = + do_dotnet logger logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger " ") + in + () + ) + in + let () = + if + products = [] + && not + (has_products_in_token_vector logger network rule_id + token_vector) + then + () + else ( + let () = + add_box_in_sbml_only ~break logger logger_err + label_list_of_products (fun logger logger_err -> + let () = + dump_list_of_species_reference ~dotnet_sep logger logger_err + products + in + let () = + dump_products_of_token_vector logger logger_err network + rule_id token_vector + in + ()) + in + let () = + do_dotnet logger logger_err (fun logger _ -> + Ode_loggers_sig.fprintf logger " ") + in + () + ) + in + let expr_opt = Ode_loggers_sig.get_expr logger var_rule in + let expr = unsome expr_opt in + let modifiers = substance_expr_in_sbml logger expr network in + let modifiers = + List.fold_left + (fun set (a, _) -> + Mods.StringSet.remove ("s" ^ string_of_int a) set) + modifiers reactants + in + (* let () = if maybe_time_dependent logger network var_rule then @@ -1815,110 +1535,86 @@ let dump_sbml_reaction () ) in*) - let () = - if Mods.StringSet.is_empty modifiers - then - () - else - add_box_in_sbml_only - ~break logger logger_err - label_list_of_mods - (fun logger logger_err -> - Mods.StringSet.iter - (fun string -> - let () = - do_sbml logger logger_err - (fun logger logger_err -> - let s = - Format.sprintf - "metaid=\"%s\" species=\"%s\"" - (meta_id_of_logger logger) string - in - let () = - single_box ~options:(fun () -> s) - logger logger_err - "modifierSpeciesReference" + let () = + if Mods.StringSet.is_empty modifiers then + () + else + add_box_in_sbml_only ~break logger logger_err label_list_of_mods + (fun logger logger_err -> + Mods.StringSet.iter + (fun string -> + let () = + do_sbml logger logger_err (fun logger logger_err -> + let s = + Format.sprintf "metaid=\"%s\" species=\"%s\"" + (meta_id_of_logger logger) string + in + let () = + single_box + ~options:(fun () -> s) + logger logger_err "modifierSpeciesReference" in ()) in - () - ) - modifiers - ) - in - let () = - add_box_in_sbml_only ~break logger logger_err "kineticLaw" - (fun logger logger_err -> - add_box - ~break - ~options:(fun () -> - " xmlns=\"http://www.w3.org/1998/Math/MathML\"") - logger logger_err "math" label - (fun logger logger_err -> - dump_kinetic_law - ~propagate_constants - string_of_var_id - logger - logger_err - network - reactants - var_rule - correct - nocc - ) - ) - in - () - ) + ()) + modifiers) + in + let () = + add_box_in_sbml_only ~break logger logger_err "kineticLaw" + (fun logger logger_err -> + add_box ~break + ~options:(fun () -> + " xmlns=\"http://www.w3.org/1998/Math/MathML\"") + logger logger_err "math" label + (fun logger logger_err -> + dump_kinetic_law ~propagate_constants string_of_var_id logger + logger_err network reactants var_rule correct nocc)) + in + ()) in () let time_advance logger logger_err = let reaction_id = Ode_loggers_sig.get_fresh_reaction_id logger in - let label_reaction = "reaction" in + let label_reaction = "reaction" in let label_dotnet = "" in let label_list_of_products = "listOfProducts" in - let options = - (fun () -> Format.asprintf - "id=\"re%i\" name=\"time advance\" reversible=\"false\" fast=\"false\"" reaction_id) + let options () = + Format.asprintf + "id=\"re%i\" name=\"time advance\" reversible=\"false\" fast=\"false\"" + reaction_id in let () = add_box ~options ~break logger logger_err label_reaction label_dotnet (fun logger logger_err -> - let () = - add_box ~break logger logger_err label_list_of_products label_dotnet - (fun logger logger_err -> - let () = - do_sbml logger logger_err (fun logger logger_err -> - let s = - Format.sprintf - "metaid=\"%s\" species=\"time\"" - (meta_id_of_logger logger) - in - let () = - single_box ~options:(fun () -> s) logger logger_err - "speciesReference" - in - () - ) - in - () - ) - in - let () = - add_box ~break logger logger_err "kineticLaw" label_dotnet - (fun logger logger_err -> - add_box - ~break - ~options:(fun () -> - " xmlns=\"http://www.w3.org/1998/Math/MathML\"") - logger logger_err "math" label_dotnet - (fun logger logger_err -> - print_sbml logger logger_err (" 1 " )) - - ) - in - () - ) + let () = + add_box ~break logger logger_err label_list_of_products label_dotnet + (fun logger logger_err -> + let () = + do_sbml logger logger_err (fun logger logger_err -> + let s = + Format.sprintf "metaid=\"%s\" species=\"time\"" + (meta_id_of_logger logger) + in + let () = + single_box + ~options:(fun () -> s) + logger logger_err "speciesReference" + in + ()) + in + ()) + in + let () = + add_box ~break logger logger_err "kineticLaw" label_dotnet + (fun logger logger_err -> + add_box ~break + ~options:(fun () -> + " xmlns=\"http://www.w3.org/1998/Math/MathML\"") + logger logger_err "math" label_dotnet + (fun logger logger_err -> + print_sbml logger logger_err " 1 ")) + in + ()) in () diff --git a/core/parameters/config.ml b/core/parameters/config.ml index 1d655e6406..68f5a55309 100644 --- a/core/parameters/config.ml +++ b/core/parameters/config.ml @@ -1,4 +1,4 @@ - (** +(** * config.ml * openkappa * Jérôme Feret, projet Abstraction/Antique, INRIA Paris-Rocquencourt @@ -17,30 +17,34 @@ (** if unsafe = true, then whenever an exception is raised, a default value is output, and no exception is raised*) -let date="<2015.01.23" +let date = "<2015.01.23" let version = "4.01" - let output_directory = ref "output" let output_cm_directory = ref "output" let output_im_directory = ref "output" let output_local_trace_directory = ref "output" - let unsafe = ref true let trace = ref false let syntax_version = ref "V4" let dump_error_as_soon_as_they_occur = ref false let log = ref stdout let formatter = ref Format.std_formatter -let file = ref (None:string option) +let file = ref (None : string option) let link_mode = ref Remanent_parameters_sig.Bound_indices - (** influence map *) let do_influence_map = ref true + let rule_shape = ref Graph_loggers_sig.Rect -let rule_color = ref Graph_loggers_sig.LightSkyBlue (*"#87ceeb" (* light sky blue *)*) + +let rule_color = + ref Graph_loggers_sig.LightSkyBlue (*"#87ceeb" (* light sky blue *)*) + let variable_shape = ref Graph_loggers_sig.Ellipse -let variable_color = ref Graph_loggers_sig.PaleGreen (* "#98fb98" (*Pale green*)*) + +let variable_color = + ref Graph_loggers_sig.PaleGreen (* "#98fb98" (*Pale green*)*) + let center_color = ref Graph_loggers_sig.Red let wake_up_color = ref Graph_loggers_sig.Green (*"#00ff00" (*Green *)*) let inhibition_color = ref Graph_loggers_sig.Red (*"#ff0000" (*red*)*) @@ -50,16 +54,13 @@ let influence_map_file = ref "influence" let influence_map_format = ref "DOT" let prompt_full_var_def = ref false let prompt_full_rule_def = ref false -let make_labels_compatible_with_dot = - ref - [ - '\"', ['\\';'\"']; - '\\', ['\\';'\\'] - ] +let make_labels_compatible_with_dot = + ref [ '\"', [ '\\'; '\"' ]; '\\', [ '\\'; '\\' ] ] (** contact map*) let do_contact_map = ref true + let do_scc = ref false let pure_contact = ref false let contact_map_file = ref "contact" @@ -70,8 +71,8 @@ let internal_site_shape = ref Graph_loggers_sig.Ellipse let internal_site_color = ref Graph_loggers_sig.Green let counter_site_shape = ref Graph_loggers_sig.House let counter_site_color = ref Graph_loggers_sig.Grey -let agent_shape_array = ref ([||]:Graph_loggers_sig.shape option array) -let agent_color_array = ref ([||]:Graph_loggers_sig.color option array) +let agent_shape_array = ref ([||] : Graph_loggers_sig.shape option array) +let agent_color_array = ref ([||] : Graph_loggers_sig.color option array) let agent_shape_def = ref Graph_loggers_sig.Rect let agent_color_def = ref Graph_loggers_sig.Blue let link_color = ref Graph_loggers_sig.Black @@ -80,9 +81,12 @@ let influence_arrow = ref Graph_loggers_sig.Normal (**flow of information: internal; external flow*) let do_ODE_flow_of_information = ref false + let do_stochastic_flow_of_information = ref false + (*covering classes: this parameter does not matter if it is true/false*) let do_site_dependencies = ref false + (*set to true if one wants to print covering classes*) let dump_site_dependencies = ref false @@ -97,9 +101,7 @@ let dump_reachability_analysis_static = ref false let dump_reachability_analysis_dynamic = ref false let dump_reachability_analysis_diff = ref false let dump_reachability_analysis_wl = ref false - let hide_reverse_rule_without_label_from_dead_rules = ref true - let hide_one_d_relations_from_cartesian_decomposition = ref true let smash_relations = ref true let use_natural_language = ref "kappa" @@ -111,7 +113,6 @@ let add_singular_microstates = ref false let do_not_compress_trivial_losanges = ref false let local_trace_prefix = ref "Agent_trace_" let local_trace_format = ref "DOT" - let compute_separating_transitions = ref false (** accuracy *) @@ -122,8 +123,6 @@ let with_parallel_bonds_analysis = ref true let with_dynamic_contact_map = ref "dynamic" let with_counters_analysis = ref true let counter_analysis_domain = ref "mi" - - let view_accuracy_level = ref "High" let influence_map_accuracy_level = ref "Direct" let contact_map_accuracy_level = ref "Low" diff --git a/core/parameters/dune b/core/parameters/dune index 6e7ec7b12d..e68cd57f1c 100644 --- a/core/parameters/dune +++ b/core/parameters/dune @@ -1,10 +1,23 @@ (library - (name kappa_parameters) - (libraries yojson result kappa_version kappa_cli kappa-library.generic kappa_classical_graphs) - (flags (:standard) - -open Kappa_cli - -open Kappa_version - -open Kappa_grammar - -open Kappa_generic_toolset - -open Kappa_logging - -open Kappa_classical_graphs)) + (name kappa_parameters) + (libraries + yojson + result + kappa_version + kappa_cli + kappa-library.generic + kappa_classical_graphs) + (flags + (:standard) + -open + Kappa_cli + -open + Kappa_version + -open + Kappa_grammar + -open + Kappa_generic_toolset + -open + Kappa_logging + -open + Kappa_classical_graphs)) diff --git a/core/parameters/exception_without_parameter.ml b/core/parameters/exception_without_parameter.ml index 3451c916d2..4936dd2b7c 100644 --- a/core/parameters/exception_without_parameter.ml +++ b/core/parameters/exception_without_parameter.ml @@ -1,4 +1,4 @@ - (** +(** * exception.ml * openkappa * Jérôme Feret, projet Abstraction, INRIA Paris-Rocquencourt @@ -12,176 +12,146 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) +type uncaught_exception = { + file_name: string option; + message: string option; + alarm: exn; +} -type uncaught_exception = - {file_name:string option; - message:string option; - alarm: exn} -type caught_exception = - {uncaught_exception: uncaught_exception; - calling_stack: string list} +type caught_exception = { + uncaught_exception: uncaught_exception; + calling_stack: string list; +} exception Uncaught_exception of uncaught_exception exception Caught_exception of caught_exception - - -let rec exn_to_json = - function - | Exit -> `Assoc ["Exit", `Null] - | Not_found -> `Assoc ["Not_found", `Null] - | Arg.Bad x -> `Assoc ["Arg.Bad", JsonUtil.of_string x] - | Sys.Break -> `Assoc ["Sys.Break", `Null] - | Stack.Empty -> `Assoc ["Stack.Empty", `Null] - | Queue.Empty -> `Assoc ["Queue.Empty", `Null] - | Stream.Error x -> `Assoc ["Stream.Error", JsonUtil.of_string x] - | Stream.Failure -> `Assoc ["Stream.Failure", `Null] - | Arg.Help x -> `Assoc ["Arg.Help", JsonUtil.of_string x] - | Parsing.Parse_error -> `Assoc ["Parsing.Parse_error", `Null] - | Scanf.Scan_failure x -> - `Assoc ["Scan_failure", JsonUtil.of_string x] - | Lazy.Undefined -> `Assoc ["Lazy.Undefined", `Null] - | UnixLabels.Unix_error (a,b,c) -> +let rec exn_to_json = function + | Exit -> `Assoc [ "Exit", `Null ] + | Not_found -> `Assoc [ "Not_found", `Null ] + | Arg.Bad x -> `Assoc [ "Arg.Bad", JsonUtil.of_string x ] + | Sys.Break -> `Assoc [ "Sys.Break", `Null ] + | Stack.Empty -> `Assoc [ "Stack.Empty", `Null ] + | Queue.Empty -> `Assoc [ "Queue.Empty", `Null ] + | Stream.Error x -> `Assoc [ "Stream.Error", JsonUtil.of_string x ] + | Stream.Failure -> `Assoc [ "Stream.Failure", `Null ] + | Arg.Help x -> `Assoc [ "Arg.Help", JsonUtil.of_string x ] + | Parsing.Parse_error -> `Assoc [ "Parsing.Parse_error", `Null ] + | Scanf.Scan_failure x -> `Assoc [ "Scan_failure", JsonUtil.of_string x ] + | Lazy.Undefined -> `Assoc [ "Lazy.Undefined", `Null ] + | UnixLabels.Unix_error (a, b, c) -> `Assoc - ["UnixLabels.Unix_error", - `Assoc - ["fst",JsonUtil.of_unix_label a; - "snd",JsonUtil.of_string b; - "trd",JsonUtil.of_string c]] - | Unix.Unix_error (a,b,c) -> + [ + ( "UnixLabels.Unix_error", + `Assoc + [ + "fst", JsonUtil.of_unix_label a; + "snd", JsonUtil.of_string b; + "trd", JsonUtil.of_string c; + ] ); + ] + | Unix.Unix_error (a, b, c) -> `Assoc [ - "Unix.Unix.error", - `Assoc - ["fst",JsonUtil.of_unix_error a; - "snd",JsonUtil.of_string b; - "trd",JsonUtil.of_string c] + ( "Unix.Unix.error", + `Assoc + [ + "fst", JsonUtil.of_unix_error a; + "snd", JsonUtil.of_string b; + "trd", JsonUtil.of_string c; + ] ); ] - | Failure x -> `Assoc ["Failure", JsonUtil.of_string x] - | Stack_overflow -> `Assoc ["Stack_overflow", `Null] - | Caught_exception x -> - `Assoc ["Caught", caught_exception_to_json x] - | Uncaught_exception x -> `Assoc ["Uncaught", uncaught_exception_to_json x] - | _ -> `Assoc ["Unknown", `Null] + | Failure x -> `Assoc [ "Failure", JsonUtil.of_string x ] + | Stack_overflow -> `Assoc [ "Stack_overflow", `Null ] + | Caught_exception x -> `Assoc [ "Caught", caught_exception_to_json x ] + | Uncaught_exception x -> `Assoc [ "Uncaught", uncaught_exception_to_json x ] + | _ -> `Assoc [ "Unknown", `Null ] and uncaught_exception_to_json uncaught = - JsonUtil.of_triple - ~lab1:"file_name" ~lab2:"message" ~lab3:"exn" + JsonUtil.of_triple ~lab1:"file_name" ~lab2:"message" ~lab3:"exn" (JsonUtil.of_option JsonUtil.of_string) (JsonUtil.of_option JsonUtil.of_string) exn_to_json (uncaught.file_name, uncaught.message, uncaught.alarm) and caught_exception_to_json caught = - JsonUtil.of_pair - ~lab1:"uncaught_exception" ~lab2:"calling_stack" + JsonUtil.of_pair ~lab1:"uncaught_exception" ~lab2:"calling_stack" uncaught_exception_to_json (JsonUtil.of_list JsonUtil.of_string) (caught.uncaught_exception, caught.calling_stack) let rec exn_of_json (json : Yojson.Basic.t) = - match - json - with - | `Assoc ["Exit", `Null] -> Exit - | `Assoc ["Not_found", `Null] -> Not_found - | `Assoc ["Arg.Bad", x] -> Arg.Bad (JsonUtil.to_string x) - | `Assoc ["Sys.Break", `Null] -> Sys.Break - | `Assoc ["Stack.Empty", `Null] -> Stack.Empty - | `Assoc ["Queue.Empty", `Null] -> Queue.Empty - | `Assoc ["Stream.Error", x] -> Stream.Error (JsonUtil.to_string x) - | `Assoc ["Stream.Failure", `Null] -> Stream.Failure - | `Assoc ["Arg.Help", x] -> Arg.Help (JsonUtil.to_string x) - | `Assoc ["Parsing.Parse_error", `Null] -> Parsing.Parse_error - | `Assoc ["Scan_failure", x] -> - Scanf.Scan_failure - (JsonUtil.to_string x) - | `Assoc ["Lazy.Undefined", `Null] -> Lazy.Undefined - | `Assoc - ["UnixLabels.Unix_error", `Assoc l] when List.length l = 3 -> - begin - try - UnixLabels.Unix_error - (JsonUtil.to_unix_label (List.assoc "fst" l), + match json with + | `Assoc [ ("Exit", `Null) ] -> Exit + | `Assoc [ ("Not_found", `Null) ] -> Not_found + | `Assoc [ ("Arg.Bad", x) ] -> Arg.Bad (JsonUtil.to_string x) + | `Assoc [ ("Sys.Break", `Null) ] -> Sys.Break + | `Assoc [ ("Stack.Empty", `Null) ] -> Stack.Empty + | `Assoc [ ("Queue.Empty", `Null) ] -> Queue.Empty + | `Assoc [ ("Stream.Error", x) ] -> Stream.Error (JsonUtil.to_string x) + | `Assoc [ ("Stream.Failure", `Null) ] -> Stream.Failure + | `Assoc [ ("Arg.Help", x) ] -> Arg.Help (JsonUtil.to_string x) + | `Assoc [ ("Parsing.Parse_error", `Null) ] -> Parsing.Parse_error + | `Assoc [ ("Scan_failure", x) ] -> Scanf.Scan_failure (JsonUtil.to_string x) + | `Assoc [ ("Lazy.Undefined", `Null) ] -> Lazy.Undefined + | `Assoc [ ("UnixLabels.Unix_error", `Assoc l) ] when List.length l = 3 -> + (try + UnixLabels.Unix_error + ( JsonUtil.to_unix_label (List.assoc "fst" l), JsonUtil.to_string (List.assoc "snd" l), - JsonUtil.to_string (List.assoc "trd" l)) - with - | _ -> - raise (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "unix labels error",json)) - end - | `Assoc - ["Unix.Unix_error", `Assoc l] when List.length l = 3 -> - begin - try - Unix.Unix_error - (JsonUtil.to_unix_label (List.assoc "fst" l), + JsonUtil.to_string (List.assoc "trd" l) ) + with _ -> + raise + (Yojson.Basic.Util.Type_error + (JsonUtil.build_msg "unix labels error", json))) + | `Assoc [ ("Unix.Unix_error", `Assoc l) ] when List.length l = 3 -> + (try + Unix.Unix_error + ( JsonUtil.to_unix_label (List.assoc "fst" l), JsonUtil.to_string (List.assoc "snd" l), - JsonUtil.to_string (List.assoc "trd" l)) - with - | _ -> - raise (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "unix error",json)) - end - | `Assoc ["Failure", x] -> Failure (JsonUtil.to_string x) - | `Assoc ["Stack_overflow", `Null] -> Stack_overflow - | `Assoc ["Caught", x] -> Caught_exception (caught_exception_of_json x) - | `Assoc ["Uncaught", x] -> Uncaught_exception (uncaught_exception_of_json x) - | `Assoc ["Unknown", `Null] -> Failure "Unknown" + JsonUtil.to_string (List.assoc "trd" l) ) + with _ -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "unix error", json))) + | `Assoc [ ("Failure", x) ] -> Failure (JsonUtil.to_string x) + | `Assoc [ ("Stack_overflow", `Null) ] -> Stack_overflow + | `Assoc [ ("Caught", x) ] -> Caught_exception (caught_exception_of_json x) + | `Assoc [ ("Uncaught", x) ] -> + Uncaught_exception (uncaught_exception_of_json x) + | `Assoc [ ("Unknown", `Null) ] -> Failure "Unknown" | _ -> - raise (Yojson.Basic.Util.Type_error - (JsonUtil.build_msg "exception",json)) + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "exception", json)) and uncaught_exception_of_json json = - let a,b,c = - JsonUtil.to_triple - ~lab1:"file_name" ~lab2:"message" ~lab3:"exn" - (JsonUtil.to_option (JsonUtil.to_string ~error_msg:"file_name")) - (JsonUtil.to_option (JsonUtil.to_string ~error_msg:"message")) - exn_of_json - json + let a, b, c = + JsonUtil.to_triple ~lab1:"file_name" ~lab2:"message" ~lab3:"exn" + (JsonUtil.to_option (JsonUtil.to_string ~error_msg:"file_name")) + (JsonUtil.to_option (JsonUtil.to_string ~error_msg:"message")) + exn_of_json json in - { - file_name = a ; - message = b ; - alarm = c - } + { file_name = a; message = b; alarm = c } and caught_exception_of_json json = - let a,b = - JsonUtil.to_pair - ~lab1:"uncaught_exception" ~lab2:"calling_stack" - uncaught_exception_of_json - (JsonUtil.to_list ~error_msg:"calling stack" (JsonUtil.to_string ~error_msg:"stack elt")) - json + let a, b = + JsonUtil.to_pair ~lab1:"uncaught_exception" ~lab2:"calling_stack" + uncaught_exception_of_json + (JsonUtil.to_list ~error_msg:"calling stack" + (JsonUtil.to_string ~error_msg:"stack elt")) + json in - { - uncaught_exception = a; - calling_stack = b - } - - - + { uncaught_exception = a; calling_stack = b } let build_uncaught_exception ?file_name ?message exn = - { - file_name = file_name; - message = message ; - alarm = exn ; - } + { file_name; message; alarm = exn } let build_caught_exception file_name message exn stack = { - uncaught_exception = build_uncaught_exception ?file_name ?message exn ; - calling_stack = stack ; + uncaught_exception = build_uncaught_exception ?file_name ?message exn; + calling_stack = stack; } let raise_exception file_name _key message exn = - raise - (Uncaught_exception - {file_name=file_name; - message=message; - alarm=exn}) + raise (Uncaught_exception { file_name; message; alarm = exn }) let rec pp_exception f = function | Exit -> Format.pp_print_string f "Exit" @@ -196,133 +166,177 @@ let rec pp_exception f = function | Parsing.Parse_error -> Format.pp_print_string f "Parsing.Parse_error" | Scanf.Scan_failure x -> Format.fprintf f "Scanf.Scan.failure(%s)" x | Lazy.Undefined -> Format.pp_print_string f "Lazy.Undefined" - | UnixLabels.Unix_error (er,x,y) -> + | UnixLabels.Unix_error (er, x, y) -> Format.fprintf f "UnixLabels.Unix_error(%s,%s,%s)" - (UnixLabels.error_message er) x y - | Unix.Unix_error (er,x,y) -> + (UnixLabels.error_message er) + x y + | Unix.Unix_error (er, x, y) -> Format.fprintf f "Unix.Unix_error(%s,%s,%s)" (Unix.error_message er) x y | Failure x -> Format.fprintf f "Failure(%s)" x | Stack_overflow -> Format.pp_print_string f "Stack_overflow" - | Uncaught_exception x -> + | Uncaught_exception x -> Format.fprintf f "Uncaught_exception(%a)" pp_uncaught x - | Caught_exception x -> - Format.fprintf f "Caught_exception(%a)" pp_caught x + | Caught_exception x -> Format.fprintf f "Caught_exception(%a)" pp_caught x | exc -> Format.pp_print_string f (Printexc.to_string exc) + and pp_uncaught f x = let with_space = false in Format.fprintf f "@[%a%aexception:@ %a@]" (Pp.option ~with_space (fun f x -> Format.fprintf f "file_name: %s; " x)) x.file_name (Pp.option ~with_space (fun f x -> Format.fprintf f "message: %s; " x)) - x.message - pp_exception x.alarm + x.message pp_exception x.alarm + and pp_caught f x = Format.fprintf f "@[calling_stack: %a; %a@]" - (Pp.list (Pp.space) Format.pp_print_string) x.calling_stack - pp_uncaught x.uncaught_exception + (Pp.list Pp.space Format.pp_print_string) + x.calling_stack pp_uncaught x.uncaught_exception let rec stringlist_of_exception x stack = match x with - Exit -> "Exit"::stack - | Not_found -> "Not_found"::stack - | Arg.Bad x -> "Arg.Bad("::x::")"::stack - | Sys.Break -> "Sys.Break"::stack - | Stack.Empty -> "Stack.Empty"::stack - | Queue.Empty -> "Queue.Empty"::stack - | Stream.Error x -> "Stream.Error"::x::stack - | Stream.Failure -> "Stream.Failure"::stack - | Arg.Help x -> "Arg.Help("::x::")"::stack - | Parsing.Parse_error -> "Parsing.Parse_error"::stack - | Scanf.Scan_failure x -> "Scanf.Scan.failure("::x::")"::stack - | Lazy.Undefined -> "Lazy.Undefined"::stack - | UnixLabels.Unix_error _ -> "UnixLabels.Unix_error"::stack - | Unix.Unix_error _ -> "Unix.Unix.error"::stack - | Failure x -> "Failure("::x::")"::stack - | Stack_overflow -> "Stack_overflow"::stack - | Caught_exception x -> "Caught_exception("::(stringlist_of_caught x (")"::stack)) - | Uncaught_exception x -> "Uncaught_exception("::(stringlist_of_uncaught x (")"::stack)) - | _ -> "Unknown"::stack + | Exit -> "Exit" :: stack + | Not_found -> "Not_found" :: stack + | Arg.Bad x -> "Arg.Bad(" :: x :: ")" :: stack + | Sys.Break -> "Sys.Break" :: stack + | Stack.Empty -> "Stack.Empty" :: stack + | Queue.Empty -> "Queue.Empty" :: stack + | Stream.Error x -> "Stream.Error" :: x :: stack + | Stream.Failure -> "Stream.Failure" :: stack + | Arg.Help x -> "Arg.Help(" :: x :: ")" :: stack + | Parsing.Parse_error -> "Parsing.Parse_error" :: stack + | Scanf.Scan_failure x -> "Scanf.Scan.failure(" :: x :: ")" :: stack + | Lazy.Undefined -> "Lazy.Undefined" :: stack + | UnixLabels.Unix_error _ -> "UnixLabels.Unix_error" :: stack + | Unix.Unix_error _ -> "Unix.Unix.error" :: stack + | Failure x -> "Failure(" :: x :: ")" :: stack + | Stack_overflow -> "Stack_overflow" :: stack + | Caught_exception x -> + "Caught_exception(" :: stringlist_of_caught x (")" :: stack) + | Uncaught_exception x -> + "Uncaught_exception(" :: stringlist_of_uncaught x (")" :: stack) + | _ -> "Unknown" :: stack + and stringlist_of_uncaught x stack = - (match x.file_name with - None -> "" - | Some file_name -> "file_name: "^file_name^"; ") - ::(match x.message with - None -> "" - | Some message -> "message: "^message^"; ") - ::"exception:" - ::(stringlist_of_exception x.alarm stack) + (match x.file_name with + | None -> "" + | Some file_name -> "file_name: " ^ file_name ^ "; ") + :: (match x.message with + | None -> "" + | Some message -> "message: " ^ message ^ "; ") + :: "exception:" + :: stringlist_of_exception x.alarm stack + and stringlist_of_caught x stack = "calling_stack: " - ::(List.fold_left - (fun sol string -> string::", "::sol) - ("; "::(stringlist_of_uncaught x.uncaught_exception ("; "::stack)))) - x.calling_stack + :: (List.fold_left + (fun sol string -> string :: ", " :: sol) + ("; " :: stringlist_of_uncaught x.uncaught_exception ("; " :: stack))) + x.calling_stack + and stringlist_of_uncaught_light x stack = - (match x.file_name with - None -> "" - | Some file_name -> "file_name: "^file_name^"; ") - ::(match x.message with - None -> "" - | Some message -> "message: "^message^"; ") - ::"exception:" - ::(stringlist_of_exception x.alarm stack) + (match x.file_name with + | None -> "" + | Some file_name -> "file_name: " ^ file_name ^ "; ") + :: (match x.message with + | None -> "" + | Some message -> "message: " ^ message ^ "; ") + :: "exception:" + :: stringlist_of_exception x.alarm stack + and stringlist_of_caught_light x stack = "calling_stack: " - ::(List.fold_left - (fun sol string -> string::", "::sol) - ("; "::(stringlist_of_uncaught_light x.uncaught_exception ("; "::stack)))) - x.calling_stack + :: (List.fold_left + (fun sol string -> string :: ", " :: sol) + ("; " + :: stringlist_of_uncaught_light x.uncaught_exception ("; " :: stack))) + x.calling_stack type method_handler = { - mh_caught_error_list:caught_exception list; - mh_uncaught_error_list:uncaught_exception list; + mh_caught_error_list: caught_exception list; + mh_caught_error_list_to_ui: caught_exception list; + mh_uncaught_error_list: uncaught_exception list; + mh_uncaught_error_list_to_ui: uncaught_exception list; } let to_json method_handler = `Assoc [ - "caught", - JsonUtil.of_list - caught_exception_to_json method_handler.mh_caught_error_list; - "uncaught", - JsonUtil.of_list - uncaught_exception_to_json method_handler.mh_uncaught_error_list; + ( "caught", + JsonUtil.of_list caught_exception_to_json + method_handler.mh_caught_error_list ); + ( "caught", + JsonUtil.of_list caught_exception_to_json + method_handler.mh_caught_error_list_to_ui ); + ( "uncaught", + JsonUtil.of_list uncaught_exception_to_json + method_handler.mh_uncaught_error_list ); + ( "uncaught_to_ui", + JsonUtil.of_list uncaught_exception_to_json + method_handler.mh_uncaught_error_list_to_ui ); ] -let of_json = - function +let of_json = function | `Assoc l as x when List.length l = 2 -> - begin - try - let caught = - (JsonUtil.to_list caught_exception_of_json) - (List.assoc "caught" l) - in - let uncaught = - (JsonUtil.to_list uncaught_exception_of_json) - (List.assoc "uncaught" l) - in - { - mh_caught_error_list = caught ; - mh_uncaught_error_list = uncaught ; - } - with - | _ -> - raise - (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "error handler",x)) - end + (try + let caught = + (JsonUtil.to_list caught_exception_of_json) (List.assoc "caught" l) + in + let caught_to_ui = + (JsonUtil.to_list caught_exception_of_json) + (List.assoc "caught_to_ui" l) + in + let uncaught = + (JsonUtil.to_list uncaught_exception_of_json) (List.assoc "uncaught" l) + in + let uncaught_to_ui = + (JsonUtil.to_list uncaught_exception_of_json) + (List.assoc "uncaught_to_ui" l) + in + { + mh_caught_error_list = caught; + mh_caught_error_list_to_ui = caught_to_ui; + mh_uncaught_error_list = uncaught; + mh_uncaught_error_list_to_ui = uncaught_to_ui; + } + with _ -> + raise + (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "error handler", x))) | x -> - raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "error handler",x)) + raise (Yojson.Basic.Util.Type_error (JsonUtil.build_msg "error handler", x)) let empty_error_handler = { - mh_caught_error_list=[]; - mh_uncaught_error_list=[]; + mh_caught_error_list = []; + mh_caught_error_list_to_ui = []; + mh_uncaught_error_list = []; + mh_uncaught_error_list_to_ui = []; + } + +let add_uncaught_error_to_ui uncaught error = + { + error with + mh_uncaught_error_list_to_ui = + uncaught :: error.mh_uncaught_error_list_to_ui; } -let add_uncaught_error uncaught error = {error with mh_uncaught_error_list = uncaught::error.mh_uncaught_error_list} +let add_uncaught_error_to_others uncaught error = + { + error with + mh_uncaught_error_list = uncaught :: error.mh_uncaught_error_list; + } + +let add_uncaught_error ?to_ui uncaught error = + let error = + match to_ui with + | Some false | None -> error + | Some true -> add_uncaught_error_to_ui uncaught error + in + add_uncaught_error_to_others uncaught error + let get_caught_exception_list error = error.mh_caught_error_list +let get_caught_exception_list_to_ui error = error.mh_caught_error_list_to_ui let get_uncaught_exception_list error = error.mh_uncaught_error_list +let get_uncaught_exception_list_to_ui error = error.mh_uncaught_error_list_to_ui let is_empty_error_handler x = - x.mh_caught_error_list=[] && x.mh_uncaught_error_list=[] + x.mh_caught_error_list = [] && x.mh_uncaught_error_list = [] diff --git a/core/parameters/exception_without_parameter.mli b/core/parameters/exception_without_parameter.mli index b37c02f860..55ca8371a0 100644 --- a/core/parameters/exception_without_parameter.mli +++ b/core/parameters/exception_without_parameter.mli @@ -1,4 +1,4 @@ - (** +(** * exception.mli * openkappa * Jérôme Feret, projet Abstraction, INRIA Paris-Rocquencourt @@ -12,33 +12,42 @@ * en Automatique. All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - type uncaught_exception + exception Uncaught_exception of uncaught_exception type caught_exception + exception Caught_exception of caught_exception type method_handler -val raise_exception: string option -> unit -> string option -> exn -> unit -val build_uncaught_exception: ?file_name:string -> ?message:string -> exn -> uncaught_exception -val build_caught_exception: string option -> string option -> exn -> string list -> caught_exception -val add_uncaught_error: uncaught_exception -> method_handler -> method_handler -val stringlist_of_exception: exn -> string list -> string list -val stringlist_of_uncaught: uncaught_exception -> string list -> string list -val stringlist_of_caught: caught_exception -> string list -> string list -val stringlist_of_caught_light: caught_exception -> string list -> string list +val raise_exception : string option -> unit -> string option -> exn -> unit + +val build_uncaught_exception : + ?file_name:string -> ?message:string -> exn -> uncaught_exception + +val build_caught_exception : + string option -> string option -> exn -> string list -> caught_exception -val pp_exception: Format.formatter -> exn -> unit -val pp_uncaught: Format.formatter -> uncaught_exception -> unit -val pp_caught: Format.formatter -> caught_exception -> unit +val add_uncaught_error : + ?to_ui:bool -> uncaught_exception -> method_handler -> method_handler -val empty_error_handler: method_handler -val is_empty_error_handler: method_handler -> bool +val stringlist_of_exception : exn -> string list -> string list +val stringlist_of_uncaught : uncaught_exception -> string list -> string list +val stringlist_of_caught : caught_exception -> string list -> string list +val stringlist_of_caught_light : caught_exception -> string list -> string list +val pp_exception : Format.formatter -> exn -> unit +val pp_uncaught : Format.formatter -> uncaught_exception -> unit +val pp_caught : Format.formatter -> caught_exception -> unit +val empty_error_handler : method_handler +val is_empty_error_handler : method_handler -> bool +val get_caught_exception_list : method_handler -> caught_exception list +val get_caught_exception_list_to_ui : method_handler -> caught_exception list +val get_uncaught_exception_list : method_handler -> uncaught_exception list -val get_caught_exception_list: method_handler -> caught_exception list -val get_uncaught_exception_list: method_handler -> uncaught_exception list +val get_uncaught_exception_list_to_ui : + method_handler -> uncaught_exception list -val to_json: method_handler -> Yojson.Basic.t -val of_json: Yojson.Basic.t -> method_handler +val to_json : method_handler -> Yojson.Basic.t +val of_json : Yojson.Basic.t -> method_handler diff --git a/core/parameters/fileNames.ml b/core/parameters/fileNames.ml index 41764452e9..fbf1ef89da 100644 --- a/core/parameters/fileNames.ml +++ b/core/parameters/fileNames.ml @@ -1,4 +1,4 @@ (*file names*) -let input:(string list ref) = ref [] (*name of the kappa files*) +let input : string list ref = ref [] (*name of the kappa files*) let output = ref "data.out" diff --git a/core/parameters/get_option.ml b/core/parameters/get_option.ml index 19dc5da24c..89bcbfb61c 100644 --- a/core/parameters/get_option.ml +++ b/core/parameters/get_option.ml @@ -14,458 +14,493 @@ open Superarg -let actions = "Actions",0,None -let syntax = "Syntax",1,None -let output = "Output",2,None -let reachability = "Reachability analysis",3,None -let traces = "Trace analysis",4,None -let contact_map = "Contact map",5,None -let influence_map = "Influence map",6,None -let flow = "Flow of information",7,None -let debug = "Debugging information",8,None +let actions = "Actions", 0, None +let syntax = "Syntax", 1, None +let output = "Output", 2, None +let reachability = "Reachability analysis", 3, None +let traces = "Trace analysis", 4, None +let contact_map = "Contact map", 5, None +let influence_map = "Influence map", 6, None +let flow = "Flow of information", 7, None +let debug = "Debugging information", 8, None let options = List.rev [ - "--do-all", - Multi( - [ - "--compute-contact-map"; - "--compute-influence-map"; - "--compute-ODE-flow-of-information"; - "--compute-potential-cycles"; - "--compute-stochastic-flow-of-information"; - "--compute-reachability-analysis"; - ],[]),"launch everything",[actions,0],Normal; - "--reset-all", - Multi( - [ - "--no-compute-contact-map"; - "--no-compute-influence-map"; - "--no-compute-ODE-flow-of-information"; - "--no-compute-potential-cycles"; - "--no-compute-stochastic-flow-of-information"; - "--no-compute-reachability-analysis"; - ],[]),"launch nothing",[actions,1],Normal; - "--void",Void,"",[actions,2],Normal; - "-syntax", - Choice - (["V3","previous version"; - "V4","current version"], - ["V3";"V4";"3";"4";"v3";"v4"], - Config.syntax_version), - "Version of the lexer/parser", - [syntax,1;actions,30], - Normal; - - "--compute-contact-map", - Bool Config.do_contact_map, - "compute the contact map", - [actions,2;contact_map,0], - Normal; - - "--compute-influence-map", - Bool Config.do_influence_map, - "compute the influence map", - [actions,3;influence_map,0], - Normal; - - "--influence-map-accuracy-level", - (Choice - (["Indirect","Ignore gluing compatibility"; - "Direct","Ignore reachable states"; - "Realisable","Take into account reachable states" ], - ["Low";"Medium";"High";"Full"], - Config.influence_map_accuracy_level)), - "Tune the accuracy level of the influence map", - [influence_map,1], - Normal; - - "--compute-ODE-flow-of-information", - Bool Config.do_ODE_flow_of_information, - "Compute an approximation of the flow of information in the ODE semantics", - [actions,4;flow,6], - Expert; - - "--compute-potential-cycles", - Bool Config.do_scc, - "Compute the bonds that may be involved in polymerisation", - [actions,5;contact_map,1], Normal; - - "--compute-stochastic-flow-of-information", - Bool Config.do_stochastic_flow_of_information, - "Compute an approximation of the flow of information in the stochastic semantics", - [actions,6;flow,6], - Expert; - - "--compute-reachability-analysis", - Bool Config.do_reachability_analysis, - "Compute an approximation of the states of agent sites", - [actions,7;reachability,0], - Normal; - "--enable-every-domain", - Multi( - [ - "--contact-map-domain";"dynamic"; - "--views-domain"; - "--double-bonds-domain"; - "--sites-across-bonds-domain"; - ],[]),"enable every abstract domain",[reachability,1],Normal; - "--disable-every-domain", - Multi( - [ - "--contact-map-domain";"static"; - "--no-views-domain"; - "--no-double-bonds-domain"; - "--no-sites-across-bonds-domain"; - ],[]),"disable every abstract domain",[reachability,2],Normal; - "--contact-map-domain", - Choice - (["static","Very coarse static abstraction: every bond that occurs in initial states and rhs of rules is considered"; - "dynamic","More accurate abstraction: only the bonds that occur in the initial state or a rule that has already been applied successfully, are considered"], - [], - Config.with_dynamic_contact_map),"contact map domain is used to over-approximate side-effects", - [reachability,3],Normal; - "--views-domain", - Bool Config.with_views_analysis, - "enable local views analysis", - [reachability,4],Normal; - "--counters-domain", - Bool Config.with_counters_analysis, - "enable counter analysis", - [reachability,5],Normal; - "--counters-accuracy", - Choice - (["non-relational","Lower and upper bounds for each variable"; - "octagons","Lower and upper bounds for each variable, an each sum and each difference among two variables"; - "mi","Approximate reduced product between intervals and affine relationships"; - ],["oct";"octo";"octagon";"MI";"Mi";"Oct";"Octo";"Octagon";"Octagons";"non-relational";"nr";"non-rel";"non_rel"; "non_relational";"Non-relational";"Nr";"Non-rel";"Non_rel"; "Non_relational"],Config.counter_analysis_domain), - "Abstract domain for counter analysis", - [reachability,6],Normal; - "--double-bonds-domain", - Bool Config.with_parallel_bonds_analysis, - "enable double bonds analysis", - [reachability,7],Normal; - "--sites-across-bonds-domain", - Bool Config.with_site_across_bonds_analysis, - "enable the analysis of the relation among the states of sites in connected agents", - [reachability,8],Normal; - "--sites-accross-bonds-domain", - Bool Config.with_site_across_bonds_analysis, - "enable the analysis of the relation among the states of sites in connected agents", - [reachability,8],Hidden; - - "--compute-symmetries", - Bool Config.do_symmetries, - "Look up for pairs of symmetric sites", - [actions,8],Normal; - "--verbosity-level-for-view-analysis", - (Choice - ([ - "Mute","No information displayed"; - "Low","Show analysis result only"; - "Medium","Also show which rules are applied"; - "High","Also show when new views are discovered"; - "Full","Also show which rules are put in the working list"], - [], - Config.verbosity_level_for_reachability_analysis)), - "Tune the verbosity level for the view analysis", - [reachability,9], - Hidden; - - "--verbosity-level-for-reachability-analysis", - (Choice - ([ - "Mute","No information displayed"; - "Low","Show analysis result only"; - "Medium","Also show which rules are applied"; - "High","Also show when patterns are discovered"; - "Full","Also show which rules are put in the working list"], - [], - Config.verbosity_level_for_reachability_analysis)), - "Tune the verbosity level for the reachability analysis", - [reachability,10], - Normal; - "--hide-one-d-relations-from-cartesian-decomposition", - Bool Config.hide_one_d_relations_from_cartesian_decomposition, - "Filter out 1-d relations from the Cartesian decomposition", - [reachability,11], - Developper; - - "--smash-relations", - Bool Config.smash_relations, - "Recombine relations to get a more precise & compact output", - [reachability,12], - Developper; - - "--output-mode-for-reachability-analysis", - (Choice (["raw","no post-processing"; - "kappa","kappa mode"; - "english","natural language" - ],[], - Config.use_natural_language)), - "post-process relation and output the result in the chosen format", - [reachability,13], - Normal; - - "--compute-local-traces", - Bool Config.compute_local_traces, - "Compute the local traces of interesting parts of agent interfaces", - [actions,9;traces,0], - Normal; - - "--show-rule-names-in-local-traces", - Bool Config.show_rule_names_in_local_traces, - "Annotate each transition with the name of the rules in trace abstraction", - [traces,1], - Normal; - - "--use-macrotransitions-in-local-traces", - Bool Config.use_macrotransitions_in_local_traces, - "Use macrotransitions to get a compact trace up to change of the interleaving order of commuting microtransitions", - [traces,2], - Normal; - - "--ignore-trivial-losanges", - Bool Config.do_not_compress_trivial_losanges, - "Do not use macrotransitions for simplifying trivial losanges", - [traces,3], - Expert; - - "--add-singular-macrostates", - Bool Config.add_singular_macrostates, - "Complete the simplicial complexes with singular intersection of higher-dimension faces", - [traces,4], - Hidden; - - "--add-singular-microstates", - Bool Config.add_singular_microstates, - "Complete the simplicial complexes with singular intersection of higher-dimension faces", - [traces,5], - Hidden; - - "--compute-separating-transitions", - Bool Config.compute_separating_transitions, - "Compute the transitions that separates strongly connected set of configurations", - [actions,10;traces,6], - Normal; - - "--output-directory", - MultiExt - [ - "--output-contact-map-directory",""; - "--output-influence-map-directory",""; - "--output-local-traces-directory",""; - "--output-log-directory",""], - "Default repository for outputs", - [output,0], - Normal; - + ( "--do-all", + Multi + ( [ + "--compute-contact-map"; + "--compute-influence-map"; + "--compute-ODE-flow-of-information"; + "--compute-potential-cycles"; + "--compute-stochastic-flow-of-information"; + "--compute-reachability-analysis"; + ], + [] ), + "launch everything", + [ actions, 0 ], + Normal ); + ( "--reset-all", + Multi + ( [ + "--no-compute-contact-map"; + "--no-compute-influence-map"; + "--no-compute-ODE-flow-of-information"; + "--no-compute-potential-cycles"; + "--no-compute-stochastic-flow-of-information"; + "--no-compute-reachability-analysis"; + ], + [] ), + "launch nothing", + [ actions, 1 ], + Normal ); + "--void", Void, "", [ actions, 2 ], Normal; + ( "-syntax", + Choice + ( [ "V3", "previous version"; "V4", "current version" ], + [ "V3"; "V4"; "3"; "4"; "v3"; "v4" ], + Config.syntax_version ), + "Version of the lexer/parser", + [ syntax, 1; actions, 30 ], + Normal ); + ( "--compute-contact-map", + Bool Config.do_contact_map, + "compute the contact map", + [ actions, 2; contact_map, 0 ], + Normal ); + ( "--compute-influence-map", + Bool Config.do_influence_map, + "compute the influence map", + [ actions, 3; influence_map, 0 ], + Normal ); + ( "--influence-map-accuracy-level", + Choice + ( [ + "Indirect", "Ignore gluing compatibility"; + "Direct", "Ignore reachable states"; + "Realisable", "Take into account reachable states"; + ], + [ "Low"; "Medium"; "High"; "Full" ], + Config.influence_map_accuracy_level ), + "Tune the accuracy level of the influence map", + [ influence_map, 1 ], + Normal ); + ( "--compute-ODE-flow-of-information", + Bool Config.do_ODE_flow_of_information, + "Compute an approximation of the flow of information in the ODE \ + semantics", + [ actions, 4; flow, 6 ], + Expert ); + ( "--compute-potential-cycles", + Bool Config.do_scc, + "Compute the bonds that may be involved in polymerisation", + [ actions, 5; contact_map, 1 ], + Normal ); + ( "--compute-stochastic-flow-of-information", + Bool Config.do_stochastic_flow_of_information, + "Compute an approximation of the flow of information in the stochastic \ + semantics", + [ actions, 6; flow, 6 ], + Expert ); + ( "--compute-reachability-analysis", + Bool Config.do_reachability_analysis, + "Compute an approximation of the states of agent sites", + [ actions, 7; reachability, 0 ], + Normal ); + ( "--enable-every-domain", + Multi + ( [ + "--contact-map-domain"; + "dynamic"; + "--views-domain"; + "--double-bonds-domain"; + "--sites-across-bonds-domain"; + ], + [] ), + "enable every abstract domain", + [ reachability, 1 ], + Normal ); + ( "--disable-every-domain", + Multi + ( [ + "--contact-map-domain"; + "static"; + "--no-views-domain"; + "--no-double-bonds-domain"; + "--no-sites-across-bonds-domain"; + ], + [] ), + "disable every abstract domain", + [ reachability, 2 ], + Normal ); + ( "--contact-map-domain", + Choice + ( [ + ( "static", + "Very coarse static abstraction: every bond that occurs in \ + initial states and rhs of rules is considered" ); + ( "dynamic", + "More accurate abstraction: only the bonds that occur in the \ + initial state or a rule that has already been applied \ + successfully, are considered" ); + ], + [], + Config.with_dynamic_contact_map ), + "contact map domain is used to over-approximate side-effects", + [ reachability, 3 ], + Normal ); + ( "--views-domain", + Bool Config.with_views_analysis, + "enable local views analysis", + [ reachability, 4 ], + Normal ); + ( "--counters-domain", + Bool Config.with_counters_analysis, + "enable counter analysis", + [ reachability, 5 ], + Normal ); + ( "--counters-accuracy", + Choice + ( [ + "non-relational", "Lower and upper bounds for each variable"; + ( "octagons", + "Lower and upper bounds for each variable, an each sum and \ + each difference among two variables" ); + ( "mi", + "Approximate reduced product between intervals and affine \ + relationships" ); + ], + [ + "oct"; + "octo"; + "octagon"; + "MI"; + "Mi"; + "Oct"; + "Octo"; + "Octagon"; + "Octagons"; + "non-relational"; + "nr"; + "non-rel"; + "non_rel"; + "non_relational"; + "Non-relational"; + "Nr"; + "Non-rel"; + "Non_rel"; + "Non_relational"; + ], + Config.counter_analysis_domain ), + "Abstract domain for counter analysis", + [ reachability, 6 ], + Normal ); + ( "--double-bonds-domain", + Bool Config.with_parallel_bonds_analysis, + "enable double bonds analysis", + [ reachability, 7 ], + Normal ); + ( "--sites-across-bonds-domain", + Bool Config.with_site_across_bonds_analysis, + "enable the analysis of the relation among the states of sites in \ + connected agents", + [ reachability, 8 ], + Normal ); + ( "--sites-accross-bonds-domain", + Bool Config.with_site_across_bonds_analysis, + "enable the analysis of the relation among the states of sites in \ + connected agents", + [ reachability, 8 ], + Hidden ); + ( "--compute-symmetries", + Bool Config.do_symmetries, + "Look up for pairs of symmetric sites", + [ actions, 8 ], + Normal ); + ( "--verbosity-level-for-view-analysis", + Choice + ( [ + "Mute", "No information displayed"; + "Low", "Show analysis result only"; + "Medium", "Also show which rules are applied"; + "High", "Also show when new views are discovered"; + "Full", "Also show which rules are put in the working list"; + ], + [], + Config.verbosity_level_for_reachability_analysis ), + "Tune the verbosity level for the view analysis", + [ reachability, 9 ], + Hidden ); + ( "--verbosity-level-for-reachability-analysis", + Choice + ( [ + "Mute", "No information displayed"; + "Low", "Show analysis result only"; + "Medium", "Also show which rules are applied"; + "High", "Also show when patterns are discovered"; + "Full", "Also show which rules are put in the working list"; + ], + [], + Config.verbosity_level_for_reachability_analysis ), + "Tune the verbosity level for the reachability analysis", + [ reachability, 10 ], + Normal ); + ( "--hide-one-d-relations-from-cartesian-decomposition", + Bool Config.hide_one_d_relations_from_cartesian_decomposition, + "Filter out 1-d relations from the Cartesian decomposition", + [ reachability, 11 ], + Developper ); + ( "--smash-relations", + Bool Config.smash_relations, + "Recombine relations to get a more precise & compact output", + [ reachability, 12 ], + Developper ); + ( "--output-mode-for-reachability-analysis", + Choice + ( [ + "raw", "no post-processing"; + "kappa", "kappa mode"; + "english", "natural language"; + ], + [], + Config.use_natural_language ), + "post-process relation and output the result in the chosen format", + [ reachability, 13 ], + Normal ); + ( "--compute-local-traces", + Bool Config.compute_local_traces, + "Compute the local traces of interesting parts of agent interfaces", + [ actions, 9; traces, 0 ], + Normal ); + ( "--show-rule-names-in-local-traces", + Bool Config.show_rule_names_in_local_traces, + "Annotate each transition with the name of the rules in trace \ + abstraction", + [ traces, 1 ], + Normal ); + ( "--use-macrotransitions-in-local-traces", + Bool Config.use_macrotransitions_in_local_traces, + "Use macrotransitions to get a compact trace up to change of the \ + interleaving order of commuting microtransitions", + [ traces, 2 ], + Normal ); + ( "--ignore-trivial-losanges", + Bool Config.do_not_compress_trivial_losanges, + "Do not use macrotransitions for simplifying trivial losanges", + [ traces, 3 ], + Expert ); + ( "--add-singular-macrostates", + Bool Config.add_singular_macrostates, + "Complete the simplicial complexes with singular intersection of \ + higher-dimension faces", + [ traces, 4 ], + Hidden ); + ( "--add-singular-microstates", + Bool Config.add_singular_microstates, + "Complete the simplicial complexes with singular intersection of \ + higher-dimension faces", + [ traces, 5 ], + Hidden ); + ( "--compute-separating-transitions", + Bool Config.compute_separating_transitions, + "Compute the transitions that separates strongly connected set of \ + configurations", + [ actions, 10; traces, 6 ], + Normal ); + ( "--output-directory", + MultiExt + [ + "--output-contact-map-directory", ""; + "--output-influence-map-directory", ""; + "--output-local-traces-directory", ""; + "--output-log-directory", ""; + ], + "Default repository for outputs", + [ output, 0 ], + Normal ); (* CONTACT MAP *) - "--output-contact-map-directory", - String Config.output_cm_directory, - "put the contact map file in this directory", - [output,0;contact_map,3], - Normal; - - "--output-contact-map", - String Config.contact_map_file, - "file name for the contact map output", - [output,1;contact_map,4], - Normal; - - "--contact-map-format", - (Choice (["DOT","dot format"; - "GEPHI","Gephi format"; - (*"HTML","HTML format"*)],[], - Config.contact_map_format)), - "Tune the output format for the contact map", - [output,2;contact_map,5], - Normal; - - "--contact-map-accuracy-level", - (Choice - (["Low","Collect info from rhs of rules and initial state"; - "High","Only consider reachable rules"; - ],[], - Config.contact_map_accuracy_level)), - "Tune the accuracy level of the contact map", - [contact_map,6], - Normal; - - "--polymer-detection-accuracy-level", - (Choice - (["Low","based only on the contact map"; - "High","use reachability analysis as well"; - ],[], - Config.scc_accuracy_level)), - "Tune the accuracy level of the detection of polymers", - [contact_map,7], - Normal; - - "--pure-contact", - Bool Config.pure_contact, - "show in the contact map only the sites with a binding state", - [contact_map,8], - Expert; - - - + ( "--output-contact-map-directory", + String Config.output_cm_directory, + "put the contact map file in this directory", + [ output, 0; contact_map, 3 ], + Normal ); + ( "--output-contact-map", + String Config.contact_map_file, + "file name for the contact map output", + [ output, 1; contact_map, 4 ], + Normal ); + ( "--contact-map-format", + Choice + ( [ + "DOT", "dot format"; + "GEPHI", "Gephi format"; + (*"HTML","HTML format"*) + ], + [], + Config.contact_map_format ), + "Tune the output format for the contact map", + [ output, 2; contact_map, 5 ], + Normal ); + ( "--contact-map-accuracy-level", + Choice + ( [ + "Low", "Collect info from rhs of rules and initial state"; + "High", "Only consider reachable rules"; + ], + [], + Config.contact_map_accuracy_level ), + "Tune the accuracy level of the contact map", + [ contact_map, 6 ], + Normal ); + ( "--polymer-detection-accuracy-level", + Choice + ( [ + "Low", "based only on the contact map"; + "High", "use reachability analysis as well"; + ], + [], + Config.scc_accuracy_level ), + "Tune the accuracy level of the detection of polymers", + [ contact_map, 7 ], + Normal ); + ( "--pure-contact", + Bool Config.pure_contact, + "show in the contact map only the sites with a binding state", + [ contact_map, 8 ], + Expert ); (* INFLUENCE MAP *) - "--output-influence-map-directory", - String Config.output_im_directory, - "put the influence map file in this directory", - [output,3;influence_map,2], - Normal; - - "--output-influence-map", - String Config.influence_map_file, - "file name for the influence map", - [output,3;influence_map,3], - Normal; - - "--influence-map-format", - (Choice ([ - "DOT","dot format"; - "DIM","DIM format"; - "HTML","HTML format"; - ],[], - Config.influence_map_format)), - "Tune the output format for the influence map", - [output,4;influence_map,4], - Normal; - - - + ( "--output-influence-map-directory", + String Config.output_im_directory, + "put the influence map file in this directory", + [ output, 3; influence_map, 2 ], + Normal ); + ( "--output-influence-map", + String Config.influence_map_file, + "file name for the influence map", + [ output, 3; influence_map, 3 ], + Normal ); + ( "--influence-map-format", + Choice + ( [ "DOT", "dot format"; "DIM", "DIM format"; "HTML", "HTML format" ], + [], + Config.influence_map_format ), + "Tune the output format for the influence map", + [ output, 4; influence_map, 4 ], + Normal ); (* LOCAL TRACES *) - "--output-local-traces-directory", - String Config.output_local_trace_directory, - "put the files about local traces in this directory", - [output,5;traces,7], - Normal; - - "--local-traces-format", - (Choice ( - [ - "DOT","dot format"; - "HTML","HTML format" - ],[], - Config.local_trace_format)), - "Tune the output format for the local transition systems", - [output,6;traces,8], - Normal; - + ( "--output-local-traces-directory", + String Config.output_local_trace_directory, + "put the files about local traces in this directory", + [ output, 5; traces, 7 ], + Normal ); + ( "--local-traces-format", + Choice + ( [ "DOT", "dot format"; "HTML", "HTML format" ], + [], + Config.local_trace_format ), + "Tune the output format for the local transition systems", + [ output, 6; traces, 8 ], + Normal ); (* LOG *) - "--output-log-directory", - String Config.output_directory, - "put the log files in this directory", - [output,7;debug,0], - Expert; - "--debug", - Bool Config.trace, - "dump debugging information", - [debug,1], - Expert; - "--debug-mode", - Bool Config.trace, - "dump debugging information", - [debug,2], - Hidden; - "--debugging-mode", - Bool Config.trace, - "dump debugging information", - [debug,3], - Hidden; - "--unsafe-mode", - Bool Config.unsafe, - "exceptions are gathered at the end of the computation, instead of halting it ", - [debug,4], - Expert; - "--print-efficiency", - Bool Config.print_efficiency, - "prompt CPU time and various datas", - [debug,5], - Expert; - - "--backdoor-dump-nbr-rules", - Bool Config.backdoor_nbr_of_rules, - "dump the number of rules", - [], - Hidden; - - "--backdoor-dump-nbr-constraints", - Bool Config.backdoor_nbr_of_constraints, - "dump the number of refinement constraints", - [], - Hidden; - - "--backdoor-dump-nbr-nr-constraints", - Bool Config.backdoor_nbr_of_nr_constraints, - "dump the number of non relational refinement constraints", - [], - Hidden; - - "--backdoor-dump-nbr-influences", - Bool Config.backdoor_nbr_of_influences, - "dump the number of influence relations", - [], - Hidden; - - - "--backdoor-dump-nbr-dead-rules", - Bool Config.backdoor_nbr_of_dead_rules, - "dump the number of dead rules", - [], - Hidden; - - "--backdoor-dump-nbr-non-weakly-reversible-transitions", - Bool Config.backdoor_nbr_of_non_weakly_reversible_transitions, - "dump the number of non weakly reversible transitions", - [], - Hidden; - - "--backdoor-dump-nbr-of-rules-with-non-weakly-reversible-transitions", - Bool Config.backdoor_nbr_of_rules_with_non_weakly_reversible_transitions, - "dump the number of rules with non weakly reversible transitions", - [], - Hidden; - - "--backdoor-dump-nbr-scc", - Bool Config.backdoor_nbr_of_scc, - "dump the number of strongly connected components", - [], - Hidden; - - "--backdoor-dump-average-scc", - Bool Config.backdoor_average_size_of_scc, - "dump the average size of strongly connected components", - [], - Hidden; - - "--backdoor-dump-timing", - Bool Config.backdoor_timing, - "dump CPU time", - [], - Hidden; - - "--backdoor-file", - String Config.backdoor_file, - "select the file to dump backdoor information", - [], - Hidden; - - "--backdoor-directory", - String Config.backdoor_directory, - "select the directory for the file to dump backdoor information", - [], - Hidden; - + ( "--output-log-directory", + String Config.output_directory, + "put the log files in this directory", + [ output, 7; debug, 0 ], + Expert ); + ( "--debug", + Bool Config.trace, + "dump debugging information", + [ debug, 1 ], + Expert ); + ( "--debug-mode", + Bool Config.trace, + "dump debugging information", + [ debug, 2 ], + Hidden ); + ( "--debugging-mode", + Bool Config.trace, + "dump debugging information", + [ debug, 3 ], + Hidden ); + ( "--unsafe-mode", + Bool Config.unsafe, + "exceptions are gathered at the end of the computation, instead of \ + halting it ", + [ debug, 4 ], + Expert ); + ( "--print-efficiency", + Bool Config.print_efficiency, + "prompt CPU time and various datas", + [ debug, 5 ], + Expert ); + ( "--backdoor-dump-nbr-rules", + Bool Config.backdoor_nbr_of_rules, + "dump the number of rules", + [], + Hidden ); + ( "--backdoor-dump-nbr-constraints", + Bool Config.backdoor_nbr_of_constraints, + "dump the number of refinement constraints", + [], + Hidden ); + ( "--backdoor-dump-nbr-nr-constraints", + Bool Config.backdoor_nbr_of_nr_constraints, + "dump the number of non relational refinement constraints", + [], + Hidden ); + ( "--backdoor-dump-nbr-influences", + Bool Config.backdoor_nbr_of_influences, + "dump the number of influence relations", + [], + Hidden ); + ( "--backdoor-dump-nbr-dead-rules", + Bool Config.backdoor_nbr_of_dead_rules, + "dump the number of dead rules", + [], + Hidden ); + ( "--backdoor-dump-nbr-non-weakly-reversible-transitions", + Bool Config.backdoor_nbr_of_non_weakly_reversible_transitions, + "dump the number of non weakly reversible transitions", + [], + Hidden ); + ( "--backdoor-dump-nbr-of-rules-with-non-weakly-reversible-transitions", + Bool Config.backdoor_nbr_of_rules_with_non_weakly_reversible_transitions, + "dump the number of rules with non weakly reversible transitions", + [], + Hidden ); + ( "--backdoor-dump-nbr-scc", + Bool Config.backdoor_nbr_of_scc, + "dump the number of strongly connected components", + [], + Hidden ); + ( "--backdoor-dump-average-scc", + Bool Config.backdoor_average_size_of_scc, + "dump the average size of strongly connected components", + [], + Hidden ); + ( "--backdoor-dump-timing", + Bool Config.backdoor_timing, + "dump CPU time", + [], + Hidden ); + ( "--backdoor-file", + String Config.backdoor_file, + "select the file to dump backdoor information", + [], + Hidden ); + ( "--backdoor-directory", + String Config.backdoor_directory, + "select the directory for the file to dump backdoor information", + [], + Hidden ); ] let get_option error = let title = Version.version_kasa_full_name in let () = SuperargTk.parse ~title options FileNames.input in let parameters = - Remanent_parameters.get_parameters - ~called_from:Remanent_parameters_sig.KaSa () in - error,parameters,!FileNames.input + Remanent_parameters.get_parameters ~called_from:Remanent_parameters_sig.KaSa + () + in + error, parameters, !FileNames.input diff --git a/core/parameters/headers.ml b/core/parameters/headers.ml index 6e945cc741..ab4934b5d7 100644 --- a/core/parameters/headers.ml +++ b/core/parameters/headers.ml @@ -18,21 +18,38 @@ (** if unsafe = true, then whenever an exception is raised, a default value is output, and no exception is raised*) let dot_comment = "#" -let head parameters = ["This file has been computed by KaSa: a Static Analyzer for Kappa ("^(Remanent_parameters.get_short_version parameters)^")"; - "Download sources/binaries at https://github.com/Kappa-Dev/KaSim"; - ""; - Remanent_parameters.get_launched_when_and_where parameters; - "Command line is: "^(String.concat " " (match Array.to_list (Remanent_parameters.get_command_line parameters) with _t::q -> "KaSa"::q | [] -> [])); - ""; - ] +let head parameters = + [ + "This file has been computed by KaSa: a Static Analyzer for Kappa (" + ^ Remanent_parameters.get_short_version parameters + ^ ")"; + "Download sources/binaries at https://github.com/Kappa-Dev/KaSim"; + ""; + Remanent_parameters.get_launched_when_and_where parameters; + "Command line is: " + ^ String.concat " " + (match + Array.to_list (Remanent_parameters.get_command_line parameters) + with + | _t :: q -> "KaSa" :: q + | [] -> []); + ""; + ] -let dot_to_pdf = "Please use graphviz (http://www.graphviz.org) or OmniGraffle to export it to a PDF" +let dot_to_pdf = + "Please use graphviz (http://www.graphviz.org) or OmniGraffle to export it \ + to a PDF" let head_influence_map_in_dot = - ["This file contains the description of the influence map in dot."; - dot_to_pdf; - ""] + [ + "This file contains the description of the influence map in dot."; + dot_to_pdf; + ""; + ] + let head_contact_map_in_dot = - ["This file contains the description of the contact map in dot."; - dot_to_pdf; - ""] + [ + "This file contains the description of the contact map in dot."; + dot_to_pdf; + ""; + ] diff --git a/core/parameters/ode_args.ml b/core/parameters/ode_args.ml index de9388285f..1073b87f39 100644 --- a/core/parameters/ode_args.ml +++ b/core/parameters/ode_args.ml @@ -3,283 +3,405 @@ open Superarg type count = Embeddings | Occurrences type t = { - backend : string ref ; - rule_rate_convention : string ref ; - reaction_rate_convention : string ref ; - count : string ref ; - internal_meaning : string ref ; - show_reactions : bool ref ; - compute_jacobian : bool ref ; - octave_output : string option ref ; - matlab_output : string option ref ; - maple_output : string option ref ; - mathematica_output : string option ref ; - sbml_output : string option ref ; - dotnet_output : string option ref ; - data_file : string option ref ; - with_symmetries : string ref ; - show_symmetries : bool ref ; - views : bool ref ; - dbonds : bool ref ; - site_across : bool ref; - nonnegative : bool ref ; - show_time_advance : bool ref; - initial_step : float ref ; - max_step : float ref ; - relative_tolerance : float ref ; - absolute_tolerance : float ref ; - smash_reactions : bool ref ; - propagate_constants : bool ref ; - print_efficiency : bool ref ; - max_size_for_species : int option ref ; - csv_sep: string ref ; + backend: string ref; + rule_rate_convention: string ref; + reaction_rate_convention: string ref; + count: string ref; + internal_meaning: string ref; + show_reactions: bool ref; + compute_jacobian: bool ref; + octave_output: string option ref; + matlab_output: string option ref; + maple_output: string option ref; + mathematica_output: string option ref; + sbml_output: string option ref; + dotnet_output: string option ref; + data_file: string option ref; + with_symmetries: string ref; + show_symmetries: bool ref; + views: bool ref; + dbonds: bool ref; + site_across: bool ref; + nonnegative: bool ref; + show_time_advance: bool ref; + initial_step: float ref; + max_step: float ref; + relative_tolerance: float ref; + absolute_tolerance: float ref; + smash_reactions: bool ref; + propagate_constants: bool ref; + print_efficiency: bool ref; + max_size_for_species: int option ref; + csv_sep: string ref; } let default : t = { - backend = ref "octave" ; - rule_rate_convention = ref "Divide_by_nbr_of_autos_in_lhs" ; - reaction_rate_convention = ref "Divide_by_nbr_of_autos_in_lhs" ; - count = ref "Embeddings" ; - internal_meaning = ref "Embeddings" ; - show_reactions = ref true ; - compute_jacobian = ref true ; - dotnet_output = ref (Some "network.net") ; - octave_output = ref (Some "ode.m") ; - matlab_output = ref (Some "ode.m") ; - maple_output = ref (Some "ode.mws") ; - mathematica_output = ref (Some "ode.nb") ; - sbml_output = ref (Some "network.xml") ; - data_file = ref (Some "data.csv") ; - with_symmetries = ref "None" ; - show_symmetries = ref false ; - views = ref true ; - dbonds = ref true ; - site_across = ref true ; - nonnegative = ref false ; - show_time_advance = ref false ; - initial_step = ref 0.00001 ; - max_step = ref 0.02 ; - absolute_tolerance = ref 0.001 ; - relative_tolerance = ref 0.001 ; - smash_reactions = ref false ; - propagate_constants = ref false ; - print_efficiency = ref false ; - max_size_for_species = ref None ; + backend = ref "octave"; + rule_rate_convention = ref "Divide_by_nbr_of_autos_in_lhs"; + reaction_rate_convention = ref "Divide_by_nbr_of_autos_in_lhs"; + count = ref "Embeddings"; + internal_meaning = ref "Embeddings"; + show_reactions = ref true; + compute_jacobian = ref true; + dotnet_output = ref (Some "network.net"); + octave_output = ref (Some "ode.m"); + matlab_output = ref (Some "ode.m"); + maple_output = ref (Some "ode.mws"); + mathematica_output = ref (Some "ode.nb"); + sbml_output = ref (Some "network.xml"); + data_file = ref (Some "data.csv"); + with_symmetries = ref "None"; + show_symmetries = ref false; + views = ref true; + dbonds = ref true; + site_across = ref true; + nonnegative = ref false; + show_time_advance = ref false; + initial_step = ref 0.00001; + max_step = ref 0.02; + absolute_tolerance = ref 0.001; + relative_tolerance = ref 0.001; + smash_reactions = ref false; + propagate_constants = ref false; + print_efficiency = ref false; + max_size_for_species = ref None; csv_sep = ref " "; } let combine l1 l2 = List.fold_left (fun list a1 -> - List.fold_left - (fun list (a2:int) -> - (a1,a2)::list) - list l2) + List.fold_left (fun list (a2 : int) -> (a1, a2) :: list) list l2) [] l1 - -let options (t :t) : (Superarg.key * Superarg.spec * Superarg.msg * - (Superarg.category * Superarg.position) list * Superarg.level) list = +let options (t : t) : + (Superarg.key + * Superarg.spec + * Superarg.msg + * (Superarg.category * Superarg.position) list + * Superarg.level) + list = [ - "--void",Superarg.Void,"", - combine - [Common_args.data_set; - Common_args.output; - Common_args.semantics; - Common_args.integration_settings; - Common_args.model_reduction; - Common_args.static_analysis; - Common_args.debug_mode] - [50;51;52], - Normal; - - "--output", - Superarg.MultiExt - ["--dotnet-output",".net"; - "--maple-output",".mws"; - "--mathematica-output",".nb"; - "--matlab-output",".m"; - "--octave-output",".m"; - "--sbml-output",".xml"], - "Prefix for file name output", - [Common_args.data_set,101; - Common_args.output,101; - Common_args.semantics,101; - Common_args.integration_settings,101; - Common_args.model_reduction,101; - Common_args.static_analysis,101; - Common_args.debug_mode,101],Normal; - "--ode-backend", - Superarg.Choice ( - [ "dotnet", "dotnet (BNGL) backend"; - "maple", "maple backend (in progress)"; - "mathematica", "mathematica backend (in progress)"; - "matlab", "matlab backend"; - "octave", "octave backend"; - "sbml", "sbml backend"], - ["Dotnet";"DOTNET";"Octave";"OCTAVE";"Matlab";"MATLAB";"Mathematica";"MATHEMATICA";"Maple";"MAPLE";"Sbml";"SBML"],t.backend), - "Select the backend format", - [Common_args.output,1],Normal; - "--dotnet-output", - Superarg.String_opt t.dotnet_output, - "ODEs file for dotnet backend", - [Common_args.output,2],Hidden; - "--maple-output", - Superarg.String_opt t.maple_output, - "ODEs file for maple backend", - [Common_args.output,3],Hidden; - "--mathematica-output", - Superarg.String_opt t.mathematica_output, - "ODEs file for mathematica backend", - [Common_args.output,4],Hidden; - "--matlab-output", - Superarg.String_opt t.matlab_output, - "ODEs file for matlab backend", - [Common_args.output,5],Hidden; - "--octave-output", - Superarg.String_opt t.octave_output, - "ODEs file for octave backend", - [Common_args.output,6],Hidden; - "--sbml-output", - Superarg.String_opt t.sbml_output, - "ODEs file for sbml backend", - [Common_args.output,7],Hidden; - "--propagate-constants", - Superarg.Bool t.propagate_constants, - "propagate constants", - [Common_args.output,8],Hidden; - "--constant-propagation", - Superarg.Bool t.propagate_constants, - "propagate constants", - [Common_args.output,9],Normal; - "--csv-separator", - Superarg.String t.csv_sep, - "separator symbol in CSV files", - [Common_args.output,10],Normal; - "--rate-convention", - Superarg.Choice ( - [ "KaSim","do not divide by anything"; - "Divide_by_nbr_of_autos_in_lhs","divide by the number of autos in the lhs of rules"; - "Biochemist","divide by the number of autos in the lhs of rules that induce an auto also in the rhs"], - ["kasim";"KASIM";"Kasim";"DIVIDE_BY_NBR_OF_AUTOS_IN_LHS";"divide_by_nbr_of_autos_in_lhs";"biobhemist";"BIOCHEMIST"],t.rule_rate_convention), - "convention for dividing constant rates", - [Common_args.semantics,1],Hidden; - "--rule-rate-convention", - Superarg.Choice ( - [ "KaSim","do not divide by anything"; - "Divide_by_nbr_of_autos_in_lhs","divide by the number of autos in the lhs of rules"; - "Biochemist","divide by the number of autos in the lhs of rules that induce an auto also in the rhs"], - ["kasim";"KASIM";"Kasim";"DIVIDE_BY_NBR_OF_AUTOS_IN_LHS";"divide_by_nbr_of_autos_in_lhs";"biobhemist";"BIOCHEMIST"],t.rule_rate_convention), - "convention for dividing constant rates (for rules)", - [Common_args.semantics,1],Normal; - "--reaction-rate-convention", - Superarg.Choice ( - [ "KaSim","do not divide by anything"; - "Divide_by_nbr_of_autos_in_lhs","divide by the number of autos in the lhs of reactions"; - "Biochemist","divide by the number of autos in the lhs of reactions that induce an auto also in the rhs"], - ["kasim";"KASIM";"Kasim";"DIVIDE_BY_NBR_OF_AUTOS_IN_LHS";"divide_by_nbr_of_autos_in_lhs";"biobhemist";"BIOCHEMIST"],t.reaction_rate_convention), - "convention for dividing constant rates (for reactions)", - [Common_args.semantics,2],Normal; - "--count", - Superarg.Choice ( - [ "Embeddings","count the number of embeddings of patterns into species"; - "Occurrences","count the number of occurrences of species"], - ["embeddings";"EMBEDDINGS";"occurrences";"OCCURRENCES"], - t.count), - "tune whether we count in embeddings or in occurrences", - [Common_args.semantics,3],Normal; - "--internal-meaning", - Superarg.Choice ( + ( "--void", + Superarg.Void, + "", + combine + [ + Common_args.data_set; + Common_args.output; + Common_args.semantics; + Common_args.integration_settings; + Common_args.model_reduction; + Common_args.static_analysis; + Common_args.debug_mode; + ] + [ 50; 51; 52 ], + Normal ); + ( "--output", + Superarg.MultiExt + [ + "--dotnet-output", ".net"; + "--maple-output", ".mws"; + "--mathematica-output", ".nb"; + "--matlab-output", ".m"; + "--octave-output", ".m"; + "--sbml-output", ".xml"; + ], + "Prefix for file name output", [ - "Embeddings", - "Variables for Kappa species denote numbers of embeddings"; - "Occurrences", - "Variables for Kappa species denote numbers of occurrences" + Common_args.data_set, 101; + Common_args.output, 101; + Common_args.semantics, 101; + Common_args.integration_settings, 101; + Common_args.model_reduction, 101; + Common_args.static_analysis, 101; + Common_args.debug_mode, 101; ], - [ - "embeddings"; - "EMBEDDINGS"; - "occurrences"; - "OCCURRENCES" - ], - t.internal_meaning), - "tune the meaning of variable for Kappa species (whether it is the number of embeddings or the number of occurrences)", - [Common_args.semantics,4],Hidden; - "--truncate", - Superarg.Int_opt t.max_size_for_species, - "truncate the network by discarding species with size greater than the argument", - [Common_args.semantics,4],Normal; - "--max-size-for-species", - Superarg.Int_opt t.max_size_for_species, - "truncate the network by discarding species with size greater than the argument", - [Common_args.semantics,5],Hidden; - "--show-reactions", - Superarg.Bool t.show_reactions, - "Annotate ODEs by the corresponding chemical reactions", - [Common_args.output,10],Normal ; - "--smash-reactions", - Superarg.Bool t.smash_reactions, - "Gather identical reactions in the ODEs", - [Common_args.output,11;Common_args.integration_settings,1],Normal ; - "--compute-jacobian", - Superarg.Bool t.compute_jacobian, - "Enable/disable the computation of the Jacobian of the ODEs \n\t (not available yet)", - [Common_args.integration_settings,2],Normal ; - "--with-symmetries", - Superarg.Choice ( - ["None", "no symmetries reduction"; - "Backward", "use the symmetries satisfied by the rules and the algebraic expressions"; - "Forward", "use the symmetries satisfied by the rules and the initial state"], - ["none";"NONE";"BACKWARD";"backward";"forward";"FORWARD";"true";"TRUE";"True";"false";"FALSE";"False"], - t.with_symmetries), - "Tune which kind of bisimulation is used to reduce the set of species", - [Common_args.semantics,5;Common_args.model_reduction,1],Normal; - "--show-symmetries", - Superarg.Bool t.show_symmetries, - "Display the equivalence relations over the sites", - [Common_args.model_reduction,2],Normal; - "--views-domain", - Superarg.Bool t.views, - "Enable/disable views analysis when detecting symmetric sites", - [Common_args.static_analysis,1],Expert ; - "--double-bonds-domain", - Superarg.Bool t.dbonds, - "Enable/disable double bonds analysis when detecting symmetric sites", - [Common_args.static_analysis,2],Expert ; - "--site-across-bonds-domain", - Superarg.Bool t.site_across , - "Enable/disable the analysis of the relation amond the states of sites in connected agents", - [Common_args.static_analysis,3],Expert ; - "--nonnegative", - Superarg.Bool t.nonnegative, - "Enable/disable the correction of negative concentrations in stiff ODE systems", - [Common_args.integration_settings,3],Normal; - "--show-time-advance", - Superarg.Bool t.show_time_advance, - "Display time advance during numerical integration", - [Common_args.debug_mode,1],Expert; - "--initial-step", - Superarg.Float t.initial_step, - "Initial integration step", - [Common_args.integration_settings,4],Normal ; - "--max-step", - Superarg.Float t.max_step, - "Maximum integration step", - [Common_args.integration_settings,5],Normal; - "--relative-tolerance", - Superarg.Float t.relative_tolerance, - "tolerance to relative rounding errors", - [Common_args.integration_settings,6],Normal; - "--absolute-tolerance", - Superarg.Float t.absolute_tolerance, - "tolerance to absolute rounding errors", - [Common_args.integration_settings,7],Normal; - "--print-efficiency", - Superarg.Bool t.print_efficiency, - "prompt CPU time and various datas", - [Common_args.debug_mode,2],Expert; -] + Normal ); + ( "--ode-backend", + Superarg.Choice + ( [ + "dotnet", "dotnet (BNGL) backend"; + "maple", "maple backend (in progress)"; + "mathematica", "mathematica backend (in progress)"; + "matlab", "matlab backend"; + "octave", "octave backend"; + "sbml", "sbml backend"; + ], + [ + "Dotnet"; + "DOTNET"; + "Octave"; + "OCTAVE"; + "Matlab"; + "MATLAB"; + "Mathematica"; + "MATHEMATICA"; + "Maple"; + "MAPLE"; + "Sbml"; + "SBML"; + ], + t.backend ), + "Select the backend format", + [ Common_args.output, 1 ], + Normal ); + ( "--dotnet-output", + Superarg.String_opt t.dotnet_output, + "ODEs file for dotnet backend", + [ Common_args.output, 2 ], + Hidden ); + ( "--maple-output", + Superarg.String_opt t.maple_output, + "ODEs file for maple backend", + [ Common_args.output, 3 ], + Hidden ); + ( "--mathematica-output", + Superarg.String_opt t.mathematica_output, + "ODEs file for mathematica backend", + [ Common_args.output, 4 ], + Hidden ); + ( "--matlab-output", + Superarg.String_opt t.matlab_output, + "ODEs file for matlab backend", + [ Common_args.output, 5 ], + Hidden ); + ( "--octave-output", + Superarg.String_opt t.octave_output, + "ODEs file for octave backend", + [ Common_args.output, 6 ], + Hidden ); + ( "--sbml-output", + Superarg.String_opt t.sbml_output, + "ODEs file for sbml backend", + [ Common_args.output, 7 ], + Hidden ); + ( "--propagate-constants", + Superarg.Bool t.propagate_constants, + "propagate constants", + [ Common_args.output, 8 ], + Hidden ); + ( "--constant-propagation", + Superarg.Bool t.propagate_constants, + "propagate constants", + [ Common_args.output, 9 ], + Normal ); + ( "--csv-separator", + Superarg.String t.csv_sep, + "separator symbol in CSV files", + [ Common_args.output, 10 ], + Normal ); + ( "--rate-convention", + Superarg.Choice + ( [ + "KaSim", "do not divide by anything"; + ( "Divide_by_nbr_of_autos_in_lhs", + "divide by the number of autos in the lhs of rules" ); + ( "Biochemist", + "divide by the number of autos in the lhs of rules that induce \ + an auto also in the rhs" ); + ], + [ + "kasim"; + "KASIM"; + "Kasim"; + "DIVIDE_BY_NBR_OF_AUTOS_IN_LHS"; + "divide_by_nbr_of_autos_in_lhs"; + "biobhemist"; + "BIOCHEMIST"; + ], + t.rule_rate_convention ), + "convention for dividing constant rates", + [ Common_args.semantics, 1 ], + Hidden ); + ( "--rule-rate-convention", + Superarg.Choice + ( [ + "KaSim", "do not divide by anything"; + ( "Divide_by_nbr_of_autos_in_lhs", + "divide by the number of autos in the lhs of rules" ); + ( "Biochemist", + "divide by the number of autos in the lhs of rules that induce \ + an auto also in the rhs" ); + ], + [ + "kasim"; + "KASIM"; + "Kasim"; + "DIVIDE_BY_NBR_OF_AUTOS_IN_LHS"; + "divide_by_nbr_of_autos_in_lhs"; + "biobhemist"; + "BIOCHEMIST"; + ], + t.rule_rate_convention ), + "convention for dividing constant rates (for rules)", + [ Common_args.semantics, 1 ], + Normal ); + ( "--reaction-rate-convention", + Superarg.Choice + ( [ + "KaSim", "do not divide by anything"; + ( "Divide_by_nbr_of_autos_in_lhs", + "divide by the number of autos in the lhs of reactions" ); + ( "Biochemist", + "divide by the number of autos in the lhs of reactions that \ + induce an auto also in the rhs" ); + ], + [ + "kasim"; + "KASIM"; + "Kasim"; + "DIVIDE_BY_NBR_OF_AUTOS_IN_LHS"; + "divide_by_nbr_of_autos_in_lhs"; + "biobhemist"; + "BIOCHEMIST"; + ], + t.reaction_rate_convention ), + "convention for dividing constant rates (for reactions)", + [ Common_args.semantics, 2 ], + Normal ); + ( "--count", + Superarg.Choice + ( [ + ( "Embeddings", + "count the number of embeddings of patterns into species" ); + "Occurrences", "count the number of occurrences of species"; + ], + [ "embeddings"; "EMBEDDINGS"; "occurrences"; "OCCURRENCES" ], + t.count ), + "tune whether we count in embeddings or in occurrences", + [ Common_args.semantics, 3 ], + Normal ); + ( "--internal-meaning", + Superarg.Choice + ( [ + ( "Embeddings", + "Variables for Kappa species denote numbers of embeddings" ); + ( "Occurrences", + "Variables for Kappa species denote numbers of occurrences" ); + ], + [ "embeddings"; "EMBEDDINGS"; "occurrences"; "OCCURRENCES" ], + t.internal_meaning ), + "tune the meaning of variable for Kappa species (whether it is the \ + number of embeddings or the number of occurrences)", + [ Common_args.semantics, 4 ], + Hidden ); + ( "--truncate", + Superarg.Int_opt t.max_size_for_species, + "truncate the network by discarding species with size greater than the \ + argument", + [ Common_args.semantics, 4 ], + Normal ); + ( "--max-size-for-species", + Superarg.Int_opt t.max_size_for_species, + "truncate the network by discarding species with size greater than the \ + argument", + [ Common_args.semantics, 5 ], + Hidden ); + ( "--show-reactions", + Superarg.Bool t.show_reactions, + "Annotate ODEs by the corresponding chemical reactions", + [ Common_args.output, 10 ], + Normal ); + ( "--smash-reactions", + Superarg.Bool t.smash_reactions, + "Gather identical reactions in the ODEs", + [ Common_args.output, 11; Common_args.integration_settings, 1 ], + Normal ); + ( "--compute-jacobian", + Superarg.Bool t.compute_jacobian, + "Enable/disable the computation of the Jacobian of the ODEs \n\ + \t (not available yet)", + [ Common_args.integration_settings, 2 ], + Normal ); + ( "--with-symmetries", + Superarg.Choice + ( [ + "None", "no symmetries reduction"; + ( "Backward", + "use the symmetries satisfied by the rules and the algebraic \ + expressions" ); + ( "Forward", + "use the symmetries satisfied by the rules and the initial state" + ); + ], + [ + "none"; + "NONE"; + "BACKWARD"; + "backward"; + "forward"; + "FORWARD"; + "true"; + "TRUE"; + "True"; + "false"; + "FALSE"; + "False"; + ], + t.with_symmetries ), + "Tune which kind of bisimulation is used to reduce the set of species", + [ Common_args.semantics, 5; Common_args.model_reduction, 1 ], + Normal ); + ( "--show-symmetries", + Superarg.Bool t.show_symmetries, + "Display the equivalence relations over the sites", + [ Common_args.model_reduction, 2 ], + Normal ); + ( "--views-domain", + Superarg.Bool t.views, + "Enable/disable views analysis when detecting symmetric sites", + [ Common_args.static_analysis, 1 ], + Expert ); + ( "--double-bonds-domain", + Superarg.Bool t.dbonds, + "Enable/disable double bonds analysis when detecting symmetric sites", + [ Common_args.static_analysis, 2 ], + Expert ); + ( "--site-across-bonds-domain", + Superarg.Bool t.site_across, + "Enable/disable the analysis of the relation amond the states of sites \ + in connected agents", + [ Common_args.static_analysis, 3 ], + Expert ); + ( "--nonnegative", + Superarg.Bool t.nonnegative, + "Enable/disable the correction of negative concentrations in stiff ODE \ + systems", + [ Common_args.integration_settings, 3 ], + Normal ); + ( "--show-time-advance", + Superarg.Bool t.show_time_advance, + "Display time advance during numerical integration", + [ Common_args.debug_mode, 1 ], + Expert ); + ( "--initial-step", + Superarg.Float t.initial_step, + "Initial integration step", + [ Common_args.integration_settings, 4 ], + Normal ); + ( "--max-step", + Superarg.Float t.max_step, + "Maximum integration step", + [ Common_args.integration_settings, 5 ], + Normal ); + ( "--relative-tolerance", + Superarg.Float t.relative_tolerance, + "tolerance to relative rounding errors", + [ Common_args.integration_settings, 6 ], + Normal ); + ( "--absolute-tolerance", + Superarg.Float t.absolute_tolerance, + "tolerance to absolute rounding errors", + [ Common_args.integration_settings, 7 ], + Normal ); + ( "--print-efficiency", + Superarg.Bool t.print_efficiency, + "prompt CPU time and various datas", + [ Common_args.debug_mode, 2 ], + Expert ); + ] let get_option options = let title = Version.version_kade_full_name in @@ -288,10 +410,8 @@ let get_option options = !input let build_kasa_parameters ~called_from t t_common = - Config.with_views_analysis := !(t.views) ; - Config.with_parallel_bonds_analysis := !(t.dbonds) ; - Config.with_site_across_bonds_analysis := !(t.site_across) ; - Config.trace := t_common.Common_args.debug ; - Remanent_parameters.get_parameters - ~called_from - () + Config.with_views_analysis := !(t.views); + Config.with_parallel_bonds_analysis := !(t.dbonds); + Config.with_site_across_bonds_analysis := !(t.site_across); + Config.trace := t_common.Common_args.debug; + Remanent_parameters.get_parameters ~called_from () diff --git a/core/parameters/remanent_parameters.ml b/core/parameters/remanent_parameters.ml index 00e953d525..547f5f9b6c 100644 --- a/core/parameters/remanent_parameters.ml +++ b/core/parameters/remanent_parameters.ml @@ -1,4 +1,4 @@ - (** +(** * parameters.ml * openkappa * Jérôme Feret, projet Abstraction/Antique, INRIA Paris-Rocquencourt @@ -18,81 +18,81 @@ let add_extension_if_not_already_mentioned a ext = let size_a = String.length a in let size_ext = String.length ext in try - if - size_a < size_ext || - (String.sub a (size_a - size_ext) size_ext = ext) - then a - else a^ext - with - | _ -> a^ext + if size_a < size_ext || String.sub a (size_a - size_ext) size_ext = ext then + a + else + a ^ ext + with _ -> a ^ ext let open_out a ext = (* it would be easier with OCaml 3.04 *) let a = add_extension_if_not_already_mentioned a ext in let d = Filename.dirname a in - let () = try - if not (Sys.is_directory d) - then (Format.eprintf "'%s' is not a directory@." d; exit 1) - with Sys_error _ -> Kappa_files.mk_dir_r d in + let () = + try + if not (Sys.is_directory d) then ( + Format.eprintf "'%s' is not a directory@." d; + exit 1 + ) + with Sys_error _ -> Kappa_files.mk_dir_r d + in open_out a let open_append a ext = let a = add_extension_if_not_already_mentioned a ext in let d = Filename.dirname a in - let () = try - if not (Sys.is_directory d) - then (Format.eprintf "'%s' is not a directory@." d; exit 1) - with Sys_error _ -> Kappa_files.mk_dir_r d in - try - open_out_gen [Open_append] 511 a - with - | _ -> open_out a ext + let () = + try + if not (Sys.is_directory d) then ( + Format.eprintf "'%s' is not a directory@." d; + exit 1 + ) + with Sys_error _ -> Kappa_files.mk_dir_r d + in + try open_out_gen [ Open_append ] 511 a with _ -> open_out a ext + +let compose f g x = f (g x) -let compose f g = fun x -> f (g x) let ext_format x = - match - x - with + match x with | Remanent_parameters_sig.DOT -> ".dot" | Remanent_parameters_sig.HTML -> ".html" | Remanent_parameters_sig.DIM -> ".dim.json" | Remanent_parameters_sig.GEPHI -> ".gexf" let fetch_level_gen s r = - match - Tools.lowercase !r - with - | "mute" | "none"-> Remanent_parameters_sig.None + match Tools.lowercase !r with + | "mute" | "none" -> Remanent_parameters_sig.None | "low" -> Remanent_parameters_sig.Low | "medium" -> Remanent_parameters_sig.Medium | "high" -> Remanent_parameters_sig.High | "complete" | "full" -> Remanent_parameters_sig.Full | x -> - let () = Printf.eprintf "%s: %s is not a valid level !!!" s x in raise Exit + let () = Printf.eprintf "%s: %s is not a valid level !!!" s x in + raise Exit let fetch_graph_format f = - match - Tools.lowercase !f - with + match Tools.lowercase !f with | "dot" -> Remanent_parameters_sig.DOT | "html" -> Remanent_parameters_sig.HTML | "dim" -> Remanent_parameters_sig.DIM | "gephi" -> Remanent_parameters_sig.GEPHI | x -> - let () = Printf.eprintf "%s is not a valid graph format !!!" x in raise Exit + let () = Printf.eprintf "%s is not a valid graph format !!!" x in + raise Exit + let fetch_accuracy_level r = fetch_level_gen "an accuracy" r let fetch_verbosity_level r = fetch_level_gen "a verbosity" r let fetch_rate_convention f = - match - Tools.lowercase !f - with + match Tools.lowercase !f with | "kasim" -> Remanent_parameters_sig.No_correction | "divide_by_nbr_of_autos_in_lhs" -> Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs | "biochemist" -> Remanent_parameters_sig.Biochemist | x -> - let () = Printf.eprintf "%s is not a valid rate convention !!!" x in raise Exit + let () = Printf.eprintf "%s is not a valid rate convention !!!" x in + raise Exit let get_syntax_version () = match !Config.syntax_version with @@ -100,7 +100,6 @@ let get_syntax_version () = | "3" | "v3" | "V3" -> Ast.V3 | _ -> failwith "Syntax version should be either V3 or V4" - let get_symbols () = match get_syntax_version () with | Ast.V3 -> Symbol_table.symbol_table_V3 @@ -109,35 +108,30 @@ let get_symbols () = let get_influence_map () = { Remanent_parameters_sig.im_format = - fetch_graph_format Config.influence_map_format ; + fetch_graph_format Config.influence_map_format; Remanent_parameters_sig.im_file = - (match !Config.influence_map_file - with - | "" -> None - | x -> Some x) ; - + (match !Config.influence_map_file with + | "" -> None + | x -> Some x); Remanent_parameters_sig.im_directory = - (match !Config.output_im_directory - with - | "" -> Some "" - | x -> Some (x^"/")) ; - - Remanent_parameters_sig.rule_shape = !Config.rule_shape ; - Remanent_parameters_sig.rule_color = !Config.rule_color ; - Remanent_parameters_sig.variable_shape = !Config.variable_shape ; - Remanent_parameters_sig.variable_color = !Config.variable_color ; - Remanent_parameters_sig.wake_up_color = !Config.wake_up_color ; - Remanent_parameters_sig.inhibition_color = !Config.inhibition_color ; - Remanent_parameters_sig.wake_up_arrow = !Config.wake_up_arrow ; - Remanent_parameters_sig.inhibition_arrow = !Config.inhibition_arrow ; - Remanent_parameters_sig.prompt_full_var_def = !Config.prompt_full_var_def ; - Remanent_parameters_sig.prompt_full_rule_def = - !Config.prompt_full_rule_def ; + (match !Config.output_im_directory with + | "" -> Some "" + | x -> Some (x ^ "/")); + Remanent_parameters_sig.rule_shape = !Config.rule_shape; + Remanent_parameters_sig.rule_color = !Config.rule_color; + Remanent_parameters_sig.variable_shape = !Config.variable_shape; + Remanent_parameters_sig.variable_color = !Config.variable_color; + Remanent_parameters_sig.wake_up_color = !Config.wake_up_color; + Remanent_parameters_sig.inhibition_color = !Config.inhibition_color; + Remanent_parameters_sig.wake_up_arrow = !Config.wake_up_arrow; + Remanent_parameters_sig.inhibition_arrow = !Config.inhibition_arrow; + Remanent_parameters_sig.prompt_full_var_def = !Config.prompt_full_var_def; + Remanent_parameters_sig.prompt_full_rule_def = !Config.prompt_full_rule_def; Remanent_parameters_sig.make_labels_compatible = List.fold_left - (fun map (a,l) -> Remanent_parameters_sig.CharMap.add a l map) + (fun map (a, l) -> Remanent_parameters_sig.CharMap.add a l map) Remanent_parameters_sig.CharMap.empty - !Config.make_labels_compatible_with_dot + !Config.make_labels_compatible_with_dot; } let get_contact_map () = @@ -145,30 +139,27 @@ let get_contact_map () = Remanent_parameters_sig.cm_format = fetch_graph_format Config.contact_map_format; Remanent_parameters_sig.cm_file = - (match !Config.contact_map_file - with - | "" -> None - | x -> Some x) ; - + (match !Config.contact_map_file with + | "" -> None + | x -> Some x); Remanent_parameters_sig.cm_directory = - (match !Config.output_cm_directory - with - | "" -> Some "" - | x -> Some (x^"/")) ; - Remanent_parameters_sig.pure_contact = !Config.pure_contact ; - Remanent_parameters_sig.binding_site_shape = !Config.binding_site_shape ; - Remanent_parameters_sig.binding_site_color = !Config.binding_site_color ; - Remanent_parameters_sig.internal_site_shape = !Config.internal_site_shape ; - Remanent_parameters_sig.internal_site_color = !Config.internal_site_color ; - Remanent_parameters_sig.counter_site_shape = !Config.counter_site_shape ; - Remanent_parameters_sig.counter_site_color = !Config.counter_site_color ; - Remanent_parameters_sig.agent_shape_array = !Config.agent_shape_array ; - Remanent_parameters_sig.agent_color_array = !Config.agent_color_array ; - Remanent_parameters_sig.agent_shape_def = !Config.agent_shape_def ; - Remanent_parameters_sig.agent_color_def = !Config.agent_color_def ; - Remanent_parameters_sig.link_color = !Config.link_color ; - Remanent_parameters_sig.influence_color = !Config.influence_color ; - Remanent_parameters_sig.influence_arrow = !Config.influence_arrow ; + (match !Config.output_cm_directory with + | "" -> Some "" + | x -> Some (x ^ "/")); + Remanent_parameters_sig.pure_contact = !Config.pure_contact; + Remanent_parameters_sig.binding_site_shape = !Config.binding_site_shape; + Remanent_parameters_sig.binding_site_color = !Config.binding_site_color; + Remanent_parameters_sig.internal_site_shape = !Config.internal_site_shape; + Remanent_parameters_sig.internal_site_color = !Config.internal_site_color; + Remanent_parameters_sig.counter_site_shape = !Config.counter_site_shape; + Remanent_parameters_sig.counter_site_color = !Config.counter_site_color; + Remanent_parameters_sig.agent_shape_array = !Config.agent_shape_array; + Remanent_parameters_sig.agent_color_array = !Config.agent_color_array; + Remanent_parameters_sig.agent_shape_def = !Config.agent_shape_def; + Remanent_parameters_sig.agent_color_def = !Config.agent_color_def; + Remanent_parameters_sig.link_color = !Config.link_color; + Remanent_parameters_sig.influence_color = !Config.influence_color; + Remanent_parameters_sig.influence_arrow = !Config.influence_arrow; } let reachability_map_0 = @@ -180,7 +171,8 @@ let reachability_map_0 = Remanent_parameters_sig.dump_reachability_analysis_covering_classes = false; Remanent_parameters_sig.dump_reachability_analysis_static = false; Remanent_parameters_sig.dump_reachability_analysis_dynamic = false; - Remanent_parameters_sig.hide_one_d_relations_from_cartesian_decomposition = false; + Remanent_parameters_sig.hide_one_d_relations_from_cartesian_decomposition = + false; Remanent_parameters_sig.compute_local_traces = false; Remanent_parameters_sig.compute_separating_transitions = false; Remanent_parameters_sig.show_rule_names_in_local_traces = false; @@ -189,145 +181,134 @@ let reachability_map_0 = Remanent_parameters_sig.add_singular_macrostates = false; Remanent_parameters_sig.add_singular_microstates = false; Remanent_parameters_sig.smash_relations = false; - Remanent_parameters_sig.hide_reverse_rule_without_label_from_dead_rules = true ; - Remanent_parameters_sig.use_natural_language = - Remanent_parameters_sig.Kappa; + Remanent_parameters_sig.hide_reverse_rule_without_label_from_dead_rules = + true; + Remanent_parameters_sig.use_natural_language = Remanent_parameters_sig.Kappa; Remanent_parameters_sig.format_for_local_traces = - Remanent_parameters_sig.DOT ; + Remanent_parameters_sig.DOT; Remanent_parameters_sig.trace_prefix = "Agent_trace_"; Remanent_parameters_sig.trace_directory = - (match !Config.output_local_trace_directory - with - | "" -> "" - | x -> (x^"/")) ; + (match !Config.output_local_trace_directory with + | "" -> "" + | x -> x ^ "/"); } let reachability_map_1 = - { reachability_map_0 with - Remanent_parameters_sig.dump_reachability_analysis_result = true + { + reachability_map_0 with + Remanent_parameters_sig.dump_reachability_analysis_result = true; } let reachability_map_2 = - { reachability_map_1 with - Remanent_parameters_sig.dump_reachability_analysis_iteration = true + { + reachability_map_1 with + Remanent_parameters_sig.dump_reachability_analysis_iteration = true; } let reachability_map_3 = - { reachability_map_2 with - Remanent_parameters_sig.dump_reachability_analysis_diff = true } + { + reachability_map_2 with + Remanent_parameters_sig.dump_reachability_analysis_diff = true; + } let reachability_map_4 = - { reachability_map_3 with - Remanent_parameters_sig.dump_reachability_analysis_wl = true ; + { + reachability_map_3 with + Remanent_parameters_sig.dump_reachability_analysis_wl = true; } let add_debugging_parameters_to_reachability_map reachability = let trace = !Config.trace in let reachability = { - reachability - with - Remanent_parameters_sig.hide_reverse_rule_without_label_from_dead_rules = - !Config.hide_reverse_rule_without_label_from_dead_rules ; - Remanent_parameters_sig.hide_one_d_relations_from_cartesian_decomposition - = !Config.hide_one_d_relations_from_cartesian_decomposition; - Remanent_parameters_sig.smash_relations = !Config.smash_relations; - Remanent_parameters_sig.use_natural_language = - begin - match !Config.use_natural_language with - | "raw" | "RAW" | "Raw" -> Remanent_parameters_sig.Raw - | "kappa" | "KAPPA" | "Kappa" -> Remanent_parameters_sig.Kappa - | "English" | "ENGLISH" | "english" -> - Remanent_parameters_sig.Natural_language - | _ -> Remanent_parameters_sig.Kappa - end; - Remanent_parameters_sig.compute_local_traces = - !Config.compute_local_traces; - Remanent_parameters_sig.compute_separating_transitions = - !Config.compute_separating_transitions; - Remanent_parameters_sig.ignore_trivial_losanges = - !Config.do_not_compress_trivial_losanges; - Remanent_parameters_sig.add_singular_macrostates = - !Config.add_singular_macrostates; - Remanent_parameters_sig.add_singular_microstates = - !Config.add_singular_microstates; - Remanent_parameters_sig.show_rule_names_in_local_traces = - !Config.show_rule_names_in_local_traces ; - Remanent_parameters_sig.use_macrotransitions_in_local_traces = - !Config.use_macrotransitions_in_local_traces ; - Remanent_parameters_sig.format_for_local_traces = - fetch_graph_format Config.local_trace_format ; - Remanent_parameters_sig.trace_prefix = - !Config.local_trace_prefix ; - Remanent_parameters_sig.trace_directory = - match !Config.output_local_trace_directory - with "" -> "" - | x -> x^"/" ; + reachability with + Remanent_parameters_sig.hide_reverse_rule_without_label_from_dead_rules = + !Config.hide_reverse_rule_without_label_from_dead_rules; + Remanent_parameters_sig.hide_one_d_relations_from_cartesian_decomposition = + !Config.hide_one_d_relations_from_cartesian_decomposition; + Remanent_parameters_sig.smash_relations = !Config.smash_relations; + Remanent_parameters_sig.use_natural_language = + (match !Config.use_natural_language with + | "raw" | "RAW" | "Raw" -> Remanent_parameters_sig.Raw + | "kappa" | "KAPPA" | "Kappa" -> Remanent_parameters_sig.Kappa + | "English" | "ENGLISH" | "english" -> + Remanent_parameters_sig.Natural_language + | _ -> Remanent_parameters_sig.Kappa); + Remanent_parameters_sig.compute_local_traces = + !Config.compute_local_traces; + Remanent_parameters_sig.compute_separating_transitions = + !Config.compute_separating_transitions; + Remanent_parameters_sig.ignore_trivial_losanges = + !Config.do_not_compress_trivial_losanges; + Remanent_parameters_sig.add_singular_macrostates = + !Config.add_singular_macrostates; + Remanent_parameters_sig.add_singular_microstates = + !Config.add_singular_microstates; + Remanent_parameters_sig.show_rule_names_in_local_traces = + !Config.show_rule_names_in_local_traces; + Remanent_parameters_sig.use_macrotransitions_in_local_traces = + !Config.use_macrotransitions_in_local_traces; + Remanent_parameters_sig.format_for_local_traces = + fetch_graph_format Config.local_trace_format; + Remanent_parameters_sig.trace_prefix = !Config.local_trace_prefix; + Remanent_parameters_sig.trace_directory = + (match !Config.output_local_trace_directory with + | "" -> "" + | x -> x ^ "/"); } in if trace then - { reachability - with - Remanent_parameters_sig.dump_reachability_analysis_covering_classes = - !Config.dump_reachability_analysis_covering_classes; - Remanent_parameters_sig.dump_reachability_analysis_static = - !Config.dump_reachability_analysis_static; - Remanent_parameters_sig.dump_reachability_analysis_dynamic = - !Config.dump_reachability_analysis_dynamic; + { + reachability with + Remanent_parameters_sig.dump_reachability_analysis_covering_classes = + !Config.dump_reachability_analysis_covering_classes; + Remanent_parameters_sig.dump_reachability_analysis_static = + !Config.dump_reachability_analysis_static; + Remanent_parameters_sig.dump_reachability_analysis_dynamic = + !Config.dump_reachability_analysis_dynamic; } - else reachability + else + reachability let get_reachability_map () = add_debugging_parameters_to_reachability_map - begin - match - fetch_verbosity_level Config.verbosity_level_for_reachability_analysis - with - | Remanent_parameters_sig.None -> reachability_map_0 - | Remanent_parameters_sig.Low -> reachability_map_1 - | Remanent_parameters_sig.Medium -> reachability_map_2 - | Remanent_parameters_sig.High -> reachability_map_3 - | Remanent_parameters_sig.Full -> reachability_map_4 - end + (match + fetch_verbosity_level Config.verbosity_level_for_reachability_analysis + with + | Remanent_parameters_sig.None -> reachability_map_0 + | Remanent_parameters_sig.Low -> reachability_map_1 + | Remanent_parameters_sig.Medium -> reachability_map_2 + | Remanent_parameters_sig.High -> reachability_map_3 + | Remanent_parameters_sig.Full -> reachability_map_4) let get_reachability_parameters () = { Remanent_parameters_sig.views = !Config.with_views_analysis; Remanent_parameters_sig.site_across_bonds = - !Config.with_site_across_bonds_analysis ; + !Config.with_site_across_bonds_analysis; Remanent_parameters_sig.parallel_bonds = - !Config.with_parallel_bonds_analysis ; + !Config.with_parallel_bonds_analysis; Remanent_parameters_sig.counters = !Config.with_counters_analysis; - Remanent_parameters_sig.dynamic_contact_map = - begin - match Tools.lowercase !Config.with_dynamic_contact_map - with - | "dynamic" -> true - | "static" -> false - | _ -> true; - end; + (match Tools.lowercase !Config.with_dynamic_contact_map with + | "dynamic" -> true + | "static" -> false + | _ -> true); Remanent_parameters_sig.counter_domain = - begin - match - Tools.lowercase !Config.counter_analysis_domain - with - | "mi" -> Remanent_parameters_sig.Mi - | "octagon" | "oct" | "octo" -> Remanent_parameters_sig.Octagons - | "abstract-multiset" | "am" | "abstract_multiset"-> Remanent_parameters_sig.Abstract_multiset - | "non-relational" | "nr" | "non-rel" | "non_rel" | "non_relational"-> - Remanent_parameters_sig.Non_relational - | _ -> Remanent_parameters_sig.Mi - end ; - + (match Tools.lowercase !Config.counter_analysis_domain with + | "mi" -> Remanent_parameters_sig.Mi + | "octagon" | "oct" | "octo" -> Remanent_parameters_sig.Octagons + | "abstract-multiset" | "am" | "abstract_multiset" -> + Remanent_parameters_sig.Abstract_multiset + | "non-relational" | "nr" | "non-rel" | "non_rel" | "non_relational" -> + Remanent_parameters_sig.Non_relational + | _ -> Remanent_parameters_sig.Mi); } let open_tasks_profiling = let cache = ref None in fun () -> - match - !cache - with + match !cache with | None -> let channel = Kappa_files.open_tasks_profiling () in let () = cache := Some channel in @@ -336,158 +317,143 @@ let open_tasks_profiling = let fetch_backdoors () = { - Remanent_parameters_sig.backdoor_nbr_of_scc= - !Config.backdoor_nbr_of_scc; - Remanent_parameters_sig.backdoor_average_size_of_scc= + Remanent_parameters_sig.backdoor_nbr_of_scc = !Config.backdoor_nbr_of_scc; + Remanent_parameters_sig.backdoor_average_size_of_scc = !Config.backdoor_average_size_of_scc; - Remanent_parameters_sig.backdoor_nbr_of_constraints= + Remanent_parameters_sig.backdoor_nbr_of_constraints = !Config.backdoor_nbr_of_constraints; - Remanent_parameters_sig.backdoor_nbr_of_nr_constraints= - !Config.backdoor_nbr_of_nr_constraints; - Remanent_parameters_sig.backdoor_nbr_of_influences= - !Config.backdoor_nbr_of_influences; - Remanent_parameters_sig.backdoor_nbr_of_dead_rules= !Config.backdoor_nbr_of_dead_rules; - Remanent_parameters_sig.backdoor_nbr_of_rules= !Config.backdoor_nbr_of_rules; - - Remanent_parameters_sig.backdoor_nbr_of_non_weakly_reversible_transitions= !Config.backdoor_nbr_of_non_weakly_reversible_transitions; - Remanent_parameters_sig.backdoor_nbr_of_rules_with_non_weakly_reversible_transitions= + Remanent_parameters_sig.backdoor_nbr_of_nr_constraints = + !Config.backdoor_nbr_of_nr_constraints; + Remanent_parameters_sig.backdoor_nbr_of_influences = + !Config.backdoor_nbr_of_influences; + Remanent_parameters_sig.backdoor_nbr_of_dead_rules = + !Config.backdoor_nbr_of_dead_rules; + Remanent_parameters_sig.backdoor_nbr_of_rules = + !Config.backdoor_nbr_of_rules; + Remanent_parameters_sig.backdoor_nbr_of_non_weakly_reversible_transitions = + !Config.backdoor_nbr_of_non_weakly_reversible_transitions; + Remanent_parameters_sig + .backdoor_nbr_of_rules_with_non_weakly_reversible_transitions = !Config.backdoor_nbr_of_rules_with_non_weakly_reversible_transitions; - - Remanent_parameters_sig.backdoor_timing= !Config.backdoor_timing; - Remanent_parameters_sig.backdoor_file= !Config.backdoor_file; - Remanent_parameters_sig.backdoor_directory= !Config.backdoor_directory; + Remanent_parameters_sig.backdoor_timing = !Config.backdoor_timing; + Remanent_parameters_sig.backdoor_file = !Config.backdoor_file; + Remanent_parameters_sig.backdoor_directory = !Config.backdoor_directory; } -let get_parameters ?html_mode:(html_mode=true) ~called_from () = - let channel,channel_err,channel_backdoor,html_mode,command = - match - called_from - with +let get_parameters ?(html_mode = true) ~called_from () = + let channel, channel_err, channel_backdoor, html_mode, command = + match called_from with | Remanent_parameters_sig.Server -> - None,None,None,false || html_mode, [|"KaSa";"(Interractive mode)"|] + None, None, None, false || html_mode, [| "KaSa"; "(Interractive mode)" |] | Remanent_parameters_sig.Internalised -> - Some stdout,Some Format.err_formatter,Some stdout,false || html_mode, Sys.argv - + ( Some stdout, + Some Format.err_formatter, + Some stdout, + false || html_mode, + Sys.argv ) | Remanent_parameters_sig.KaSim -> - Some (open_tasks_profiling ()), None,None, false || html_mode, Sys.argv + Some (open_tasks_profiling ()), None, None, false || html_mode, Sys.argv | Remanent_parameters_sig.KaSa -> - begin - match - !Config.output_directory,"profiling",".html" - (*temporary, to do: provide a parameterisable filename*) + ( (match + !Config.output_directory, "profiling", ".html" + (*temporary, to do: provide a parameterisable filename*) + with + | _, "", _ -> Some stdout + | "", a, ext -> Some (open_out a ext) + | a, b, ext -> Some (open_out (a ^ "/" ^ b) ext)), + Some Format.err_formatter, + (match + ( !Config.backdoor_nbr_of_rules + || !Config.backdoor_nbr_of_scc + || !Config.backdoor_average_size_of_scc + || !Config.backdoor_nbr_of_dead_rules + || !Config.backdoor_nbr_of_rules + || !Config.backdoor_nbr_of_non_weakly_reversible_transitions + || !Config + .backdoor_nbr_of_rules_with_non_weakly_reversible_transitions + || !Config.backdoor_nbr_of_non_weakly_reversible_transitions + || !Config.backdoor_nbr_of_constraints + || !Config.backdoor_nbr_of_nr_constraints + || !Config.backdoor_timing + || !Config.backdoor_nbr_of_influences, + !Config.backdoor_directory, + !Config.backdoor_file, + ".tex" ) with - | _,"",_ -> Some stdout - | "",a,ext -> Some (open_out a ext) - | a,b,ext -> Some (open_out (a^"/"^b) ext) - end, Some Format.err_formatter, - begin - match - !Config.backdoor_nbr_of_rules - || - !Config.backdoor_nbr_of_scc - || - !Config.backdoor_average_size_of_scc - || - !Config.backdoor_nbr_of_dead_rules - || - !Config.backdoor_nbr_of_rules - || - !Config.backdoor_nbr_of_non_weakly_reversible_transitions - || - !Config.backdoor_nbr_of_rules_with_non_weakly_reversible_transitions - || - !Config.backdoor_nbr_of_non_weakly_reversible_transitions - || - !Config.backdoor_nbr_of_constraints - || - !Config.backdoor_nbr_of_nr_constraints - || - !Config.backdoor_timing - || - !Config.backdoor_nbr_of_influences - , - !Config.backdoor_directory,!Config.backdoor_file,".tex" - with - | false, _,_,_ -> None - | _,_,"",_ -> Some stdout - | _,"",a,ext -> Some (open_append a ext) - | _,a,b,ext -> Some (open_append (a^"/"^b) ext) - end, - false || html_mode, Sys.argv + | false, _, _, _ -> None + | _, _, "", _ -> Some stdout + | _, "", a, ext -> Some (open_append a ext) + | _, a, b, ext -> Some (open_append (a ^ "/" ^ b) ext)), + false || html_mode, + Sys.argv ) in - { Remanent_parameters_sig.marshalisable_parameters = + { + Remanent_parameters_sig.marshalisable_parameters = { - Remanent_parameters_sig.syntax_version = get_syntax_version () ; - Remanent_parameters_sig.do_contact_map = !Config.do_contact_map ; - Remanent_parameters_sig.do_scc = !Config.do_scc ; - Remanent_parameters_sig.do_influence_map = !Config.do_influence_map ; + Remanent_parameters_sig.syntax_version = get_syntax_version (); + Remanent_parameters_sig.do_contact_map = !Config.do_contact_map; + Remanent_parameters_sig.do_scc = !Config.do_scc; + Remanent_parameters_sig.do_influence_map = !Config.do_influence_map; Remanent_parameters_sig.do_ODE_flow_of_information = - !Config.do_ODE_flow_of_information ; + !Config.do_ODE_flow_of_information; Remanent_parameters_sig.do_stochastic_flow_of_information = - !Config.do_stochastic_flow_of_information ; + !Config.do_stochastic_flow_of_information; Remanent_parameters_sig.do_site_dependencies = - !Config.do_site_dependencies ; - Remanent_parameters_sig.do_symmetries_analysis = !Config.do_symmetries ; + !Config.do_site_dependencies; + Remanent_parameters_sig.do_symmetries_analysis = !Config.do_symmetries; Remanent_parameters_sig.rate_convention = - fetch_rate_convention Config.rate_convention ; + fetch_rate_convention Config.rate_convention; Remanent_parameters_sig.dump_site_dependencies = - !Config.dump_site_dependencies ; + !Config.dump_site_dependencies; (*different reachability output*) Remanent_parameters_sig.do_reachability_analysis = - !Config.do_reachability_analysis ; - + !Config.do_reachability_analysis; (*GET SYMBOLS*) - Remanent_parameters_sig.file = !Config.file ; - Remanent_parameters_sig.symbols = get_symbols () ; - Remanent_parameters_sig.influence_map_output = get_influence_map () ; - Remanent_parameters_sig.contact_map_output = get_contact_map () ; + Remanent_parameters_sig.file = !Config.file; + Remanent_parameters_sig.symbols = get_symbols (); + Remanent_parameters_sig.influence_map_output = get_influence_map (); + Remanent_parameters_sig.contact_map_output = get_contact_map (); Remanent_parameters_sig.reachability_map_output = get_reachability_map (); Remanent_parameters_sig.reachability_analysis_parameters = get_reachability_parameters (); - - Remanent_parameters_sig.unsafe = !Config.unsafe ; - Remanent_parameters_sig.trace = !Config.trace ; + Remanent_parameters_sig.unsafe = !Config.unsafe; + Remanent_parameters_sig.trace = !Config.trace; Remanent_parameters_sig.dump_error_as_soon_as_they_occur = !Config.dump_error_as_soon_as_they_occur; - Remanent_parameters_sig.prefix = "" ; + Remanent_parameters_sig.prefix = ""; Remanent_parameters_sig.call_stack = []; - Remanent_parameters_sig.link_mode = !Config.link_mode ; + Remanent_parameters_sig.link_mode = !Config.link_mode; Remanent_parameters_sig.kasa_state = - Remanent_state_signature.empty_engine_state ; + Remanent_state_signature.empty_engine_state; Remanent_parameters_sig.launching_date = - Unix.localtime (Unix.gettimeofday ()) ; + Unix.localtime (Unix.gettimeofday ()); Remanent_parameters_sig.time_shift = (let x = Unix.gettimeofday () in - (Unix.localtime x).Unix.tm_hour - (Unix.gmtime x).Unix.tm_hour) ; - Remanent_parameters_sig.hostname = - begin try Unix.gethostname () with _ -> "javascript" end; - Remanent_parameters_sig.command_line= command; - Remanent_parameters_sig.short_version=Version.version_string; - Remanent_parameters_sig.version=Version.version_kasa_full_name; - Remanent_parameters_sig.tk_interface= !Version.tk_is_initialized; + (Unix.localtime x).Unix.tm_hour - (Unix.gmtime x).Unix.tm_hour); + Remanent_parameters_sig.hostname = + (try Unix.gethostname () with _ -> "javascript"); + Remanent_parameters_sig.command_line = command; + Remanent_parameters_sig.short_version = Version.version_string; + Remanent_parameters_sig.version = Version.version_kasa_full_name; + Remanent_parameters_sig.tk_interface = !Version.tk_is_initialized; Remanent_parameters_sig.influence_map_accuracy_level = - begin - match Tools.lowercase !Config.influence_map_accuracy_level with - | "indirect" -> Remanent_parameters_sig.Low - | "direct" -> Remanent_parameters_sig.Medium - | "realisable" | "realizable" -> Remanent_parameters_sig.High - | _ -> - fetch_accuracy_level Config.influence_map_accuracy_level - end - ; - Remanent_parameters_sig.contact_map_accuracy_level = - fetch_accuracy_level Config.contact_map_accuracy_level ; + (match Tools.lowercase !Config.influence_map_accuracy_level with + | "indirect" -> Remanent_parameters_sig.Low + | "direct" -> Remanent_parameters_sig.Medium + | "realisable" | "realizable" -> Remanent_parameters_sig.High + | _ -> fetch_accuracy_level Config.influence_map_accuracy_level); + Remanent_parameters_sig.contact_map_accuracy_level = + fetch_accuracy_level Config.contact_map_accuracy_level; Remanent_parameters_sig.scc_accuracy_level = - fetch_accuracy_level Config.scc_accuracy_level ; - - Remanent_parameters_sig.view_accuracy_level = - fetch_accuracy_level Config.view_accuracy_level ; - Remanent_parameters_sig.called_from = called_from ; - Remanent_parameters_sig.html_mode = html_mode ; - Remanent_parameters_sig.empty_hashtbl_size = 1 ; - Remanent_parameters_sig.backdoors = fetch_backdoors () ; - } ; + fetch_accuracy_level Config.scc_accuracy_level; + Remanent_parameters_sig.view_accuracy_level = + fetch_accuracy_level Config.view_accuracy_level; + Remanent_parameters_sig.called_from; + Remanent_parameters_sig.html_mode; + Remanent_parameters_sig.empty_hashtbl_size = 1; + Remanent_parameters_sig.backdoors = fetch_backdoors (); + }; Remanent_parameters_sig.save_error_list = (fun _ -> ()); Remanent_parameters_sig.save_progress_bar = (fun _ -> ()); Remanent_parameters_sig.reset_progress_bar = (fun _ -> ()); @@ -495,64 +461,61 @@ let get_parameters ?html_mode:(html_mode=true) ~called_from () = Remanent_parameters_sig.reset_current_phase_title = (fun _ -> ()); Remanent_parameters_sig.logger = (match channel with - | None -> Loggers.dummy_txt_logger - | Some _ -> Loggers.open_logger_from_formatter !Config.formatter); - Remanent_parameters_sig.logger_err = - (match channel_err with - | None -> Loggers.dummy_txt_logger - | Some fmt -> Loggers.open_logger_from_formatter fmt); + | None -> Loggers.dummy_txt_logger + | Some _ -> Loggers.open_logger_from_formatter !Config.formatter); + Remanent_parameters_sig.logger_err = + (match channel_err with + | None -> Loggers.dummy_txt_logger + | Some fmt -> Loggers.open_logger_from_formatter fmt); Remanent_parameters_sig.logger_backdoor = (match channel_backdoor with - | None -> Loggers.dummy_txt_logger - | Some channel -> Loggers.open_logger_from_channel channel); + | None -> Loggers.dummy_txt_logger + | Some channel -> Loggers.open_logger_from_channel channel); Remanent_parameters_sig.compression_status = Loggers.dummy_txt_logger; Remanent_parameters_sig.print_efficiency = !Config.print_efficiency; Remanent_parameters_sig.profiler = - begin - match - channel - with - | None -> Loggers.dummy_txt_logger - | Some a -> - Loggers.open_logger_from_channel ~mode:Loggers.HTML_Tabular a - end ; + (match channel with + | None -> Loggers.dummy_txt_logger + | Some a -> Loggers.open_logger_from_channel ~mode:Loggers.HTML_Tabular a); } let dummy_parameters ~called_from = let cache = ref None in fun () -> - match - !cache - with + match !cache with | None -> let p = get_parameters ~called_from () in let () = cache := Some p in p | Some p -> p - let get_bound_symbol_1 symbol = symbol.Symbol_table.bound let get_open_binding_state_1 symbol = symbol.Symbol_table.open_binding_state let get_close_binding_state_1 symbol = symbol.Symbol_table.close_binding_state -let get_missing_binding_state_1 symbol = symbol.Symbol_table.missing_binding_state + +let get_missing_binding_state_1 symbol = + symbol.Symbol_table.missing_binding_state + let get_link_to_any_1 symbol = symbol.Symbol_table.link_to_any let get_link_to_some_1 symbol = symbol.Symbol_table.link_to_some -let get_internal_state_symbol_1 symbol = symbol.Symbol_table.internal_state_symbol + +let get_internal_state_symbol_1 symbol = + symbol.Symbol_table.internal_state_symbol + let get_open_internal_state_1 symbol = symbol.Symbol_table.open_internal_state let get_close_internal_state_1 symbol = symbol.Symbol_table.close_internal_state let get_free_1 symbol = symbol.Symbol_table.free let get_at_symbol_1 symbol = symbol.Symbol_table.at let get_agent_open_symbol_1 symbol = symbol.Symbol_table.agent_open let get_agent_close_symbol_1 symbol = symbol.Symbol_table.agent_close + let get_agent_sep_comma_symbol_1 symbol = fst symbol.Symbol_table.agent_sep_comma -let get_agent_sep_plus_symbol_1 symbol = - fst symbol.Symbol_table.agent_sep_plus -let get_agent_sep_dot_symbol_1 symbol = - fst symbol.Symbol_table.agent_sep_dot + +let get_agent_sep_plus_symbol_1 symbol = fst symbol.Symbol_table.agent_sep_plus +let get_agent_sep_dot_symbol_1 symbol = fst symbol.Symbol_table.agent_sep_dot let get_btype_sep_symbol_1 symbol = symbol.Symbol_table.btype_sep -let get_site_sep_comma_symbol_1 symbol = - fst symbol.Symbol_table.site_sep +let get_site_sep_comma_symbol_1 symbol = fst symbol.Symbol_table.site_sep let get_ghost_agent_symbol_1 symbol = symbol.Symbol_table.ghost_agent let get_do_we_show_ghost_1 symbol = symbol.Symbol_table.show_ghost let get_uni_arrow_symbol_1 symbol = symbol.Symbol_table.uni_arrow @@ -564,229 +527,336 @@ let get_rev_arrow_no_poly_symbol_1 symbol = symbol.Symbol_table.rev_arrow_nopoly let get_open_int_interval_inclusive_symbol_1 symbol = symbol.Symbol_table.open_int_interval_inclusive + let get_open_int_interval_exclusive_symbol_1 symbol = symbol.Symbol_table.open_int_interval_exclusive + let get_open_int_interval_infinity_symbol_1 symbol = symbol.Symbol_table.open_int_interval_infinity + let get_close_int_interval_inclusive_symbol_1 symbol = symbol.Symbol_table.close_int_interval_inclusive + let get_close_int_interval_exclusive_symbol_1 symbol = symbol.Symbol_table.close_int_interval_exclusive + let get_close_int_interval_infinity_symbol_1 symbol = symbol.Symbol_table.close_int_interval_infinity -let get_plus_infinity_symbol_1 symbol = - symbol.Symbol_table.plus_infinity -let get_minus_infinity_symbol_1 symbol = - symbol.Symbol_table.minus_infinity + +let get_plus_infinity_symbol_1 symbol = symbol.Symbol_table.plus_infinity +let get_minus_infinity_symbol_1 symbol = symbol.Symbol_table.minus_infinity + let get_int_interval_separator_symbol_1 symbol = symbol.Symbol_table.int_interval_separator -let get_open_counter_state_1 symbol = symbol.Symbol_table.open_counter_state -let get_open_counterceq_1 symbol = - symbol.Symbol_table.open_counterceq -let get_open_countercvar_1 symbol = - symbol.Symbol_table.open_countercvar -let get_open_countercgte_1 symbol = - symbol.Symbol_table.open_countercgte -let get_open_counterdelta_1 symbol = - symbol.Symbol_table.open_counterdelta -let get_open_counterval_1 symbol = - symbol.Symbol_table.open_counterval +let get_open_counter_state_1 symbol = symbol.Symbol_table.open_counter_state +let get_open_counterceq_1 symbol = symbol.Symbol_table.open_counterceq +let get_open_countercvar_1 symbol = symbol.Symbol_table.open_countercvar +let get_open_countercgte_1 symbol = symbol.Symbol_table.open_countercgte +let get_open_counterdelta_1 symbol = symbol.Symbol_table.open_counterdelta +let get_open_counterval_1 symbol = symbol.Symbol_table.open_counterval let get_close_counter_state_1 symbol = symbol.Symbol_table.close_counter_state -let get_close_counterceq_1 symbol = - symbol.Symbol_table.close_counterceq -let get_close_countercvar_1 symbol = - symbol.Symbol_table.close_countercvar -let get_close_countercgte_1 symbol = - symbol.Symbol_table.close_countercgte -let get_close_counterdelta_1 symbol = - symbol.Symbol_table.close_counterdelta -let get_close_counterval_1 symbol = - symbol.Symbol_table.close_counterval - -let get_counterceq_symbol_1 symbol = - symbol.Symbol_table.counterceq_symbol -let get_countercvar_symbol_1 symbol = - symbol.Symbol_table.countercvar_symbol -let get_countercgte_symbol_1 symbol = - symbol.Symbol_table.countercgte_symbol +let get_close_counterceq_1 symbol = symbol.Symbol_table.close_counterceq +let get_close_countercvar_1 symbol = symbol.Symbol_table.close_countercvar +let get_close_countercgte_1 symbol = symbol.Symbol_table.close_countercgte +let get_close_counterdelta_1 symbol = symbol.Symbol_table.close_counterdelta +let get_close_counterval_1 symbol = symbol.Symbol_table.close_counterval +let get_counterceq_symbol_1 symbol = symbol.Symbol_table.counterceq_symbol +let get_countercvar_symbol_1 symbol = symbol.Symbol_table.countercvar_symbol +let get_countercgte_symbol_1 symbol = symbol.Symbol_table.countercgte_symbol + let get_counterdeltaplus_symbol_1 symbol = symbol.Symbol_table.counterdeltaplus_symbol + let get_counterdeltaminus_symbol_1 symbol = symbol.Symbol_table.counterdeltaminus_symbol -let get_counterval_symbol_1 symbol = - symbol.Symbol_table.counterval_symbol + +let get_counterval_symbol_1 symbol = symbol.Symbol_table.counterval_symbol (*Influence*) -let get_im_format_1 influence = influence.Remanent_parameters_sig.im_format -let get_im_file_1 influence = influence.Remanent_parameters_sig.im_file -let get_im_directory_1 influence = influence.Remanent_parameters_sig.im_directory -let get_rule_shape_1 influence = influence.Remanent_parameters_sig.rule_shape -let get_rule_color_1 influence = influence.Remanent_parameters_sig.rule_color -let get_variable_shape_1 influence = influence.Remanent_parameters_sig.variable_shape -let get_variable_color_1 influence = influence.Remanent_parameters_sig.variable_color -let get_wake_up_color_1 influence = influence.Remanent_parameters_sig.wake_up_color -let get_inhibition_color_1 influence = influence.Remanent_parameters_sig.inhibition_color -let get_wake_up_arrow_1 influence = influence.Remanent_parameters_sig.wake_up_arrow -let get_inhibition_arrow_1 influence = influence.Remanent_parameters_sig.inhibition_arrow -let get_prompt_full_var_def_1 influence = influence.Remanent_parameters_sig.prompt_full_var_def -let get_prompt_full_rule_def_1 influence = influence.Remanent_parameters_sig.prompt_full_rule_def -let get_make_labels_compatible_1 influence = influence.Remanent_parameters_sig.make_labels_compatible - -let get_pure_contact_1 cm = cm.Remanent_parameters_sig.pure_contact -let get_cm_format_1 cm = cm.Remanent_parameters_sig.cm_format -let get_cm_file_1 cm = cm.Remanent_parameters_sig.cm_file -let get_cm_directory_1 cm = cm.Remanent_parameters_sig.cm_directory -let get_binding_site_shape_1 cm = cm.Remanent_parameters_sig.binding_site_shape -let get_binding_site_color_1 cm = cm.Remanent_parameters_sig.binding_site_color -let get_internal_site_shape_1 cm = cm.Remanent_parameters_sig.internal_site_shape -let get_internal_site_color_1 cm = cm.Remanent_parameters_sig.internal_site_color +let get_im_format_1 influence = influence.Remanent_parameters_sig.im_format +let get_im_file_1 influence = influence.Remanent_parameters_sig.im_file + +let get_im_directory_1 influence = + influence.Remanent_parameters_sig.im_directory + +let get_rule_shape_1 influence = influence.Remanent_parameters_sig.rule_shape +let get_rule_color_1 influence = influence.Remanent_parameters_sig.rule_color + +let get_variable_shape_1 influence = + influence.Remanent_parameters_sig.variable_shape + +let get_variable_color_1 influence = + influence.Remanent_parameters_sig.variable_color + +let get_wake_up_color_1 influence = + influence.Remanent_parameters_sig.wake_up_color + +let get_inhibition_color_1 influence = + influence.Remanent_parameters_sig.inhibition_color + +let get_wake_up_arrow_1 influence = + influence.Remanent_parameters_sig.wake_up_arrow + +let get_inhibition_arrow_1 influence = + influence.Remanent_parameters_sig.inhibition_arrow + +let get_prompt_full_var_def_1 influence = + influence.Remanent_parameters_sig.prompt_full_var_def + +let get_prompt_full_rule_def_1 influence = + influence.Remanent_parameters_sig.prompt_full_rule_def + +let get_make_labels_compatible_1 influence = + influence.Remanent_parameters_sig.make_labels_compatible + +let get_pure_contact_1 cm = cm.Remanent_parameters_sig.pure_contact +let get_cm_format_1 cm = cm.Remanent_parameters_sig.cm_format +let get_cm_file_1 cm = cm.Remanent_parameters_sig.cm_file +let get_cm_directory_1 cm = cm.Remanent_parameters_sig.cm_directory +let get_binding_site_shape_1 cm = cm.Remanent_parameters_sig.binding_site_shape +let get_binding_site_color_1 cm = cm.Remanent_parameters_sig.binding_site_color + +let get_internal_site_shape_1 cm = + cm.Remanent_parameters_sig.internal_site_shape + +let get_internal_site_color_1 cm = + cm.Remanent_parameters_sig.internal_site_color + let get_counter_site_shape_1 cm = cm.Remanent_parameters_sig.counter_site_shape let get_counter_site_color_1 cm = cm.Remanent_parameters_sig.counter_site_color -let get_agent_shape_array_1 cm = cm.Remanent_parameters_sig.agent_shape_array -let get_agent_color_array_1 cm = cm.Remanent_parameters_sig.agent_color_array -let get_agent_shape_def_1 cm = cm.Remanent_parameters_sig.agent_shape_def -let get_agent_color_def_1 cm = cm.Remanent_parameters_sig.agent_color_def -let get_link_color_1 cm = cm.Remanent_parameters_sig.link_color -let get_influence_color_1 cm = cm.Remanent_parameters_sig.influence_color -let get_influence_arrow_1 cm = cm.Remanent_parameters_sig.influence_arrow +let get_agent_shape_array_1 cm = cm.Remanent_parameters_sig.agent_shape_array +let get_agent_color_array_1 cm = cm.Remanent_parameters_sig.agent_color_array +let get_agent_shape_def_1 cm = cm.Remanent_parameters_sig.agent_shape_def +let get_agent_color_def_1 cm = cm.Remanent_parameters_sig.agent_color_def +let get_link_color_1 cm = cm.Remanent_parameters_sig.link_color +let get_influence_color_1 cm = cm.Remanent_parameters_sig.influence_color +let get_influence_arrow_1 cm = cm.Remanent_parameters_sig.influence_arrow (*add reachability*) -let get_dump_reachability_analysis_result_1 r = r.Remanent_parameters_sig.dump_reachability_analysis_result -let get_dump_reachability_analysis_iteration_1 r = r.Remanent_parameters_sig.dump_reachability_analysis_iteration -let get_dump_reachability_analysis_static_1 r = r.Remanent_parameters_sig.dump_reachability_analysis_static -let get_dump_reachability_analysis_dynamic_1 r = r.Remanent_parameters_sig.dump_reachability_analysis_dynamic -let get_dump_reachability_analysis_diff_1 r = r.Remanent_parameters_sig.dump_reachability_analysis_diff -let get_dump_reachability_analysis_wl_1 r = r.Remanent_parameters_sig.dump_reachability_analysis_wl +let get_dump_reachability_analysis_result_1 r = + r.Remanent_parameters_sig.dump_reachability_analysis_result + +let get_dump_reachability_analysis_iteration_1 r = + r.Remanent_parameters_sig.dump_reachability_analysis_iteration + +let get_dump_reachability_analysis_static_1 r = + r.Remanent_parameters_sig.dump_reachability_analysis_static + +let get_dump_reachability_analysis_dynamic_1 r = + r.Remanent_parameters_sig.dump_reachability_analysis_dynamic + +let get_dump_reachability_analysis_diff_1 r = + r.Remanent_parameters_sig.dump_reachability_analysis_diff + +let get_dump_reachability_analysis_wl_1 r = + r.Remanent_parameters_sig.dump_reachability_analysis_wl + let get_smash_relations_1 r = r.Remanent_parameters_sig.smash_relations -let get_hide_one_d_relations_from_cartesian_decomposition_1 r = r.Remanent_parameters_sig.hide_one_d_relations_from_cartesian_decomposition + +let get_hide_one_d_relations_from_cartesian_decomposition_1 r = + r.Remanent_parameters_sig.hide_one_d_relations_from_cartesian_decomposition + let get_hide_reverse_rule_without_label_from_dead_rules_1 r = r.Remanent_parameters_sig.hide_reverse_rule_without_label_from_dead_rules let get_post_processing_1 r = match r.Remanent_parameters_sig.use_natural_language with - Remanent_parameters_sig.Raw -> false - | Remanent_parameters_sig.Kappa - | Remanent_parameters_sig.Natural_language -> true -let get_backend_mode_1 r = - r.Remanent_parameters_sig.use_natural_language - -let get_local_trace_format_1 r = r.Remanent_parameters_sig.format_for_local_traces -let get_compute_local_traces_1 r = r.Remanent_parameters_sig.compute_local_traces -let get_compute_separating_transitions_1 r = r.Remanent_parameters_sig.compute_separating_transitions + | Remanent_parameters_sig.Raw -> false + | Remanent_parameters_sig.Kappa | Remanent_parameters_sig.Natural_language -> + true + +let get_backend_mode_1 r = r.Remanent_parameters_sig.use_natural_language + +let get_local_trace_format_1 r = + r.Remanent_parameters_sig.format_for_local_traces + +let get_compute_local_traces_1 r = + r.Remanent_parameters_sig.compute_local_traces + +let get_compute_separating_transitions_1 r = + r.Remanent_parameters_sig.compute_separating_transitions + let set_compute_separating_transitions_1 r b = - {r with - Remanent_parameters_sig.compute_separating_transitions = b} + { r with Remanent_parameters_sig.compute_separating_transitions = b } + let set_use_macrotransition_in_local_traces_1 r b = - {r with - Remanent_parameters_sig.use_macrotransitions_in_local_traces = b} + { r with Remanent_parameters_sig.use_macrotransitions_in_local_traces = b } + let get_ignore_trivial_losanges_1 r = r.Remanent_parameters_sig.ignore_trivial_losanges -let get_show_rule_names_in_local_traces_1 r = r.Remanent_parameters_sig.show_rule_names_in_local_traces -let get_use_macrotransitions_in_local_traces_1 r = r.Remanent_parameters_sig.use_macrotransitions_in_local_traces -let get_add_singular_macrostates_1 r = r.Remanent_parameters_sig.add_singular_macrostates -let get_add_singular_microstates_1 r = r.Remanent_parameters_sig.add_singular_microstates + +let get_show_rule_names_in_local_traces_1 r = + r.Remanent_parameters_sig.show_rule_names_in_local_traces + +let get_use_macrotransitions_in_local_traces_1 r = + r.Remanent_parameters_sig.use_macrotransitions_in_local_traces + +let get_add_singular_macrostates_1 r = + r.Remanent_parameters_sig.add_singular_macrostates + +let get_add_singular_microstates_1 r = + r.Remanent_parameters_sig.add_singular_microstates + let get_local_trace_prefix_1 r = r.Remanent_parameters_sig.trace_prefix let get_local_trace_directory_1 r = r.Remanent_parameters_sig.trace_directory let get_view_analysis_1 r = r.Remanent_parameters_sig.views -let get_site_across_bonds_analysis_1 r = r.Remanent_parameters_sig.site_across_bonds -let get_parallel_bonds_analysis_1 r = - r.Remanent_parameters_sig.parallel_bonds + +let get_site_across_bonds_analysis_1 r = + r.Remanent_parameters_sig.site_across_bonds + +let get_parallel_bonds_analysis_1 r = r.Remanent_parameters_sig.parallel_bonds let get_dynamic_contact_map_1 r = r.Remanent_parameters_sig.dynamic_contact_map let get_counters_analysis_1 r = r.Remanent_parameters_sig.counters let get_counters_domain_1 r = r.Remanent_parameters_sig.counter_domain let get_compute_symmetries_1 marshalisable = marshalisable.Remanent_parameters_sig.do_symmetries_analysis + let get_rate_convention_1 marshalisable = marshalisable.Remanent_parameters_sig.rate_convention + let get_empty_hashtbl_size_1 marshalisable = marshalisable.Remanent_parameters_sig.empty_hashtbl_size let get_symbols_1 marshalisable = marshalisable.Remanent_parameters_sig.symbols let get_file_1 marshalisable = marshalisable.Remanent_parameters_sig.file -let get_influence_map_1 marshalisable = marshalisable.Remanent_parameters_sig.influence_map_output -let get_contact_map_1 marshalisable = marshalisable.Remanent_parameters_sig.contact_map_output + +let get_influence_map_1 marshalisable = + marshalisable.Remanent_parameters_sig.influence_map_output + +let get_contact_map_1 marshalisable = + marshalisable.Remanent_parameters_sig.contact_map_output + (*add reachability*) -let get_reachability_map_1 marshalisable = marshalisable.Remanent_parameters_sig.reachability_map_output +let get_reachability_map_1 marshalisable = + marshalisable.Remanent_parameters_sig.reachability_map_output + let get_reachability_analysis_parameters_1 marshalisable = marshalisable.Remanent_parameters_sig.reachability_analysis_parameters -let get_unsafe_1 marshalisable = marshalisable.Remanent_parameters_sig.unsafe -let get_trace_1 marshalisable = marshalisable.Remanent_parameters_sig.trace -let get_dump_error_as_soon_as_they_occur_1 marshalisable = marshalisable.Remanent_parameters_sig.dump_error_as_soon_as_they_occur -let get_prefix_1 marshalisable = marshalisable.Remanent_parameters_sig.prefix -let get_call_stack_1 marshalisable = marshalisable.Remanent_parameters_sig.call_stack -let get_link_mode_1 marshalisable = marshalisable.Remanent_parameters_sig.link_mode -let get_kasa_state_1 marshalisable = marshalisable.Remanent_parameters_sig.kasa_state -let get_do_contact_map_1 marshalisable = marshalisable.Remanent_parameters_sig.do_contact_map -let get_syntax_version_1 marshalisable = +let get_unsafe_1 marshalisable = marshalisable.Remanent_parameters_sig.unsafe +let get_trace_1 marshalisable = marshalisable.Remanent_parameters_sig.trace + +let get_dump_error_as_soon_as_they_occur_1 marshalisable = + marshalisable.Remanent_parameters_sig.dump_error_as_soon_as_they_occur + +let get_prefix_1 marshalisable = marshalisable.Remanent_parameters_sig.prefix + +let get_call_stack_1 marshalisable = + marshalisable.Remanent_parameters_sig.call_stack + +let get_link_mode_1 marshalisable = + marshalisable.Remanent_parameters_sig.link_mode + +let get_kasa_state_1 marshalisable = + marshalisable.Remanent_parameters_sig.kasa_state + +let get_do_contact_map_1 marshalisable = + marshalisable.Remanent_parameters_sig.do_contact_map + +let get_syntax_version_1 marshalisable = marshalisable.Remanent_parameters_sig.syntax_version -let get_do_scc_1 marshalisable = marshalisable.Remanent_parameters_sig.do_scc -let get_do_influence_map_1 marshalisable = marshalisable.Remanent_parameters_sig.do_influence_map -let get_do_ODE_flow_of_information_1 marshalisable = marshalisable.Remanent_parameters_sig.do_ODE_flow_of_information -let get_do_stochastic_flow_of_information_1 marshalisable = marshalisable.Remanent_parameters_sig.do_stochastic_flow_of_information -let get_do_site_dependencies_1 marshalisable = marshalisable.Remanent_parameters_sig.do_site_dependencies -let get_dump_site_dependencies_1 marshalisable = marshalisable.Remanent_parameters_sig.dump_site_dependencies +let get_do_scc_1 marshalisable = marshalisable.Remanent_parameters_sig.do_scc + +let get_do_influence_map_1 marshalisable = + marshalisable.Remanent_parameters_sig.do_influence_map + +let get_do_ODE_flow_of_information_1 marshalisable = + marshalisable.Remanent_parameters_sig.do_ODE_flow_of_information + +let get_do_stochastic_flow_of_information_1 marshalisable = + marshalisable.Remanent_parameters_sig.do_stochastic_flow_of_information + +let get_do_site_dependencies_1 marshalisable = + marshalisable.Remanent_parameters_sig.do_site_dependencies + +let get_dump_site_dependencies_1 marshalisable = + marshalisable.Remanent_parameters_sig.dump_site_dependencies (*reachability different output*) -let get_do_reachability_analysis_1 marshalisable = +let get_do_reachability_analysis_1 marshalisable = marshalisable.Remanent_parameters_sig.do_reachability_analysis (**) -let get_influence_map_accuracy_level_1 marshalisable = marshalisable.Remanent_parameters_sig.influence_map_accuracy_level -let get_contact_map_accuracy_level_1 marshalisable = marshalisable.Remanent_parameters_sig.contact_map_accuracy_level -let get_scc_accuracy_level_1 marshalisable = marshalisable.Remanent_parameters_sig.scc_accuracy_level -let get_view_accuracy_level_1 marshalisable = marshalisable.Remanent_parameters_sig.view_accuracy_level +let get_influence_map_accuracy_level_1 marshalisable = + marshalisable.Remanent_parameters_sig.influence_map_accuracy_level + +let get_contact_map_accuracy_level_1 marshalisable = + marshalisable.Remanent_parameters_sig.contact_map_accuracy_level + +let get_scc_accuracy_level_1 marshalisable = + marshalisable.Remanent_parameters_sig.scc_accuracy_level + +let get_view_accuracy_level_1 marshalisable = + marshalisable.Remanent_parameters_sig.view_accuracy_level -let get_launching_date_1 marshalisable = +let get_launching_date_1 marshalisable = let t = marshalisable.Remanent_parameters_sig.launching_date in let gmt = marshalisable.Remanent_parameters_sig.time_shift in Printf.sprintf "Analysis launched at %04i/%02i/%02i %02i:%02i:%02i (GMT%+i)" - (t.Unix.tm_year+1900) - (t.Unix.tm_mon+1) - (t.Unix.tm_mday) - t.Unix.tm_hour - t.Unix.tm_min t.Unix.tm_sec gmt -let get_short_version_1 marshalisable = + (t.Unix.tm_year + 1900) (t.Unix.tm_mon + 1) t.Unix.tm_mday t.Unix.tm_hour + t.Unix.tm_min t.Unix.tm_sec gmt + +let get_short_version_1 marshalisable = marshalisable.Remanent_parameters_sig.version -let get_full_version_1 marshalisable = + +let get_full_version_1 marshalisable = Printf.sprintf "%s (with%s Tk interface)" marshalisable.Remanent_parameters_sig.version - (if marshalisable.Remanent_parameters_sig.tk_interface then "" else "out") + (if marshalisable.Remanent_parameters_sig.tk_interface then + "" + else + "out") -let get_launched_where_1 marshalisable = - marshalisable.Remanent_parameters_sig.hostname -let get_command_line_1 marshalisable = +let get_launched_where_1 marshalisable = + marshalisable.Remanent_parameters_sig.hostname + +let get_command_line_1 marshalisable = marshalisable.Remanent_parameters_sig.command_line -let get_marshalisable parameter = parameter.Remanent_parameters_sig.marshalisable_parameters +let get_marshalisable parameter = + parameter.Remanent_parameters_sig.marshalisable_parameters + let get_logger parameter = parameter.Remanent_parameters_sig.logger let get_logger_err parameter = parameter.Remanent_parameters_sig.logger_err + let get_logger_backdoor parameter = parameter.Remanent_parameters_sig.logger_backdoor (*let get_formatter parameter = parameter.Remanent_parameters_sig.formatter -let set_formatter parameter logger = {parameter with Remanent_parameters_sig.formatter = logger}*) + let set_formatter parameter logger = {parameter with Remanent_parameters_sig.formatter = logger}*) let upgrade_from_marshal_field f = compose f get_marshalisable - let get_command_line = upgrade_from_marshal_field get_command_line_1 let get_short_version = upgrade_from_marshal_field get_short_version_1 let get_launched_where = upgrade_from_marshal_field get_launched_where_1 let get_full_version = upgrade_from_marshal_field get_full_version_1 let get_launching_date = upgrade_from_marshal_field get_launching_date_1 -let get_launched_when_and_where parameters = Printf.sprintf "%s on %s" (get_launching_date parameters) (get_launched_where parameters) + +let get_launched_when_and_where parameters = + Printf.sprintf "%s on %s" + (get_launching_date parameters) + (get_launched_where parameters) + let get_do_contact_map = upgrade_from_marshal_field get_do_contact_map_1 let get_syntax_version = upgrade_from_marshal_field get_syntax_version_1 let get_do_scc = upgrade_from_marshal_field get_do_scc_1 let get_do_influence_map = upgrade_from_marshal_field get_do_influence_map_1 -let get_do_ODE_flow_of_information = upgrade_from_marshal_field get_do_ODE_flow_of_information_1 -let get_do_stochastic_flow_of_information = upgrade_from_marshal_field get_do_stochastic_flow_of_information_1 -let get_do_site_dependencies = upgrade_from_marshal_field get_do_site_dependencies_1 -let get_dump_site_dependencies = upgrade_from_marshal_field get_dump_site_dependencies_1 + +let get_do_ODE_flow_of_information = + upgrade_from_marshal_field get_do_ODE_flow_of_information_1 + +let get_do_stochastic_flow_of_information = + upgrade_from_marshal_field get_do_stochastic_flow_of_information_1 + +let get_do_site_dependencies = + upgrade_from_marshal_field get_do_site_dependencies_1 + +let get_dump_site_dependencies = + upgrade_from_marshal_field get_dump_site_dependencies_1 (*reachability analysis in different output*) (**) @@ -796,99 +866,153 @@ let get_compute_symmetries = upgrade_from_marshal_field get_compute_symmetries_1 let get_rate_convention = upgrade_from_marshal_field get_rate_convention_1 let get_influence_map = upgrade_from_marshal_field get_influence_map_1 let get_contact_map = upgrade_from_marshal_field get_contact_map_1 + (*add reachability*) let get_reachability_map = upgrade_from_marshal_field get_reachability_map_1 + let get_reachability_analysis_parameters = upgrade_from_marshal_field get_reachability_analysis_parameters_1 + let get_unsafe = upgrade_from_marshal_field get_unsafe_1 let get_trace = upgrade_from_marshal_field get_trace_1 -let get_dump_error_as_soon_as_they_occur = upgrade_from_marshal_field get_dump_error_as_soon_as_they_occur_1 + +let get_dump_error_as_soon_as_they_occur = + upgrade_from_marshal_field get_dump_error_as_soon_as_they_occur_1 + let get_prefix = upgrade_from_marshal_field get_prefix_1 let get_call_stack = upgrade_from_marshal_field get_call_stack_1 let get_link_mode = upgrade_from_marshal_field get_link_mode_1 -let get_contact_map_accuracy_level = upgrade_from_marshal_field get_contact_map_accuracy_level_1 + +let get_contact_map_accuracy_level = + upgrade_from_marshal_field get_contact_map_accuracy_level_1 + let get_scc_accuracy_level = upgrade_from_marshal_field get_scc_accuracy_level_1 -let get_influence_map_accuracy_level = upgrade_from_marshal_field get_influence_map_accuracy_level_1 -let get_view_accuracy_level = upgrade_from_marshal_field get_view_accuracy_level_1 -let get_empty_hashtbl_size = upgrade_from_marshal_field get_empty_hashtbl_size_1 +let get_influence_map_accuracy_level = + upgrade_from_marshal_field get_influence_map_accuracy_level_1 + +let get_view_accuracy_level = + upgrade_from_marshal_field get_view_accuracy_level_1 + +let get_empty_hashtbl_size = upgrade_from_marshal_field get_empty_hashtbl_size_1 let upgrade_from_influence_map_field f = compose f get_influence_map let upgrade_from_contact_map_field f = compose f get_contact_map let upgrade_from_symbols_field f = compose f get_symbols + (*add reachability*) let upgrade_from_reachability_map_field f = compose f get_reachability_map -let upgrade_from_reachability_analysis_parameters_field f = compose f get_reachability_analysis_parameters + +let upgrade_from_reachability_analysis_parameters_field f = + compose f get_reachability_analysis_parameters (*symbols*) let get_bound_symbol = upgrade_from_symbols_field get_bound_symbol_1 let get_open_binding_state = upgrade_from_symbols_field get_open_binding_state_1 -let get_close_binding_state = upgrade_from_symbols_field get_close_binding_state_1 -let get_missing_binding_state = upgrade_from_symbols_field get_missing_binding_state_1 -let get_internal_state_symbol = upgrade_from_symbols_field get_internal_state_symbol_1 -let get_open_internal_state = upgrade_from_symbols_field get_open_internal_state_1 -let get_close_internal_state = upgrade_from_symbols_field get_close_internal_state_1 + +let get_close_binding_state = + upgrade_from_symbols_field get_close_binding_state_1 + +let get_missing_binding_state = + upgrade_from_symbols_field get_missing_binding_state_1 + +let get_internal_state_symbol = + upgrade_from_symbols_field get_internal_state_symbol_1 + +let get_open_internal_state = + upgrade_from_symbols_field get_open_internal_state_1 + +let get_close_internal_state = + upgrade_from_symbols_field get_close_internal_state_1 + let get_link_to_any = upgrade_from_symbols_field get_link_to_any_1 let get_link_to_some = upgrade_from_symbols_field get_link_to_some_1 let get_free_symbol = upgrade_from_symbols_field get_free_1 let get_at_symbol = upgrade_from_symbols_field get_at_symbol_1 let get_agent_open_symbol = upgrade_from_symbols_field get_agent_open_symbol_1 let get_agent_close_symbol = upgrade_from_symbols_field get_agent_close_symbol_1 -let get_agent_sep_comma_symbol = upgrade_from_symbols_field get_agent_sep_comma_symbol_1 -let get_agent_sep_plus_symbol = upgrade_from_symbols_field get_agent_sep_plus_symbol_1 -let get_agent_sep_dot_symbol = upgrade_from_symbols_field get_agent_sep_dot_symbol_1 + +let get_agent_sep_comma_symbol = + upgrade_from_symbols_field get_agent_sep_comma_symbol_1 + +let get_agent_sep_plus_symbol = + upgrade_from_symbols_field get_agent_sep_plus_symbol_1 + +let get_agent_sep_dot_symbol = + upgrade_from_symbols_field get_agent_sep_dot_symbol_1 + let get_btype_sep_symbol = upgrade_from_symbols_field get_btype_sep_symbol_1 -let get_site_sep_comma_symbol = upgrade_from_symbols_field get_site_sep_comma_symbol_1 + +let get_site_sep_comma_symbol = + upgrade_from_symbols_field get_site_sep_comma_symbol_1 + let get_ghost_agent_symbol = upgrade_from_symbols_field get_ghost_agent_symbol_1 let get_do_we_show_ghost = upgrade_from_symbols_field get_do_we_show_ghost_1 let get_uni_arrow_symbol = upgrade_from_symbols_field get_uni_arrow_symbol_1 let get_rev_arrow_symbol = upgrade_from_symbols_field get_rev_arrow_symbol_1 let get_bi_arrow_symbol = upgrade_from_symbols_field get_bi_arrow_symbol_1 -let get_bi_arrow_no_poly_symbol = upgrade_from_symbols_field get_bi_arrow_no_poly_symbol_1 -let get_rev_arrow_no_poly_symbol = upgrade_from_symbols_field get_rev_arrow_no_poly_symbol_1 -let get_uni_arrow_no_poly_symbol = upgrade_from_symbols_field get_uni_arrow_no_poly_symbol_1 -let get_open_int_interval_inclusive_symbol = upgrade_from_symbols_field get_open_int_interval_inclusive_symbol_1 -let get_open_int_interval_exclusive_symbol = upgrade_from_symbols_field get_open_int_interval_exclusive_symbol_1 -let get_open_int_interval_infinity_symbol = upgrade_from_symbols_field get_open_int_interval_infinity_symbol_1 -let get_close_int_interval_inclusive_symbol = upgrade_from_symbols_field get_close_int_interval_inclusive_symbol_1 -let get_close_int_interval_exclusive_symbol = upgrade_from_symbols_field get_close_int_interval_exclusive_symbol_1 -let get_close_int_interval_infinity_symbol = upgrade_from_symbols_field get_close_int_interval_infinity_symbol_1 -let get_plus_infinity_symbol = upgrade_from_symbols_field get_plus_infinity_symbol_1 -let get_minus_infinity_symbol = upgrade_from_symbols_field get_minus_infinity_symbol_1 -let get_int_interval_separator_symbol = upgrade_from_symbols_field get_int_interval_separator_symbol_1 - -let get_open_counter_state = upgrade_from_symbols_field - get_open_counter_state_1 -let get_open_counterceq = upgrade_from_symbols_field - get_open_counterceq_1 -let get_open_countercgte = upgrade_from_symbols_field - get_open_countercgte_1 -let get_open_countercvar = upgrade_from_symbols_field - get_open_countercvar_1 + +let get_bi_arrow_no_poly_symbol = + upgrade_from_symbols_field get_bi_arrow_no_poly_symbol_1 + +let get_rev_arrow_no_poly_symbol = + upgrade_from_symbols_field get_rev_arrow_no_poly_symbol_1 + +let get_uni_arrow_no_poly_symbol = + upgrade_from_symbols_field get_uni_arrow_no_poly_symbol_1 + +let get_open_int_interval_inclusive_symbol = + upgrade_from_symbols_field get_open_int_interval_inclusive_symbol_1 + +let get_open_int_interval_exclusive_symbol = + upgrade_from_symbols_field get_open_int_interval_exclusive_symbol_1 + +let get_open_int_interval_infinity_symbol = + upgrade_from_symbols_field get_open_int_interval_infinity_symbol_1 + +let get_close_int_interval_inclusive_symbol = + upgrade_from_symbols_field get_close_int_interval_inclusive_symbol_1 + +let get_close_int_interval_exclusive_symbol = + upgrade_from_symbols_field get_close_int_interval_exclusive_symbol_1 + +let get_close_int_interval_infinity_symbol = + upgrade_from_symbols_field get_close_int_interval_infinity_symbol_1 + +let get_plus_infinity_symbol = + upgrade_from_symbols_field get_plus_infinity_symbol_1 + +let get_minus_infinity_symbol = + upgrade_from_symbols_field get_minus_infinity_symbol_1 + +let get_int_interval_separator_symbol = + upgrade_from_symbols_field get_int_interval_separator_symbol_1 + +let get_open_counter_state = upgrade_from_symbols_field get_open_counter_state_1 +let get_open_counterceq = upgrade_from_symbols_field get_open_counterceq_1 +let get_open_countercgte = upgrade_from_symbols_field get_open_countercgte_1 +let get_open_countercvar = upgrade_from_symbols_field get_open_countercvar_1 let get_open_counterdelta = upgrade_from_symbols_field get_open_counterdelta_1 let get_open_counterval = upgrade_from_symbols_field get_open_counterval_1 -let get_close_counter_state = upgrade_from_symbols_field - get_close_counter_state_1 -let get_close_counterceq = upgrade_from_symbols_field - get_close_counterceq_1 -let get_close_countercgte = upgrade_from_symbols_field - get_close_countercgte_1 -let get_close_countercvar = upgrade_from_symbols_field - get_close_countercvar_1 +let get_close_counter_state = + upgrade_from_symbols_field get_close_counter_state_1 + +let get_close_counterceq = upgrade_from_symbols_field get_close_counterceq_1 +let get_close_countercgte = upgrade_from_symbols_field get_close_countercgte_1 +let get_close_countercvar = upgrade_from_symbols_field get_close_countercvar_1 let get_close_counterdelta = upgrade_from_symbols_field get_close_counterdelta_1 let get_close_counterval = upgrade_from_symbols_field get_close_counterval_1 +let get_counterceq_symbol = upgrade_from_symbols_field get_counterceq_symbol_1 +let get_countercgte_symbol = upgrade_from_symbols_field get_countercgte_symbol_1 +let get_countercvar_symbol = upgrade_from_symbols_field get_countercvar_symbol_1 -let get_counterceq_symbol = upgrade_from_symbols_field - get_counterceq_symbol_1 -let get_countercgte_symbol = upgrade_from_symbols_field - get_countercgte_symbol_1 -let get_countercvar_symbol = upgrade_from_symbols_field - get_countercvar_symbol_1 -let get_counterdeltaplus_symbol = upgrade_from_symbols_field get_counterdeltaplus_symbol_1 -let get_counterdeltaminus_symbol = upgrade_from_symbols_field get_counterdeltaminus_symbol_1 -let get_counterval_symbol = upgrade_from_symbols_field get_counterval_symbol_1 +let get_counterdeltaplus_symbol = + upgrade_from_symbols_field get_counterdeltaplus_symbol_1 +let get_counterdeltaminus_symbol = + upgrade_from_symbols_field get_counterdeltaminus_symbol_1 +let get_counterval_symbol = upgrade_from_symbols_field get_counterval_symbol_1 let get_im_format = upgrade_from_influence_map_field get_im_format_1 let get_im_file = upgrade_from_influence_map_field get_im_file_1 let get_im_directory = upgrade_from_influence_map_field get_im_directory_1 @@ -897,25 +1021,53 @@ let get_rule_color = upgrade_from_influence_map_field get_rule_color_1 let get_variable_shape = upgrade_from_influence_map_field get_variable_shape_1 let get_variable_color = upgrade_from_influence_map_field get_variable_color_1 let get_wake_up_color = upgrade_from_influence_map_field get_wake_up_color_1 -let get_inhibition_color = upgrade_from_influence_map_field get_inhibition_color_1 + +let get_inhibition_color = + upgrade_from_influence_map_field get_inhibition_color_1 + let get_wake_up_arrow = upgrade_from_influence_map_field get_wake_up_arrow_1 -let get_inhibition_arrow = upgrade_from_influence_map_field get_inhibition_arrow_1 -let get_prompt_full_var_def = upgrade_from_influence_map_field get_prompt_full_var_def_1 -let get_prompt_full_rule_def = upgrade_from_influence_map_field get_prompt_full_rule_def_1 -let get_make_labels_compatible_with_dot = upgrade_from_influence_map_field get_make_labels_compatible_1 + +let get_inhibition_arrow = + upgrade_from_influence_map_field get_inhibition_arrow_1 + +let get_prompt_full_var_def = + upgrade_from_influence_map_field get_prompt_full_var_def_1 + +let get_prompt_full_rule_def = + upgrade_from_influence_map_field get_prompt_full_rule_def_1 + +let get_make_labels_compatible_with_dot = + upgrade_from_influence_map_field get_make_labels_compatible_1 let get_pure_contact = upgrade_from_contact_map_field get_pure_contact_1 let get_cm_format = upgrade_from_contact_map_field get_cm_format_1 let get_cm_file = upgrade_from_contact_map_field get_cm_file_1 let get_cm_directory = upgrade_from_contact_map_field get_cm_directory_1 -let get_binding_site_shape = upgrade_from_contact_map_field get_binding_site_shape_1 -let get_binding_site_color = upgrade_from_contact_map_field get_binding_site_color_1 -let get_internal_site_shape = upgrade_from_contact_map_field get_internal_site_shape_1 -let get_internal_site_color = upgrade_from_contact_map_field get_internal_site_color_1 -let get_counter_site_shape = upgrade_from_contact_map_field get_counter_site_shape_1 -let get_counter_site_color = upgrade_from_contact_map_field get_counter_site_color_1 -let get_agent_shape_array = upgrade_from_contact_map_field get_agent_shape_array_1 -let get_agent_color_array = upgrade_from_contact_map_field get_agent_color_array_1 + +let get_binding_site_shape = + upgrade_from_contact_map_field get_binding_site_shape_1 + +let get_binding_site_color = + upgrade_from_contact_map_field get_binding_site_color_1 + +let get_internal_site_shape = + upgrade_from_contact_map_field get_internal_site_shape_1 + +let get_internal_site_color = + upgrade_from_contact_map_field get_internal_site_color_1 + +let get_counter_site_shape = + upgrade_from_contact_map_field get_counter_site_shape_1 + +let get_counter_site_color = + upgrade_from_contact_map_field get_counter_site_color_1 + +let get_agent_shape_array = + upgrade_from_contact_map_field get_agent_shape_array_1 + +let get_agent_color_array = + upgrade_from_contact_map_field get_agent_color_array_1 + let get_agent_shape_def = upgrade_from_contact_map_field get_agent_shape_def_1 let get_agent_color_def = upgrade_from_contact_map_field get_agent_color_def_1 let get_link_color = upgrade_from_contact_map_field get_link_color_1 @@ -924,220 +1076,307 @@ let get_influence_arrow = upgrade_from_contact_map_field get_influence_arrow_1 (*add reachablity*) -let get_dump_reachability_analysis_result = upgrade_from_reachability_map_field get_dump_reachability_analysis_result_1 -let get_dump_reachability_analysis_iteration = upgrade_from_reachability_map_field get_dump_reachability_analysis_iteration_1 -let get_dump_reachability_analysis_static = upgrade_from_reachability_map_field get_dump_reachability_analysis_static_1 -let get_dump_reachability_analysis_dynamic = upgrade_from_reachability_map_field get_dump_reachability_analysis_dynamic_1 -let get_dump_reachability_analysis_diff = upgrade_from_reachability_map_field get_dump_reachability_analysis_diff_1 -let get_dump_reachability_analysis_wl = upgrade_from_reachability_map_field get_dump_reachability_analysis_wl_1 -let get_post_processing = upgrade_from_reachability_map_field get_post_processing_1 +let get_dump_reachability_analysis_result = + upgrade_from_reachability_map_field get_dump_reachability_analysis_result_1 + +let get_dump_reachability_analysis_iteration = + upgrade_from_reachability_map_field get_dump_reachability_analysis_iteration_1 + +let get_dump_reachability_analysis_static = + upgrade_from_reachability_map_field get_dump_reachability_analysis_static_1 + +let get_dump_reachability_analysis_dynamic = + upgrade_from_reachability_map_field get_dump_reachability_analysis_dynamic_1 + +let get_dump_reachability_analysis_diff = + upgrade_from_reachability_map_field get_dump_reachability_analysis_diff_1 + +let get_dump_reachability_analysis_wl = + upgrade_from_reachability_map_field get_dump_reachability_analysis_wl_1 + +let get_post_processing = + upgrade_from_reachability_map_field get_post_processing_1 + let get_backend_mode = upgrade_from_reachability_map_field get_backend_mode_1 -let get_hide_one_d_relations_from_cartesian_decomposition = upgrade_from_reachability_map_field get_hide_one_d_relations_from_cartesian_decomposition_1 + +let get_hide_one_d_relations_from_cartesian_decomposition = + upgrade_from_reachability_map_field + get_hide_one_d_relations_from_cartesian_decomposition_1 + let get_hide_reverse_rule_without_label_from_dead_rules = - upgrade_from_reachability_map_field get_hide_reverse_rule_without_label_from_dead_rules_1 + upgrade_from_reachability_map_field + get_hide_reverse_rule_without_label_from_dead_rules_1 + +let get_smash_relations = + upgrade_from_reachability_map_field get_smash_relations_1 + +let get_local_trace_format = + upgrade_from_reachability_map_field get_local_trace_format_1 + +let get_compute_local_traces = + upgrade_from_reachability_map_field get_compute_local_traces_1 + +let get_compute_separating_transitions = + upgrade_from_reachability_map_field get_compute_separating_transitions_1 -let get_smash_relations = upgrade_from_reachability_map_field get_smash_relations_1 -let get_local_trace_format = upgrade_from_reachability_map_field get_local_trace_format_1 -let get_compute_local_traces = upgrade_from_reachability_map_field get_compute_local_traces_1 -let get_compute_separating_transitions = upgrade_from_reachability_map_field get_compute_separating_transitions_1 let set_compute_separating_transitions_2 r b = - {r with - Remanent_parameters_sig.reachability_map_output = - set_compute_separating_transitions_1 r.Remanent_parameters_sig.reachability_map_output b} + { + r with + Remanent_parameters_sig.reachability_map_output = + set_compute_separating_transitions_1 + r.Remanent_parameters_sig.reachability_map_output b; + } + let set_use_macrotransition_in_local_traces_2 r b = - {r with - Remanent_parameters_sig.reachability_map_output = - set_use_macrotransition_in_local_traces_1 r.Remanent_parameters_sig.reachability_map_output b} + { + r with + Remanent_parameters_sig.reachability_map_output = + set_use_macrotransition_in_local_traces_1 + r.Remanent_parameters_sig.reachability_map_output b; + } let set_compute_separating_transitions r b = - {r with - Remanent_parameters_sig.marshalisable_parameters = - set_compute_separating_transitions_2 r.Remanent_parameters_sig.marshalisable_parameters b} + { + r with + Remanent_parameters_sig.marshalisable_parameters = + set_compute_separating_transitions_2 + r.Remanent_parameters_sig.marshalisable_parameters b; + } + let set_use_macrotransitions_in_local_traces r b = - {r with - Remanent_parameters_sig.marshalisable_parameters = - set_use_macrotransition_in_local_traces_2 r.Remanent_parameters_sig.marshalisable_parameters b} + { + r with + Remanent_parameters_sig.marshalisable_parameters = + set_use_macrotransition_in_local_traces_2 + r.Remanent_parameters_sig.marshalisable_parameters b; + } + +let get_show_rule_names_in_local_traces = + upgrade_from_reachability_map_field get_show_rule_names_in_local_traces_1 -let get_show_rule_names_in_local_traces = upgrade_from_reachability_map_field get_show_rule_names_in_local_traces_1 -let get_use_macrotransitions_in_local_traces = upgrade_from_reachability_map_field get_use_macrotransitions_in_local_traces_1 -let get_ignore_local_losanges = upgrade_from_reachability_map_field get_ignore_trivial_losanges_1 +let get_use_macrotransitions_in_local_traces = + upgrade_from_reachability_map_field get_use_macrotransitions_in_local_traces_1 + +let get_ignore_local_losanges = + upgrade_from_reachability_map_field get_ignore_trivial_losanges_1 let get_add_singular_macrostates = - upgrade_from_reachability_map_field - get_add_singular_macrostates_1 + upgrade_from_reachability_map_field get_add_singular_macrostates_1 + let get_add_singular_microstates = - upgrade_from_reachability_map_field - get_add_singular_microstates_1 -let get_local_trace_prefix = upgrade_from_reachability_map_field get_local_trace_prefix_1 -let get_local_trace_directory = upgrade_from_reachability_map_field get_local_trace_directory_1 + upgrade_from_reachability_map_field get_add_singular_microstates_1 + +let get_local_trace_prefix = + upgrade_from_reachability_map_field get_local_trace_prefix_1 +let get_local_trace_directory = + upgrade_from_reachability_map_field get_local_trace_directory_1 + +let get_view_analysis = + upgrade_from_reachability_analysis_parameters_field get_view_analysis_1 -let get_view_analysis = upgrade_from_reachability_analysis_parameters_field - get_view_analysis_1 let get_parallel_bonds_analysis = upgrade_from_reachability_analysis_parameters_field get_parallel_bonds_analysis_1 + let get_site_across_bonds_analysis = upgrade_from_reachability_analysis_parameters_field get_site_across_bonds_analysis_1 + let get_dynamic_contact_map = upgrade_from_reachability_analysis_parameters_field get_dynamic_contact_map_1 + let get_counters_analysis = -upgrade_from_reachability_analysis_parameters_field - get_counters_analysis_1 + upgrade_from_reachability_analysis_parameters_field get_counters_analysis_1 let get_counters_domain = - upgrade_from_reachability_analysis_parameters_field - get_counters_domain_1 + upgrade_from_reachability_analysis_parameters_field get_counters_domain_1 + let get_do_reachability_analysis p = upgrade_from_marshal_field get_do_reachability_analysis_1 p || get_compute_local_traces p let set_prefix_1 marshalisable prefix = - {marshalisable with Remanent_parameters_sig.prefix = prefix} + { marshalisable with Remanent_parameters_sig.prefix } + let set_call_stack_1 marshalisable call_stack = - {marshalisable with Remanent_parameters_sig.call_stack = call_stack} + { marshalisable with Remanent_parameters_sig.call_stack } + let set_trace_1 marshalisable bool = - {marshalisable with Remanent_parameters_sig.trace = bool} + { marshalisable with Remanent_parameters_sig.trace = bool } let upgrade_to_marshalisable f parameters prefix = - {parameters with + { + parameters with Remanent_parameters_sig.marshalisable_parameters = - f (get_marshalisable parameters) prefix} + f (get_marshalisable parameters) prefix; + } let set_prefix = upgrade_to_marshalisable set_prefix_1 let set_call_stack = upgrade_to_marshalisable set_call_stack_1 let set_trace = upgrade_to_marshalisable set_trace_1 let update_prefix parameters suffix = - set_prefix parameters ((get_prefix parameters)^suffix) + set_prefix parameters (get_prefix parameters ^ suffix) let update_call_stack parameters bool name = let rep_bool = get_trace parameters || bool in - match name,get_trace parameters=bool with - | None,true -> parameters - | None,false -> set_trace parameters rep_bool - | Some x,true -> set_call_stack parameters (x::(get_call_stack parameters)) - | Some x,false -> - set_call_stack - (set_trace parameters rep_bool) - (x::(get_call_stack parameters)) - -let open_influence_map_file parameters = + match name, get_trace parameters = bool with + | None, true -> parameters + | None, false -> set_trace parameters rep_bool + | Some x, true -> set_call_stack parameters (x :: get_call_stack parameters) + | Some x, false -> + set_call_stack + (set_trace parameters rep_bool) + (x :: get_call_stack parameters) + +let open_influence_map_file parameters = let channel = - match get_im_file parameters,get_im_directory parameters,ext_format (get_im_format parameters) + match + ( get_im_file parameters, + get_im_directory parameters, + ext_format (get_im_format parameters) ) with - | None,_,_ -> stdout - | Some a,None,ext -> open_out a ext - | Some a,Some d,ext -> open_out (d^a) ext + | None, _, _ -> stdout + | Some a, None, ext -> open_out a ext + | Some a, Some d, ext -> open_out (d ^ a) ext in let format = - match get_im_format parameters with - | Remanent_parameters_sig.DOT -> Loggers.DOT - | Remanent_parameters_sig.HTML -> Loggers.HTML_Graph - | Remanent_parameters_sig.DIM -> Loggers.Matrix - | Remanent_parameters_sig.GEPHI -> Loggers.GEPHI - in - let logger = Loggers.open_logger_from_channel ~mode:format channel + match get_im_format parameters with + | Remanent_parameters_sig.DOT -> Loggers.DOT + | Remanent_parameters_sig.HTML -> Loggers.HTML_Graph + | Remanent_parameters_sig.DIM -> Loggers.Matrix + | Remanent_parameters_sig.GEPHI -> Loggers.GEPHI in - {parameters with Remanent_parameters_sig.logger = logger} + let logger = Loggers.open_logger_from_channel ~mode:format channel in + { parameters with Remanent_parameters_sig.logger } let open_contact_map_file parameters = let channel = - match get_cm_file parameters,get_cm_directory parameters, - ext_format (get_cm_format parameters) + match + ( get_cm_file parameters, + get_cm_directory parameters, + ext_format (get_cm_format parameters) ) with - | None,_,_ -> stdout - | Some a,None,ext -> open_out a ext - | Some a,Some d,ext -> open_out (d^a) ext + | None, _, _ -> stdout + | Some a, None, ext -> open_out a ext + | Some a, Some d, ext -> open_out (d ^ a) ext in - { - parameters - with - Remanent_parameters_sig.logger = - Loggers.open_logger_from_channel channel} - - let persistent_mode = false + { + parameters with + Remanent_parameters_sig.logger = Loggers.open_logger_from_channel channel; + } - let lexical_analysis_of_tested_only_patterns_is_required_by_the_influence_map parameter = - (match - get_influence_map_accuracy_level parameter - with - | Remanent_parameters_sig.Full - | Remanent_parameters_sig.Medium - | Remanent_parameters_sig.High - | Remanent_parameters_sig.Low -> true - | Remanent_parameters_sig.None -> false ) - && - (get_do_influence_map parameter) - let lexical_analysis_of_tested_only_patterns_is_required_by_the_persistent_mode _ = - persistent_mode - let lexical_analysis_of_tested_only_patterns_is_required_by_the_contact_map parameter = - (get_do_contact_map parameter) - && (match get_contact_map_accuracy_level parameter with - | Remanent_parameters_sig.Medium | Remanent_parameters_sig.Low -> true - | Remanent_parameters_sig.None | Remanent_parameters_sig.High | Remanent_parameters_sig.Full-> false) - - let lexical_analysis_of_tested_only_patterns parameter = - lexical_analysis_of_tested_only_patterns_is_required_by_the_persistent_mode parameter - || lexical_analysis_of_tested_only_patterns_is_required_by_the_contact_map parameter - || lexical_analysis_of_tested_only_patterns_is_required_by_the_influence_map parameter - -let get_called_from parameter = parameter.Remanent_parameters_sig.marshalisable_parameters.Remanent_parameters_sig.called_from +let persistent_mode = false + +let lexical_analysis_of_tested_only_patterns_is_required_by_the_influence_map + parameter = + (match get_influence_map_accuracy_level parameter with + | Remanent_parameters_sig.Full | Remanent_parameters_sig.Medium + | Remanent_parameters_sig.High | Remanent_parameters_sig.Low -> + true + | Remanent_parameters_sig.None -> false) + && get_do_influence_map parameter + +let lexical_analysis_of_tested_only_patterns_is_required_by_the_persistent_mode + _ = + persistent_mode + +let lexical_analysis_of_tested_only_patterns_is_required_by_the_contact_map + parameter = + get_do_contact_map parameter + && + match get_contact_map_accuracy_level parameter with + | Remanent_parameters_sig.Medium | Remanent_parameters_sig.Low -> true + | Remanent_parameters_sig.None | Remanent_parameters_sig.High + | Remanent_parameters_sig.Full -> + false + +let lexical_analysis_of_tested_only_patterns parameter = + lexical_analysis_of_tested_only_patterns_is_required_by_the_persistent_mode + parameter + || lexical_analysis_of_tested_only_patterns_is_required_by_the_contact_map + parameter + || lexical_analysis_of_tested_only_patterns_is_required_by_the_influence_map + parameter + +let get_called_from parameter = + parameter.Remanent_parameters_sig.marshalisable_parameters + .Remanent_parameters_sig.called_from let get_backdoor_nbr_of_scc_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_nbr_of_scc + let get_backdoor_average_size_of_scc_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_average_size_of_scc let get_backdoor_nbr_of_influences_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_nbr_of_influences + let get_backdoor_nbr_of_constraints_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_nbr_of_constraints + let get_backdoor_nbr_of_nr_constraints_1 backdoors = - backdoors.Remanent_parameters_sig.backdoor_nbr_of_nr_constraints + backdoors.Remanent_parameters_sig.backdoor_nbr_of_nr_constraints + let get_backdoor_nbr_of_dead_rules_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_nbr_of_dead_rules + let get_backdoor_nbr_of_rules_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_nbr_of_rules -let get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions_1 backdoors = - backdoors.Remanent_parameters_sig.backdoor_nbr_of_rules_with_non_weakly_reversible_transitions + +let get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions_1 backdoors + = + backdoors + .Remanent_parameters_sig + .backdoor_nbr_of_rules_with_non_weakly_reversible_transitions + let get_backdoor_nbr_of_non_weakly_reversible_transitions_1 backdoors = - backdoors.Remanent_parameters_sig.backdoor_nbr_of_non_weakly_reversible_transitions + backdoors + .Remanent_parameters_sig.backdoor_nbr_of_non_weakly_reversible_transitions + let get_backdoor_timing_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_timing + let get_backdoor_file_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_file + let get_backdoor_directory_1 backdoors = backdoors.Remanent_parameters_sig.backdoor_directory let get_backdoors marshalisable = marshalisable.Remanent_parameters_sig.backdoors -let get_backdoor_nbr_of_scc_2 = - compose get_backdoor_nbr_of_scc_1 get_backdoors -let get_backdoor_average_size_of_scc_2 = +let get_backdoor_nbr_of_scc_2 = compose get_backdoor_nbr_of_scc_1 get_backdoors + +let get_backdoor_average_size_of_scc_2 = compose get_backdoor_average_size_of_scc_1 get_backdoors -let get_backdoor_nbr_of_constraints_2 = + +let get_backdoor_nbr_of_constraints_2 = compose get_backdoor_nbr_of_constraints_1 get_backdoors -let get_backdoor_nbr_of_nr_constraints_2 = + +let get_backdoor_nbr_of_nr_constraints_2 = compose get_backdoor_nbr_of_nr_constraints_1 get_backdoors -let get_backdoor_nbr_of_influences_2 = + +let get_backdoor_nbr_of_influences_2 = compose get_backdoor_nbr_of_influences_1 get_backdoors -let get_backdoor_nbr_of_dead_rules_2 = + +let get_backdoor_nbr_of_dead_rules_2 = compose get_backdoor_nbr_of_dead_rules_1 get_backdoors -let get_backdoor_nbr_of_rules_2 = - compose get_backdoor_nbr_of_rules_1 get_backdoors + +let get_backdoor_nbr_of_rules_2 = + compose get_backdoor_nbr_of_rules_1 get_backdoors + let get_backdoor_nbr_of_non_weakly_reversible_transitions_2 = compose get_backdoor_nbr_of_non_weakly_reversible_transitions_1 get_backdoors + let get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions_2 = - compose get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions_1 get_backdoors -let get_backdoor_timing_2 = - compose get_backdoor_timing_1 get_backdoors -let get_backdoor_file_2 = - compose get_backdoor_file_1 get_backdoors -let get_backdoor_directory_2 = - compose get_backdoor_directory_1 get_backdoors + compose get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions_1 + get_backdoors + +let get_backdoor_timing_2 = compose get_backdoor_timing_1 get_backdoors +let get_backdoor_file_2 = compose get_backdoor_file_1 get_backdoors +let get_backdoor_directory_2 = compose get_backdoor_directory_1 get_backdoors let get_backdoor_nbr_of_constraints = compose get_backdoor_nbr_of_constraints_2 get_marshalisable @@ -1155,39 +1394,49 @@ let get_backdoor_nbr_of_influences = compose get_backdoor_nbr_of_influences_2 get_marshalisable let get_backdoor_nbr_of_rules = - compose get_backdoor_nbr_of_rules_2 get_marshalisable + compose get_backdoor_nbr_of_rules_2 get_marshalisable + let get_backdoor_nbr_of_dead_rules = compose get_backdoor_nbr_of_dead_rules_2 get_marshalisable + let get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions = - compose get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions_2 get_marshalisable + compose get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions_2 + get_marshalisable + let get_backdoor_nbr_of_non_weakly_reversible_transitions = - compose get_backdoor_nbr_of_non_weakly_reversible_transitions_2 get_marshalisable -let get_backdoor_timing = - compose get_backdoor_timing_2 get_marshalisable -let get_backdoor_file = - compose get_backdoor_file_2 get_marshalisable -let get_backdoor_directory = - compose get_backdoor_directory_2 get_marshalisable + compose get_backdoor_nbr_of_non_weakly_reversible_transitions_2 + get_marshalisable +let get_backdoor_timing = compose get_backdoor_timing_2 get_marshalisable +let get_backdoor_file = compose get_backdoor_file_2 get_marshalisable +let get_backdoor_directory = compose get_backdoor_directory_2 get_marshalisable let get_profiler parameter = parameter.Remanent_parameters_sig.profiler + let get_compression_status_logger parameter = parameter.Remanent_parameters_sig.compression_status let get_kasa_state = compose get_kasa_state_1 get_marshalisable let set_print_efficiency parameter bool = - {parameter with Remanent_parameters_sig.print_efficiency = bool} + { parameter with Remanent_parameters_sig.print_efficiency = bool } + let get_print_efficiency parameter = parameter.Remanent_parameters_sig.print_efficiency - let set_logger parameter logger = - { parameter with Remanent_parameters_sig.logger = logger} + +let set_logger parameter logger = + { parameter with Remanent_parameters_sig.logger } + let save_error_list parameter error = parameter.Remanent_parameters_sig.save_error_list error + let save_progress_bar parameter bar = parameter.Remanent_parameters_sig.save_progress_bar bar + let reset_progress_bar parameter = parameter.Remanent_parameters_sig.reset_progress_bar + let save_current_phase_title parameter = parameter.Remanent_parameters_sig.save_current_phase_title + let reset_current_phase_title parameter = parameter.Remanent_parameters_sig.reset_current_phase_title diff --git a/core/parameters/remanent_parameters.mli b/core/parameters/remanent_parameters.mli index 4542de91d5..1b8d10453c 100644 --- a/core/parameters/remanent_parameters.mli +++ b/core/parameters/remanent_parameters.mli @@ -15,232 +15,410 @@ (** if unsafe = true, then whenever an exception is raised, a default value is output, and no exception is raised*) -val open_out: string -> string -> out_channel -val ext_format: Remanent_parameters_sig.graph_format -> string -val get_parameters: +val open_out : string -> string -> out_channel +val ext_format : Remanent_parameters_sig.graph_format -> string + +val get_parameters : ?html_mode:bool -> called_from:Remanent_parameters_sig.called_from -> - unit -> Remanent_parameters_sig.parameters - -val dummy_parameters: called_from:Remanent_parameters_sig.called_from -> unit -> Remanent_parameters_sig.parameters - -val get_called_from: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.called_from - -val get_logger: Remanent_parameters_sig.parameters -> Loggers.t -val get_logger_err: Remanent_parameters_sig.parameters -> Loggers.t -val get_logger_backdoor: Remanent_parameters_sig.parameters -> Loggers.t - -val get_command_line: Remanent_parameters_sig.parameters -> string array -val get_short_version: Remanent_parameters_sig.parameters -> string -val get_full_version: Remanent_parameters_sig.parameters -> string -val get_launched_when_and_where: Remanent_parameters_sig.parameters -> string -val get_syntax_version: Remanent_parameters_sig.parameters -> Ast.syntax_version - -val get_file: Remanent_parameters_sig.parameters -> string option - -val get_do_contact_map: Remanent_parameters_sig.parameters -> bool -val get_do_scc: Remanent_parameters_sig.parameters -> bool -val get_do_influence_map: Remanent_parameters_sig.parameters -> bool -val get_do_ODE_flow_of_information: Remanent_parameters_sig.parameters -> bool -val get_do_reachability_analysis: Remanent_parameters_sig.parameters -> bool -val get_do_stochastic_flow_of_information: Remanent_parameters_sig.parameters -> bool -val get_do_site_dependencies: Remanent_parameters_sig.parameters -> bool -val get_dump_site_dependencies: Remanent_parameters_sig.parameters -> bool - -val get_unsafe: Remanent_parameters_sig.parameters -> bool -val get_dump_error_as_soon_as_they_occur: Remanent_parameters_sig.parameters -> bool -val get_trace: Remanent_parameters_sig.parameters -> bool - -val get_prefix: Remanent_parameters_sig.parameters -> string -val set_logger: Remanent_parameters_sig.parameters -> Loggers.t -> Remanent_parameters_sig.parameters -val set_prefix: Remanent_parameters_sig.parameters -> string -> Remanent_parameters_sig.parameters -val get_link_mode: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.link_mode -val get_view_accuracy_level: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level -val get_influence_map_accuracy_level: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level -val get_contact_map_accuracy_level: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level -val get_cm_format: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.graph_format -val get_scc_accuracy_level: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level + unit -> + Remanent_parameters_sig.parameters + +val dummy_parameters : + called_from:Remanent_parameters_sig.called_from -> + unit -> + Remanent_parameters_sig.parameters + +val get_called_from : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.called_from + +val get_logger : Remanent_parameters_sig.parameters -> Loggers.t +val get_logger_err : Remanent_parameters_sig.parameters -> Loggers.t +val get_logger_backdoor : Remanent_parameters_sig.parameters -> Loggers.t +val get_command_line : Remanent_parameters_sig.parameters -> string array +val get_short_version : Remanent_parameters_sig.parameters -> string +val get_full_version : Remanent_parameters_sig.parameters -> string +val get_launched_when_and_where : Remanent_parameters_sig.parameters -> string + +val get_syntax_version : + Remanent_parameters_sig.parameters -> Ast.syntax_version + +val get_file : Remanent_parameters_sig.parameters -> string option +val get_do_contact_map : Remanent_parameters_sig.parameters -> bool +val get_do_scc : Remanent_parameters_sig.parameters -> bool +val get_do_influence_map : Remanent_parameters_sig.parameters -> bool +val get_do_ODE_flow_of_information : Remanent_parameters_sig.parameters -> bool +val get_do_reachability_analysis : Remanent_parameters_sig.parameters -> bool + +val get_do_stochastic_flow_of_information : + Remanent_parameters_sig.parameters -> bool + +val get_do_site_dependencies : Remanent_parameters_sig.parameters -> bool +val get_dump_site_dependencies : Remanent_parameters_sig.parameters -> bool +val get_unsafe : Remanent_parameters_sig.parameters -> bool + +val get_dump_error_as_soon_as_they_occur : + Remanent_parameters_sig.parameters -> bool + +val get_trace : Remanent_parameters_sig.parameters -> bool +val get_prefix : Remanent_parameters_sig.parameters -> string + +val set_logger : + Remanent_parameters_sig.parameters -> + Loggers.t -> + Remanent_parameters_sig.parameters + +val set_prefix : + Remanent_parameters_sig.parameters -> + string -> + Remanent_parameters_sig.parameters + +val get_link_mode : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.link_mode + +val get_view_accuracy_level : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level + +val get_influence_map_accuracy_level : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level + +val get_contact_map_accuracy_level : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level +val get_cm_format : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.graph_format + +val get_scc_accuracy_level : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.accuracy_level + +val get_btype_sep_symbol : Remanent_parameters_sig.parameters -> string (** Kappa pretty-printing *) -val get_btype_sep_symbol: Remanent_parameters_sig.parameters -> string -val get_bound_symbol: Remanent_parameters_sig.parameters -> string -val get_open_binding_state: Remanent_parameters_sig.parameters -> string -val get_close_binding_state: Remanent_parameters_sig.parameters -> string -val get_missing_binding_state: Remanent_parameters_sig.parameters -> string -val get_at_symbol: Remanent_parameters_sig.parameters -> string -val get_link_to_any: Remanent_parameters_sig.parameters -> string -val get_link_to_some: Remanent_parameters_sig.parameters -> string -val get_agent_open_symbol: Remanent_parameters_sig.parameters -> string -val get_agent_close_symbol: Remanent_parameters_sig.parameters -> string -val get_agent_sep_comma_symbol: Remanent_parameters_sig.parameters -> string -val get_agent_sep_plus_symbol: Remanent_parameters_sig.parameters -> string -val get_agent_sep_dot_symbol: Remanent_parameters_sig.parameters -> string -val get_site_sep_comma_symbol: Remanent_parameters_sig.parameters -> string -val get_ghost_agent_symbol: Remanent_parameters_sig.parameters -> string -val get_do_we_show_ghost: Remanent_parameters_sig.parameters -> bool -val get_internal_state_symbol: Remanent_parameters_sig.parameters -> string -val get_open_internal_state: Remanent_parameters_sig.parameters -> string -val get_close_internal_state: Remanent_parameters_sig.parameters -> string -val get_free_symbol: Remanent_parameters_sig.parameters -> string -val get_uni_arrow_symbol: Remanent_parameters_sig.parameters -> string -val get_rev_arrow_symbol: Remanent_parameters_sig.parameters -> string -val get_rev_arrow_no_poly_symbol: Remanent_parameters_sig.parameters -> string -val get_uni_arrow_no_poly_symbol: Remanent_parameters_sig.parameters -> string -val get_bi_arrow_symbol: Remanent_parameters_sig.parameters -> string -val get_bi_arrow_no_poly_symbol: Remanent_parameters_sig.parameters -> string -val get_open_counter_state: Remanent_parameters_sig.parameters -> string -val get_open_counterceq: Remanent_parameters_sig.parameters -> string -val get_open_countercvar: Remanent_parameters_sig.parameters -> string -val get_open_countercgte: Remanent_parameters_sig.parameters -> string -val get_open_counterval: Remanent_parameters_sig.parameters -> string -val get_close_counter_state: Remanent_parameters_sig.parameters -> string -val get_close_counterceq: Remanent_parameters_sig.parameters -> string -val get_close_countercvar: Remanent_parameters_sig.parameters -> string -val get_close_countercgte: Remanent_parameters_sig.parameters -> string -val get_close_counterval: Remanent_parameters_sig.parameters -> string -val get_counterceq_symbol: Remanent_parameters_sig.parameters -> string -val get_countercvar_symbol: Remanent_parameters_sig.parameters -> string -val get_countercgte_symbol: Remanent_parameters_sig.parameters -> string -val get_open_counterdelta: Remanent_parameters_sig.parameters -> string -val get_close_counterdelta: Remanent_parameters_sig.parameters -> string -val get_counterdeltaplus_symbol: Remanent_parameters_sig.parameters -> string -val get_counterdeltaminus_symbol: Remanent_parameters_sig.parameters -> string -val get_counterval_symbol: Remanent_parameters_sig.parameters -> string +val get_bound_symbol : Remanent_parameters_sig.parameters -> string +val get_open_binding_state : Remanent_parameters_sig.parameters -> string +val get_close_binding_state : Remanent_parameters_sig.parameters -> string +val get_missing_binding_state : Remanent_parameters_sig.parameters -> string +val get_at_symbol : Remanent_parameters_sig.parameters -> string +val get_link_to_any : Remanent_parameters_sig.parameters -> string +val get_link_to_some : Remanent_parameters_sig.parameters -> string +val get_agent_open_symbol : Remanent_parameters_sig.parameters -> string +val get_agent_close_symbol : Remanent_parameters_sig.parameters -> string +val get_agent_sep_comma_symbol : Remanent_parameters_sig.parameters -> string +val get_agent_sep_plus_symbol : Remanent_parameters_sig.parameters -> string +val get_agent_sep_dot_symbol : Remanent_parameters_sig.parameters -> string +val get_site_sep_comma_symbol : Remanent_parameters_sig.parameters -> string +val get_ghost_agent_symbol : Remanent_parameters_sig.parameters -> string +val get_do_we_show_ghost : Remanent_parameters_sig.parameters -> bool +val get_internal_state_symbol : Remanent_parameters_sig.parameters -> string +val get_open_internal_state : Remanent_parameters_sig.parameters -> string +val get_close_internal_state : Remanent_parameters_sig.parameters -> string +val get_free_symbol : Remanent_parameters_sig.parameters -> string +val get_uni_arrow_symbol : Remanent_parameters_sig.parameters -> string +val get_rev_arrow_symbol : Remanent_parameters_sig.parameters -> string +val get_rev_arrow_no_poly_symbol : Remanent_parameters_sig.parameters -> string +val get_uni_arrow_no_poly_symbol : Remanent_parameters_sig.parameters -> string +val get_bi_arrow_symbol : Remanent_parameters_sig.parameters -> string +val get_bi_arrow_no_poly_symbol : Remanent_parameters_sig.parameters -> string +val get_open_counter_state : Remanent_parameters_sig.parameters -> string +val get_open_counterceq : Remanent_parameters_sig.parameters -> string +val get_open_countercvar : Remanent_parameters_sig.parameters -> string +val get_open_countercgte : Remanent_parameters_sig.parameters -> string +val get_open_counterval : Remanent_parameters_sig.parameters -> string +val get_close_counter_state : Remanent_parameters_sig.parameters -> string +val get_close_counterceq : Remanent_parameters_sig.parameters -> string +val get_close_countercvar : Remanent_parameters_sig.parameters -> string +val get_close_countercgte : Remanent_parameters_sig.parameters -> string +val get_close_counterval : Remanent_parameters_sig.parameters -> string +val get_counterceq_symbol : Remanent_parameters_sig.parameters -> string +val get_countercvar_symbol : Remanent_parameters_sig.parameters -> string +val get_countercgte_symbol : Remanent_parameters_sig.parameters -> string +val get_open_counterdelta : Remanent_parameters_sig.parameters -> string +val get_close_counterdelta : Remanent_parameters_sig.parameters -> string +val get_counterdeltaplus_symbol : Remanent_parameters_sig.parameters -> string +val get_counterdeltaminus_symbol : Remanent_parameters_sig.parameters -> string +val get_counterval_symbol : Remanent_parameters_sig.parameters -> string + +val get_rule_shape : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape (** influence map *) -val get_rule_shape: Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape -val get_rule_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_link_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_variable_shape: Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape -val get_variable_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_influence_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_wake_up_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_inhibition_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_wake_up_arrow: Remanent_parameters_sig.parameters -> Graph_loggers_sig.headkind -val get_inhibition_arrow: Remanent_parameters_sig.parameters -> Graph_loggers_sig.headkind -val get_influence_arrow: Remanent_parameters_sig.parameters -> Graph_loggers_sig.headkind -val get_prompt_full_var_def: Remanent_parameters_sig.parameters -> bool -val get_prompt_full_rule_def: Remanent_parameters_sig.parameters -> bool -val get_make_labels_compatible_with_dot: Remanent_parameters_sig.parameters -> char list Remanent_parameters_sig.CharMap.t +val get_rule_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_link_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_variable_shape : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape + +val get_variable_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_influence_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_wake_up_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_inhibition_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_wake_up_arrow : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.headkind + +val get_inhibition_arrow : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.headkind + +val get_influence_arrow : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.headkind + +val get_prompt_full_var_def : Remanent_parameters_sig.parameters -> bool +val get_prompt_full_rule_def : Remanent_parameters_sig.parameters -> bool + +val get_make_labels_compatible_with_dot : + Remanent_parameters_sig.parameters -> + char list Remanent_parameters_sig.CharMap.t + +val get_pure_contact : Remanent_parameters_sig.parameters -> bool (** contact map *) -val get_pure_contact: Remanent_parameters_sig.parameters -> bool -val get_binding_site_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_binding_site_shape: Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape -val get_internal_site_shape: Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape -val get_internal_site_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_counter_site_shape: Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape -val get_counter_site_color: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_agent_shape_array: Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape option array +val get_binding_site_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color -val get_agent_color_array: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color option array -val get_agent_shape_def: Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape +val get_binding_site_shape : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape -val get_agent_color_def: Remanent_parameters_sig.parameters -> Graph_loggers_sig.color +val get_internal_site_shape : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape +val get_internal_site_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color +val get_counter_site_shape : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape + +val get_counter_site_color : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_agent_shape_array : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape option array + +val get_agent_color_array : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color option array + +val get_agent_shape_def : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.shape + +val get_agent_color_def : + Remanent_parameters_sig.parameters -> Graph_loggers_sig.color + +val get_dump_reachability_analysis_static : + Remanent_parameters_sig.parameters -> bool (** reachability analysis *) -val get_dump_reachability_analysis_static: Remanent_parameters_sig.parameters -> bool -val get_dump_reachability_analysis_dynamic: Remanent_parameters_sig.parameters -> bool -val get_dump_reachability_analysis_result: Remanent_parameters_sig.parameters -> bool -val get_dump_reachability_analysis_iteration: Remanent_parameters_sig.parameters -> bool -val get_dump_reachability_analysis_diff: Remanent_parameters_sig.parameters -> bool -val get_dump_reachability_analysis_wl: Remanent_parameters_sig.parameters -> bool + +val get_dump_reachability_analysis_dynamic : + Remanent_parameters_sig.parameters -> bool + +val get_dump_reachability_analysis_result : + Remanent_parameters_sig.parameters -> bool + +val get_dump_reachability_analysis_iteration : + Remanent_parameters_sig.parameters -> bool + +val get_dump_reachability_analysis_diff : + Remanent_parameters_sig.parameters -> bool + +val get_dump_reachability_analysis_wl : + Remanent_parameters_sig.parameters -> bool (*+ view analysis *) -val get_post_processing: Remanent_parameters_sig.parameters -> bool -val get_backend_mode: Remanent_parameters_sig.parameters -> +val get_post_processing : Remanent_parameters_sig.parameters -> bool + +val get_backend_mode : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.reachability_output -val get_hide_one_d_relations_from_cartesian_decomposition: Remanent_parameters_sig.parameters -> bool -val get_smash_relations: Remanent_parameters_sig.parameters -> bool - -val get_view_analysis: Remanent_parameters_sig.parameters -> bool -val get_site_across_bonds_analysis: Remanent_parameters_sig.parameters -> bool -val get_parallel_bonds_analysis: Remanent_parameters_sig.parameters -> bool -val get_dynamic_contact_map: Remanent_parameters_sig.parameters -> bool -val get_view_analysis_1: Remanent_parameters_sig.reachability_parameters-> bool -val get_counters_analysis: Remanent_parameters_sig.parameters -> bool -val get_counters_domain: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.counters_domain -val get_counters_analysis_1: Remanent_parameters_sig.reachability_parameters -> bool -val get_counters_domain_1: Remanent_parameters_sig.reachability_parameters -> Remanent_parameters_sig.counters_domain - -val get_reachability_analysis_parameters: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.reachability_parameters -val get_site_across_bonds_analysis_1: Remanent_parameters_sig.reachability_parameters -> bool -val get_parallel_bonds_analysis_1: Remanent_parameters_sig.reachability_parameters -> bool -val get_dynamic_contact_map_1: Remanent_parameters_sig.reachability_parameters -> bool -val get_reachability_parameters: unit -> Remanent_parameters_sig.reachability_parameters - -val get_hide_reverse_rule_without_label_from_dead_rules: Remanent_parameters_sig.parameters -> bool +val get_hide_one_d_relations_from_cartesian_decomposition : + Remanent_parameters_sig.parameters -> bool + +val get_smash_relations : Remanent_parameters_sig.parameters -> bool +val get_view_analysis : Remanent_parameters_sig.parameters -> bool +val get_site_across_bonds_analysis : Remanent_parameters_sig.parameters -> bool +val get_parallel_bonds_analysis : Remanent_parameters_sig.parameters -> bool +val get_dynamic_contact_map : Remanent_parameters_sig.parameters -> bool + +val get_view_analysis_1 : + Remanent_parameters_sig.reachability_parameters -> bool + +val get_counters_analysis : Remanent_parameters_sig.parameters -> bool + +val get_counters_domain : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.counters_domain + +val get_counters_analysis_1 : + Remanent_parameters_sig.reachability_parameters -> bool + +val get_counters_domain_1 : + Remanent_parameters_sig.reachability_parameters -> + Remanent_parameters_sig.counters_domain + +val get_reachability_analysis_parameters : + Remanent_parameters_sig.parameters -> + Remanent_parameters_sig.reachability_parameters + +val get_site_across_bonds_analysis_1 : + Remanent_parameters_sig.reachability_parameters -> bool + +val get_parallel_bonds_analysis_1 : + Remanent_parameters_sig.reachability_parameters -> bool + +val get_dynamic_contact_map_1 : + Remanent_parameters_sig.reachability_parameters -> bool + +val get_reachability_parameters : + unit -> Remanent_parameters_sig.reachability_parameters + +val get_hide_reverse_rule_without_label_from_dead_rules : + Remanent_parameters_sig.parameters -> bool + +val get_local_trace_format : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.graph_format (** local traces *) -val get_local_trace_format: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.graph_format -val get_compute_local_traces: Remanent_parameters_sig.parameters -> bool -val get_show_rule_names_in_local_traces: Remanent_parameters_sig.parameters -> bool -val get_use_macrotransitions_in_local_traces: Remanent_parameters_sig.parameters -> bool -val set_use_macrotransitions_in_local_traces: - Remanent_parameters_sig.parameters -> bool -> Remanent_parameters_sig.parameters -val get_ignore_local_losanges: Remanent_parameters_sig.parameters -> bool -val get_add_singular_macrostates: Remanent_parameters_sig.parameters -> bool -val get_add_singular_microstates: Remanent_parameters_sig.parameters -> bool -val get_local_trace_prefix: Remanent_parameters_sig.parameters -> string -val get_local_trace_directory: Remanent_parameters_sig.parameters -> string -val get_compute_separating_transitions: Remanent_parameters_sig.parameters -> bool -val set_compute_separating_transitions: Remanent_parameters_sig.parameters -> bool -> Remanent_parameters_sig.parameters - - -val get_compute_symmetries: Remanent_parameters_sig.parameters -> bool -val get_rate_convention: + +val get_compute_local_traces : Remanent_parameters_sig.parameters -> bool + +val get_show_rule_names_in_local_traces : + Remanent_parameters_sig.parameters -> bool + +val get_use_macrotransitions_in_local_traces : + Remanent_parameters_sig.parameters -> bool + +val set_use_macrotransitions_in_local_traces : + Remanent_parameters_sig.parameters -> + bool -> + Remanent_parameters_sig.parameters + +val get_ignore_local_losanges : Remanent_parameters_sig.parameters -> bool +val get_add_singular_macrostates : Remanent_parameters_sig.parameters -> bool +val get_add_singular_microstates : Remanent_parameters_sig.parameters -> bool +val get_local_trace_prefix : Remanent_parameters_sig.parameters -> string +val get_local_trace_directory : Remanent_parameters_sig.parameters -> string + +val get_compute_separating_transitions : + Remanent_parameters_sig.parameters -> bool + +val set_compute_separating_transitions : + Remanent_parameters_sig.parameters -> + bool -> + Remanent_parameters_sig.parameters + +val get_compute_symmetries : Remanent_parameters_sig.parameters -> bool + +val get_rate_convention : Remanent_parameters_sig.parameters -> Remanent_parameters_sig.rate_convention -val set_trace: Remanent_parameters_sig.parameters -> bool -> Remanent_parameters_sig.parameters -val update_prefix: Remanent_parameters_sig.parameters -> string -> Remanent_parameters_sig.parameters -val update_call_stack: + +val set_trace : + Remanent_parameters_sig.parameters -> + bool -> + Remanent_parameters_sig.parameters + +val update_prefix : + Remanent_parameters_sig.parameters -> + string -> + Remanent_parameters_sig.parameters + +val update_call_stack : Remanent_parameters_sig.parameters -> bool -> string option -> Remanent_parameters_sig.parameters -val get_print_efficiency: Remanent_parameters_sig.parameters -> bool -val set_print_efficiency: Remanent_parameters_sig.parameters -> bool -> Remanent_parameters_sig.parameters -val open_influence_map_file: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.parameters -val open_contact_map_file: Remanent_parameters_sig.parameters -> Remanent_parameters_sig.parameters +val get_print_efficiency : Remanent_parameters_sig.parameters -> bool -val lexical_analysis_of_tested_only_patterns: Remanent_parameters_sig.parameters -> bool -val get_profiler: Remanent_parameters_sig.parameters -> Loggers.t -val get_compression_status_logger: Remanent_parameters_sig.parameters -> Loggers.t -val save_error_list: Remanent_parameters_sig.parameters -> Exception_without_parameter.method_handler -> unit -val save_progress_bar: +val set_print_efficiency : Remanent_parameters_sig.parameters -> - bool * int * int * int -> + bool -> + Remanent_parameters_sig.parameters + +val open_influence_map_file : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.parameters + +val open_contact_map_file : + Remanent_parameters_sig.parameters -> Remanent_parameters_sig.parameters + +val lexical_analysis_of_tested_only_patterns : + Remanent_parameters_sig.parameters -> bool + +val get_profiler : Remanent_parameters_sig.parameters -> Loggers.t + +val get_compression_status_logger : + Remanent_parameters_sig.parameters -> Loggers.t + +val save_error_list : + Remanent_parameters_sig.parameters -> + Exception_without_parameter.method_handler -> unit -val reset_progress_bar: Remanent_parameters_sig.parameters -> unit -> unit -val save_current_phase_title: Remanent_parameters_sig.parameters -> string -> unit -val reset_current_phase_title: Remanent_parameters_sig.parameters -> unit -> unit - -val get_empty_hashtbl_size: Remanent_parameters_sig.parameters -> int - -val get_open_int_interval_inclusive_symbol: Remanent_parameters_sig.parameters -> string -val get_open_int_interval_exclusive_symbol: Remanent_parameters_sig.parameters -> string -val get_open_int_interval_infinity_symbol: Remanent_parameters_sig.parameters -> string -val get_close_int_interval_inclusive_symbol: Remanent_parameters_sig.parameters -> string -val get_close_int_interval_exclusive_symbol: Remanent_parameters_sig.parameters -> string -val get_close_int_interval_infinity_symbol: Remanent_parameters_sig.parameters -> string -val get_plus_infinity_symbol: Remanent_parameters_sig.parameters -> string -val get_minus_infinity_symbol: Remanent_parameters_sig.parameters -> string -val get_int_interval_separator_symbol: Remanent_parameters_sig.parameters -> string - -val get_backdoor_nbr_of_scc: Remanent_parameters_sig.parameters -> bool -val get_backdoor_average_size_of_scc: Remanent_parameters_sig.parameters -> bool -val get_backdoor_nbr_of_constraints: Remanent_parameters_sig.parameters -> bool -val get_backdoor_nbr_of_nr_constraints: Remanent_parameters_sig.parameters -> bool -val get_backdoor_nbr_of_influences: Remanent_parameters_sig.parameters -> bool -val get_backdoor_nbr_of_dead_rules: Remanent_parameters_sig.parameters -> bool -val get_backdoor_nbr_of_rules: Remanent_parameters_sig.parameters -> bool -val get_backdoor_nbr_of_non_weakly_reversible_transitions: Remanent_parameters_sig.parameters -> bool -val get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions: Remanent_parameters_sig.parameters -> bool -val get_backdoor_timing: Remanent_parameters_sig.parameters -> bool -val get_backdoor_file: Remanent_parameters_sig.parameters -> string -val get_backdoor_directory: Remanent_parameters_sig.parameters -> string - -val get_kasa_state: Remanent_parameters_sig.parameters -> - Remanent_state_signature.engine_state + +val save_progress_bar : + Remanent_parameters_sig.parameters -> bool * int * int * int -> unit + +val reset_progress_bar : Remanent_parameters_sig.parameters -> unit -> unit + +val save_current_phase_title : + Remanent_parameters_sig.parameters -> string -> unit + +val reset_current_phase_title : + Remanent_parameters_sig.parameters -> unit -> unit + +val get_empty_hashtbl_size : Remanent_parameters_sig.parameters -> int + +val get_open_int_interval_inclusive_symbol : + Remanent_parameters_sig.parameters -> string + +val get_open_int_interval_exclusive_symbol : + Remanent_parameters_sig.parameters -> string + +val get_open_int_interval_infinity_symbol : + Remanent_parameters_sig.parameters -> string + +val get_close_int_interval_inclusive_symbol : + Remanent_parameters_sig.parameters -> string + +val get_close_int_interval_exclusive_symbol : + Remanent_parameters_sig.parameters -> string + +val get_close_int_interval_infinity_symbol : + Remanent_parameters_sig.parameters -> string + +val get_plus_infinity_symbol : Remanent_parameters_sig.parameters -> string +val get_minus_infinity_symbol : Remanent_parameters_sig.parameters -> string + +val get_int_interval_separator_symbol : + Remanent_parameters_sig.parameters -> string + +val get_backdoor_nbr_of_scc : Remanent_parameters_sig.parameters -> bool + +val get_backdoor_average_size_of_scc : + Remanent_parameters_sig.parameters -> bool + +val get_backdoor_nbr_of_constraints : Remanent_parameters_sig.parameters -> bool + +val get_backdoor_nbr_of_nr_constraints : + Remanent_parameters_sig.parameters -> bool + +val get_backdoor_nbr_of_influences : Remanent_parameters_sig.parameters -> bool +val get_backdoor_nbr_of_dead_rules : Remanent_parameters_sig.parameters -> bool +val get_backdoor_nbr_of_rules : Remanent_parameters_sig.parameters -> bool + +val get_backdoor_nbr_of_non_weakly_reversible_transitions : + Remanent_parameters_sig.parameters -> bool + +val get_backdoor_nbr_of_rules_with_non_weakly_reversible_transitions : + Remanent_parameters_sig.parameters -> bool + +val get_backdoor_timing : Remanent_parameters_sig.parameters -> bool +val get_backdoor_file : Remanent_parameters_sig.parameters -> string +val get_backdoor_directory : Remanent_parameters_sig.parameters -> string + +val get_kasa_state : + Remanent_parameters_sig.parameters -> Remanent_state_signature.engine_state diff --git a/core/parameters/remanent_parameters_sig.ml b/core/parameters/remanent_parameters_sig.ml index 6f7dca0c7d..7996a986de 100644 --- a/core/parameters/remanent_parameters_sig.ml +++ b/core/parameters/remanent_parameters_sig.ml @@ -1,4 +1,4 @@ - (** +(** * parameters.ml * openkappa * Jérôme Feret, projet Abstraction/Antique, INRIA Paris-Rocquencourt @@ -21,166 +21,153 @@ type called_from = KaSa | KaSim | Internalised | Server type accuracy_level = None | Low | Medium | High | Full type link_mode = Bound_indices | Site_address | Bound_type type graph_format = DOT | HTML | DIM | GEPHI - type reachability_output = Raw | Natural_language | Kappa type counters_domain = Mi | Non_relational | Abstract_multiset | Octagons - type rate_convention = | No_correction | Divide_by_nbr_of_autos_in_lhs | Biochemist | Common - -type influence_map_output = - { - im_directory : string option ; - im_file : string option ; - im_format: graph_format ; - rule_shape : Graph_loggers_sig.shape ; - rule_color : Graph_loggers_sig.color ; - variable_shape : Graph_loggers_sig.shape ; - variable_color : Graph_loggers_sig.color ; - wake_up_color : Graph_loggers_sig.color ; - inhibition_color : Graph_loggers_sig.color ; - wake_up_arrow : Graph_loggers_sig.headkind ; - inhibition_arrow : Graph_loggers_sig.headkind ; - prompt_full_var_def: bool ; - prompt_full_rule_def: bool ; - make_labels_compatible: char list CharMap.t - } - -type contact_map_output = - { - cm_directory : string option ; - cm_file : string option ; - cm_format: graph_format ; - pure_contact : bool ; - binding_site_shape : Graph_loggers_sig.shape ; - binding_site_color : Graph_loggers_sig.color ; - internal_site_shape : Graph_loggers_sig.shape ; - internal_site_color : Graph_loggers_sig.color ; - counter_site_shape : Graph_loggers_sig.shape ; - counter_site_color : Graph_loggers_sig.color ; - agent_shape_array : Graph_loggers_sig.shape option array ; - agent_color_array : Graph_loggers_sig.color option array ; - agent_shape_def : Graph_loggers_sig.shape ; - agent_color_def : Graph_loggers_sig.color ; - link_color : Graph_loggers_sig.color ; - influence_color : Graph_loggers_sig.color ; - influence_arrow : Graph_loggers_sig.headkind ; - } - -type reachability_map_output = - { - dump_reachability_analysis_result : bool; - dump_reachability_analysis_covering_classes : bool; - dump_reachability_analysis_iteration : bool; - dump_reachability_analysis_static : bool; - dump_reachability_analysis_dynamic : bool; - dump_reachability_analysis_diff : bool; - dump_reachability_analysis_wl : bool; - hide_one_d_relations_from_cartesian_decomposition : bool; - smash_relations : bool; - compute_local_traces: bool; - show_rule_names_in_local_traces: bool; - format_for_local_traces: graph_format; - use_macrotransitions_in_local_traces: bool; - add_singular_macrostates: bool; - add_singular_microstates: bool; - ignore_trivial_losanges: bool; - use_natural_language : reachability_output ; - trace_prefix: string; - trace_directory: string; - compute_separating_transitions : bool; - hide_reverse_rule_without_label_from_dead_rules : bool ; - } - -type reachability_parameters = - { - views: bool ; - site_across_bonds: bool ; - parallel_bonds: bool ; - dynamic_contact_map: bool ; - counters: bool ; - counter_domain: counters_domain ; - } - -type backdoors = - { - backdoor_nbr_of_scc: bool; - backdoor_average_size_of_scc: bool; - backdoor_nbr_of_influences: bool; - backdoor_nbr_of_constraints: bool; - backdoor_nbr_of_nr_constraints: bool; - backdoor_nbr_of_dead_rules: bool; - backdoor_nbr_of_rules: bool; - backdoor_nbr_of_non_weakly_reversible_transitions: bool; - backdoor_nbr_of_rules_with_non_weakly_reversible_transitions: bool; - backdoor_timing: bool; - backdoor_file: string; - backdoor_directory: string; - } - -type marshalisable_parameters = - { - syntax_version: Ast.syntax_version ; - unsafe : bool ; - trace : bool ; - do_contact_map : bool ; - do_scc : bool ; - do_influence_map : bool ; - do_ODE_flow_of_information : bool ; - do_stochastic_flow_of_information : bool ; - do_site_dependencies : bool ; - do_symmetries_analysis : bool ; - rate_convention: rate_convention ; - dump_site_dependencies : bool ; - do_reachability_analysis : bool ; - called_from : called_from; - dump_error_as_soon_as_they_occur : bool ; - file : string option ; - prefix : string ; - call_stack : string list; - link_mode : link_mode ; - symbols : Symbol_table.symbol_table ; - influence_map_output : influence_map_output ; - contact_map_output : contact_map_output ; - reachability_analysis_parameters: reachability_parameters ; - reachability_map_output : reachability_map_output; - influence_map_accuracy_level: accuracy_level ; - contact_map_accuracy_level: accuracy_level ; - scc_accuracy_level: accuracy_level ; - view_accuracy_level: accuracy_level ; - kasa_state : Remanent_state_signature.engine_state ; - launching_date: Unix.tm ; - time_shift: int ; - hostname: string ; - command_line: string array ; - version: string ; - short_version: string ; - tk_interface : bool; - html_mode: bool ; - empty_hashtbl_size: int ; - backdoors: backdoors - } - - - - -type parameters = - { - logger_backdoor: Loggers.t; - logger: Loggers.t; - logger_err: Loggers.t; - profiler: Loggers.t; - compression_status: Loggers.t; - print_efficiency: bool; - save_error_list: Exception_without_parameter.method_handler -> unit; - save_progress_bar: (bool*int*int*int) -> unit; - reset_progress_bar: unit -> unit; - save_current_phase_title: string -> unit ; - reset_current_phase_title: unit -> unit ; - marshalisable_parameters : marshalisable_parameters; - } +type influence_map_output = { + im_directory: string option; + im_file: string option; + im_format: graph_format; + rule_shape: Graph_loggers_sig.shape; + rule_color: Graph_loggers_sig.color; + variable_shape: Graph_loggers_sig.shape; + variable_color: Graph_loggers_sig.color; + wake_up_color: Graph_loggers_sig.color; + inhibition_color: Graph_loggers_sig.color; + wake_up_arrow: Graph_loggers_sig.headkind; + inhibition_arrow: Graph_loggers_sig.headkind; + prompt_full_var_def: bool; + prompt_full_rule_def: bool; + make_labels_compatible: char list CharMap.t; +} + +type contact_map_output = { + cm_directory: string option; + cm_file: string option; + cm_format: graph_format; + pure_contact: bool; + binding_site_shape: Graph_loggers_sig.shape; + binding_site_color: Graph_loggers_sig.color; + internal_site_shape: Graph_loggers_sig.shape; + internal_site_color: Graph_loggers_sig.color; + counter_site_shape: Graph_loggers_sig.shape; + counter_site_color: Graph_loggers_sig.color; + agent_shape_array: Graph_loggers_sig.shape option array; + agent_color_array: Graph_loggers_sig.color option array; + agent_shape_def: Graph_loggers_sig.shape; + agent_color_def: Graph_loggers_sig.color; + link_color: Graph_loggers_sig.color; + influence_color: Graph_loggers_sig.color; + influence_arrow: Graph_loggers_sig.headkind; +} + +type reachability_map_output = { + dump_reachability_analysis_result: bool; + dump_reachability_analysis_covering_classes: bool; + dump_reachability_analysis_iteration: bool; + dump_reachability_analysis_static: bool; + dump_reachability_analysis_dynamic: bool; + dump_reachability_analysis_diff: bool; + dump_reachability_analysis_wl: bool; + hide_one_d_relations_from_cartesian_decomposition: bool; + smash_relations: bool; + compute_local_traces: bool; + show_rule_names_in_local_traces: bool; + format_for_local_traces: graph_format; + use_macrotransitions_in_local_traces: bool; + add_singular_macrostates: bool; + add_singular_microstates: bool; + ignore_trivial_losanges: bool; + use_natural_language: reachability_output; + trace_prefix: string; + trace_directory: string; + compute_separating_transitions: bool; + hide_reverse_rule_without_label_from_dead_rules: bool; +} + +type reachability_parameters = { + views: bool; + site_across_bonds: bool; + parallel_bonds: bool; + dynamic_contact_map: bool; + counters: bool; + counter_domain: counters_domain; +} + +type backdoors = { + backdoor_nbr_of_scc: bool; + backdoor_average_size_of_scc: bool; + backdoor_nbr_of_influences: bool; + backdoor_nbr_of_constraints: bool; + backdoor_nbr_of_nr_constraints: bool; + backdoor_nbr_of_dead_rules: bool; + backdoor_nbr_of_rules: bool; + backdoor_nbr_of_non_weakly_reversible_transitions: bool; + backdoor_nbr_of_rules_with_non_weakly_reversible_transitions: bool; + backdoor_timing: bool; + backdoor_file: string; + backdoor_directory: string; +} + +type marshalisable_parameters = { + syntax_version: Ast.syntax_version; + unsafe: bool; + trace: bool; + do_contact_map: bool; + do_scc: bool; + do_influence_map: bool; + do_ODE_flow_of_information: bool; + do_stochastic_flow_of_information: bool; + do_site_dependencies: bool; + do_symmetries_analysis: bool; + rate_convention: rate_convention; + dump_site_dependencies: bool; + do_reachability_analysis: bool; + called_from: called_from; + dump_error_as_soon_as_they_occur: bool; + file: string option; + prefix: string; + call_stack: string list; + link_mode: link_mode; + symbols: Symbol_table.symbol_table; + influence_map_output: influence_map_output; + contact_map_output: contact_map_output; + reachability_analysis_parameters: reachability_parameters; + reachability_map_output: reachability_map_output; + influence_map_accuracy_level: accuracy_level; + contact_map_accuracy_level: accuracy_level; + scc_accuracy_level: accuracy_level; + view_accuracy_level: accuracy_level; + kasa_state: Remanent_state_signature.engine_state; + launching_date: Unix.tm; + time_shift: int; + hostname: string; + command_line: string array; + version: string; + short_version: string; + tk_interface: bool; + html_mode: bool; + empty_hashtbl_size: int; + backdoors: backdoors; +} + +type parameters = { + logger_backdoor: Loggers.t; + logger: Loggers.t; + logger_err: Loggers.t; + profiler: Loggers.t; + compression_status: Loggers.t; + print_efficiency: bool; + save_error_list: Exception_without_parameter.method_handler -> unit; + save_progress_bar: bool * int * int * int -> unit; + reset_progress_bar: unit -> unit; + save_current_phase_title: string -> unit; + reset_current_phase_title: unit -> unit; + marshalisable_parameters: marshalisable_parameters; +} diff --git a/core/parameters/remanent_state_signature.ml b/core/parameters/remanent_state_signature.ml index 1009a84741..799d1eefc5 100644 --- a/core/parameters/remanent_state_signature.ml +++ b/core/parameters/remanent_state_signature.ml @@ -14,16 +14,10 @@ type rule_key = int -type engine_state = - { - command_line : string option; - wake_up_map : (rule_key -> rule_key list) option; - } - -let empty_engine_state = - { - command_line = None ; - wake_up_map = None ; - } +type engine_state = { + command_line: string option; + wake_up_map: (rule_key -> rule_key list) option; +} +let empty_engine_state = { command_line = None; wake_up_map = None } let wake_up_map error engine_state = error, engine_state.wake_up_map diff --git a/core/parameters/symbol_table.ml b/core/parameters/symbol_table.ml index b28be166c6..4080403294 100644 --- a/core/parameters/symbol_table.ml +++ b/core/parameters/symbol_table.ml @@ -1,71 +1,68 @@ -type break_hint = - Space | No_space +type break_hint = Space | No_space - -type symbol_table = - { - agent_open : string ; - agent_close : string ; - agent_sep_comma : string * break_hint ; - agent_sep_dot : string * break_hint ; - agent_sep_plus : string * break_hint ; - ghost_agent : string ; - show_ghost : bool ; - internal_state_symbol : string; - open_internal_state : string; - close_internal_state : string; - open_internal_state_mod : string; - close_internal_state_mod : string; - internal_state_mod_symbol: string; - internal_state_any: string; - open_binding_state : string; - close_binding_state : string; - missing_binding_state : string; - open_binding_state_mod: string; - binding_state_mod_symbol: string; - close_binding_state_mod: string; - free : string; - bound : string; - link_to_any : string; - link_to_some : string; - at : string ; - site_sep : string * break_hint; - btype_sep : string ; - uni_arrow : string ; - rev_arrow : string ; - bi_arrow : string ; - uni_arrow_nopoly : string ; - rev_arrow_nopoly : string ; - bi_arrow_nopoly : string ; - breakable : bool ; - open_int_interval_inclusive : string ; - open_int_interval_exclusive : string ; - open_int_interval_infinity : string ; - close_int_interval_inclusive : string ; - close_int_interval_exclusive : string ; - close_int_interval_infinity : string ; - int_interval_separator : string ; - plus_infinity : string ; - minus_infinity : string ; - open_counter_state : string ; - open_counterceq: string ; - open_countercgte: string ; - open_countercvar: string ; - open_counterdelta: string; - open_counterval: string ; - close_counter_state: string; - close_counterceq: string ; - close_countercgte: string ; - close_countercvar: string ; - close_counterdelta: string ; - close_counterval: string ; - counterceq_symbol: string ; - countercgte_symbol: string ; - countercvar_symbol: string ; - counterdeltaplus_symbol: string ; - counterdeltaminus_symbol: string ; - counterval_symbol: string ; - } +type symbol_table = { + agent_open: string; + agent_close: string; + agent_sep_comma: string * break_hint; + agent_sep_dot: string * break_hint; + agent_sep_plus: string * break_hint; + ghost_agent: string; + show_ghost: bool; + internal_state_symbol: string; + open_internal_state: string; + close_internal_state: string; + open_internal_state_mod: string; + close_internal_state_mod: string; + internal_state_mod_symbol: string; + internal_state_any: string; + open_binding_state: string; + close_binding_state: string; + missing_binding_state: string; + open_binding_state_mod: string; + binding_state_mod_symbol: string; + close_binding_state_mod: string; + free: string; + bound: string; + link_to_any: string; + link_to_some: string; + at: string; + site_sep: string * break_hint; + btype_sep: string; + uni_arrow: string; + rev_arrow: string; + bi_arrow: string; + uni_arrow_nopoly: string; + rev_arrow_nopoly: string; + bi_arrow_nopoly: string; + breakable: bool; + open_int_interval_inclusive: string; + open_int_interval_exclusive: string; + open_int_interval_infinity: string; + close_int_interval_inclusive: string; + close_int_interval_exclusive: string; + close_int_interval_infinity: string; + int_interval_separator: string; + plus_infinity: string; + minus_infinity: string; + open_counter_state: string; + open_counterceq: string; + open_countercgte: string; + open_countercvar: string; + open_counterdelta: string; + open_counterval: string; + close_counter_state: string; + close_counterceq: string; + close_countercgte: string; + close_countercvar: string; + close_counterdelta: string; + close_counterval: string; + counterceq_symbol: string; + countercgte_symbol: string; + countercvar_symbol: string; + counterdeltaplus_symbol: string; + counterdeltaminus_symbol: string; + counterval_symbol: string; +} let symbol_table_V3 = { @@ -86,31 +83,31 @@ let symbol_table_V3 = close_binding_state_mod = ""; binding_state_mod_symbol = ""; free = ""; - at = "." ; - agent_open = "(" ; - agent_close = ")" ; - agent_sep_comma = (",",Space) ; - agent_sep_plus = (",",Space) ; - agent_sep_dot = (",",Space) ; + at = "."; + agent_open = "("; + agent_close = ")"; + agent_sep_comma = ",", Space; + agent_sep_plus = ",", Space; + agent_sep_dot = ",", Space; btype_sep = "."; - site_sep = (",",No_space) ; - ghost_agent = "." ; - show_ghost = false ; - uni_arrow = "->" ; - rev_arrow = "<-" ; - bi_arrow = "<->" ; - uni_arrow_nopoly = "-!->" ; - rev_arrow_nopoly = "<-!-" ; - bi_arrow_nopoly = "<-!->" ; - breakable = true ; - open_int_interval_inclusive = "[" ; - open_int_interval_exclusive = "]" ; - open_int_interval_infinity = "]" ; - plus_infinity = "+oo" ; - minus_infinity = "-oo" ; - close_int_interval_inclusive = "]" ; - close_int_interval_exclusive = "[" ; - close_int_interval_infinity = "[" ; + site_sep = ",", No_space; + ghost_agent = "."; + show_ghost = false; + uni_arrow = "->"; + rev_arrow = "<-"; + bi_arrow = "<->"; + uni_arrow_nopoly = "-!->"; + rev_arrow_nopoly = "<-!-"; + bi_arrow_nopoly = "<-!->"; + breakable = true; + open_int_interval_inclusive = "["; + open_int_interval_exclusive = "]"; + open_int_interval_infinity = "]"; + plus_infinity = "+oo"; + minus_infinity = "-oo"; + close_int_interval_inclusive = "]"; + close_int_interval_exclusive = "["; + close_int_interval_infinity = "["; int_interval_separator = " .. "; open_counter_state = "{"; open_counterceq = ""; @@ -133,16 +130,13 @@ let symbol_table_V3 = } let lighten symbol_table = - { - symbol_table with - site_sep = " ",snd symbol_table.site_sep - } + { symbol_table with site_sep = " ", snd symbol_table.site_sep } let to_dotnet symbol_table = { symbol_table with - agent_sep_plus = " +",snd symbol_table.agent_sep_plus ; - agent_sep_dot = ".",No_space + agent_sep_plus = " +", snd symbol_table.agent_sep_plus; + agent_sep_dot = ".", No_space; } let symbol_table_V4 = @@ -164,39 +158,39 @@ let symbol_table_V4 = close_binding_state_mod = ""; binding_state_mod_symbol = ""; free = "."; - at = "." ; - agent_open = "(" ; - agent_close = ")" ; - agent_sep_comma = (",",Space) ; - agent_sep_plus = (",",Space) ; - agent_sep_dot = (",",Space) ; + at = "."; + agent_open = "("; + agent_close = ")"; + agent_sep_comma = ",", Space; + agent_sep_plus = ",", Space; + agent_sep_dot = ",", Space; btype_sep = "."; - site_sep = (",",No_space) ; - ghost_agent = "." ; - show_ghost = true ; - uni_arrow = "->" ; - rev_arrow = "<-" ; - bi_arrow = "<->" ; - uni_arrow_nopoly = "-!->" ; - rev_arrow_nopoly = "<-!-" ; - bi_arrow_nopoly = "<-!->" ; - breakable = true ; - open_int_interval_inclusive = "[" ; - open_int_interval_exclusive = "]" ; - open_int_interval_infinity = "]" ; - plus_infinity = "+oo" ; - minus_infinity = "-oo" ; - open_counter_state = "{" ; - close_int_interval_inclusive = "]" ; - close_int_interval_exclusive = "[" ; - close_int_interval_infinity = "[" ; - int_interval_separator = " .. " ; + site_sep = ",", No_space; + ghost_agent = "."; + show_ghost = true; + uni_arrow = "->"; + rev_arrow = "<-"; + bi_arrow = "<->"; + uni_arrow_nopoly = "-!->"; + rev_arrow_nopoly = "<-!-"; + bi_arrow_nopoly = "<-!->"; + breakable = true; + open_int_interval_inclusive = "["; + open_int_interval_exclusive = "]"; + open_int_interval_infinity = "]"; + plus_infinity = "+oo"; + minus_infinity = "-oo"; + open_counter_state = "{"; + close_int_interval_inclusive = "]"; + close_int_interval_exclusive = "["; + close_int_interval_infinity = "["; + int_interval_separator = " .. "; open_counterceq = ""; open_countercgte = ""; open_countercvar = ""; open_counterdelta = ""; open_counterval = ""; - close_counter_state = "}" ; + close_counter_state = "}"; close_counterceq = ""; close_countercgte = ""; close_countercvar = ""; @@ -208,22 +202,19 @@ let symbol_table_V4 = counterval_symbol = ":="; counterdeltaplus_symbol = "+"; counterdeltaminus_symbol = "-"; - } -let not_breakable symbol_table = {symbol_table with breakable = false} - +let not_breakable symbol_table = { symbol_table with breakable = false } let symbol_table_V3_light = lighten symbol_table_V3 let symbol_table_dotnet = to_dotnet symbol_table_V3 let unbreakable_symbol_table_V3 = not_breakable symbol_table_V3 let unbreakable_symbol_table_V4 = not_breakable symbol_table_V4 - let unbreakable_symbol_table_V3_light = not_breakable symbol_table_V3_light let unbreakable_symbol_table_dotnet = not_breakable symbol_table_dotnet let with_dot_and_plus symbol_table = - {symbol_table - with - agent_sep_plus = unbreakable_symbol_table_dotnet.agent_sep_plus ; - agent_sep_dot = unbreakable_symbol_table_dotnet.agent_sep_dot ; + { + symbol_table with + agent_sep_plus = unbreakable_symbol_table_dotnet.agent_sep_plus; + agent_sep_dot = unbreakable_symbol_table_dotnet.agent_sep_dot; } diff --git a/core/parameters/symbol_table.mli b/core/parameters/symbol_table.mli index 0525562a36..1671803aab 100644 --- a/core/parameters/symbol_table.mli +++ b/core/parameters/symbol_table.mli @@ -1,78 +1,75 @@ -type break_hint = - Space | No_space +type break_hint = Space | No_space - type symbol_table = - { - agent_open : string ; - agent_close : string ; - agent_sep_comma : string * break_hint ; - agent_sep_dot : string * break_hint ; - agent_sep_plus : string * break_hint ; - ghost_agent : string ; - show_ghost : bool ; - internal_state_symbol : string; - open_internal_state : string; - close_internal_state : string; - open_internal_state_mod : string; - close_internal_state_mod : string; - internal_state_mod_symbol: string; - internal_state_any: string; - open_binding_state : string; - close_binding_state : string; - missing_binding_state : string; - open_binding_state_mod: string; - binding_state_mod_symbol: string; - close_binding_state_mod: string; - free : string; - bound : string; - link_to_any : string; - link_to_some : string; - at : string ; - site_sep : string * break_hint; - btype_sep : string ; - uni_arrow : string ; - rev_arrow : string ; - bi_arrow : string ; - uni_arrow_nopoly : string ; - rev_arrow_nopoly : string ; - bi_arrow_nopoly : string ; - breakable : bool ; - open_int_interval_inclusive : string ; - open_int_interval_exclusive : string ; - open_int_interval_infinity : string ; - close_int_interval_inclusive : string ; - close_int_interval_exclusive : string ; - close_int_interval_infinity : string ; - int_interval_separator : string ; - plus_infinity : string ; - minus_infinity : string ; - open_counter_state : string ; - open_counterceq: string ; - open_countercgte: string ; - open_countercvar: string ; - open_counterdelta: string ; - open_counterval: string ; - close_counter_state : string ; - close_counterceq: string ; - close_countercgte: string ; - close_countercvar: string ; - close_counterdelta: string ; - close_counterval: string ; - counterceq_symbol: string ; - countercgte_symbol: string ; - countercvar_symbol: string ; - counterdeltaplus_symbol: string ; - counterdeltaminus_symbol: string ; - counterval_symbol: string ; - } +type symbol_table = { + agent_open: string; + agent_close: string; + agent_sep_comma: string * break_hint; + agent_sep_dot: string * break_hint; + agent_sep_plus: string * break_hint; + ghost_agent: string; + show_ghost: bool; + internal_state_symbol: string; + open_internal_state: string; + close_internal_state: string; + open_internal_state_mod: string; + close_internal_state_mod: string; + internal_state_mod_symbol: string; + internal_state_any: string; + open_binding_state: string; + close_binding_state: string; + missing_binding_state: string; + open_binding_state_mod: string; + binding_state_mod_symbol: string; + close_binding_state_mod: string; + free: string; + bound: string; + link_to_any: string; + link_to_some: string; + at: string; + site_sep: string * break_hint; + btype_sep: string; + uni_arrow: string; + rev_arrow: string; + bi_arrow: string; + uni_arrow_nopoly: string; + rev_arrow_nopoly: string; + bi_arrow_nopoly: string; + breakable: bool; + open_int_interval_inclusive: string; + open_int_interval_exclusive: string; + open_int_interval_infinity: string; + close_int_interval_inclusive: string; + close_int_interval_exclusive: string; + close_int_interval_infinity: string; + int_interval_separator: string; + plus_infinity: string; + minus_infinity: string; + open_counter_state: string; + open_counterceq: string; + open_countercgte: string; + open_countercvar: string; + open_counterdelta: string; + open_counterval: string; + close_counter_state: string; + close_counterceq: string; + close_countercgte: string; + close_countercvar: string; + close_counterdelta: string; + close_counterval: string; + counterceq_symbol: string; + countercgte_symbol: string; + countercvar_symbol: string; + counterdeltaplus_symbol: string; + counterdeltaminus_symbol: string; + counterval_symbol: string; +} -val symbol_table_V4: symbol_table -val symbol_table_V3: symbol_table -val symbol_table_V3_light: symbol_table -val symbol_table_dotnet: symbol_table -val unbreakable_symbol_table_V4: symbol_table -val unbreakable_symbol_table_V3: symbol_table -val unbreakable_symbol_table_V3_light: symbol_table -val unbreakable_symbol_table_dotnet: symbol_table - -val with_dot_and_plus: symbol_table -> symbol_table +val symbol_table_V4 : symbol_table +val symbol_table_V3 : symbol_table +val symbol_table_V3_light : symbol_table +val symbol_table_dotnet : symbol_table +val unbreakable_symbol_table_V4 : symbol_table +val unbreakable_symbol_table_V3 : symbol_table +val unbreakable_symbol_table_V3_light : symbol_table +val unbreakable_symbol_table_dotnet : symbol_table +val with_dot_and_plus : symbol_table -> symbol_table diff --git a/core/profiling/dune b/core/profiling/dune index f021c6cd44..4b31924b7d 100644 --- a/core/profiling/dune +++ b/core/profiling/dune @@ -1,7 +1,5 @@ (library - (name kappa_profiling) - (libraries yojson result kappa_logging kappa_parameters kappa_errors) - (flags (:standard - -open Kappa_logging - -open Kappa_parameters - -open Kappa_errors ))) + (name kappa_profiling) + (libraries yojson result kappa_logging kappa_parameters kappa_errors) + (flags + (:standard -open Kappa_logging -open Kappa_parameters -open Kappa_errors))) diff --git a/core/profiling/storyProfiling.ml b/core/profiling/storyProfiling.ml index 21139c04e1..6bf0d76f3c 100644 --- a/core/profiling/storyProfiling.ml +++ b/core/profiling/storyProfiling.ml @@ -63,611 +63,650 @@ type step_kind = | LKappa_signature let string_of_step_kind x = - match - x - with - | Dummy - | Beginning -> "" - | Build_configuration -> "Build configuration" - | Collect_traces -> "Collect traces" - | Causal_compression -> "Causal compression" - | Weak_compression -> "Weak compression" - | Strong_compression -> "Strong compression" - | Iteration int -> Printf.sprintf "Iteration %i" int - | Story int -> Printf.sprintf "Story %i" int - | Partial_order_reduction -> "Partial order reduction" - | Siphon_detection -> "Detection of siphons" - | Decompose_initial_state -> "Splitting initial states" - | Agent_ids_disambiguation -> "Renaming agents to avoid conflicts" - | Pseudo_inverse_deletion -> "Deletion of pseudo inverse events" - | Remove_events_after_last_observable -> "Removing events after the last observables" - | Compression -> "Compression" - | Transitive_closure -> "Transitive closure" - | Build_grid -> "Grid computation" - | Graph_reduction -> "Transitive reduction" - | Graph_conversion -> "Graph conversion" - | Cannonic_form_computation -> "Computing the cannonic form" - | Store_trace -> "Store trace" - | Removing_blacklisted_events -> "Removing black-listed events" - | Blacklisting_events -> "Blaklisting events" - | Global_initialization -> "Global initialization" - | Domains_initialization -> "Domains initialization" - | Domain_initialization string -> Printf.sprintf "Domain initialization (%s)" string - | Apply_rule int -> Printf.sprintf "Apply rule %i" int - | Initial_state int -> Printf.sprintf "Initial state %i" int - | Scan_rule_static int -> Printf.sprintf "Scan rule %i (static)" int - | Scan_rule_dynamic int -> Printf.sprintf "Scan rule %i (dynamic)" int - | Regular_influences -> Printf.sprintf "Regular influences computation" - | Side_effects_influences -> Printf.sprintf "Side-effects influences computation" - | Merge_influences -> Printf.sprintf "Merging influences" - | KaSim_compilation -> Printf.sprintf "KaSim frontend" - | KaSa_precompilation -> Printf.sprintf "KaSa precompilation" - | KaSa_lexing -> Printf.sprintf "KaSa Lexing" - | KaSa_linking -> Printf.sprintf "KaSa Linking" - | Influence_map string -> Printf.sprintf "Influence map (%s)" string - | Internal_influence_map string -> Printf.sprintf "Influence map (internal %s)" string - | LKappa_signature -> Printf.sprintf "LKappa signature" + match x with + | Dummy | Beginning -> "" + | Build_configuration -> "Build configuration" + | Collect_traces -> "Collect traces" + | Causal_compression -> "Causal compression" + | Weak_compression -> "Weak compression" + | Strong_compression -> "Strong compression" + | Iteration int -> Printf.sprintf "Iteration %i" int + | Story int -> Printf.sprintf "Story %i" int + | Partial_order_reduction -> "Partial order reduction" + | Siphon_detection -> "Detection of siphons" + | Decompose_initial_state -> "Splitting initial states" + | Agent_ids_disambiguation -> "Renaming agents to avoid conflicts" + | Pseudo_inverse_deletion -> "Deletion of pseudo inverse events" + | Remove_events_after_last_observable -> + "Removing events after the last observables" + | Compression -> "Compression" + | Transitive_closure -> "Transitive closure" + | Build_grid -> "Grid computation" + | Graph_reduction -> "Transitive reduction" + | Graph_conversion -> "Graph conversion" + | Cannonic_form_computation -> "Computing the cannonic form" + | Store_trace -> "Store trace" + | Removing_blacklisted_events -> "Removing black-listed events" + | Blacklisting_events -> "Blaklisting events" + | Global_initialization -> "Global initialization" + | Domains_initialization -> "Domains initialization" + | Domain_initialization string -> + Printf.sprintf "Domain initialization (%s)" string + | Apply_rule int -> Printf.sprintf "Apply rule %i" int + | Initial_state int -> Printf.sprintf "Initial state %i" int + | Scan_rule_static int -> Printf.sprintf "Scan rule %i (static)" int + | Scan_rule_dynamic int -> Printf.sprintf "Scan rule %i (dynamic)" int + | Regular_influences -> Printf.sprintf "Regular influences computation" + | Side_effects_influences -> + Printf.sprintf "Side-effects influences computation" + | Merge_influences -> Printf.sprintf "Merging influences" + | KaSim_compilation -> Printf.sprintf "KaSim frontend" + | KaSa_precompilation -> Printf.sprintf "KaSa precompilation" + | KaSa_lexing -> Printf.sprintf "KaSa Lexing" + | KaSa_linking -> Printf.sprintf "KaSa Linking" + | Influence_map string -> Printf.sprintf "Influence map (%s)" string + | Internal_influence_map string -> + Printf.sprintf "Influence map (internal %s)" string + | LKappa_signature -> Printf.sprintf "LKappa signature" let print_step_kind parameters x = - Loggers.print_cell (Remanent_parameters.get_profiler parameters) + Loggers.print_cell + (Remanent_parameters.get_profiler parameters) (string_of_step_kind x) -module type StoryStats = - sig - type log_info - - val inc_removed_events: log_info -> log_info - val inc_selected_events: log_info -> log_info - val log_info_to_json: log_info -> Yojson.Basic.t - val log_info_of_json: Yojson.Basic.t -> log_info - val inc_cut_events: log_info -> log_info - val inc_k_cut_events: int -> log_info -> log_info - val reset_cut_events: log_info -> log_info - val inc_n_kasim_events: log_info -> log_info - val inc_n_init_events: log_info -> log_info - val inc_n_side_events: log_info -> log_info - val inc_n_obs_events: log_info -> log_info - val inc_branch: log_info -> log_info - val inc_cut: log_info -> log_info - val reset_log: log_info -> log_info - val dump_complete_log: Remanent_parameters_sig.parameters -> log_info -> unit - val dump_short_log: Remanent_parameters_sig.parameters -> log_info -> unit - val add_propagation_case_up: int -> log_info -> log_info - val add_propagation_case_down: int -> log_info -> log_info - val add_look_up_case: int -> log_info -> log_info - val add_look_down_case: int -> log_info -> log_info - - val copy: log_info -> log_info - - val is_dummy: step_kind -> bool - val add_event: Remanent_parameters_sig.parameters -> Exception.method_handler -> step_kind -> (unit -> int) option -> log_info -> Exception.method_handler * log_info - val close_event: Remanent_parameters_sig.parameters -> Exception.method_handler -> step_kind -> (unit -> int) option -> log_info -> Exception.method_handler * log_info - val add_event_opt: Remanent_parameters_sig.parameters -> Exception.method_handler -> step_kind option -> (unit -> int) option -> log_info -> Exception.method_handler * log_info - val close_event_opt: Remanent_parameters_sig.parameters -> Exception.method_handler -> step_kind option -> (unit -> int) option -> log_info -> Exception.method_handler * log_info - - val set_time: log_info -> log_info - val set_step_time: log_info -> log_info - val set_global_cut: int -> log_info -> log_info - val set_pseudo_inv: int -> log_info -> log_info - val set_start_compression: log_info -> log_info - val set_grid_generation: log_info -> log_info - val set_canonicalisation: log_info -> log_info - val set_concurrent_event_detection_time : log_info -> log_info - val set_concurrent_event_deletion_time : log_info -> log_info - val set_story_research_time: log_info -> log_info - val ellapsed_global_time: log_info -> float - val ellapsed_time: log_info -> float - val init_log_info: unit -> log_info - val tick: log_info -> bool * log_info - val close_logger: Remanent_parameters_sig.parameters -> unit - val flush_logger: Remanent_parameters_sig.parameters -> unit - end - -module StoryStats = - (struct - type stack_head = - { - current_branch : int ; - selected_events: int ; - remaining_events: int ; - removed_events: int ; - stack_size: int ; - } - - type step = - { - tag: step_kind; - size_before: int option; - size_after: int option; - time_start: float; - duration: float option; - depth: int - } - - - let k_first _parameter k l = - let rec aux k l output = - if k=0 then [],List.rev output - else - match - l - with - | [] -> (let rec aux k output = if k = 0 then output else aux (k-1) (""::output) in aux k []),List.rev output - | t::q -> aux (k-1) q (t::output) - in aux k l [] - - let print_task parameter (a,b) = - let _ = print_step_kind parameter a.tag in - let tab,b = k_first parameter 4 b in - let _ = - List.iter - (print_step_kind parameter) - b - in - let _ = List.iter (Loggers.print_cell (Remanent_parameters.get_profiler parameter)) tab in - let _ = - Loggers.print_cell (Remanent_parameters.get_profiler parameter) - begin - match - a.size_before - with - | None -> "" - | Some i -> (string_of_int i) - end - in - let _ = - Loggers.print_cell (Remanent_parameters.get_profiler parameter) - begin - match - a.size_after - with - | None -> "" - | Some i -> (string_of_int i) - end - in - let _ = - Loggers.print_cell (Remanent_parameters.get_profiler parameter) - begin - match - a.duration - with - | None -> "" - | Some time -> (string_of_float time) - end - in - () - let close_logger parameter = - Loggers.close_logger (Remanent_parameters.get_profiler parameter) - - let flush_logger parameter = - Loggers.flush_logger (Remanent_parameters.get_profiler parameter) - - type log_info = - { - global_time: float; - story_time: float; - step_time: float; - current_task: step list; - next_depth:int; - branch: int; - cut: int; - stack: stack_head list ; - current_stack: stack_head ; - propagation: int array ; - last_tick:float; - } - - let is_dummy step_kind = - match - step_kind - with - | Dummy -> true - | Beginning|Collect_traces|Causal_compression|Weak_compression|Strong_compression| - Partial_order_reduction|Siphon_detection|Decompose_initial_state| - Agent_ids_disambiguation|Pseudo_inverse_deletion| - Remove_events_after_last_observable|Compression|Build_grid| - Build_configuration|Transitive_closure|Graph_reduction|Graph_conversion| - Cannonic_form_computation|Store_trace|Removing_blacklisted_events| - Blacklisting_events|Global_initialization|Domains_initialization| - Regular_influences|Side_effects_influences|Merge_influences| - KaSim_compilation|KaSa_precompilation|KaSa_lexing|KaSa_linking| - LKappa_signature|Iteration _|Story _|Domain_initialization _|Apply_rule _| - Initial_state _|Scan_rule_static _|Scan_rule_dynamic _|Influence_map _| - Internal_influence_map _ -> false - - let add_event parameter error step_kind f log_info = - if is_dummy step_kind - then - let error,() = - Exception.warn - parameter error __POS__ - ~message:"Inconsistent profiling information, add_event should not be called with a dummy event" - (Failure "Dummy event in add_event") () - in - error,log_info - else - let next_depth = log_info.next_depth in - let task = - { - tag = step_kind ; - size_before = begin match f with | None -> None | Some f -> Some (f ()) end ; - size_after = None ; - time_start = Sys.time () ; - duration = None ; - depth = next_depth ; - } - in - let _ = Loggers.open_row (Remanent_parameters.get_profiler parameter) in - let _ = Loggers.print_cell (Remanent_parameters.get_profiler parameter) "Start" in - let terminated_task = - (task,List.rev_map (fun x -> x.tag) (List.rev log_info.current_task)) - in - let _ = print_task parameter terminated_task in - let _ = Loggers.close_row (Remanent_parameters.get_profiler parameter) in - let _ = flush_logger parameter in - let () = Remanent_parameters.save_current_phase_title parameter (string_of_step_kind step_kind) in - let current_task = task::log_info.current_task in - error, - { log_info - with - next_depth = next_depth + 1 ; - current_task = current_task - } - - let close_event parameter error step_kind f log_info = - if is_dummy step_kind then - let error,() = - Exception.warn - parameter error __POS__ - ~message:"Inconsistent profiling information, close_event should not be called with a dummy event" - (Failure "Dummy event in close_event") () - in - error,log_info - else - let rec aux log_info error interrupted = - let next_depth = log_info.next_depth in - let error,() = - if next_depth = 1 - then - Exception.warn - parameter error __POS__ - ~message:"Inconsistent profiling information, depth should not be equal to 1 when closing an event" - (Failure "Depth=1 in close_event") () +module type StoryStats = sig + type log_info + + val inc_removed_events : log_info -> log_info + val inc_selected_events : log_info -> log_info + val log_info_to_json : log_info -> Yojson.Basic.t + val log_info_of_json : Yojson.Basic.t -> log_info + val inc_cut_events : log_info -> log_info + val inc_k_cut_events : int -> log_info -> log_info + val reset_cut_events : log_info -> log_info + val inc_n_kasim_events : log_info -> log_info + val inc_n_init_events : log_info -> log_info + val inc_n_side_events : log_info -> log_info + val inc_n_obs_events : log_info -> log_info + val inc_branch : log_info -> log_info + val inc_cut : log_info -> log_info + val reset_log : log_info -> log_info + val dump_complete_log : Remanent_parameters_sig.parameters -> log_info -> unit + val dump_short_log : Remanent_parameters_sig.parameters -> log_info -> unit + val add_propagation_case_up : int -> log_info -> log_info + val add_propagation_case_down : int -> log_info -> log_info + val add_look_up_case : int -> log_info -> log_info + val add_look_down_case : int -> log_info -> log_info + val copy : log_info -> log_info + val is_dummy : step_kind -> bool + + val add_event : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + step_kind -> + (unit -> int) option -> + log_info -> + Exception.method_handler * log_info + + val close_event : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + step_kind -> + (unit -> int) option -> + log_info -> + Exception.method_handler * log_info + + val add_event_opt : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + step_kind option -> + (unit -> int) option -> + log_info -> + Exception.method_handler * log_info + + val close_event_opt : + Remanent_parameters_sig.parameters -> + Exception.method_handler -> + step_kind option -> + (unit -> int) option -> + log_info -> + Exception.method_handler * log_info + + val set_time : log_info -> log_info + val set_step_time : log_info -> log_info + val set_global_cut : int -> log_info -> log_info + val set_pseudo_inv : int -> log_info -> log_info + val set_start_compression : log_info -> log_info + val set_grid_generation : log_info -> log_info + val set_canonicalisation : log_info -> log_info + val set_concurrent_event_detection_time : log_info -> log_info + val set_concurrent_event_deletion_time : log_info -> log_info + val set_story_research_time : log_info -> log_info + val ellapsed_global_time : log_info -> float + val ellapsed_time : log_info -> float + val init_log_info : unit -> log_info + val tick : log_info -> bool * log_info + val close_logger : Remanent_parameters_sig.parameters -> unit + val flush_logger : Remanent_parameters_sig.parameters -> unit +end + +module StoryStats : StoryStats = struct + type stack_head = { + current_branch: int; + selected_events: int; + remaining_events: int; + removed_events: int; + stack_size: int; + } + + type step = { + tag: step_kind; + size_before: int option; + size_after: int option; + time_start: float; + duration: float option; + depth: int; + } + + let k_first _parameter k l = + let rec aux k l output = + if k = 0 then + [], List.rev output + else ( + match l with + | [] -> + ( (let rec aux k output = + if k = 0 then + output else - error,() + aux (k - 1) ("" :: output) in - match - log_info.current_task - with - | [] -> - Exception.warn parameter error __POS__ - ~message:"Inconsistent profiling information, no current task when closing an event" - (Failure "No current tasks in close_event") log_info - | current_task::tail when current_task.tag = step_kind -> - begin - let size_after = - match f - with Some f -> Some (f ()) - | None -> None - in - let time = Sys.time () -. current_task.time_start in - let task = - { - current_task - with - size_after = size_after ; - duration = Some time - } - in - let terminated_task = - (task,List.rev_map (fun x -> x.tag) (List.rev tail)) - in - let () = Loggers.open_row (Remanent_parameters.get_profiler parameter) in - let () = Loggers.print_cell (Remanent_parameters.get_profiler parameter) (if interrupted then "Interrupted" else "End") in - let () = print_task parameter terminated_task in - let () = Loggers.close_row (Remanent_parameters.get_profiler parameter) in - let () = flush_logger parameter in - error, - { - log_info - with - next_depth = next_depth - 1; - current_task = tail ; - } - end - | current_task::tail -> - let () = Loggers.open_row (Remanent_parameters.get_profiler parameter) in - let terminated_task = (current_task,List.rev_map (fun x -> x.tag) (List.rev tail)) in - let () = Loggers.print_cell (Remanent_parameters.get_logger parameter) "Interrupted" in - let () = print_task parameter terminated_task in - let () = Loggers.close_row (Remanent_parameters.get_profiler parameter) in - let () = flush_logger parameter in - aux - { - log_info - with - next_depth = next_depth - 1; - current_task = tail ; - } - error true - in aux log_info error false - - let gen_opt gen parameter error step_kind f log_info = - match - step_kind - with - | None -> error,log_info - | Some e -> gen parameter error e f log_info - - let add_event_opt = gen_opt add_event - let close_event_opt = gen_opt close_event - - let propagation_labels = - [| - "None" ; - "Up: case 1 " ; - "Up: case 2 " ; - "Up: case 3 " ; - "Up: case 4 " ; - "Up: case 5 " ; - "Up: case 6 " ; - "Up: case 7 " ; - "Up: case 8 " ; - "Up: case 9 " ; - "Up: case 10" ; - "Up: case 11" ; - "Up: case 12" ; - "Up: case 13" ; - "Up: case 14" ; - "Up: case 15" ; - "Up: case 16" ; - "Down: case 1 " ;(*17*) - "Down: case 2 " ;(*18*) - "Down: case 3 " ;(*19*) - "Down: case 4 " ;(*20*) - "Down: case 5 " ;(*21*) - "Down: case 6 " ;(*22*) - "Down: case 7 " ;(*23*) - "Down: case 8 " ;(*24*) - "Down: case 9 " ;(*25*) - "Down: case 10" ;(*26*) - "Down: case 11" ;(*27*) - "Down: case 12" ;(*28*) - "Down: case 13" ;(*29*) - "Down: case 14" ;(*30*) - "Down: case 15" ;(*31*) - "Down: case 16" ;(*32*) - "Look_up: case 1" ;(*33*) - "Look_up: case 2" ;(*34*) - "Look_up: case 3" ;(*35*) - "Look_up: case 4" ;(*36*) - "Look_down: case 1" ;(*37*) - "Look_down: case 2" ;(*38*) - "Look_down: case 3" ;(*39*) - "Look_down: case 4" ;(*40*) - |] - - let propagation_cases = Array.length propagation_labels - - let copy log_info = - {log_info with propagation = Array.copy log_info.propagation} - - let init_log_info () = - let time = Sys.time () in + aux k []), + List.rev output ) + | t :: q -> aux (k - 1) q (t :: output) + ) + in + aux k l [] + + let print_task parameter (a, b) = + let _ = print_step_kind parameter a.tag in + let tab, b = k_first parameter 4 b in + let _ = List.iter (print_step_kind parameter) b in + let _ = + List.iter + (Loggers.print_cell (Remanent_parameters.get_profiler parameter)) + tab + in + let _ = + Loggers.print_cell + (Remanent_parameters.get_profiler parameter) + (match a.size_before with + | None -> "" + | Some i -> string_of_int i) + in + let _ = + Loggers.print_cell + (Remanent_parameters.get_profiler parameter) + (match a.size_after with + | None -> "" + | Some i -> string_of_int i) + in + let _ = + Loggers.print_cell + (Remanent_parameters.get_profiler parameter) + (match a.duration with + | None -> "" + | Some time -> string_of_float time) + in + () + + let close_logger parameter = + Loggers.close_logger (Remanent_parameters.get_profiler parameter) + + let flush_logger parameter = + Loggers.flush_logger (Remanent_parameters.get_profiler parameter) + + type log_info = { + global_time: float; + story_time: float; + step_time: float; + current_task: step list; + next_depth: int; + branch: int; + cut: int; + stack: stack_head list; + current_stack: stack_head; + propagation: int array; + last_tick: float; + } + + let is_dummy step_kind = + match step_kind with + | Dummy -> true + | Beginning | Collect_traces | Causal_compression | Weak_compression + | Strong_compression | Partial_order_reduction | Siphon_detection + | Decompose_initial_state | Agent_ids_disambiguation + | Pseudo_inverse_deletion | Remove_events_after_last_observable + | Compression | Build_grid | Build_configuration | Transitive_closure + | Graph_reduction | Graph_conversion | Cannonic_form_computation + | Store_trace | Removing_blacklisted_events | Blacklisting_events + | Global_initialization | Domains_initialization | Regular_influences + | Side_effects_influences | Merge_influences | KaSim_compilation + | KaSa_precompilation | KaSa_lexing | KaSa_linking | LKappa_signature + | Iteration _ | Story _ | Domain_initialization _ | Apply_rule _ + | Initial_state _ | Scan_rule_static _ | Scan_rule_dynamic _ + | Influence_map _ | Internal_influence_map _ -> + false + + let add_event parameter error step_kind f log_info = + if is_dummy step_kind then ( + let error, () = + Exception.warn parameter error __POS__ + ~message: + "Inconsistent profiling information, add_event should not be \ + called with a dummy event" + (Failure "Dummy event in add_event") () + in + error, log_info + ) else ( + let next_depth = log_info.next_depth in + let task = + { + tag = step_kind; + size_before = + (match f with + | None -> None + | Some f -> Some (f ())); + size_after = None; + time_start = Sys.time (); + duration = None; + depth = next_depth; + } + in + let _ = Loggers.open_row (Remanent_parameters.get_profiler parameter) in + let _ = + Loggers.print_cell (Remanent_parameters.get_profiler parameter) "Start" + in + let terminated_task = + task, List.rev_map (fun x -> x.tag) (List.rev log_info.current_task) + in + let _ = print_task parameter terminated_task in + let _ = Loggers.close_row (Remanent_parameters.get_profiler parameter) in + let _ = flush_logger parameter in + let () = + Remanent_parameters.save_current_phase_title parameter + (string_of_step_kind step_kind) + in + let current_task = task :: log_info.current_task in + error, { log_info with next_depth = next_depth + 1; current_task } + ) + + let close_event parameter error step_kind f log_info = + if is_dummy step_kind then ( + let error, () = + Exception.warn parameter error __POS__ + ~message: + "Inconsistent profiling information, close_event should not be \ + called with a dummy event" + (Failure "Dummy event in close_event") () + in + error, log_info + ) else ( + let rec aux log_info error interrupted = + let next_depth = log_info.next_depth in + let error, () = + if next_depth = 1 then + Exception.warn parameter error __POS__ + ~message: + "Inconsistent profiling information, depth should not be equal \ + to 1 when closing an event" + (Failure "Depth=1 in close_event") () + else + error, () + in + match log_info.current_task with + | [] -> + Exception.warn parameter error __POS__ + ~message: + "Inconsistent profiling information, no current task when \ + closing an event" + (Failure "No current tasks in close_event") log_info + | current_task :: tail when current_task.tag = step_kind -> + let size_after = + match f with + | Some f -> Some (f ()) + | None -> None + in + let time = Sys.time () -. current_task.time_start in + let task = { current_task with size_after; duration = Some time } in + let terminated_task = + task, List.rev_map (fun x -> x.tag) (List.rev tail) + in + let () = + Loggers.open_row (Remanent_parameters.get_profiler parameter) + in + let () = + Loggers.print_cell + (Remanent_parameters.get_profiler parameter) + (if interrupted then + "Interrupted" + else + "End") + in + let () = print_task parameter terminated_task in + let () = + Loggers.close_row (Remanent_parameters.get_profiler parameter) + in + let () = flush_logger parameter in + ( error, + { log_info with next_depth = next_depth - 1; current_task = tail } ) + | current_task :: tail -> + let () = + Loggers.open_row (Remanent_parameters.get_profiler parameter) + in + let terminated_task = + current_task, List.rev_map (fun x -> x.tag) (List.rev tail) + in + let () = + Loggers.print_cell + (Remanent_parameters.get_logger parameter) + "Interrupted" + in + let () = print_task parameter terminated_task in + let () = + Loggers.close_row (Remanent_parameters.get_profiler parameter) + in + let () = flush_logger parameter in + aux + { log_info with next_depth = next_depth - 1; current_task = tail } + error true + in + aux log_info error false + ) + + let gen_opt gen parameter error step_kind f log_info = + match step_kind with + | None -> error, log_info + | Some e -> gen parameter error e f log_info + + let add_event_opt = gen_opt add_event + let close_event_opt = gen_opt close_event + + let propagation_labels = + [| + "None"; + "Up: case 1 "; + "Up: case 2 "; + "Up: case 3 "; + "Up: case 4 "; + "Up: case 5 "; + "Up: case 6 "; + "Up: case 7 "; + "Up: case 8 "; + "Up: case 9 "; + "Up: case 10"; + "Up: case 11"; + "Up: case 12"; + "Up: case 13"; + "Up: case 14"; + "Up: case 15"; + "Up: case 16"; + "Down: case 1 "; + (*17*) + "Down: case 2 "; + (*18*) + "Down: case 3 "; + (*19*) + "Down: case 4 "; + (*20*) + "Down: case 5 "; + (*21*) + "Down: case 6 "; + (*22*) + "Down: case 7 "; + (*23*) + "Down: case 8 "; + (*24*) + "Down: case 9 "; + (*25*) + "Down: case 10"; + (*26*) + "Down: case 11"; + (*27*) + "Down: case 12"; + (*28*) + "Down: case 13"; + (*29*) + "Down: case 14"; + (*30*) + "Down: case 15"; + (*31*) + "Down: case 16"; + (*32*) + "Look_up: case 1"; + (*33*) + "Look_up: case 2"; + (*34*) + "Look_up: case 3"; + (*35*) + "Look_up: case 4"; + (*36*) + "Look_down: case 1"; + (*37*) + "Look_down: case 2"; + (*38*) + "Look_down: case 3"; + (*39*) + "Look_down: case 4"; + (*40*) + |] + + let propagation_cases = Array.length propagation_labels + + let copy log_info = + { log_info with propagation = Array.copy log_info.propagation } + + let init_log_info () = + let time = Sys.time () in + { + next_depth = 1; + global_time = time; + story_time = time; + step_time = time; + current_task = []; + propagation = Array.make propagation_cases 0; + branch = 0; + cut = 0; + current_stack = + { + current_branch = 0; + selected_events = 0; + remaining_events = 0; + removed_events = 0; + stack_size = 0; + }; + stack = []; + last_tick = 0.; + } + + let log_info_to_json log_info = + `Assoc + [ + "global_time", `Float log_info.global_time; + "story_time", `Float log_info.story_time; + "step_time", `Float log_info.step_time; + "next_depth", `Int log_info.next_depth; + "branch", `Int log_info.branch; + "cut", `Int log_info.cut; + ] + + let float_of_json = function + | `Float f -> f + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct float", x)) + + let int_of_json = function + | `Int f -> f + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct float", x)) + + let log_info_of_json x = + let init = init_log_info () in + match x with + | `Assoc l when List.length l = 6 -> + (try { - next_depth = 1; - global_time = time ; - story_time = time; - step_time = time; - current_task = []; - propagation = Array.make propagation_cases 0 ; - branch = 0 ; - cut = 0 ; - current_stack = - { - current_branch = 0 ; - selected_events = 0 ; - remaining_events = 0 ; - removed_events = 0 ; - stack_size = 0 - } ; - stack = [] ; - last_tick = 0.; + init with + global_time = float_of_json (List.assoc "global_time" l); + story_time = float_of_json (List.assoc "story_time" l); + step_time = float_of_json (List.assoc "step_time" l); + next_depth = int_of_json (List.assoc "next_depth" l); + branch = int_of_json (List.assoc "branch" l); + cut = int_of_json (List.assoc "cut" l); } - - let log_info_to_json log_info = - `Assoc - [ - "global_time", `Float log_info.global_time ; - "story_time", `Float log_info.story_time; - "step_time", `Float log_info.step_time; - "next_depth", `Int log_info.next_depth; - "branch", `Int log_info.branch; - "cut", `Int log_info.cut; - ] - - let float_of_json = function - | `Float f -> f - | x -> raise - (Yojson.Basic.Util.Type_error ("Not a correct float",x)) - - let int_of_json = function - | `Int f -> f - | x -> raise - (Yojson.Basic.Util.Type_error ("Not a correct float",x)) - - let log_info_of_json x = - let init = init_log_info () in - match x with - | `Assoc l when List.length l = 6 -> - begin - try - {init with - global_time = - float_of_json (List.assoc "global_time" l); - story_time = - float_of_json (List.assoc "story_time" l); - step_time = - float_of_json (List.assoc "step_time" l); - next_depth = - int_of_json (List.assoc "next_depth" l); - branch = - int_of_json (List.assoc "branch" l); - cut = - int_of_json (List.assoc "cut" l) - } - with - | Not_found -> - raise - (Yojson.Basic.Util.Type_error ("Not a correct log_info",x)) - end - | x -> raise - (Yojson.Basic.Util.Type_error ("Not a correct log_info",x)) - - - - let dump_short_log parameter log_info = - let _ = Loggers.fprintf - (Remanent_parameters.get_compression_status_logger parameter) - "Remaining events: %i ; Stack size: %i ; " - log_info.current_stack.remaining_events - log_info.current_stack.stack_size - in - Loggers.fprintf (Remanent_parameters.get_compression_status_logger parameter) "Total branch: %i ; Total cut: %i ; Current depth: %i @." - log_info.branch log_info.cut log_info.current_stack.current_branch - - - let reset_log log = - let t = log.propagation in - let _ = Array.fill t 0 (Array.length t) 0 in - let time = Sys.time () in - { log - with - step_time = time ; - story_time = time} - - - let propagate_up i = i - let propagate_down i = i+16 - let look_up i = i+32 - let look_down i = i+36 - - let ellapsed_time log = - let time = Sys.time () in - time -. log.story_time - - let ellapsed_global_time log = - let time = Sys.time () in - time -. log.global_time - - let set_time log = - { log with story_time = Sys.time () ; step_time = Sys.time ()} - let set_step_time log = - { log with step_time = Sys.time ()} - - - let set_start_compression = set_time - - let set_story_research_time log = - let t = Sys.time () in - let st = log.step_time in - { log - with - story_time = t -. st ; - step_time = t } - - let set_concurrent_event_detection_time log = log - let set_concurrent_event_deletion_time log = log - let set_grid_generation log = log - let set_canonicalisation log = log - - let add_case i log = - let t = log.propagation in - let _ = t.(i)<-t.(i)+1 in - log - - let add_look_down_case i = add_case (look_down i) - let add_look_up_case i = add_case (look_up i) - let add_propagation_case_down i = add_case (propagate_down i) - let add_propagation_case_up i = add_case (propagate_up i) - - let inc_cut log = - match - log.stack - with - | [] -> log - | t::q -> - { - log - with - current_stack = t ; - stack = q ; - cut = log.cut + 1; - } - - let inc_branch log = - { - log - with - stack = log.current_stack::log.stack ; - branch = log.branch + 1; - current_stack = - {log.current_stack - with current_branch = log.current_stack.current_branch + 1}} - - let inc_n_kasim_events log = log - let inc_n_obs_events log = log - let inc_n_side_events log = log - let inc_n_init_events log = log - let inc_cut_events log = log - let inc_k_cut_events _k log = log - let reset_cut_events log = log - let inc_selected_events log = log - let inc_removed_events log = log - - - let dump_complete_log parameter log_info = - let logger = Remanent_parameters.get_compression_status_logger parameter in - let () = Loggers.fprintf logger "/*" in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "Story profiling" in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "Ellapsed_time: %f" (ellapsed_time log_info) in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "Story research time: %f" (log_info.story_time) in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "Exploration depth: %i" log_info.current_stack.current_branch in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "Exploration cuts: %i" log_info.cut in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "***" in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "Propagation Hits:" in - let () = Loggers.print_newline logger in - let rec aux k = - if k>=propagation_cases - then () - else - let () = - let () = Loggers.fprintf logger " %s %i" propagation_labels.(k) log_info.propagation.(k) in - let () = Loggers.print_newline logger in - () - in aux (k+1) - in - let _ = aux 1 in - let () = Loggers.fprintf logger "*/" in - let () = Loggers.print_newline logger in - () - - let tick log_info = - let time = Sys.time () in - if time-.log_info.last_tick > 600. - then - true,{log_info with last_tick = time} - else - false,log_info - - let set_global_cut _n log_info = log_info - let set_pseudo_inv _n log_info = log_info - - end:StoryStats) + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct log_info", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct log_info", x)) + + let dump_short_log parameter log_info = + let _ = + Loggers.fprintf + (Remanent_parameters.get_compression_status_logger parameter) + "Remaining events: %i ; Stack size: %i ; " + log_info.current_stack.remaining_events + log_info.current_stack.stack_size + in + Loggers.fprintf + (Remanent_parameters.get_compression_status_logger parameter) + "Total branch: %i ; Total cut: %i ; Current depth: %i @." log_info.branch + log_info.cut log_info.current_stack.current_branch + + let reset_log log = + let t = log.propagation in + let _ = Array.fill t 0 (Array.length t) 0 in + let time = Sys.time () in + { log with step_time = time; story_time = time } + + let propagate_up i = i + let propagate_down i = i + 16 + let look_up i = i + 32 + let look_down i = i + 36 + + let ellapsed_time log = + let time = Sys.time () in + time -. log.story_time + + let ellapsed_global_time log = + let time = Sys.time () in + time -. log.global_time + + let set_time log = + { log with story_time = Sys.time (); step_time = Sys.time () } + + let set_step_time log = { log with step_time = Sys.time () } + let set_start_compression = set_time + + let set_story_research_time log = + let t = Sys.time () in + let st = log.step_time in + { log with story_time = t -. st; step_time = t } + + let set_concurrent_event_detection_time log = log + let set_concurrent_event_deletion_time log = log + let set_grid_generation log = log + let set_canonicalisation log = log + + let add_case i log = + let t = log.propagation in + let _ = t.(i) <- t.(i) + 1 in + log + + let add_look_down_case i = add_case (look_down i) + let add_look_up_case i = add_case (look_up i) + let add_propagation_case_down i = add_case (propagate_down i) + let add_propagation_case_up i = add_case (propagate_up i) + + let inc_cut log = + match log.stack with + | [] -> log + | t :: q -> { log with current_stack = t; stack = q; cut = log.cut + 1 } + + let inc_branch log = + { + log with + stack = log.current_stack :: log.stack; + branch = log.branch + 1; + current_stack = + { + log.current_stack with + current_branch = log.current_stack.current_branch + 1; + }; + } + + let inc_n_kasim_events log = log + let inc_n_obs_events log = log + let inc_n_side_events log = log + let inc_n_init_events log = log + let inc_cut_events log = log + let inc_k_cut_events _k log = log + let reset_cut_events log = log + let inc_selected_events log = log + let inc_removed_events log = log + + let dump_complete_log parameter log_info = + let logger = Remanent_parameters.get_compression_status_logger parameter in + let () = Loggers.fprintf logger "/*" in + let () = Loggers.print_newline logger in + let () = Loggers.fprintf logger "Story profiling" in + let () = Loggers.print_newline logger in + let () = + Loggers.fprintf logger "Ellapsed_time: %f" + (ellapsed_time log_info) + in + let () = Loggers.print_newline logger in + let () = + Loggers.fprintf logger "Story research time: %f" + log_info.story_time + in + let () = Loggers.print_newline logger in + let () = + Loggers.fprintf logger "Exploration depth: %i" + log_info.current_stack.current_branch + in + let () = Loggers.print_newline logger in + let () = + Loggers.fprintf logger "Exploration cuts: %i" log_info.cut + in + let () = Loggers.print_newline logger in + let () = Loggers.fprintf logger "***" in + let () = Loggers.print_newline logger in + let () = Loggers.fprintf logger "Propagation Hits:" in + let () = Loggers.print_newline logger in + let rec aux k = + if k >= propagation_cases then + () + else ( + let () = + let () = + Loggers.fprintf logger " %s %i" propagation_labels.(k) + log_info.propagation.(k) + in + let () = Loggers.print_newline logger in + () + in + aux (k + 1) + ) + in + let _ = aux 1 in + let () = Loggers.fprintf logger "*/" in + let () = Loggers.print_newline logger in + () + + let tick log_info = + let time = Sys.time () in + if time -. log_info.last_tick > 600. then + true, { log_info with last_tick = time } + else + false, log_info + + let set_global_cut _n log_info = log_info + let set_pseudo_inv _n log_info = log_info +end diff --git a/core/simulation/counter.ml b/core/simulation/counter.ml index bed75f9261..1e9ab0638e 100644 --- a/core/simulation/counter.ml +++ b/core/simulation/counter.ml @@ -8,45 +8,42 @@ module Efficiency : sig type t = { - consecutive : int array; - mutable consecutive_blocked : int; - mutable no_more_binary : int; - mutable no_more_unary : int; - mutable clashing_instance : int; - mutable time_correction : int + consecutive: int array; + mutable consecutive_blocked: int; + mutable no_more_binary: int; + mutable no_more_unary: int; + mutable clashing_instance: int; + mutable time_correction: int; } - val init: int -> t - + val init : int -> t val nb : t -> int val nb_consecutive : rule_id:int -> t -> int val nb_consecutive_blocked : t -> int val print_detail : current_event:int -> Format.formatter -> t -> unit val reset_consecutive : rule_id:int -> t -> t val reset_consecutive_blocked : t -> t - val incr_no_more_binary : rule_id:int -> t -> t val incr_no_more_unary : rule_id:int -> t -> t val incr_clashing_instance : rule_id:int -> t -> t val incr_time_correction : t -> t val incr_consecutive_blocked : t -> t - val write_t : Buffer.t -> t -> unit val string_of_t : ?len:int -> t -> string val read_t : Yojson.Safe.lexer_state -> Lexing.lexbuf -> t val t_of_string : string -> t -end = - struct - type t = { - consecutive : int array; - mutable consecutive_blocked : int; - mutable no_more_binary : int; - mutable no_more_unary : int; - mutable clashing_instance : int; - mutable time_correction : int - } +end = struct + type t = { + consecutive: int array; + mutable consecutive_blocked: int; + mutable no_more_binary: int; + mutable no_more_unary: int; + mutable clashing_instance: int; + mutable time_correction: int; + } - let init size = { + let init size = + { consecutive = Array.make size 0; consecutive_blocked = 0; no_more_binary = 0; @@ -55,56 +52,80 @@ end = time_correction = 0; } - let nb t = - t.no_more_binary + t.no_more_unary + t.clashing_instance + t.time_correction - let nb_consecutive ~rule_id t = t.consecutive.(rule_id) - let nb_consecutive_blocked t = t.consecutive_blocked - let reset_consecutive ~rule_id t = let () = t.consecutive.(rule_id) <- 0 in t - let reset_consecutive_blocked t = let () = t.consecutive_blocked <- 0 in t - - let incr_consecutive_blocked t = - let () = t.consecutive_blocked <- succ t.consecutive_blocked in - t - let incr_no_more_binary ~rule_id t = - let () = t.no_more_binary <- succ t.no_more_binary in - let () = t.consecutive.(rule_id) <- succ t.consecutive.(rule_id) in - t - let incr_no_more_unary ~rule_id t = - let () = t.no_more_unary <- succ t.no_more_unary in - let () = t.consecutive.(rule_id) <- succ t.consecutive.(rule_id) in - t - let incr_clashing_instance ~rule_id t = - let () = t.clashing_instance <- succ t.clashing_instance in - let () = t.consecutive.(rule_id) <- succ t.consecutive.(rule_id) in - t - let incr_time_correction t = - let () = t.time_correction <- succ t.time_correction in - t - - let print_detail ~current_event f t = - let all = float_of_int (nb t) in - let events = float_of_int current_event in - let () = Format.pp_open_vbox f 0 in - let () = - if all > 0. then - Format.fprintf f - "@[%.2f%% of event loops were productive.@ Null event cause:@]@," - (100. *. events /. (all +. events)) in - let () = if t.no_more_unary > 0 then Format.fprintf - f "\tValid embedding but no longer unary when required: %.2f%%@," - (100. *. (float_of_int t.no_more_unary) /. all) in - let () = if t.no_more_binary > 0 then Format.fprintf - f "\tValid embedding but not binary when required: %.2f%%@," - (100. *. (float_of_int t.no_more_binary) /. all) in - let () = if t.clashing_instance > 0 then Format.fprintf - f "\tClashing instance: %.2f%%@," - (100. *. (float_of_int t.clashing_instance) /. all) in - let () = if t.time_correction > 0 then Format.fprintf - f "\tPerturbation interrupting time advance: %.2f%%@," - (100. *. (float_of_int t.time_correction) /. all) in - Format.fprintf f "@]" - - let to_yojson t = `Assoc [ + let nb t = + t.no_more_binary + t.no_more_unary + t.clashing_instance + t.time_correction + + let nb_consecutive ~rule_id t = t.consecutive.(rule_id) + let nb_consecutive_blocked t = t.consecutive_blocked + + let reset_consecutive ~rule_id t = + let () = t.consecutive.(rule_id) <- 0 in + t + + let reset_consecutive_blocked t = + let () = t.consecutive_blocked <- 0 in + t + + let incr_consecutive_blocked t = + let () = t.consecutive_blocked <- succ t.consecutive_blocked in + t + + let incr_no_more_binary ~rule_id t = + let () = t.no_more_binary <- succ t.no_more_binary in + let () = t.consecutive.(rule_id) <- succ t.consecutive.(rule_id) in + t + + let incr_no_more_unary ~rule_id t = + let () = t.no_more_unary <- succ t.no_more_unary in + let () = t.consecutive.(rule_id) <- succ t.consecutive.(rule_id) in + t + + let incr_clashing_instance ~rule_id t = + let () = t.clashing_instance <- succ t.clashing_instance in + let () = t.consecutive.(rule_id) <- succ t.consecutive.(rule_id) in + t + + let incr_time_correction t = + let () = t.time_correction <- succ t.time_correction in + t + + let print_detail ~current_event f t = + let all = float_of_int (nb t) in + let events = float_of_int current_event in + let () = Format.pp_open_vbox f 0 in + let () = + if all > 0. then + Format.fprintf f + "@[%.2f%% of event loops were productive.@ Null event cause:@]@," + (100. *. events /. (all +. events)) + in + let () = + if t.no_more_unary > 0 then + Format.fprintf f + "\tValid embedding but no longer unary when required: %.2f%%@," + (100. *. float_of_int t.no_more_unary /. all) + in + let () = + if t.no_more_binary > 0 then + Format.fprintf f + "\tValid embedding but not binary when required: %.2f%%@," + (100. *. float_of_int t.no_more_binary /. all) + in + let () = + if t.clashing_instance > 0 then + Format.fprintf f "\tClashing instance: %.2f%%@," + (100. *. float_of_int t.clashing_instance /. all) + in + let () = + if t.time_correction > 0 then + Format.fprintf f "\tPerturbation interrupting time advance: %.2f%%@," + (100. *. float_of_int t.time_correction /. all) + in + Format.fprintf f "@]" + + let to_yojson t = + `Assoc + [ "consecutive", JsonUtil.of_array JsonUtil.of_int t.consecutive; "consecutive_blocked", `Int t.consecutive_blocked; "no_more_binary", `Int t.no_more_binary; @@ -113,88 +134,104 @@ end = "time_correction", `Int t.time_correction; ] - let of_yojson = function - | `Assoc l as x when List.length l = 6 -> { - consecutive = - (JsonUtil.to_array Yojson.Basic.Util.to_int) - (Yojson.Basic.Util.member "consecutive" x); - consecutive_blocked = - Yojson.Basic.Util.to_int - (Yojson.Basic.Util.member "consecutive_blocked" x); - no_more_binary = - Yojson.Basic.Util.to_int - (Yojson.Basic.Util.member "no_more_binary" x); - no_more_unary = - Yojson.Basic.Util.to_int - (Yojson.Basic.Util.member "no_more_unary" x); - clashing_instance = - Yojson.Basic.Util.to_int - (Yojson.Basic.Util.member "clashing_instance" x); - time_correction = - Yojson.Basic.Util.to_int - (Yojson.Basic.Util.member "time_correction" x); - } - | x -> - raise (Yojson.Basic.Util.Type_error ("Invalid simulation efficiency",x)) - - let write_t ob f = - Yojson.Basic.to_buffer ob (to_yojson f) - - let string_of_t ?(len = 1024) x = - let ob = Buffer.create len in - write_t ob x; - Buffer.contents ob - - let read_t p lb = - of_yojson (Yojson.Basic.from_lexbuf ~stream:true p lb) - - let t_of_string s = - read_t (Yojson.Safe.init_lexer ()) (Lexing.from_string s) - end + let of_yojson = function + | `Assoc l as x when List.length l = 6 -> + { + consecutive = + (JsonUtil.to_array Yojson.Basic.Util.to_int) + (Yojson.Basic.Util.member "consecutive" x); + consecutive_blocked = + Yojson.Basic.Util.to_int + (Yojson.Basic.Util.member "consecutive_blocked" x); + no_more_binary = + Yojson.Basic.Util.to_int (Yojson.Basic.Util.member "no_more_binary" x); + no_more_unary = + Yojson.Basic.Util.to_int (Yojson.Basic.Util.member "no_more_unary" x); + clashing_instance = + Yojson.Basic.Util.to_int + (Yojson.Basic.Util.member "clashing_instance" x); + time_correction = + Yojson.Basic.Util.to_int + (Yojson.Basic.Util.member "time_correction" x); + } + | x -> + raise (Yojson.Basic.Util.Type_error ("Invalid simulation efficiency", x)) + + let write_t ob f = Yojson.Basic.to_buffer ob (to_yojson f) + + let string_of_t ?(len = 1024) x = + let ob = Buffer.create len in + write_t ob x; + Buffer.contents ob + + let read_t p lb = of_yojson (Yojson.Basic.from_lexbuf ~stream:true p lb) + let t_of_string s = read_t (Yojson.Safe.init_lexer ()) (Lexing.from_string s) +end type t = { - mutable time:float ; - mutable events:int ; - mutable stories:int ; - mutable last_point : int; - mutable stat_null : Efficiency.t ; - init_time : float ; - init_event : int ; - mutable plot_period : Configuration.period; - mutable max_time : float option ; - mutable max_event : int option ; - } + mutable time: float; + mutable events: int; + mutable stories: int; + mutable last_point: int; + mutable stat_null: Efficiency.t; + init_time: float; + init_event: int; + mutable plot_period: Configuration.period; + mutable max_time: float option; + mutable max_event: int option; +} let current_story c = c.stories let current_time c = c.time let current_event c = c.events let nb_null_event c = Efficiency.nb c.stat_null -let consecutive_null_event ~rule_id c = Efficiency.nb_consecutive ~rule_id c.stat_null + +let consecutive_null_event ~rule_id c = + Efficiency.nb_consecutive ~rule_id c.stat_null + let consecutive_blocked c = Efficiency.nb_consecutive_blocked c.stat_null -let inc_stories c = c.stories <- (c.stories + 1) -let inc_events c =c.events <- (c.events + 1) +let inc_stories c = c.stories <- c.stories + 1 +let inc_events c = c.events <- c.events + 1 + let check_time c = - match c.max_time with None -> true | Some max -> c.time <= max + match c.max_time with + | None -> true + | Some max -> c.time <= max + let check_output_time c ot = - match c.max_time with None -> true | Some max -> ot <= max + match c.max_time with + | None -> true + | Some max -> ot <= max + let check_events c = - match c.max_event with None -> true | Some max -> c.events < max + match c.max_event with + | None -> true + | Some max -> c.events < max + let one_time_advance c dt = - let () = c.time <- (c.time +. dt) in check_time c + let () = c.time <- c.time +. dt in + check_time c + let one_constructive_event ~rule_id c = let () = c.stat_null <- Efficiency.reset_consecutive ~rule_id c.stat_null in let () = c.stat_null <- Efficiency.reset_consecutive_blocked c.stat_null in let () = inc_events c in check_time c && check_events c + let one_no_more_binary_event ~rule_id c = let () = c.stat_null <- Efficiency.incr_no_more_binary ~rule_id c.stat_null in check_time c && check_events c + let one_no_more_unary_event ~rule_id c = let () = c.stat_null <- Efficiency.incr_no_more_unary ~rule_id c.stat_null in check_time c && check_events c + let one_clashing_instance_event ~rule_id c = - let () = c.stat_null <- Efficiency.incr_clashing_instance ~rule_id c.stat_null in + let () = + c.stat_null <- Efficiency.incr_clashing_instance ~rule_id c.stat_null + in check_time c && check_events c + let one_time_correction_event ?ti c = match Option_util.bind Nbr.to_float ti with | None -> false @@ -202,13 +239,16 @@ let one_time_correction_event ?ti c = let () = c.time <- ti in let () = c.stat_null <- Efficiency.incr_time_correction c.stat_null in check_time c && check_events c + let one_blocked_event c = let () = c.stat_null <- Efficiency.incr_consecutive_blocked c.stat_null in check_time c && check_events c let get_efficiency c = c.stat_null + let print_efficiency f c = Efficiency.print_detail ~current_event:(current_event c) f c.stat_null + let init_time c = c.init_time let max_time c = c.max_time let max_events c = c.max_event @@ -220,36 +260,44 @@ let time_ratio t = | Some tmax -> if tmax > t.init_time then Some ((t.time -. t.init_time) /. (tmax -. t.init_time)) - else None + else + None let event_ratio t = match t.max_event with | None -> None | Some emax -> - if emax = 0 then None + if emax = 0 then + None else - Some (float_of_int (t.events - t.init_event) /. - float_of_int (emax - t.init_event)) + Some + (float_of_int (t.events - t.init_event) + /. float_of_int (emax - t.init_event)) let set_max_time c t = c.max_time <- t let set_max_events c e = c.max_event <- e - let tracked_events (counter : t) : int option = - if counter.stories >= 0 then Some counter.stories else None - -let set_plot_period (t :t) plot_period : unit = t.plot_period <- plot_period - -let create ?(init_t=0.) ?(init_e=0) ?max_time ?max_event ~plot_period ~nb_rules () = - {time = init_t ; - events = init_e ; - stories = -1 ; - stat_null = Efficiency.init nb_rules; - plot_period = plot_period ; - init_time = init_t ; - init_event = init_e ; - max_time; max_event; - last_point = 0 ; + if counter.stories >= 0 then + Some counter.stories + else + None + +let set_plot_period (t : t) plot_period : unit = t.plot_period <- plot_period + +let create ?(init_t = 0.) ?(init_e = 0) ?max_time ?max_event ~plot_period + ~nb_rules () = + { + time = init_t; + events = init_e; + stories = -1; + stat_null = Efficiency.init nb_rules; + plot_period; + init_time = init_t; + init_event = init_e; + max_time; + max_event; + last_point = 0; } let reinitialize counter = @@ -257,18 +305,28 @@ let reinitialize counter = counter.events <- counter.init_event; counter.stories <- -1; counter.last_point <- 0; - counter.stat_null <- Efficiency.init (Array.length counter.stat_null.Efficiency.consecutive) + counter.stat_null <- + Efficiency.init (Array.length counter.stat_null.Efficiency.consecutive) + +let next_step_simulation_info c = + { + Trace.Simulation_info.story_id = current_story c; + Trace.Simulation_info.story_time = current_time c; + Trace.Simulation_info.story_event = current_event c + 1; + Trace.Simulation_info.profiling_info = (); + } -let current_simulation_info c = { - Trace.Simulation_info.story_id = current_story c; - Trace.Simulation_info.story_time = current_time c; - Trace.Simulation_info.story_event = current_event c+1; - Trace.Simulation_info.profiling_info = (); -} +let current_simulation_info c = + { + Trace.Simulation_info.story_id = current_story c; + Trace.Simulation_info.story_time = current_time c; + Trace.Simulation_info.story_event = current_event c; + Trace.Simulation_info.profiling_info = (); + } let next_story c = let () = inc_stories c in - current_simulation_info c + next_step_simulation_info c let positive_plot_period counter = match plot_period counter with @@ -278,12 +336,19 @@ let positive_plot_period counter = let next_point counter dt = match counter.plot_period with | Configuration.DT dT -> - if dT <= 0. then 0 else + if dT <= 0. then + 0 + else int_of_float - ((min (Option_util.unsome infinity (max_time counter)) - (dt +. current_time counter) -. counter.init_time) /. dT) + ((min + (Option_util.unsome infinity (max_time counter)) + (dt +. current_time counter) + -. counter.init_time) + /. dT) | Configuration.DE dE -> - if dE <= 0 then 0 else + if dE <= 0 then + 0 + else (current_event counter - counter.init_event) / dE let to_plot_points counter dt = @@ -293,21 +358,28 @@ let to_plot_points counter dt = let n = next - last in match counter.plot_period with | Configuration.DT dT -> - snd - (Tools.recti - (fun (time,acc) _ -> - time -. dT, - if check_output_time counter time then time::acc else acc) - (counter.init_time +. (float_of_int next) *. dT,[]) n),counter + ( snd + (Tools.recti + (fun (time, acc) _ -> + ( time -. dT, + if check_output_time counter time then + time :: acc + else + acc )) + (counter.init_time +. (float_of_int next *. dT), []) + n), + counter ) | Configuration.DE _ -> - if n=1 then [counter.time],counter - else if n=0 then [],counter + if n = 1 then + [ counter.time ], counter + else if n = 0 then + [], counter else invalid_arg - ("Counter.to_plot_points: invalid increment "^string_of_int n) + ("Counter.to_plot_points: invalid increment " ^ string_of_int n) let fill ~outputs counter ~dt = let points, counter' = to_plot_points counter dt in List.iter (fun time -> outputs counter' time) points -let fake_time t time = {t with time} +let fake_time t time = { t with time } diff --git a/core/simulation/counter.mli b/core/simulation/counter.mli index b80b0c53ee..44544aa7fe 100644 --- a/core/simulation/counter.mli +++ b/core/simulation/counter.mli @@ -9,14 +9,14 @@ (** Simulation progress keeper *) module Efficiency : sig - type t = { - consecutive : int array; - mutable consecutive_blocked : int; - mutable no_more_binary : int; - mutable no_more_unary : int; - mutable clashing_instance : int; - mutable time_correction : int - } + type t = { + consecutive: int array; + mutable consecutive_blocked: int; + mutable no_more_binary: int; + mutable no_more_unary: int; + mutable clashing_instance: int; + mutable time_correction: int; + } val write_t : Buffer.t -> t -> unit (** Output a JSON value of type {!t}. *) @@ -35,47 +35,47 @@ module Efficiency : sig end type t -val create : ?init_t:float -> ?init_e:int -> - ?max_time:float -> ?max_event:int -> - plot_period:Configuration.period -> nb_rules:int -> unit -> t -val reinitialize : t -> unit +val create : + ?init_t:float -> + ?init_e:int -> + ?max_time:float -> + ?max_event:int -> + plot_period:Configuration.period -> + nb_rules:int -> + unit -> + t +val reinitialize : t -> unit val current_simulation_info : t -> unit Trace.Simulation_info.t +val next_step_simulation_info : t -> unit Trace.Simulation_info.t val next_story : t -> unit Trace.Simulation_info.t - val fill : outputs:(t -> float -> unit) -> t -> dt:float -> unit val fake_time : t -> float -> t - val one_time_advance : t -> float -> bool val one_blocked_event : t -> bool val one_constructive_event : rule_id:int -> t -> bool val one_clashing_instance_event : rule_id:int -> t -> bool val one_no_more_unary_event : rule_id:int -> t -> bool val one_no_more_binary_event : rule_id:int -> t -> bool -val one_time_correction_event : ?ti : Nbr.t -> t -> bool - +val one_time_correction_event : ?ti:Nbr.t -> t -> bool val inc_stories : t -> unit - val init_time : t -> float val max_time : t -> float option val max_events : t -> int option -val set_max_time : t -> float option -> unit +val set_max_time : t -> float option -> unit val set_max_events : t -> int option -> unit val event_ratio : t -> float option val time_ratio : t -> float option val tracked_events : t -> int option - val positive_plot_period : t -> bool val plot_period : t -> Configuration.period val set_plot_period : t -> Configuration.period -> unit - val current_time : t -> float val current_event : t -> int val current_story : t -> int val nb_null_event : t -> int val consecutive_null_event : rule_id:int -> t -> int val consecutive_blocked : t -> int - val get_efficiency : t -> Efficiency.t val print_efficiency : Format.formatter -> t -> unit diff --git a/core/simulation/data.ml b/core/simulation/data.ml index 7e5c6b8953..d0ed1f9703 100644 --- a/core/simulation/data.ml +++ b/core/simulation/data.ml @@ -8,119 +8,146 @@ let print_initial_inputs ?uuid conf env inputs_form init = let noCounters = false in - let () = match uuid with + let () = + match uuid with | None -> () - | Some uuid -> Format.fprintf inputs_form "// \"uuid\" : \"%i\"@." uuid in - let () = Format.fprintf inputs_form - "%a@.%a@." Configuration.print conf - (Kappa_printer.env_kappa ~noCounters) env in + | Some uuid -> Format.fprintf inputs_form "// \"uuid\" : \"%i\"@." uuid + in + let () = + Format.fprintf inputs_form "%a@.%a@." Configuration.print conf + (Kappa_printer.env_kappa ~noCounters) + env + in let sigs = Model.signatures env in Format.fprintf inputs_form "@.@[%a@]@." - (Pp.list Pp.space - (fun f (n,r) -> - let _,ins_fresh = - Pattern_compiler.lkappa_of_elementary_rule sigs (Model.domain env) r in - let () = - if ins_fresh <> [] then - let () = - Format.fprintf f "@[%%init:@ @[%a@]@ @[%a@]@]" - (Kappa_printer.alg_expr ~noCounters ~env) n - (Raw_mixture.print - ~noCounters ~created:false ~initial_comma:false ~sigs) - ins_fresh in - if r.Primitives.delta_tokens <> [] then - Format.pp_print_space f () in - Pp.list Pp.space (fun f (nb,tk) -> - Format.fprintf f "@[%%init:@ @[%a@]@ %a@]" - (Kappa_printer.alg_expr ~noCounters ~env) - (fst (Alg_expr.mult (Locality.dummy_annot n) nb)) - (Model.print_token ~env) tk) - f r.Primitives.delta_tokens)) init + (Pp.list Pp.space (fun f (n, r) -> + let _, ins_fresh = + Pattern_compiler.lkappa_of_elementary_rule sigs (Model.domain env) r + in + let () = + if ins_fresh <> [] then ( + let () = + Format.fprintf f "@[%%init:@ @[%a@]@ @[%a@]@]" + (Kappa_printer.alg_expr ~noCounters ~env) + n + (Raw_mixture.print ~noCounters ~created:false + ~initial_comma:false ~sigs) + ins_fresh + in + if r.Primitives.delta_tokens <> [] then Format.pp_print_space f () + ) + in + Pp.list Pp.space + (fun f (nb, tk) -> + Format.fprintf f "@[%%init:@ @[%a@]@ %a@]" + (Kappa_printer.alg_expr ~noCounters ~env) + (fst (Alg_expr.mult (Loc.annot_with_dummy n) nb)) + (Model.print_token ~env) tk) + f r.Primitives.delta_tokens)) + init type snapshot = { - snapshot_event : int; - snapshot_time : float; - snapshot_agents : (int * User_graph.connected_component) list; - snapshot_tokens : (string * Nbr.t) array; + snapshot_event: int; + snapshot_time: float; + snapshot_agents: (int * User_graph.connected_component) list; + snapshot_tokens: (string * Nbr.t) array; } let print_snapshot ?uuid f s = - let () = Format.fprintf - f "@[// Snapshot [Event: %d]@,"(*", Time: %f"*)s.snapshot_event in - Format.fprintf - f "%a%%def: \"T0\" \"%g\"@,@,%a@,%a@]@." - (Pp.option ~with_space:false (fun f x -> Format.fprintf f "// \"uuid\" : \"%i\"@," x)) uuid - s.snapshot_time - (Pp.list Pp.space (fun f (i,mix) -> + let () = + Format.fprintf f "@[// Snapshot [Event: %d]@," + (*", Time: %f"*) s.snapshot_event + in + Format.fprintf f "%a%%def: \"T0\" \"%s\"@,@,%a@,%a@]@." + (Pp.option ~with_space:false (fun f x -> + Format.fprintf f "// \"uuid\" : \"%i\"@," x)) + uuid + (JsonUtil.std_json_string_of_float s.snapshot_time) + (Pp.list Pp.space (fun f (i, mix) -> Format.fprintf f "@[%%init: %i /*%i agents*/ %a@]" i (Array.fold_left (fun s e -> s + Array.length e) 0 mix) User_graph.print_cc mix)) s.snapshot_agents - (Pp.array Pp.space (fun _ f (na,el) -> - Format.fprintf - f "%%init: %a %s" Nbr.print el na)) + (Pp.array Pp.space (fun _ f (na, el) -> + Format.fprintf f "%%init: %a %s" Nbr.print el na)) s.snapshot_tokens let print_dot_snapshot ?uuid f s = - let () = Format.fprintf - f "@[// Snapshot [Event: %d]@,"(*", Time: %f"*)s.snapshot_event in - Format.fprintf - f "%adigraph G{@,%a@,%a}@]@." - (Pp.option ~with_space:false (fun f x -> Format.fprintf f "// \"uuid\" : \"%i\"@," x)) uuid - (Pp.listi - Pp.cut - (fun i f (nb,mix) -> - Format.fprintf f "@[subgraph cluster%d{@," i; - Format.fprintf - f "counter%d [label = \"%d instance(s)\", shape=none];@,%a}@]" - i nb (User_graph.print_dot_cc i) mix)) + let () = + Format.fprintf f "@[// Snapshot [Event: %d]@," + (*", Time: %f"*) s.snapshot_event + in + Format.fprintf f "%adigraph G{@,%a@,%a}@]@." + (Pp.option ~with_space:false (fun f x -> + Format.fprintf f "// \"uuid\" : \"%i\"@," x)) + uuid + (Pp.listi Pp.cut (fun i f (nb, mix) -> + Format.fprintf f "@[subgraph cluster%d{@," i; + Format.fprintf f + "counter%d [label = \"%d instance(s)\", shape=none];@,%a}@]" i nb + (User_graph.print_dot_cc i) + mix)) s.snapshot_agents - (Pp.array Pp.cut (fun i f (na,el) -> - Format.fprintf - f "token_%d [label = \"%s (%a)\" , shape=none]" - i na Nbr.print el)) + (Pp.array Pp.cut (fun i f (na, el) -> + Format.fprintf f "token_%d [label = \"%s (%a)\" , shape=none]" i na + Nbr.print el)) s.snapshot_tokens let write_snapshot ob s = let () = Buffer.add_char ob '{' in - let () = JsonUtil.write_field - "snapshot_event" Yojson.Basic.write_int ob s.snapshot_event in + let () = + JsonUtil.write_field "snapshot_event" Yojson.Basic.write_int ob + s.snapshot_event + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "snapshot_time" Yojson.Basic.write_float ob s.snapshot_time in + let () = + JsonUtil.write_field "snapshot_time" Yojson.Basic.write_float ob + s.snapshot_time + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "snapshot_agents" + let () = + JsonUtil.write_field "snapshot_agents" (JsonUtil.write_list - (JsonUtil.write_compact_pair - Yojson.Basic.write_int User_graph.write_connected_component)) - ob s.snapshot_agents in + (JsonUtil.write_compact_pair Yojson.Basic.write_int + User_graph.write_connected_component)) + ob s.snapshot_agents + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "snapshot_tokens" + let () = + JsonUtil.write_field "snapshot_tokens" (JsonUtil.write_array (JsonUtil.write_compact_pair Yojson.Basic.write_string Nbr.write_t)) - ob s.snapshot_tokens in + ob s.snapshot_tokens + in Buffer.add_char ob '}' let read_snapshot p lb = - let snapshot_event,snapshot_time,snapshot_agents,snapshot_tokens = + let snapshot_event, snapshot_time, snapshot_agents, snapshot_tokens = Yojson.Basic.read_fields - (fun (e,ti,a,t) key p lb -> - if key = "snapshot_event" then - (Yojson.Basic.read_int p lb,ti,a,t) - else if key = "snapshot_time" then - (e,Yojson.Basic.read_number p lb,a,t) - else if key = "snapshot_agents" then - (e,ti,Yojson.Basic.read_list - (JsonUtil.read_compact_pair - Yojson.Basic.read_int User_graph.read_connected_component) p lb,t) - else let () = assert (key = "snapshot_tokens") in - (e,ti,a,Yojson.Basic.read_array + (fun (e, ti, a, t) key p lb -> + if key = "snapshot_event" then + Yojson.Basic.read_int p lb, ti, a, t + else if key = "snapshot_time" then + e, Yojson.Basic.read_number p lb, a, t + else if key = "snapshot_agents" then + ( e, + ti, + Yojson.Basic.read_list + (JsonUtil.read_compact_pair Yojson.Basic.read_int + User_graph.read_connected_component) + p lb, + t ) + else ( + let () = assert (key = "snapshot_tokens") in + ( e, + ti, + a, + Yojson.Basic.read_array (JsonUtil.read_compact_pair Yojson.Basic.read_string Nbr.read_t) - p lb) - ) - (-1,nan,[],[||]) p lb in + p lb ) + )) + (-1, nan, [], [||]) p lb + in { snapshot_event; snapshot_time; snapshot_agents; snapshot_tokens } let string_of_snapshot = JsonUtil.string_of_write write_snapshot @@ -129,59 +156,82 @@ let snapshot_of_string s = read_snapshot (Yojson.Safe.init_lexer ()) (Lexing.from_string s) type din_data = { - din_kind : Primitives.din_kind; - din_start : float; - din_hits : int array; - din_fluxs : float array array; -} -type din = { - din_rules : string array; - din_data : din_data; - din_end : float; + din_kind: Primitives.din_kind; + din_start: float; + din_hits: int array; + din_fluxs: float array array; } +type din = { din_rules: string array; din_data: din_data; din_end: float } + let write_din ob f = let () = Buffer.add_char ob '{' in - let () = JsonUtil.write_field - "din_kind" Primitives.write_din_kind ob f.din_data.din_kind in + let () = + JsonUtil.write_field "din_kind" Primitives.write_din_kind ob + f.din_data.din_kind + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "din_start" Yojson.Basic.write_float ob f.din_data.din_start in + let () = + JsonUtil.write_field "din_start" Yojson.Basic.write_float ob + f.din_data.din_start + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field "din_end" - Yojson.Basic.write_float ob f.din_end in + let () = + JsonUtil.write_field "din_end" Yojson.Basic.write_float ob f.din_end + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field "din_rules" - (JsonUtil.write_array Yojson.Basic.write_string) ob f.din_rules in + let () = + JsonUtil.write_field "din_rules" + (JsonUtil.write_array Yojson.Basic.write_string) + ob f.din_rules + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field "din_hits" - (JsonUtil.write_array Yojson.Basic.write_int) ob f.din_data.din_hits in + let () = + JsonUtil.write_field "din_hits" + (JsonUtil.write_array Yojson.Basic.write_int) + ob f.din_data.din_hits + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field "din_fluxs" + let () = + JsonUtil.write_field "din_fluxs" (JsonUtil.write_array (JsonUtil.write_array Yojson.Basic.write_float)) - ob f.din_data.din_fluxs in + ob f.din_data.din_fluxs + in Buffer.add_char ob '}' let read_din p lb = - let (din_kind,din_start,din_hits,din_fluxs,din_rules,din_end) = + let din_kind, din_start, din_hits, din_fluxs, din_rules, din_end = Yojson.Basic.read_fields - (fun (k,s,h,f,r,e) key p lb -> - if key = "din_kind" then - (Primitives.read_din_kind p lb,s,h,f,r,e) - else if key = "din_start" then - (k,Yojson.Basic.read_number p lb,h,f,r,e) - else if key = "din_hits" then - (k,s,Yojson.Basic.read_array Yojson.Basic.read_int p lb,f,r,e) - else if key = "din_fluxs" then - (k,s,h,Yojson.Basic.read_array - (Yojson.Basic.read_array Yojson.Basic.read_number) p lb,r,e) - else if key = "din_end" then - (k,s,h,f,r,Yojson.Basic.read_number p lb) - else let () = assert (key = "din_rules") in - (k,s,h,f,Yojson.Basic.read_array Yojson.Basic.read_string p lb,e)) - (Primitives.ABSOLUTE,nan,[||],[||],[||],nan) p lb in - { din_rules;din_end; - din_data={ din_kind; din_start; din_hits; din_fluxs } } + (fun (k, s, h, f, r, e) key p lb -> + if key = "din_kind" then + Primitives.read_din_kind p lb, s, h, f, r, e + else if key = "din_start" then + k, Yojson.Basic.read_number p lb, h, f, r, e + else if key = "din_hits" then + k, s, Yojson.Basic.read_array Yojson.Basic.read_int p lb, f, r, e + else if key = "din_fluxs" then + ( k, + s, + h, + Yojson.Basic.read_array + (Yojson.Basic.read_array Yojson.Basic.read_number) + p lb, + r, + e ) + else if key = "din_end" then + k, s, h, f, r, Yojson.Basic.read_number p lb + else ( + let () = assert (key = "din_rules") in + k, s, h, f, Yojson.Basic.read_array Yojson.Basic.read_string p lb, e + )) + (Primitives.ABSOLUTE, nan, [||], [||], [||], nan) + p lb + in + { + din_rules; + din_end; + din_data = { din_kind; din_start; din_hits; din_fluxs }; + } let string_of_din = JsonUtil.string_of_write write_din @@ -189,98 +239,130 @@ let din_of_string s = read_din (Yojson.Safe.init_lexer ()) (Lexing.from_string s) let print_dot_din ?uuid desc flux = - let () = Format.fprintf desc "@[%a" - (Pp.option ~with_space:false - (fun f x -> Format.fprintf f "// \"uuid\" : \"%i\",@," x)) - uuid in - let () = Format.fprintf - desc "digraph G{ label=\"Dynamic influence network\" ; labelloc=\"t\" ; " in - let () = Format.fprintf - desc "node [shape=box,style=filled,fillcolor=lightskyblue]@," in + let () = + Format.fprintf desc "@[%a" + (Pp.option ~with_space:false (fun f x -> + Format.fprintf f "// \"uuid\" : \"%i\",@," x)) + uuid + in + let () = + Format.fprintf desc + "digraph G{ label=\"Dynamic influence network\" ; labelloc=\"t\" ; " + in + let () = + Format.fprintf desc "node [shape=box,style=filled,fillcolor=lightskyblue]@," + in let () = Pp.array (fun _ -> ()) (fun s -> - Pp.array - Pp.empty - (fun d f v -> - if v=0. then () - else - let color,arrowhead = - if v<0. then ("red3","tee") else ("green3","normal") in - Format.fprintf - f - "@[\"%s\" -> \"%s\" [weight=%d,label=\"%.3f\",color=%s,arrowhead=%s];@]@," - flux.din_rules.(s) - flux.din_rules.(d) - (abs (int_of_float v)) v color arrowhead)) - desc flux.din_data.din_fluxs in + Pp.array Pp.empty (fun d f v -> + if v = 0. then + () + else ( + let color, arrowhead = + if v < 0. then + "red3", "tee" + else + "green3", "normal" + in + Format.fprintf f + "@[\"%s\" -> \"%s\" \ + [weight=%d,label=\"%.3f\",color=%s,arrowhead=%s];@]@," + flux.din_rules.(s) flux.din_rules.(d) + (abs (int_of_float v)) + v color arrowhead + ))) + desc flux.din_data.din_fluxs + in Format.fprintf desc "}@]@." let print_html_din desc flux = Pp_html.graph_page (fun f -> Format.pp_print_string f "Dynamic influence map") - ~subtitle:(fun f -> Format.pp_print_string - f "between t = s and t = s ( events)") - ["http://d3js.org/d3.v4.min.js";"https://code.jquery.com/jquery-3.3.1.min.js"] + ~subtitle:(fun f -> + Format.pp_print_string f + "between t = s and t = s ( events)") + [ + "http://d3js.org/d3.v4.min.js"; + "https://code.jquery.com/jquery-3.3.1.min.js"; + ] (fun f -> - let () = - Format.fprintf - f "@[") + let () = + Format.fprintf f "@[") (fun f -> - let () = Format.fprintf f "
    @," in - let () = Format.fprintf f "@[
    @," in - let () = Format.fprintf f "@[
    @," in - let () = - Format.fprintf f "@," in - let () = - Format.fprintf - f - "@,
    @," in - let () = Format.fprintf - f "@," in - let () = Format.fprintf f "@[@]@,@," in - let () = Format.fprintf f "
    @," in - let () = Format.fprintf - f "@[@]@," Resource_strings.common_js in - let () = Format.fprintf - f "@[@]@," Resource_strings.flux_js in + let () = Format.fprintf f "
    @," in + let () = Format.fprintf f "@[
    @," in + let () = Format.fprintf f "@[
    @," in + let () = + Format.fprintf f "@," + in + let () = + Format.fprintf f + "@,
    @," + in + let () = + Format.fprintf f + "@," + in + let () = Format.fprintf f "@[@]@,@," + in + let () = Format.fprintf f "
    @," in + let () = + Format.fprintf f "@[@]@," + Resource_strings.common_js + in + let () = + Format.fprintf f "@[@]@," + Resource_strings.flux_js + in - let () = Format.fprintf - f "@[") + let () = + Format.fprintf f + "@[") desc -type plot = { - plot_legend : string array; - plot_series : float option array list; -} +type plot = { plot_legend: string array; plot_series: float option array list } let add_plot_line new_observables plot = let new_values = Array.map (fun nbr -> Nbr.to_float nbr) new_observables in @@ -294,33 +376,44 @@ let init_plot env = let plot_legend = Model.map_observables (fun o -> - Format.asprintf "@[%a@]" (Kappa_printer.alg_expr ~noCounters ~env) o) - env in - { plot_legend; plot_series = []; } + Format.asprintf "@[%a@]" (Kappa_printer.alg_expr ~noCounters ~env) o) + env + in + { plot_legend; plot_series = [] } let write_plot ob f = let () = Buffer.add_char ob '{' in - let () = JsonUtil.write_field "legend" - (JsonUtil.write_array Yojson.Basic.write_string) ob f.plot_legend in + let () = + JsonUtil.write_field "legend" + (JsonUtil.write_array Yojson.Basic.write_string) + ob f.plot_legend + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field "series" - (JsonUtil.write_list (JsonUtil.write_array - (JsonUtil.write_option Yojson.Basic.write_float))) - ob f.plot_series in + let () = + JsonUtil.write_field "series" + (JsonUtil.write_list + (JsonUtil.write_array (JsonUtil.write_option Yojson.Basic.write_float))) + ob f.plot_series + in Buffer.add_char ob '}' let read_plot p lb = - let (plot_legend,plot_series) = + let plot_legend, plot_series = Yojson.Basic.read_fields - (fun (l,s) key p lb -> - if key = "series" then - (l,Yojson.Basic.read_list + (fun (l, s) key p lb -> + if key = "series" then + ( l, + Yojson.Basic.read_list (Yojson.Basic.read_array - (JsonUtil.read_option Yojson.Basic.read_number)) p lb) - else let () = assert (key = "legend") in - (Yojson.Basic.read_array Yojson.Basic.read_string p lb,s)) - ([||],[]) p lb in - { plot_legend; plot_series; } + (JsonUtil.read_option Yojson.Basic.read_number)) + p lb ) + else ( + let () = assert (key = "legend") in + Yojson.Basic.read_array Yojson.Basic.read_string p lb, s + )) + ([||], []) p lb + in + { plot_legend; plot_series } let string_of_plot = JsonUtil.string_of_write write_plot @@ -328,7 +421,11 @@ let plot_of_string s = read_plot (Yojson.Safe.init_lexer ()) (Lexing.from_string s) let print_plot_sep is_tsv f = - Format.pp_print_string f (if is_tsv then "\t" else ",") + Format.pp_print_string f + (if is_tsv then + "\t" + else + ",") let print_plot_legend ~is_tsv f a = Format.fprintf f "@[%a@]@." @@ -337,34 +434,32 @@ let print_plot_legend ~is_tsv f a = let print_plot_line ~is_tsv pp f l = Format.fprintf f "@[%a@]@." - (Pp.array (print_plot_sep is_tsv) (fun _ -> pp)) l + (Pp.array (print_plot_sep is_tsv) (fun _ -> pp)) + l let export_plot ~is_tsv plot = Format.asprintf "%a%a" - (print_plot_legend ~is_tsv) plot.plot_legend - (Pp.list Pp.empty (print_plot_line ~is_tsv - (Pp.option (fun f -> Format.fprintf f "%e")))) + (print_plot_legend ~is_tsv) + plot.plot_legend + (Pp.list Pp.empty + (print_plot_line ~is_tsv (Pp.option (fun f -> Format.fprintf f "%e")))) (List.rev plot.plot_series) let print_warning ?pos f msg = let pr f () = Format.fprintf f "Warning: @[%t@]" msg in match pos with - | Some pos -> - Format.fprintf f "@[%a@]@." (Locality.print_annot pr) ((),pos) + | Some pos -> Format.fprintf f "@[%a@]@." (Loc.print_annoted pr) ((), pos) | None -> Format.fprintf f "@[%a@]@." pr () -type file_line = { - file_line_name : string option; - file_line_text : string; -} +type file_line = { file_line_name: string option; file_line_text: string } type t = | DIN of string * din | DeltaActivities of int * (int * (float * float)) list - | Plot of Nbr.t array (** Must have length >= 1 (at least [T] or [E]) *) + | Plot of Nbr.t array (** Must have length >= 1 (at least [T] or [E]) *) | Print of file_line | TraceStep of Trace.step | Snapshot of string * snapshot | Log of string | Species of string * float * User_graph.connected_component - | Warning of Locality.t option*(Format.formatter -> unit) + | Warning of Loc.t option * (Format.formatter -> unit) diff --git a/core/simulation/data.mli b/core/simulation/data.mli index 2ae67e6f57..971ccc8f01 100644 --- a/core/simulation/data.mli +++ b/core/simulation/data.mli @@ -7,105 +7,88 @@ (******************************************************************************) type snapshot = { - snapshot_event : int; - snapshot_time : float; - snapshot_agents : (int * User_graph.connected_component) list; - snapshot_tokens : (string * Nbr.t) array; + snapshot_event: int; + snapshot_time: float; + snapshot_agents: (int * User_graph.connected_component) list; + snapshot_tokens: (string * Nbr.t) array; } type din_data = { - din_kind : Primitives.din_kind; - din_start : float; - din_hits : int array; - din_fluxs : float array array; -} -type din = { - din_rules : string array; - din_data : din_data; - din_end : float; + din_kind: Primitives.din_kind; + din_start: float; + din_hits: int array; + din_fluxs: float array array; } -type file_line = { - file_line_name : string option; - file_line_text : string; -} +type din = { din_rules: string array; din_data: din_data; din_end: float } +type file_line = { file_line_name: string option; file_line_text: string } type t = | DIN of string * din | DeltaActivities of int * (int * (float * float)) list - | Plot of Nbr.t array (** Must have length >= 1 (at least [T] or [E]) *) + | Plot of Nbr.t array (** Must have length >= 1 (at least [T] or [E]) *) | Print of file_line | TraceStep of Trace.step | Snapshot of string * snapshot | Log of string | Species of string * float * User_graph.connected_component - | Warning of Locality.t option*(Format.formatter -> unit) + | Warning of Loc.t option * (Format.formatter -> unit) -val print_snapshot : ?uuid: int -> Format.formatter -> snapshot -> unit +val print_snapshot : ?uuid:int -> Format.formatter -> snapshot -> unit +val print_dot_snapshot : ?uuid:int -> Format.formatter -> snapshot -> unit -val print_dot_snapshot : ?uuid: int -> Format.formatter -> snapshot -> unit +val write_snapshot : Buffer.t -> snapshot -> unit +(** Output a JSON value of type {!snapshot}. *) -val write_snapshot : - Buffer.t -> snapshot -> unit - (** Output a JSON value of type {!snapshot}. *) - -val string_of_snapshot : - ?len:int -> snapshot -> string - (** Serialize a value of type {!snapshot} +val string_of_snapshot : ?len:int -> snapshot -> string +(** Serialize a value of type {!snapshot} into a JSON string. @param len specifies the initial length of the buffer used internally. Default: 1024. *) -val read_snapshot : - Yojson.Safe.lexer_state -> Lexing.lexbuf -> snapshot - (** Input JSON data of type {!snapshot}. *) - -val snapshot_of_string : - string -> snapshot - (** Deserialize JSON data of type {!snapshot}. *) +val read_snapshot : Yojson.Safe.lexer_state -> Lexing.lexbuf -> snapshot +(** Input JSON data of type {!snapshot}. *) -val print_dot_din : ?uuid: int -> Format.formatter -> din -> unit +val snapshot_of_string : string -> snapshot +(** Deserialize JSON data of type {!snapshot}. *) +val print_dot_din : ?uuid:int -> Format.formatter -> din -> unit val print_html_din : Format.formatter -> din -> unit val write_din : Buffer.t -> din -> unit - (** Output a JSON value of type {!din}. *) +(** Output a JSON value of type {!din}. *) val string_of_din : ?len:int -> din -> string - (** Serialize a value of type {!din} +(** Serialize a value of type {!din} into a JSON string. @param len specifies the initial length of the buffer used internally. Default: 1024. *) val read_din : Yojson.Safe.lexer_state -> Lexing.lexbuf -> din - (** Input JSON data of type {!din}. *) +(** Input JSON data of type {!din}. *) val din_of_string : string -> din - (** Deserialize JSON data of type {!din}. *) +(** Deserialize JSON data of type {!din}. *) -type plot = { - plot_legend : string array; - plot_series : float option array list; -} +type plot = { plot_legend: string array; plot_series: float option array list } val add_plot_line : Nbr.t array -> plot -> plot - val init_plot : Model.t -> plot val write_plot : Buffer.t -> plot -> unit - (** Output a JSON value of type {!plot}. *) +(** Output a JSON value of type {!plot}. *) val string_of_plot : ?len:int -> plot -> string - (** Serialize a value of type {!plot} +(** Serialize a value of type {!plot} into a JSON string. @param len specifies the initial length of the buffer used internally. Default: 1024. *) val read_plot : Yojson.Safe.lexer_state -> Lexing.lexbuf -> plot - (** Input JSON data of type {!plot}. *) +(** Input JSON data of type {!plot}. *) val plot_of_string : string -> plot (** Deserialize JSON data of type {!plot}. *) @@ -113,15 +96,21 @@ val plot_of_string : string -> plot val print_plot_legend : is_tsv:bool -> Format.formatter -> string array -> unit val print_plot_line : - is_tsv:bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> - 'a array -> unit + is_tsv:bool -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a array -> + unit -val export_plot : is_tsv: bool -> plot -> string +val export_plot : is_tsv:bool -> plot -> string val print_initial_inputs : - ?uuid:int -> Configuration.t -> Model.t -> - Format.formatter -> (Primitives.alg_expr * Primitives.elementary_rule) list -> + ?uuid:int -> + Configuration.t -> + Model.t -> + Format.formatter -> + (Primitives.alg_expr * Primitives.elementary_rule) list -> unit val print_warning : - ?pos:Locality.t -> Format.formatter -> (Format.formatter -> unit) -> unit + ?pos:Loc.t -> Format.formatter -> (Format.formatter -> unit) -> unit diff --git a/core/simulation/dune b/core/simulation/dune index f4f9545372..3be459f1d9 100644 --- a/core/simulation/dune +++ b/core/simulation/dune @@ -2,12 +2,21 @@ (name kappa_runtime) (libraries kappa_terms) (public_name kappa-library.runtime) - (flags (:standard -w @a - -open Kappa_generic_toolset - -open Kappa_mixtures - -open Kappa_terms))) + (flags + (:standard + -w + @a + -open + Kappa_generic_toolset + -open + Kappa_mixtures + -open + Kappa_terms))) (rule (targets resource_strings.ml) (deps ../../dev/generate-string.sh ../../shared/flux.js ../../viz/common.js) - (action (with-stdout-to %{targets} (run ocaml %{deps})))) + (action + (with-stdout-to + %{targets} + (run ocaml %{deps})))) diff --git a/core/simulation/expr_interpreter.ml b/core/simulation/expr_interpreter.ml index 595396c57a..3e148110d2 100644 --- a/core/simulation/expr_interpreter.ml +++ b/core/simulation/expr_interpreter.ml @@ -6,117 +6,153 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -let value_state_alg_op counter ?(time=Counter.current_time counter) = function +let value_state_alg_op counter ?(time = Counter.current_time counter) = function | Operator.CPUTIME -> Nbr.F (Sys.time ()) | Operator.TIME_VAR -> Nbr.F time | Operator.EVENT_VAR -> Nbr.I (Counter.current_event counter) | Operator.NULL_EVENT_VAR -> Nbr.I (Counter.nb_null_event counter) | Operator.EMAX_VAR -> (match Counter.max_events counter with - | Some n -> Nbr.I n - | None -> Nbr.F infinity) + | Some n -> Nbr.I n + | None -> Nbr.F infinity) | Operator.TMAX_VAR -> (match Counter.max_time counter with - | Some t -> Nbr.F t - | None -> Nbr.F infinity) + | Some t -> Nbr.F t + | None -> Nbr.F infinity) -type (_,_) stack = - | RETURN : ('a,'a) stack +type (_, _) stack = + | RETURN : ('a, 'a) stack | TO_EXEC_ALG : - Operator.bin_alg_op * Primitives.alg_expr * (Nbr.t,'a) stack -> - (Nbr.t,'a) stack + Operator.bin_alg_op * Primitives.alg_expr * (Nbr.t, 'a) stack + -> (Nbr.t, 'a) stack | TO_EXEC_COMP : - Operator.compare_op * Primitives.alg_expr * (bool,'a) stack -> - (Nbr.t,'a) stack + Operator.compare_op * Primitives.alg_expr * (bool, 'a) stack + -> (Nbr.t, 'a) stack | TO_EXEC_IF : - Primitives.alg_expr * Primitives.alg_expr * (Nbr.t,'a) stack -> - (bool,'a) stack + Primitives.alg_expr * Primitives.alg_expr * (Nbr.t, 'a) stack + -> (bool, 'a) stack | TO_EXEC_BOOL : - Operator.bin_bool_op * (Pattern.id array list,int) Alg_expr.bool * - (bool,'a) stack -> (bool,'a) stack + Operator.bin_bool_op + * (Pattern.id array list, int) Alg_expr.bool + * (bool, 'a) stack + -> (bool, 'a) stack | TO_COMPUTE_ALG : - Operator.bin_alg_op * Nbr.t * (Nbr.t,'a) stack -> (Nbr.t,'a) stack + Operator.bin_alg_op * Nbr.t * (Nbr.t, 'a) stack + -> (Nbr.t, 'a) stack | TO_COMPUTE_COMP : - Operator.compare_op * Nbr.t * (bool,'a) stack -> (Nbr.t,'a) stack - | TO_COMPUTE_UN : Operator.un_alg_op * (Nbr.t,'a) stack -> (Nbr.t,'a) stack - | TO_COMPUTE_BOOL : Operator.un_bool_op * (bool,'a) stack -> (bool,'a) stack + Operator.compare_op * Nbr.t * (bool, 'a) stack + -> (Nbr.t, 'a) stack + | TO_COMPUTE_UN : Operator.un_alg_op * (Nbr.t, 'a) stack -> (Nbr.t, 'a) stack + | TO_COMPUTE_BOOL : Operator.un_bool_op * (bool, 'a) stack -> (bool, 'a) stack let rec exec_alg : - type a. Counter.t -> ?time:float -> get_alg:(int -> Primitives.alg_expr) -> - get_mix:(Pattern.id array list -> Nbr.t) -> - get_tok:(int -> Nbr.t) -> (Pattern.id array list,int) Alg_expr.e -> - (Nbr.t,a) stack -> a = - fun counter ?time ~get_alg ~get_mix ~get_tok alg sk -> + type a. + Counter.t -> + ?time:float -> + get_alg:(int -> Primitives.alg_expr) -> + get_mix:(Pattern.id array list -> Nbr.t) -> + get_tok:(int -> Nbr.t) -> + (Pattern.id array list, int) Alg_expr.e -> + (Nbr.t, a) stack -> + a = + fun counter ?time ~get_alg ~get_mix ~get_tok alg sk -> match alg with - | Alg_expr.BIN_ALG_OP (op,(a,_),(b,_)) -> - exec_alg counter ?time ~get_alg ~get_mix ~get_tok a (TO_EXEC_ALG (op,b,sk)) - | Alg_expr.UN_ALG_OP (op,(a,_)) -> - exec_alg counter ?time ~get_alg ~get_mix ~get_tok a (TO_COMPUTE_UN (op,sk)) - | Alg_expr.STATE_ALG_OP (op) -> + | Alg_expr.BIN_ALG_OP (op, (a, _), (b, _)) -> + exec_alg counter ?time ~get_alg ~get_mix ~get_tok a + (TO_EXEC_ALG (op, b, sk)) + | Alg_expr.UN_ALG_OP (op, (a, _)) -> + exec_alg counter ?time ~get_alg ~get_mix ~get_tok a (TO_COMPUTE_UN (op, sk)) + | Alg_expr.STATE_ALG_OP op -> with_value counter ?time ~get_alg ~get_mix ~get_tok - (value_state_alg_op counter ?time op) sk + (value_state_alg_op counter ?time op) + sk | Alg_expr.ALG_VAR i -> exec_alg counter ?time ~get_alg ~get_mix ~get_tok (get_alg i) sk | Alg_expr.KAPPA_INSTANCE ccs -> - with_value counter ?time ~get_alg ~get_mix ~get_tok - (get_mix ccs) sk + with_value counter ?time ~get_alg ~get_mix ~get_tok (get_mix ccs) sk | Alg_expr.TOKEN_ID i -> - with_value counter ?time ~get_alg ~get_mix ~get_tok - (get_tok i) sk - | Alg_expr.CONST n -> - with_value counter ?time ~get_alg ~get_mix ~get_tok n sk - | Alg_expr.IF ((cond,_),(yes,_),(no,_)) -> - exec_bool counter ?time ~get_alg ~get_mix ~get_tok - cond (TO_EXEC_IF (yes,no,sk)) + with_value counter ?time ~get_alg ~get_mix ~get_tok (get_tok i) sk + | Alg_expr.CONST n -> with_value counter ?time ~get_alg ~get_mix ~get_tok n sk + | Alg_expr.IF ((cond, _), (yes, _), (no, _)) -> + exec_bool counter ?time ~get_alg ~get_mix ~get_tok cond + (TO_EXEC_IF (yes, no, sk)) | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ -> - raise (ExceptionDefn.Internal_Error ("Cannot evalutate derivatives in expression",Locality.dummy)) + raise + (ExceptionDefn.Internal_Error + ("Cannot evalutate derivatives in expression", Loc.dummy)) + and exec_bool : - type a. Counter.t -> ?time:float -> get_alg:(int -> Primitives.alg_expr) -> - get_mix:(Pattern.id array list -> Nbr.t) -> - get_tok:(int -> Nbr.t) -> (Pattern.id array list,int) Alg_expr.bool -> - (bool,a) stack -> a = - fun counter ?time ~get_alg ~get_mix ~get_tok expr sk -> + type a. + Counter.t -> + ?time:float -> + get_alg:(int -> Primitives.alg_expr) -> + get_mix:(Pattern.id array list -> Nbr.t) -> + get_tok:(int -> Nbr.t) -> + (Pattern.id array list, int) Alg_expr.bool -> + (bool, a) stack -> + a = + fun counter ?time ~get_alg ~get_mix ~get_tok expr sk -> match expr with - | Alg_expr.TRUE -> - with_value counter ?time ~get_alg ~get_mix ~get_tok true sk + | Alg_expr.TRUE -> with_value counter ?time ~get_alg ~get_mix ~get_tok true sk | Alg_expr.FALSE -> with_value counter ?time ~get_alg ~get_mix ~get_tok false sk - | Alg_expr.UN_BOOL_OP (op,(a,_)) -> - exec_bool counter ?time ~get_alg ~get_mix ~get_tok a (TO_COMPUTE_BOOL (op,sk)) - | Alg_expr.BIN_BOOL_OP (op,(a,_),(b,_)) -> - exec_bool counter ?time ~get_alg ~get_mix ~get_tok a (TO_EXEC_BOOL (op,b,sk)) - | Alg_expr.COMPARE_OP (op,(a,_),(b,_)) -> - exec_alg counter ?time ~get_alg ~get_mix ~get_tok a (TO_EXEC_COMP (op,b,sk)) + | Alg_expr.UN_BOOL_OP (op, (a, _)) -> + exec_bool counter ?time ~get_alg ~get_mix ~get_tok a + (TO_COMPUTE_BOOL (op, sk)) + | Alg_expr.BIN_BOOL_OP (op, (a, _), (b, _)) -> + exec_bool counter ?time ~get_alg ~get_mix ~get_tok a + (TO_EXEC_BOOL (op, b, sk)) + | Alg_expr.COMPARE_OP (op, (a, _), (b, _)) -> + exec_alg counter ?time ~get_alg ~get_mix ~get_tok a + (TO_EXEC_COMP (op, b, sk)) + and with_value : - type a b. Counter.t -> ?time:float -> get_alg:(int -> Primitives.alg_expr) -> - get_mix:(Pattern.id array list -> Nbr.t) -> - get_tok:(int -> Nbr.t) -> a -> (a,b) stack -> b = - fun counter ?time ~get_alg ~get_mix ~get_tok n -> function + type a b. + Counter.t -> + ?time:float -> + get_alg:(int -> Primitives.alg_expr) -> + get_mix:(Pattern.id array list -> Nbr.t) -> + get_tok:(int -> Nbr.t) -> + a -> + (a, b) stack -> + b = + fun counter ?time ~get_alg ~get_mix ~get_tok n -> function | RETURN -> n - | TO_EXEC_ALG (op,alg, sk) -> - exec_alg counter ?time ~get_alg ~get_mix ~get_tok alg (TO_COMPUTE_ALG (op,n,sk)) - | TO_COMPUTE_ALG (op,n1,sk) -> + | TO_EXEC_ALG (op, alg, sk) -> + exec_alg counter ?time ~get_alg ~get_mix ~get_tok alg + (TO_COMPUTE_ALG (op, n, sk)) + | TO_COMPUTE_ALG (op, n1, sk) -> + with_value counter ?time ~get_alg ~get_mix ~get_tok + (Nbr.of_bin_alg_op op n1 n) + sk + | TO_COMPUTE_UN (op, sk) -> + with_value counter ?time ~get_alg ~get_mix ~get_tok (Nbr.of_un_alg_op op n) + sk + | TO_EXEC_COMP (op, alg, sk) -> + exec_alg counter ?time ~get_alg ~get_mix ~get_tok alg + (TO_COMPUTE_COMP (op, n, sk)) + | TO_COMPUTE_COMP (op, n1, sk) -> with_value counter ?time ~get_alg ~get_mix ~get_tok - (Nbr.of_bin_alg_op op n1 n) sk - | TO_COMPUTE_UN (op,sk) -> - with_value counter ?time ~get_alg ~get_mix ~get_tok - (Nbr.of_un_alg_op op n) sk - | TO_EXEC_COMP (op,alg,sk) -> - exec_alg counter ?time ~get_alg ~get_mix ~get_tok alg (TO_COMPUTE_COMP (op,n,sk)) - | TO_COMPUTE_COMP (op,n1,sk) -> - with_value counter ?time ~get_alg ~get_mix ~get_tok (Nbr.of_compare_op op n1 n) sk - | TO_EXEC_IF (yes,no,sk) -> - exec_alg counter ?time ~get_alg ~get_mix ~get_tok (if n then yes else no) sk - | TO_EXEC_BOOL (Operator.OR,_, sk) when n -> + (Nbr.of_compare_op op n1 n) + sk + | TO_EXEC_IF (yes, no, sk) -> + exec_alg counter ?time ~get_alg ~get_mix ~get_tok + (if n then + yes + else + no) + sk + | TO_EXEC_BOOL (Operator.OR, _, sk) when n -> with_value counter ?time ~get_alg ~get_mix ~get_tok true sk - | TO_EXEC_BOOL (Operator.AND,_,sk) when not n -> + | TO_EXEC_BOOL (Operator.AND, _, sk) when not n -> with_value counter ?time ~get_alg ~get_mix ~get_tok false sk - | TO_EXEC_BOOL ((Operator.OR | Operator.AND),expr,sk) -> + | TO_EXEC_BOOL ((Operator.OR | Operator.AND), expr, sk) -> exec_bool counter ?time ~get_alg ~get_mix ~get_tok expr sk - | TO_COMPUTE_BOOL (Operator.NOT,sk) -> + | TO_COMPUTE_BOOL (Operator.NOT, sk) -> with_value counter ?time ~get_alg ~get_mix ~get_tok (not n) sk let value_bool counter ?time ~get_alg ~get_mix ~get_tok expr = exec_bool counter ?time ~get_alg ~get_mix ~get_tok expr RETURN + let value_alg counter ?time ~get_alg ~get_mix ~get_tok alg = exec_alg counter ?time ~get_alg ~get_mix ~get_tok alg RETURN diff --git a/core/simulation/expr_interpreter.mli b/core/simulation/expr_interpreter.mli index 9e2c75f7e6..9ab0d79456 100644 --- a/core/simulation/expr_interpreter.mli +++ b/core/simulation/expr_interpreter.mli @@ -7,16 +7,25 @@ (******************************************************************************) (** Algebraic expression computation *) + (** As soon as you've got an graph available, I'll probably prefer use {!module:Rule_interpreter}.value_* *) val value_alg : - Counter.t -> ?time:float -> get_alg:(int -> Primitives.alg_expr) -> + Counter.t -> + ?time:float -> + get_alg:(int -> Primitives.alg_expr) -> get_mix:(Pattern.id array list -> Nbr.t) -> - get_tok:(int -> Nbr.t) -> Primitives.alg_expr -> Nbr.t + get_tok:(int -> Nbr.t) -> + Primitives.alg_expr -> + Nbr.t (** [value_alg c ?t get_alg get_mix get_tok expr_alg] with [get_mix [interp1;...;interpn]] *) val value_bool : - Counter.t -> ?time:float -> get_alg:(int -> Primitives.alg_expr) -> - get_mix:(Pattern.id array list -> Nbr.t) -> get_tok:(int -> Nbr.t) -> - (Pattern.id array list,int) Alg_expr.bool -> bool + Counter.t -> + ?time:float -> + get_alg:(int -> Primitives.alg_expr) -> + get_mix:(Pattern.id array list -> Nbr.t) -> + get_tok:(int -> Nbr.t) -> + (Pattern.id array list, int) Alg_expr.bool -> + bool diff --git a/core/simulation/fluxmap.ml b/core/simulation/fluxmap.ml index 4b140202fc..68c6bcb0a4 100644 --- a/core/simulation/fluxmap.ml +++ b/core/simulation/fluxmap.ml @@ -25,19 +25,21 @@ let incr_flux_hit of_rule flux = let stop_flux env counter din_data = let size = Model.nb_syntactic_rules env + 1 in let din_rules = - Array.init size - (fun x -> Format.asprintf - "%a" (Model.print_ast_rule ~noCounters:false ~env) x) in + Array.init size (fun x -> + Format.asprintf "%a" (Model.print_ast_rule ~noCounters:false ~env) x) + in let () = match din_data.Data.din_kind with | Primitives.ABSOLUTE -> () | Primitives.RELATIVE | Primitives.PROBABILITY -> Array.iteri - (fun i -> Array.iteri - (fun j x -> - din_data.Data.din_fluxs.(i).(j) <- - if din_data.Data.din_hits.(i) = 0 then x - else x /. float_of_int din_data.Data.din_hits.(i))) - din_data.Data.din_fluxs in - { Data.din_rules; Data.din_data; - Data.din_end = Counter.current_time counter } + (fun i -> + Array.iteri (fun j x -> + din_data.Data.din_fluxs.(i).(j) <- + (if din_data.Data.din_hits.(i) = 0 then + x + else + x /. float_of_int din_data.Data.din_hits.(i)))) + din_data.Data.din_fluxs + in + { Data.din_rules; Data.din_data; Data.din_end = Counter.current_time counter } diff --git a/core/simulation/fluxmap.mli b/core/simulation/fluxmap.mli index 7666973efe..e3c5920b90 100644 --- a/core/simulation/fluxmap.mli +++ b/core/simulation/fluxmap.mli @@ -6,9 +6,9 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) +val create_flux : Model.t -> Counter.t -> Primitives.din_kind -> Data.din_data (** Flux map *) -val create_flux : - Model.t -> Counter.t -> Primitives.din_kind -> Data.din_data + val stop_flux : Model.t -> Counter.t -> Data.din_data -> Data.din val incr_flux_flux : int -> int -> float -> Data.din_data -> unit diff --git a/core/simulation/generic_rule_interpreter.ml b/core/simulation/generic_rule_interpreter.ml index 119722da23..a7204a1fd2 100644 --- a/core/simulation/generic_rule_interpreter.ml +++ b/core/simulation/generic_rule_interpreter.ml @@ -6,76 +6,73 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type precomputed = - { - unary_patterns: Pattern.Set.t; - always_outdated: Operator.DepSet.t; - } +type precomputed = { + unary_patterns: Pattern.Set.t; + always_outdated: Operator.DepSet.t; +} -module Make (Instances:Instances_sig.S) = struct +module Make (Instances : Instances_sig.S) = struct type event_predicate = - int option -> Matching.t -> - (Instantiation.concrete Instantiation.test) list -> - (Instantiation.concrete Instantiation.action) list -> + int option -> + Matching.t -> + Instantiation.concrete Instantiation.test list -> + Instantiation.concrete Instantiation.action list -> bool type imperative_fields = { - precomputed: precomputed; - - instances: Instances.t; - - variables_cache: Nbr.t array; - variables_overwrite: Primitives.alg_expr option array; - - tokens: Nbr.t array; - - activities : Random_tree.tree; - (* pair numbers are regular rule, odd unary instances *) - - random_state : Random.State.t; - - story_machinery : - (string (*obs name*) * Pattern.id array * - Instantiation.abstract Instantiation.test list list) - list Pattern.ObsMap.t (*currently tracked ccs *) option; - species : - (string (*filename*) * Pattern.id array (*with only one pattern*) * - Instantiation.abstract Instantiation.test list list) list - Pattern.ObsMap.t; - - changed_connectivity : (int,unit) Hashtbl.t; - (* set of ccs that have changed *) - } + precomputed: precomputed; + instances: Instances.t; + variables_cache: Nbr.t array; + variables_overwrite: Primitives.alg_expr option array; + tokens: Nbr.t array; + activities: Random_tree.tree; + (* pair numbers are regular rule, odd unary instances *) + random_state: Random.State.t; + story_machinery: + (string (*obs name*) + * Pattern.id array + * Instantiation.abstract Instantiation.test list list) + list + Pattern.ObsMap.t + (*currently tracked ccs *) + option; + species: + (string (*filename*) + * Pattern.id array (*with only one pattern*) + * Instantiation.abstract Instantiation.test list list) + list + Pattern.ObsMap.t; + changed_connectivity: (int, unit) Hashtbl.t; + (* set of ccs that have changed *) + } type instance = - bool * int * - (Kappa_terms.Matching.t * int list * Kappa_mixtures.Edges.path option) option - - type t = - { - mutable outdated : bool; - - (* Without rectangular approximation *) - matchings_of_rule: - (Matching.t * int list) list Mods.IntMap.t; - unary_candidates: (* rule_id -> list of matchings *) - (Matching.t * int list * Edges.path option) list Mods.IntMap.t; - (* rule -> cc -> number_instances (activity per cc) *) - nb_rectangular_instances_by_cc: ValMap.t Mods.IntMap.t; - - edges: Edges.t; - - imp: imperative_fields; - - outdated_elements: Operator.DepSet.t; - - events_to_block : event_predicate option - } + bool + * int + * (Kappa_terms.Matching.t * int list * Kappa_mixtures.Edges.path option) + option + + type t = { + mutable outdated: bool; + (* Without rectangular approximation *) + matchings_of_rule: (Matching.t * int list) list Mods.IntMap.t; + unary_candidates: + (* rule_id -> list of matchings *) + (Matching.t * int list * Edges.path option) list Mods.IntMap.t; + (* rule -> cc -> number_instances (activity per cc) *) + nb_rectangular_instances_by_cc: ValMap.t Mods.IntMap.t; + edges: Edges.t; + imp: imperative_fields; + outdated_elements: Operator.DepSet.t; + events_to_block: event_predicate option; + } let get_edges st = st.edges let sum_instances_numbers ?rule_id insts l = - List.fold_left (fun ac x -> ac + Instances.number_of_instances ?rule_id insts x) 0 l + List.fold_left + (fun ac x -> ac + Instances.number_of_instances ?rule_id insts x) + 0 l type result = Clash | Corrected | Blocked | Success of t @@ -86,27 +83,26 @@ module Make (Instances:Instances_sig.S) = struct let value_bool counter state expr = let () = assert (not state.outdated) in - Expr_interpreter.value_bool - counter ~get_alg:(fun i -> Alg_expr.CONST state.imp.variables_cache.(i)) + Expr_interpreter.value_bool counter + ~get_alg:(fun i -> Alg_expr.CONST state.imp.variables_cache.(i)) ~get_mix:(fun patterns -> - Nbr.I (sum_instances_numbers state.imp.instances patterns)) + Nbr.I (sum_instances_numbers state.imp.instances patterns)) ~get_tok:(fun i -> state.imp.tokens.(i)) expr + let value_alg counter state alg = let () = assert (not state.outdated) in - Expr_interpreter.value_alg - counter ~get_alg:(fun i -> Alg_expr.CONST state.imp.variables_cache.(i)) + Expr_interpreter.value_alg counter + ~get_alg:(fun i -> Alg_expr.CONST state.imp.variables_cache.(i)) ~get_mix:(fun patterns -> - Nbr.I (sum_instances_numbers state.imp.instances patterns)) + Nbr.I (sum_instances_numbers state.imp.instances patterns)) ~get_tok:(fun i -> state.imp.tokens.(i)) alg - let recompute env counter state i = state.imp.variables_cache.(i) <- value_alg counter state (raw_get_alg env state.imp.variables_overwrite i) - let activity state = Random_tree.total state.imp.activities let get_activity rule state = Random_tree.find rule state.imp.activities let set_activity rule v state = Random_tree.add rule v state.imp.activities @@ -115,48 +111,52 @@ module Make (Instances:Instances_sig.S) = struct let initial_activity ~outputs env counter state = Model.fold_rules (fun i () rule -> - if Array.length rule.Primitives.connected_components = 0 then - match Nbr.to_float @@ value_alg - counter state (fst rule.Primitives.rate) with - | None -> - outputs (Data.Warning - (Some (snd rule.Primitives.rate), - fun f -> - let noCounters = false in - - Format.fprintf f - "Problematic rule rate replaced by 0"; - (Kappa_printer.elementary_rule ~env ~noCounters f rule))) - | Some rate -> set_activity (2*i) rate state) + if Array.length rule.Primitives.connected_components = 0 then ( + match + Nbr.to_float @@ value_alg counter state (fst rule.Primitives.rate) + with + | None -> + outputs + (Data.Warning + ( Some (snd rule.Primitives.rate), + fun f -> + let noCounters = false in + + Format.fprintf f "Problematic rule rate replaced by 0"; + Kappa_printer.elementary_rule ~env ~noCounters f rule )) + | Some rate -> set_activity (2 * i) rate state + )) () env let empty ~outputs ~with_trace random_state env counter = - let activity_tree = Random_tree.create (2*Model.nb_rules env) in + let activity_tree = Random_tree.create (2 * Model.nb_rules env) in let unary_patterns = Model.unary_patterns env in let always_outdated = - let (deps_in_t,deps_in_e,_,_) = Model.all_dependencies env in - Operator.DepSet.union deps_in_t deps_in_e in + let deps_in_t, deps_in_e, _, _ = Model.all_dependencies env in + Operator.DepSet.union deps_in_t deps_in_e + in let with_connected_components = not (Pattern.Set.is_empty unary_patterns) in let variables_overwrite = Array.make (Model.nb_algs env) None in let variables_cache = Array.make (Model.nb_algs env) Nbr.zero in let cand = { - imp = { - activities = activity_tree ; - precomputed = { unary_patterns; always_outdated}; - instances = Instances.empty env; - variables_overwrite; variables_cache; - tokens = Array.make (Model.nb_tokens env) Nbr.zero; - random_state; - story_machinery = - if with_trace then - Some (Pattern.Env.new_obs_map - (Model.domain env) (fun _ -> [])) - else None; - species = Pattern.Env.new_obs_map - (Model.domain env) (fun _ -> []); - changed_connectivity = Hashtbl.create 32; - }; + imp = + { + activities = activity_tree; + precomputed = { unary_patterns; always_outdated }; + instances = Instances.empty env; + variables_overwrite; + variables_cache; + tokens = Array.make (Model.nb_tokens env) Nbr.zero; + random_state; + story_machinery = + (if with_trace then + Some (Pattern.Env.new_obs_map (Model.domain env) (fun _ -> [])) + else + None); + species = Pattern.Env.new_obs_map (Model.domain env) (fun _ -> []); + changed_connectivity = Hashtbl.create 32; + }; outdated = false; matchings_of_rule = Mods.IntMap.empty; unary_candidates = Mods.IntMap.empty; @@ -164,566 +164,636 @@ module Make (Instances:Instances_sig.S) = struct edges = Edges.empty ~with_connected_components; outdated_elements = always_outdated; events_to_block = None; - } in + } + in let () = Tools.iteri (recompute env counter cand) (Model.nb_algs env) in let () = initial_activity ~outputs env counter cand in cand - let concrete_actions_for_incomplete_inj ~debugMode rule matching = + let concrete_actions_for_incomplete_inj ~debug_mode rule matching = let abstract_actions = - rule.Primitives.instantiations.Instantiation.actions in - let inj = (matching, Mods.IntMap.empty) in + rule.Primitives.instantiations.Instantiation.actions + in + let inj = matching, Mods.IntMap.empty in List_util.map_option - (Instantiation.try_concretize_action ~debugMode inj) abstract_actions + (Instantiation.try_concretize_action ~debug_mode inj) + abstract_actions - let concrete_tests ~debugMode rule matching = + let concrete_tests ~debug_mode rule matching = let abstract_tests = - rule.Primitives.instantiations.Instantiation.tests - |> List.concat in - let inj = (matching, Mods.IntMap.empty) in - List.map - (Instantiation.concretize_test ~debugMode inj) abstract_tests + rule.Primitives.instantiations.Instantiation.tests |> List.concat + in + let inj = matching, Mods.IntMap.empty in + List.map (Instantiation.concretize_test ~debug_mode inj) abstract_tests - let is_blocked ~debugMode state ?rule_id rule matching = + let is_blocked ~debug_mode state ?rule_id rule matching = match state.events_to_block with | None -> false | Some to_block -> let actions = - concrete_actions_for_incomplete_inj ~debugMode rule matching in - let tests = concrete_tests ~debugMode rule matching in + concrete_actions_for_incomplete_inj ~debug_mode rule matching + in + let tests = concrete_tests ~debug_mode rule matching in to_block rule_id matching tests actions let set_events_to_block predicate state = - { state with - events_to_block = predicate ; - matchings_of_rule = Mods.IntMap.empty ; - unary_candidates = Mods.IntMap.empty ; + { + state with + events_to_block = predicate; + matchings_of_rule = Mods.IntMap.empty; + unary_candidates = Mods.IntMap.empty; } - let instance_to_matching ~debugMode domain edges instance patterns = + let instance_to_matching ~debug_mode domain edges instance patterns = Tools.array_fold_lefti (fun i matching root -> - match matching with - | None -> None - | Some matching -> - Matching.reconstruct - ~debugMode domain edges matching i patterns.(i) root) + match matching with + | None -> None + | Some matching -> + Matching.reconstruct ~debug_mode domain edges matching i patterns.(i) + root) (Some Matching.empty) instance - let all_injections - ~debugMode ?excp ?unary_rate ?rule_id state_insts domain edges patterna = + let all_injections ~debug_mode ?excp ?unary_rate ?rule_id state_insts domain + edges patterna = let out = Instances.fold_instances ?excp ?rule_id state_insts patterna ~init:[] (fun instance acc -> - match instance_to_matching - ~debugMode domain edges instance patterna with - | None -> acc - | Some matching -> - let rev_roots = Array.fold_left (fun t h -> h::t) [] instance in - (matching, rev_roots) :: acc - ) in + match + instance_to_matching ~debug_mode domain edges instance patterna + with + | None -> acc + | Some matching -> + let rev_roots = Array.fold_left (fun t h -> h :: t) [] instance in + (matching, rev_roots) :: acc) + in match unary_rate with | None -> out - | Some (_,None) -> + | Some (_, None) -> List.filter (function | _, [ r1; r2 ] -> not (Edges.in_same_connected_component r1 r2 edges) | _, _ -> false) out - | Some (_,(Some _ as max_distance)) -> + | Some (_, (Some _ as max_distance)) -> List.filter - (fun (inj,_) -> - let nodes = Matching.elements_with_types domain patterna inj in - None = - Edges.are_connected ?max_distance edges nodes.(0) nodes.(1)) + (fun (inj, _) -> + let nodes = Matching.elements_with_types domain patterna inj in + None = Edges.are_connected ?max_distance edges nodes.(0) nodes.(1)) out let pop_exact_matchings matchings_of_rule rule = snd (Mods.IntMap.pop rule matchings_of_rule) - let pick_a_rule_instance - ~debugMode state random_state domain edges ?rule_id rule = + let pick_a_rule_instance ~debug_mode state random_state domain edges ?rule_id + rule = let from_patterns () = let pats = rule.Primitives.connected_components in - Instances.fold_picked_instance ?rule_id - state.imp.instances random_state pats ~init:(Matching.empty,[],None) - (fun id pattern root (inj, rev_roots,_) -> - match Matching.reconstruct - ~debugMode domain edges inj id pattern root with - | None -> None - | Some inj' -> Some (inj',root::rev_roots,None) - ) in + Instances.fold_picked_instance ?rule_id state.imp.instances random_state + pats ~init:(Matching.empty, [], None) + (fun id pattern root (inj, rev_roots, _) -> + match + Matching.reconstruct ~debug_mode domain edges inj id pattern root + with + | None -> None + | Some inj' -> Some (inj', root :: rev_roots, None)) + in match rule_id with | None -> from_patterns () | Some id -> - match Mods.IntMap.find_option id state.matchings_of_rule with + (match Mods.IntMap.find_option id state.matchings_of_rule with | Some [] -> None - | Some l -> let (a,b) = List_util.random random_state l in Some (a,b,None) - | None -> from_patterns () + | Some l -> + let a, b = List_util.random random_state l in + Some (a, b, None) + | None -> from_patterns ()) - let adjust_rule_instances - ~debugMode ~rule_id ?unary_rate state domain edges ccs rule = - let matches = all_injections - ~debugMode ?unary_rate ~rule_id state.imp.instances domain edges ccs in + let adjust_rule_instances ~debug_mode ~rule_id ?unary_rate state domain edges + ccs rule = let matches = - if state.events_to_block = None then matches - else matches |> List.filter (fun (matching, _) -> - not (is_blocked ~debugMode state ~rule_id rule matching)) in - List.length matches, - { state with - matchings_of_rule = - Mods.IntMap.add rule_id matches state.matchings_of_rule } + all_injections ~debug_mode ?unary_rate ~rule_id state.imp.instances domain + edges ccs + in + let matches = + if state.events_to_block = None then + matches + else + matches + |> List.filter (fun (matching, _) -> + not (is_blocked ~debug_mode state ~rule_id rule matching)) + in + ( List.length matches, + { + state with + matchings_of_rule = + Mods.IntMap.add rule_id matches state.matchings_of_rule; + } ) (* With rectangular approximation *) - let compute_unary_number - instances (nb_rectangular_instances_by_cc, unary_candidates) - modified_ccs rule rule_id = + let compute_unary_number instances + (nb_rectangular_instances_by_cc, unary_candidates) modified_ccs rule + rule_id = let pat1 = rule.Primitives.connected_components.(0) in let pat2 = rule.Primitives.connected_components.(1) in let number_of_unary_instances_in_cc = - Instances.number_of_unary_instances_in_cc - ~rule_id instances (pat1, pat2) in + Instances.number_of_unary_instances_in_cc ~rule_id instances (pat1, pat2) + in let old_pack = - Mods.IntMap.find_default - ValMap.empty rule_id nb_rectangular_instances_by_cc in + Mods.IntMap.find_default ValMap.empty rule_id + nb_rectangular_instances_by_cc + in let new_pack = Hashtbl.fold (fun cc () i_inst -> let new_v = number_of_unary_instances_in_cc cc in - if new_v = 0 then ValMap.remove cc i_inst - else ValMap.add cc new_v i_inst) - modified_ccs old_pack in + if new_v = 0 then + ValMap.remove cc i_inst + else + ValMap.add cc new_v i_inst) + modified_ccs old_pack + in let va = ValMap.total new_pack in let nb_rectangular_instances_by_cc' = if va = 0L then Mods.IntMap.remove rule_id nb_rectangular_instances_by_cc - else Mods.IntMap.add rule_id new_pack nb_rectangular_instances_by_cc in + else + Mods.IntMap.add rule_id new_pack nb_rectangular_instances_by_cc + in let _, unary_candidates' = (* Invalidates the cache *) - Mods.IntMap.pop rule_id unary_candidates in - (va, (nb_rectangular_instances_by_cc', unary_candidates')) + Mods.IntMap.pop rule_id unary_candidates + in + va, (nb_rectangular_instances_by_cc', unary_candidates') - let pick_a_unary_rule_instance - ~debugMode state random_state domain edges ~rule_id rule = + let pick_a_unary_rule_instance ~debug_mode state random_state domain edges + ~rule_id rule = match Mods.IntMap.find_option rule_id state.unary_candidates with | Some l -> - let inj,roots,path = List_util.random random_state l in - Some (inj,roots,path) + let inj, roots, path = List_util.random random_state l in + Some (inj, roots, path) | None -> let pat1 = rule.Primitives.connected_components.(0) in let pat2 = rule.Primitives.connected_components.(1) in let pick_unary_instance_in_cc = - Instances.pick_unary_instance_in_cc ~rule_id - state.imp.instances random_state (pat1, pat2) in - let cc_id = ValMap.random - random_state - (Mods.IntMap.find_default - ValMap.empty rule_id state.nb_rectangular_instances_by_cc) in + Instances.pick_unary_instance_in_cc ~rule_id state.imp.instances + random_state (pat1, pat2) + in + let cc_id = + ValMap.random random_state + (Mods.IntMap.find_default ValMap.empty rule_id + state.nb_rectangular_instances_by_cc) + in let root1, root2 = pick_unary_instance_in_cc cc_id in let () = - if debugMode then - Format.printf "@[On roots:@ %i@ %i@]@." root1 root2 in + if debug_mode then Format.printf "@[On roots:@ %i@ %i@]@." root1 root2 + in let pattern1 = rule.Primitives.connected_components.(0) in let pattern2 = rule.Primitives.connected_components.(1) in let inj1 = - Matching.reconstruct - ~debugMode domain edges Matching.empty 0 pattern1 root1 in - match inj1 with + Matching.reconstruct ~debug_mode domain edges Matching.empty 0 pattern1 + root1 + in + (match inj1 with | None -> None | Some inj -> - match Matching.reconstruct ~debugMode domain edges inj 1 pattern2 root2 with + (match + Matching.reconstruct ~debug_mode domain edges inj 1 pattern2 root2 + with | None -> None - | Some inj_out -> Some (inj_out,[root2;root1],None) - - let adjust_unary_rule_instances - ~debugMode ~rule_id ?max_distance state domain graph pats rule = - let pattern1 = pats.(0) in let pattern2 = pats.(1) in - let cands,len = - Instances.fold_unary_instances ~rule_id - state.imp.instances (pattern1, pattern2) ~init:([], 0) - (fun (root1, root2) (list,len as out) -> - let inj1 = Matching.reconstruct - ~debugMode domain graph Matching.empty 0 pattern1 root1 in - match inj1 with - | None -> out - | Some inj -> - match Matching.reconstruct - ~debugMode domain graph inj 1 pattern2 root2 with - | None -> out - | Some inj' -> - match max_distance with - | None -> (inj',[root2;root1],None)::list,succ len - | Some _ -> - let nodes = - Matching.elements_with_types domain pats inj' in - match Edges.are_connected ?max_distance - graph nodes.(0) nodes.(1) with - | None -> out - | Some _ as p -> - if is_blocked ~debugMode state ~rule_id rule inj' then out - else (inj',[root2;root1],p)::list,succ len - ) in + | Some inj_out -> Some (inj_out, [ root2; root1 ], None))) + + let adjust_unary_rule_instances ~debug_mode ~rule_id ?max_distance state + domain graph pats rule = + let pattern1 = pats.(0) in + let pattern2 = pats.(1) in + let cands, len = + Instances.fold_unary_instances ~rule_id state.imp.instances + (pattern1, pattern2) ~init:([], 0) + (fun (root1, root2) ((list, len) as out) -> + let inj1 = + Matching.reconstruct ~debug_mode domain graph Matching.empty 0 + pattern1 root1 + in + match inj1 with + | None -> out + | Some inj -> + (match + Matching.reconstruct ~debug_mode domain graph inj 1 pattern2 + root2 + with + | None -> out + | Some inj' -> + (match max_distance with + | None -> (inj', [ root2; root1 ], None) :: list, succ len + | Some _ -> + let nodes = Matching.elements_with_types domain pats inj' in + (match + Edges.are_connected ?max_distance graph nodes.(0) nodes.(1) + with + | None -> out + | Some _ as p -> + if is_blocked ~debug_mode state ~rule_id rule inj' then + out + else + (inj', [ root2; root1 ], p) :: list, succ len)))) + in let unary_candidates = - if len = 0 then Mods.IntMap.remove rule_id state.unary_candidates - else Mods.IntMap.add rule_id cands state.unary_candidates in + if len = 0 then + Mods.IntMap.remove rule_id state.unary_candidates + else + Mods.IntMap.add rule_id cands state.unary_candidates + in len, { state with unary_candidates } let print env f state = let sigs = Model.signatures env in - Format.fprintf - f "@[%a@,%a@]" - (Pp.list Pp.space (fun f (i,mix) -> + Format.fprintf f "@[%a@,%a@]" + (Pp.list Pp.space (fun f (i, mix) -> Format.fprintf f "%%init: %i @[%a@]" i User_graph.print_cc mix)) - (Edges.build_user_snapshot ~debugMode:false ~raw:false sigs state.edges) + (Edges.build_user_snapshot ~debug_mode:false ~raw:false sigs state.edges) (Pp.array Pp.space (fun i f el -> - Format.fprintf - f "%%init: %a %a" - Nbr.print el (Model.print_token ~env) i)) + Format.fprintf f "%%init: %a %a" Nbr.print el + (Model.print_token ~env) i)) state.imp.tokens let debug_print f state = - Format.fprintf - f "@[%a@,%a@,%a@]" - Edges.debug_print state.edges + Format.fprintf f "@[%a@,%a@,%a@]" Edges.debug_print state.edges (Pp.array Pp.space (fun i f el -> - Format.fprintf f "%a token_%i" - Nbr.print el i)) - state.imp.tokens - Instances.debug_print state.imp.instances + Format.fprintf f "%a token_%i" Nbr.print el i)) + state.imp.tokens Instances.debug_print state.imp.instances - type stats = { mixture_stats : Edges.stats } + type stats = { mixture_stats: Edges.stats } - let stats state = { - mixture_stats = Edges.stats state.edges; - } + let stats state = { mixture_stats = Edges.stats state.edges } let print_stats f state = Format.fprintf f "%i agents" (stats state).mixture_stats.Edges.nb_agents - let new_place free_id (inj_nodes,inj_fresh) = function + let new_place free_id (inj_nodes, inj_fresh) = function | Matching.Agent.Existing _ -> failwith "Rule_interpreter.new_place" - | Matching.Agent.Fresh (_,id) -> - (inj_nodes,Mods.IntMap.add id free_id inj_fresh) + | Matching.Agent.Fresh (_, id) -> + inj_nodes, Mods.IntMap.add id free_id inj_fresh - let apply_negative_transformation - ?mod_connectivity_store instances (side_effects,edges) = function - | Primitives.Transformation.Agent (id,_) -> + let apply_negative_transformation ?mod_connectivity_store instances + (side_effects, edges) = function + | Primitives.Transformation.Agent (id, _) -> let edges' = Edges.remove_agent id edges in - (side_effects,edges') - | Primitives.Transformation.Freed ((id,_),s) -> (*(n,s)-bottom*) + side_effects, edges' + | Primitives.Transformation.Freed ((id, _), s) -> + (*(n,s)-bottom*) let edges' = Edges.remove_free id s edges in - (side_effects,edges') - | Primitives.Transformation.Linked (((id,_),s),((id',_),s')) -> - let edges',cc_modif = Edges.remove_link id s id' s' edges in - let () = Instances.break_apart_cc - instances edges' ?mod_connectivity_store cc_modif in - (side_effects,edges') - | Primitives.Transformation.NegativeWhatEver ((id,_),s as n) -> - begin - match (List.partition (fun x -> x =n) side_effects) with - | (_::_,side_effects') -> (side_effects',edges) - | ([],_) -> - match Edges.link_destination id s edges with - | None -> (side_effects,Edges.remove_free id s edges) - | Some ((id',_ as nc'),s') -> - let edges',cc_modif = Edges.remove_link id s id' s' edges in - let () = Instances.break_apart_cc - instances edges' ?mod_connectivity_store cc_modif in - ((nc',s')::side_effects,edges') - end + side_effects, edges' + | Primitives.Transformation.Linked (((id, _), s), ((id', _), s')) -> + let edges', cc_modif = Edges.remove_link id s id' s' edges in + let () = + Instances.break_apart_cc instances edges' ?mod_connectivity_store + cc_modif + in + side_effects, edges' + | Primitives.Transformation.NegativeWhatEver (((id, _), s) as n) -> + (match List.partition (fun x -> x = n) side_effects with + | _ :: _, side_effects' -> side_effects', edges + | [], _ -> + (match Edges.link_destination id s edges with + | None -> side_effects, Edges.remove_free id s edges + | Some (((id', _) as nc'), s') -> + let edges', cc_modif = Edges.remove_link id s id' s' edges in + let () = + Instances.break_apart_cc instances edges' ?mod_connectivity_store + cc_modif + in + (nc', s') :: side_effects, edges')) | Primitives.Transformation.PositiveInternalized _ -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot "PositiveInternalized in negative update")) - | Primitives.Transformation.NegativeInternalized ((id,_),s) -> - let _,edges' = Edges.remove_internal id s edges in - (side_effects,edges') - - let apply_positive_transformation - ~debugMode sigs ?mod_connectivity_store instances - (inj2graph,side_effects,edges) = - function + (Loc.annot_with_dummy "PositiveInternalized in negative update")) + | Primitives.Transformation.NegativeInternalized ((id, _), s) -> + let _, edges' = Edges.remove_internal id s edges in + side_effects, edges' + + let apply_positive_transformation ~debug_mode sigs ?mod_connectivity_store + instances (inj2graph, side_effects, edges) = function | Primitives.Transformation.Agent n -> - let nc, inj2graph',edges' = + let nc, inj2graph', edges' = let ty = Matching.Agent.get_type n in - let id,edges' = Edges.add_agent sigs ty edges in - (id,ty),new_place id inj2graph n,edges' in - (inj2graph',side_effects,edges'), - Primitives.Transformation.Agent nc - | Primitives.Transformation.Freed (n,s) -> (*(n,s)-bottom*) - let (id,_ as nc) = - Matching.Agent.concretize ~debugMode inj2graph n in (*(A,23)*) + let id, edges' = Edges.add_agent sigs ty edges in + (id, ty), new_place id inj2graph n, edges' + in + (inj2graph', side_effects, edges'), Primitives.Transformation.Agent nc + | Primitives.Transformation.Freed (n, s) -> + (*(n,s)-bottom*) + let ((id, _) as nc) = Matching.Agent.concretize ~debug_mode inj2graph n in + (*(A,23)*) let edges' = Edges.add_free id s edges in let side_effects' = - List_util.smart_filter (fun x -> x <> (nc,s)) side_effects in - (inj2graph,side_effects',edges'), - Primitives.Transformation.Freed (nc,s) - | Primitives.Transformation.Linked ((n,s),(n',s')) -> - let nc = Matching.Agent.concretize ~debugMode inj2graph n in - let nc' = Matching.Agent.concretize ~debugMode inj2graph n' in - let edges',modif_cc = Edges.add_link nc s nc' s' edges in - let side_effects' = List_util.smart_filter - (fun x -> x<>(nc,s) && x<>(nc',s')) side_effects in - let () = - Instances.merge_cc instances ?mod_connectivity_store modif_cc in - (inj2graph,side_effects',edges'), - Primitives.Transformation.Linked ((nc,s),(nc',s')) + List_util.smart_filter (fun x -> x <> (nc, s)) side_effects + in + (inj2graph, side_effects', edges'), Primitives.Transformation.Freed (nc, s) + | Primitives.Transformation.Linked ((n, s), (n', s')) -> + let nc = Matching.Agent.concretize ~debug_mode inj2graph n in + let nc' = Matching.Agent.concretize ~debug_mode inj2graph n' in + let edges', modif_cc = Edges.add_link nc s nc' s' edges in + let side_effects' = + List_util.smart_filter + (fun x -> x <> (nc, s) && x <> (nc', s')) + side_effects + in + let () = Instances.merge_cc instances ?mod_connectivity_store modif_cc in + ( (inj2graph, side_effects', edges'), + Primitives.Transformation.Linked ((nc, s), (nc', s')) ) | Primitives.Transformation.NegativeWhatEver _ -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot "NegativeWhatEver in positive update")) - | Primitives.Transformation.PositiveInternalized (n,s,i) -> - let (id,_ as nc) = Matching.Agent.concretize ~debugMode inj2graph n in + (Loc.annot_with_dummy "NegativeWhatEver in positive update")) + | Primitives.Transformation.PositiveInternalized (n, s, i) -> + let ((id, _) as nc) = Matching.Agent.concretize ~debug_mode inj2graph n in let edges' = Edges.add_internal id s i edges in - (inj2graph,side_effects,edges'), - Primitives.Transformation.PositiveInternalized (nc,s,i) + ( (inj2graph, side_effects, edges'), + Primitives.Transformation.PositiveInternalized (nc, s, i) ) | Primitives.Transformation.NegativeInternalized _ -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot "NegativeInternalized in positive update")) + (Loc.annot_with_dummy "NegativeInternalized in positive update")) - let apply_concrete_positive_transformation - sigs ?mod_connectivity_store instances edges = function - | Primitives.Transformation.Agent (id,ty) -> - let _,edges' = Edges.add_agent ~id sigs ty edges in + let apply_concrete_positive_transformation sigs ?mod_connectivity_store + instances edges = function + | Primitives.Transformation.Agent (id, ty) -> + let _, edges' = Edges.add_agent ~id sigs ty edges in edges' - | Primitives.Transformation.Freed ((id,_),s) -> (*(n,s)-bottom*) + | Primitives.Transformation.Freed ((id, _), s) -> + (*(n,s)-bottom*) let edges' = Edges.add_free id s edges in edges' - | Primitives.Transformation.Linked ((nc,s),(nc',s')) -> - let edges',modif_cc = Edges.add_link nc s nc' s' edges in - let () = - Instances.merge_cc instances ?mod_connectivity_store modif_cc in + | Primitives.Transformation.Linked ((nc, s), (nc', s')) -> + let edges', modif_cc = Edges.add_link nc s nc' s' edges in + let () = Instances.merge_cc instances ?mod_connectivity_store modif_cc in edges' | Primitives.Transformation.NegativeWhatEver _ -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot "NegativeWhatEver in positive update")) - | Primitives.Transformation.PositiveInternalized ((id,_),s,i) -> + (Loc.annot_with_dummy "NegativeWhatEver in positive update")) + | Primitives.Transformation.PositiveInternalized ((id, _), s, i) -> let edges' = Edges.add_internal id s i edges in edges' | Primitives.Transformation.NegativeInternalized _ -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot "NegativeInternalized in positive update")) + (Loc.annot_with_dummy "NegativeInternalized in positive update")) - let obs_from_transformation ~debugMode domain edges acc = function + let obs_from_transformation ~debug_mode domain edges acc = function | Primitives.Transformation.Agent nc -> Matching.observables_from_agent domain edges acc nc - | Primitives.Transformation.Freed (nc,s) -> (*(n,s)-bottom*) - Matching.observables_from_free ~debugMode domain edges acc nc s - | Primitives.Transformation.Linked ((nc,s),(nc',s')) -> - Matching.observables_from_link - ~debugMode domain edges acc nc s nc' s' - | Primitives.Transformation.PositiveInternalized (nc,s,i) -> - Matching.observables_from_internal - ~debugMode domain edges acc nc s i - | Primitives.Transformation.NegativeInternalized ((id,_ as nc),s) -> - let i = Edges.get_internal id s edges in - Matching.observables_from_internal - ~debugMode domain edges acc nc s i - | Primitives.Transformation.NegativeWhatEver ((id,_ as nc),s) -> - match Edges.link_destination id s edges with - | None -> - Matching.observables_from_free ~debugMode domain edges acc nc s - | Some (nc',s') -> - Matching.observables_from_link - ~debugMode domain edges acc nc s nc' s' - - let obs_from_transformations ~debugMode domain edges trans = + | Primitives.Transformation.Freed (nc, s) -> + (*(n,s)-bottom*) + Matching.observables_from_free ~debug_mode domain edges acc nc s + | Primitives.Transformation.Linked ((nc, s), (nc', s')) -> + Matching.observables_from_link ~debug_mode domain edges acc nc s nc' s' + | Primitives.Transformation.PositiveInternalized (nc, s, i) -> + Matching.observables_from_internal ~debug_mode domain edges acc nc s i + | Primitives.Transformation.NegativeInternalized (((id, _) as nc), s) -> + let i = Edges.get_internal id s edges in + Matching.observables_from_internal ~debug_mode domain edges acc nc s i + | Primitives.Transformation.NegativeWhatEver (((id, _) as nc), s) -> + (match Edges.link_destination id s edges with + | None -> Matching.observables_from_free ~debug_mode domain edges acc nc s + | Some (nc', s') -> + Matching.observables_from_link ~debug_mode domain edges acc nc s nc' s') + + let obs_from_transformations ~debug_mode domain edges trans = List.fold_left - (obs_from_transformation ~debugMode domain edges) - (([],Operator.DepSet.empty),Matching.empty_cache) + (obs_from_transformation ~debug_mode domain edges) + (([], Operator.DepSet.empty), Matching.empty_cache) trans |> fst let path_tests path tests = let known_agents = List.fold_left - (List.fold_left - (fun acc -> function - | Instantiation.Is_Here (id,_) -> Mods.IntSet.add id acc - | Instantiation.Is_Bound_to _ | Instantiation.Is_Bound _ - | Instantiation.Has_Internal _ | Instantiation.Has_Binding_type _ - | Instantiation.Is_Free _ -> acc)) Mods.IntSet.empty tests in + (List.fold_left (fun acc -> function + | Instantiation.Is_Here (id, _) -> Mods.IntSet.add id acc + | Instantiation.Is_Bound_to _ | Instantiation.Is_Bound _ + | Instantiation.Has_Internal _ | Instantiation.Has_Binding_type _ + | Instantiation.Is_Free _ -> + acc)) + Mods.IntSet.empty tests + in let pretests = List_util.map_option - (fun (x,y) -> - if List.for_all - (List.for_all - (function - | Instantiation.Is_Bound_to (a,b) -> - x <> a && x <> b && y<>a && y<>b - | Instantiation.Has_Internal _ | Instantiation.Is_Free _ - | Instantiation.Is_Bound _ | Instantiation.Has_Binding_type _ - | Instantiation.Is_Here _ -> true)) tests - then Some (Instantiation.Is_Bound_to (x,y)) - else None) path in - let _,path_tests = + (fun (x, y) -> + if + List.for_all + (List.for_all (function + | Instantiation.Is_Bound_to (a, b) -> + x <> a && x <> b && y <> a && y <> b + | Instantiation.Has_Internal _ | Instantiation.Is_Free _ + | Instantiation.Is_Bound _ | Instantiation.Has_Binding_type _ + | Instantiation.Is_Here _ -> + true)) + tests + then + Some (Instantiation.Is_Bound_to (x, y)) + else + None) + path + in + let _, path_tests = List.fold_left - (fun (ag,te) (((id,_ as a),_),((id',_ as a'),_)) -> - let ag',te' = - if Mods.IntSet.mem id ag then ag,te - else Mods.IntSet.add id ag,Instantiation.Is_Here a::te in - if Mods.IntSet.mem id' ag' then ag',te' - else Mods.IntSet.add id' ag',Instantiation.Is_Here a'::te') - (known_agents,pretests) path in + (fun (ag, te) ((((id, _) as a), _), (((id', _) as a'), _)) -> + let ag', te' = + if Mods.IntSet.mem id ag then + ag, te + else + Mods.IntSet.add id ag, Instantiation.Is_Here a :: te + in + if Mods.IntSet.mem id' ag' then + ag', te' + else + Mods.IntSet.add id' ag', Instantiation.Is_Here a' :: te') + (known_agents, pretests) path + in path_tests let step_of_event counter = function - | Trace.INIT _,e -> (Trace.Init e.Instantiation.actions) - | Trace.RULE r,x -> - (Trace.Rule (r,x,Counter.current_simulation_info counter)) - | Trace.PERT p,x -> - (Trace.Pert (p,x,Counter.current_simulation_info counter)) - - let store_event - ~debugMode counter inj2graph new_tracked_obs_instances event_kind - ?path extra_side_effects rule outputs = function + | Trace.INIT _, e -> Trace.Init e.Instantiation.actions + | Trace.RULE r, x -> + Trace.Rule (r, x, Counter.next_step_simulation_info counter) + | Trace.PERT p, x -> + Trace.Pert (p, x, Counter.current_simulation_info counter) + + let store_event ~debug_mode counter inj2graph new_tracked_obs_instances + event_kind ?path extra_side_effects rule outputs = function | None -> () | Some _ -> let cevent = - Instantiation.concretize_event - ~debugMode inj2graph rule.Primitives.instantiations in - let full_concrete_event = { - Instantiation.tests = cevent.Instantiation.tests; - Instantiation.actions = cevent.Instantiation.actions; - Instantiation.side_effects_src = cevent.Instantiation.side_effects_src; - Instantiation.side_effects_dst = List.rev_append - extra_side_effects cevent.Instantiation.side_effects_dst; - Instantiation.connectivity_tests = - (match path with - | None -> [] - | Some None -> assert false - | Some (Some path) -> path_tests path cevent.Instantiation.tests); - } in + Instantiation.concretize_event ~debug_mode inj2graph + rule.Primitives.instantiations + in + let full_concrete_event = + { + Instantiation.tests = cevent.Instantiation.tests; + Instantiation.actions = cevent.Instantiation.actions; + Instantiation.side_effects_src = cevent.Instantiation.side_effects_src; + Instantiation.side_effects_dst = + List.rev_append extra_side_effects + cevent.Instantiation.side_effects_dst; + Instantiation.connectivity_tests = + (match path with + | None -> [] + | Some None -> assert false + | Some (Some path) -> path_tests path cevent.Instantiation.tests); + } + in let () = - outputs (Data.TraceStep - (step_of_event counter (event_kind,full_concrete_event))) in + outputs + (Data.TraceStep + (step_of_event counter (event_kind, full_concrete_event))) + in List.iter - (fun (i,x) -> - outputs (Data.TraceStep - (Trace.Obs(i,x,Counter.next_story counter)))) + (fun (i, x) -> + outputs + (Data.TraceStep (Trace.Obs (i, x, Counter.next_story counter)))) new_tracked_obs_instances - let get_species_obs ~debugMode sigs edges obs acc tracked = + let get_species_obs ~debug_mode sigs edges obs acc tracked = List.fold_left - (fun acc (pattern,(root,_)) -> - try - List.fold_left - (fun acc (fn,patterns,_) -> - if Array.fold_left - (fun ok pid -> - ((Pattern.compare_canonicals pid pattern) = 0)||ok) - false patterns - then - let spec = Edges.species ~debugMode sigs root edges in - (fn,patterns,spec)::acc else acc) - acc (Pattern.ObsMap.get tracked pattern) - with Not_found -> acc) + (fun acc (pattern, (root, _)) -> + try + List.fold_left + (fun acc (fn, patterns, _) -> + if + Array.fold_left + (fun ok pid -> + Pattern.compare_canonicals pid pattern = 0 || ok) + false patterns + then ( + let spec = Edges.species ~debug_mode sigs root edges in + (fn, patterns, spec) :: acc + ) else + acc) + acc + (Pattern.ObsMap.get tracked pattern) + with Not_found -> acc) acc obs - let store_obs ~debugMode domain edges instances obs acc = function + let store_obs ~debug_mode domain edges instances obs acc = function | None -> acc | Some tracked -> List.fold_left - (fun acc (pattern,(root,_)) -> - try - List.fold_left - (fun acc (ev,patterns,tests) -> - List.fold_left - (fun acc (inj,_) -> - let tests' = - List.map - (List.map (Instantiation.concretize_test - ~debugMode (inj,Mods.IntMap.empty))) tests in - (ev,tests') :: acc) - acc - (all_injections - ~debugMode instances ~excp:(pattern,root) - domain edges patterns)) - acc (Pattern.ObsMap.get tracked pattern) - with Not_found -> acc) + (fun acc (pattern, (root, _)) -> + try + List.fold_left + (fun acc (ev, patterns, tests) -> + List.fold_left + (fun acc (inj, _) -> + let tests' = + List.map + (List.map + (Instantiation.concretize_test ~debug_mode + (inj, Mods.IntMap.empty))) + tests + in + (ev, tests') :: acc) + acc + (all_injections ~debug_mode instances ~excp:(pattern, root) + domain edges patterns)) + acc + (Pattern.ObsMap.get tracked pattern) + with Not_found -> acc) acc obs - let update_edges - ~debugMode outputs counter domain inj_nodes state event_kind ?path rule sigs = + let update_edges ~debug_mode outputs counter domain inj_nodes state event_kind + ?path rule sigs = let () = assert (not state.outdated) in let () = state.outdated <- true in let mod_connectivity_store = state.imp.changed_connectivity in (*Negative update*) let concrete_removed = List.map - (Primitives.Transformation.concretize - ~debugMode (inj_nodes,Mods.IntMap.empty)) - rule.Primitives.removed in - let ((del_obs,del_deps),_) = + (Primitives.Transformation.concretize ~debug_mode + (inj_nodes, Mods.IntMap.empty)) + rule.Primitives.removed + in + let (del_obs, del_deps), _ = List.fold_left - (obs_from_transformation ~debugMode domain state.edges) - (([],Operator.DepSet.empty),Matching.empty_cache) - concrete_removed in - let (side_effects,edges_after_neg) = + (obs_from_transformation ~debug_mode domain state.edges) + (([], Operator.DepSet.empty), Matching.empty_cache) + concrete_removed + in + let side_effects, edges_after_neg = List.fold_left - (apply_negative_transformation ~mod_connectivity_store state.imp.instances) - ([],state.edges) concrete_removed in + (apply_negative_transformation ~mod_connectivity_store + state.imp.instances) + ([], state.edges) concrete_removed + in let () = List.iter - (fun (pat,(root,_)) -> - Instances.update_roots - state.imp.instances false state.imp.precomputed.unary_patterns - edges_after_neg mod_connectivity_store pat root) - del_obs in + (fun (pat, (root, _)) -> + Instances.update_roots state.imp.instances false + state.imp.precomputed.unary_patterns edges_after_neg + mod_connectivity_store pat root) + del_obs + in (*Positive update*) - let (final_inj2graph,remaining_side_effects,edges'), - concrete_inserted = + let (final_inj2graph, remaining_side_effects, edges'), concrete_inserted = List.fold_left - (fun (x,p) h -> - let (x', h') = - apply_positive_transformation - ~debugMode (Pattern.Env.signatures domain) ~mod_connectivity_store - state.imp.instances x h in - (x',h'::p)) - (((inj_nodes,Mods.IntMap.empty),side_effects,edges_after_neg),[]) - rule.Primitives.inserted in - let (edges'',concrete_inserted') = + (fun (x, p) h -> + let x', h' = + apply_positive_transformation ~debug_mode + (Pattern.Env.signatures domain) + ~mod_connectivity_store state.imp.instances x h + in + x', h' :: p) + (((inj_nodes, Mods.IntMap.empty), side_effects, edges_after_neg), []) + rule.Primitives.inserted + in + let edges'', concrete_inserted' = List.fold_left - (fun (e,i) ((id,_ as nc),s) -> - Edges.add_free id s e,Primitives.Transformation.Freed (nc,s)::i) - (edges',concrete_inserted) remaining_side_effects in - let ((new_obs,new_deps),_) = + (fun (e, i) (((id, _) as nc), s) -> + Edges.add_free id s e, Primitives.Transformation.Freed (nc, s) :: i) + (edges', concrete_inserted) + remaining_side_effects + in + let (new_obs, new_deps), _ = List.fold_left - (obs_from_transformation ~debugMode domain edges'') - (([],Operator.DepSet.empty),Matching.empty_cache) - concrete_inserted' in + (obs_from_transformation ~debug_mode domain edges'') + (([], Operator.DepSet.empty), Matching.empty_cache) + concrete_inserted' + in let () = List.iter - (fun (pat,(root,_)) -> - Instances.update_roots - state.imp.instances true state.imp.precomputed.unary_patterns - edges'' mod_connectivity_store pat root) - new_obs in + (fun (pat, (root, _)) -> + Instances.update_roots state.imp.instances true + state.imp.precomputed.unary_patterns edges'' mod_connectivity_store + pat root) + new_obs + in (*Store event*) let new_tracked_obs_instances = - store_obs - ~debugMode domain edges'' state.imp.instances - new_obs [] state.imp.story_machinery in + store_obs ~debug_mode domain edges'' state.imp.instances new_obs [] + state.imp.story_machinery + in let () = - store_event - ~debugMode counter final_inj2graph new_tracked_obs_instances event_kind - ?path remaining_side_effects rule outputs state.imp.story_machinery in + store_event ~debug_mode counter final_inj2graph new_tracked_obs_instances + event_kind ?path remaining_side_effects rule outputs + state.imp.story_machinery + in (*Print species*) let species = - get_species_obs ~debugMode sigs edges'' new_obs [] state.imp.species in + get_species_obs ~debug_mode sigs edges'' new_obs [] state.imp.species + in let () = List.iter - (fun (file,_,mixture) -> - outputs (Data.Species - (file,(Counter.current_time counter),mixture))) species in - let rev_deps = Operator.DepSet.union - state.outdated_elements (Operator.DepSet.union del_deps new_deps) in + (fun (file, _, mixture) -> + outputs (Data.Species (file, Counter.current_time counter, mixture))) + species + in + let rev_deps = + Operator.DepSet.union state.outdated_elements + (Operator.DepSet.union del_deps new_deps) + in { outdated = false; imp = state.imp; @@ -735,73 +805,84 @@ module Make (Instances:Instances_sig.S) = struct events_to_block = state.events_to_block; } - let update_edges_from_actions - ~debugMode ~outputs sigs counter domain state (actions,side_effect_dst) = + let update_edges_from_actions ~debug_mode ~outputs sigs counter domain state + (actions, side_effect_dst) = let () = assert (not state.outdated) in let () = state.outdated <- true in let mod_connectivity_store = state.imp.changed_connectivity in (*Negative update*) - let lnk_dst ((a,_),s) = Edges.link_destination a s state.edges in + let lnk_dst ((a, _), s) = Edges.link_destination a s state.edges in let concrete_removed = - Primitives.Transformation.negative_transformations_of_actions - sigs lnk_dst actions in - let ((del_obs,del_deps),_) = + Primitives.Transformation.negative_transformations_of_actions sigs lnk_dst + actions + in + let (del_obs, del_deps), _ = List.fold_left - (obs_from_transformation ~debugMode domain state.edges) - (([],Operator.DepSet.empty),Matching.empty_cache) - concrete_removed in - let (_side_effects,edges_after_neg) = + (obs_from_transformation ~debug_mode domain state.edges) + (([], Operator.DepSet.empty), Matching.empty_cache) + concrete_removed + in + let _side_effects, edges_after_neg = List.fold_left - (apply_negative_transformation - ~mod_connectivity_store state.imp.instances) - ([],state.edges) - concrete_removed in + (apply_negative_transformation ~mod_connectivity_store + state.imp.instances) + ([], state.edges) concrete_removed + in let () = List.iter - (fun (pat,(root,_)) -> - Instances.update_roots - state.imp.instances false state.imp.precomputed.unary_patterns - edges_after_neg mod_connectivity_store pat root) - del_obs in + (fun (pat, (root, _)) -> + Instances.update_roots state.imp.instances false + state.imp.precomputed.unary_patterns edges_after_neg + mod_connectivity_store pat root) + del_obs + in (*Positive update*) let concrete_inserted = - Primitives.Transformation.positive_transformations_of_actions - sigs side_effect_dst actions in + Primitives.Transformation.positive_transformations_of_actions sigs + side_effect_dst actions + in let edges' = List.fold_left (fun x h -> - apply_concrete_positive_transformation - (Pattern.Env.signatures domain) ~mod_connectivity_store - state.imp.instances x h) - edges_after_neg concrete_inserted in - let ((new_obs,new_deps),_) = + apply_concrete_positive_transformation + (Pattern.Env.signatures domain) + ~mod_connectivity_store state.imp.instances x h) + edges_after_neg concrete_inserted + in + let (new_obs, new_deps), _ = List.fold_left - (obs_from_transformation ~debugMode domain edges') - (([],Operator.DepSet.empty),Matching.empty_cache) - concrete_inserted in + (obs_from_transformation ~debug_mode domain edges') + (([], Operator.DepSet.empty), Matching.empty_cache) + concrete_inserted + in let () = List.iter - (fun (pat,(root,_)) -> - Instances.update_roots - state.imp.instances true state.imp.precomputed.unary_patterns - edges' mod_connectivity_store pat root) - new_obs in + (fun (pat, (root, _)) -> + Instances.update_roots state.imp.instances true + state.imp.precomputed.unary_patterns edges' mod_connectivity_store + pat root) + new_obs + in (*Print species*) let species = - get_species_obs ~debugMode sigs edges' new_obs [] state.imp.species in + get_species_obs ~debug_mode sigs edges' new_obs [] state.imp.species + in let () = List.iter - (fun (file,_,mixture) -> - outputs (Data.Species - (file,(Counter.current_time counter),mixture))) species in - let rev_deps = Operator.DepSet.union - state.outdated_elements (Operator.DepSet.union del_deps new_deps) in + (fun (file, _, mixture) -> + outputs (Data.Species (file, Counter.current_time counter, mixture))) + species + in + let rev_deps = + Operator.DepSet.union state.outdated_elements + (Operator.DepSet.union del_deps new_deps) + in { outdated = false; imp = state.imp; - matchings_of_rule = state.matchings_of_rule ; - nb_rectangular_instances_by_cc = state.nb_rectangular_instances_by_cc ; - unary_candidates = state.unary_candidates ; + matchings_of_rule = state.matchings_of_rule; + nb_rectangular_instances_by_cc = state.nb_rectangular_instances_by_cc; + unary_candidates = state.unary_candidates; edges = edges'; outdated_elements = rev_deps; events_to_block = state.events_to_block; @@ -810,380 +891,476 @@ module Make (Instances:Instances_sig.S) = struct let max_dist_to_int counter state d = Nbr.to_int (value_alg counter state d) (* cc_va is the number of embeddings. It only has - to be multiplied by the rate constant of the rule *) - let store_activity - ~debugMode store env counter state id syntax_id rate cc_va = + to be multiplied by the rate constant of the rule *) + let store_activity ~debug_mode store env counter state id syntax_id rate cc_va + = let () = - if debugMode then + if debug_mode then Format.printf "@[%sule %a has now %i instances.@]@." - (if id mod 2 = 1 then "Unary r" else "R") - (Model.print_rule ~noCounters:true ~env) (id/2) cc_va in + (if id mod 2 = 1 then + "Unary r" + else + "R") + (Model.print_rule ~noCounters:true ~env) + (id / 2) cc_va + in let act = match Nbr.to_float @@ value_alg counter state rate with - | None -> if cc_va = 0 then 0. else infinity - | Some rate -> rate *. float_of_int cc_va in + | None -> + if cc_va = 0 then + 0. + else + infinity + | Some rate -> rate *. float_of_int cc_va + in let () = - if act < 0. then + if act < 0. then ( let unary = id mod 2 = 1 in raise (ExceptionDefn.Malformed_Decl - ((Format.asprintf + ( Format.asprintf "At t=%.2f %sctivity of rule %a has become negative (%f)" (Counter.current_time counter) - (if unary then "Unary " else "") - (Model.print_rule ~noCounters:debugMode ~env) id - act), - Model.get_ast_rule_rate_pos ~unary env syntax_id)) in + (if unary then + "Unary " + else + "") + (Model.print_rule ~noCounters:debug_mode ~env) + id act, + Model.get_ast_rule_rate_pos ~unary env syntax_id )) + ) + in let old_act = get_activity id state in let () = set_activity id act state in store syntax_id old_act act - let update_outdated_activities - ~debugMode store env counter state known_perts = + let update_outdated_activities ~debug_mode store env counter state known_perts + = let () = assert (not state.outdated) in let unary_rule_update modified_cc instances i pack rule = match rule.Primitives.unary_rate with | None -> pack | Some (unrate, _) -> let va, pack' = - compute_unary_number instances pack modified_cc rule i in + compute_unary_number instances pack modified_cc rule i + in let () = - store_activity - ~debugMode store env counter state (2*i+1) - rule.Primitives.syntactic_rule (fst unrate) (Int64.to_int va) in - pack' in + store_activity ~debug_mode store env counter state + ((2 * i) + 1) + rule.Primitives.syntactic_rule (fst unrate) (Int64.to_int va) + in + pack' + in let rec aux dep acc = Operator.DepSet.fold - (fun dep (exact_matchings,perts as acc) -> - match dep with - | Operator.ALG j -> - let () = recompute env counter state j in - aux (Model.get_alg_reverse_dependencies env j) acc - | Operator.MODIF p -> - (exact_matchings,p::perts) - | Operator.RULE i -> - let rule = Model.get_rule env i in - let pattern_va = Instances.number_of_instances - ~rule_id:i - state.imp.instances rule.Primitives.connected_components in - let () = - store_activity - ~debugMode store env counter state (2*i) - rule.Primitives.syntactic_rule - (fst rule.Primitives.rate) pattern_va in - (pop_exact_matchings exact_matchings i,perts)) - dep acc in - let matchings_of_rule,perts = - aux state.outdated_elements (state.matchings_of_rule,known_perts) in - let (nb_rectangular_instances_by_cc, unary_candidates) = + (fun dep ((exact_matchings, perts) as acc) -> + match dep with + | Operator.ALG j -> + let () = recompute env counter state j in + aux (Model.get_alg_reverse_dependencies env j) acc + | Operator.MODIF p -> exact_matchings, p :: perts + | Operator.RULE i -> + let rule = Model.get_rule env i in + let pattern_va = + Instances.number_of_instances ~rule_id:i state.imp.instances + rule.Primitives.connected_components + in + let () = + store_activity ~debug_mode store env counter state (2 * i) + rule.Primitives.syntactic_rule (fst rule.Primitives.rate) + pattern_va + in + pop_exact_matchings exact_matchings i, perts) + dep acc + in + let matchings_of_rule, perts = + aux state.outdated_elements (state.matchings_of_rule, known_perts) + in + let nb_rectangular_instances_by_cc, unary_candidates = if Hashtbl.length state.imp.changed_connectivity = 0 then - (state.nb_rectangular_instances_by_cc, state.unary_candidates) - else - let out = Model.fold_rules - (unary_rule_update - state.imp.changed_connectivity state.imp.instances) + state.nb_rectangular_instances_by_cc, state.unary_candidates + else ( + let out = + Model.fold_rules + (unary_rule_update state.imp.changed_connectivity + state.imp.instances) (state.nb_rectangular_instances_by_cc, state.unary_candidates) - env in + env + in let () = Hashtbl.reset state.imp.changed_connectivity in - out in - ({ - outdated = false; imp = state.imp; edges = state.edges; - events_to_block = state.events_to_block; - matchings_of_rule; nb_rectangular_instances_by_cc; unary_candidates; - outdated_elements = state.imp.precomputed.always_outdated; - },perts) + out + ) + in + ( { + outdated = false; + imp = state.imp; + edges = state.edges; + events_to_block = state.events_to_block; + matchings_of_rule; + nb_rectangular_instances_by_cc; + unary_candidates; + outdated_elements = state.imp.precomputed.always_outdated; + }, + perts ) let overwrite_var i counter state expr = let () = state.imp.variables_overwrite.(i) <- - Some (Alg_expr.CONST (value_alg counter state expr)) in - {state with - outdated_elements = - Operator.DepSet.add (Operator.ALG i) state.outdated_elements} + Some (Alg_expr.CONST (value_alg counter state expr)) + in + { + state with + outdated_elements = + Operator.DepSet.add (Operator.ALG i) state.outdated_elements; + } let update_tokens env counter state injected = - let injected' = List.rev_map - (fun ((expr,_),i) -> (value_alg counter state expr,i)) injected in - { state with + let injected' = + List.rev_map + (fun ((expr, _), i) -> value_alg counter state expr, i) + injected + in + { + state with outdated_elements = List.fold_left - (fun rdeps (va,i) -> - let () = state.imp.tokens.(i) <- Nbr.add state.imp.tokens.(i) va in - let deps' = Model.get_token_reverse_dependencies env i in - if Operator.DepSet.is_empty deps' then rdeps - else - Operator.DepSet.union rdeps deps') - state.outdated_elements injected' } - - let transform_by_a_rule - ~debugMode outputs env counter state event_kind ?path rule ?rule_id inj = - if is_blocked ~debugMode state ?rule_id rule inj then Blocked - else + (fun rdeps (va, i) -> + let () = state.imp.tokens.(i) <- Nbr.add state.imp.tokens.(i) va in + let deps' = Model.get_token_reverse_dependencies env i in + if Operator.DepSet.is_empty deps' then + rdeps + else + Operator.DepSet.union rdeps deps') + state.outdated_elements injected'; + } + + let transform_by_a_rule ~debug_mode outputs env counter state event_kind ?path + rule ?rule_id inj = + if is_blocked ~debug_mode state ?rule_id rule inj then + Blocked + else ( let state = - update_tokens - env counter state rule.Primitives.delta_tokens in + update_tokens env counter state rule.Primitives.delta_tokens + in let state = - update_edges ~debugMode outputs counter (Model.domain env) inj - state event_kind ?path rule (Model.signatures env) in + update_edges ~debug_mode outputs counter (Model.domain env) inj state + event_kind ?path rule (Model.signatures env) + in Success state + ) - let apply_given_unary_instance - ~debugMode ~outputs ~rule_id env counter state event_kind rule = function + let apply_given_unary_instance ~debug_mode ~outputs ~rule_id env counter state + event_kind rule = function | None -> Clash - | Some (inj,_rev_roots,path) -> + | Some (inj, _rev_roots, path) -> let () = assert (not state.outdated) in let state' = - {state with - outdated_elements = - Operator.DepSet.add (Operator.RULE rule_id) state.outdated_elements} in - match path with + { + state with + outdated_elements = + Operator.DepSet.add (Operator.RULE rule_id) state.outdated_elements; + } + in + (match path with | Some _ -> - transform_by_a_rule - ~debugMode outputs env counter state' event_kind ~path rule ~rule_id inj + transform_by_a_rule ~debug_mode outputs env counter state' event_kind + ~path rule ~rule_id inj | None -> - let max_distance = match rule.Primitives.unary_rate with + let max_distance = + match rule.Primitives.unary_rate with | None -> None | Some (_, dist_opt) -> (match dist_opt with - | None -> None - | Some d -> Some (max_dist_to_int counter state' d)) in + | None -> None + | Some d -> Some (max_dist_to_int counter state' d)) + in let domain = Model.domain env in - let nodes = Matching.elements_with_types - domain rule.Primitives.connected_components inj in + let nodes = + Matching.elements_with_types domain + rule.Primitives.connected_components inj + in if max_distance = None && state.imp.story_machinery = None then - if Edges.in_same_connected_component - (fst (List.hd nodes.(0))) (fst (List.hd nodes.(1))) state.edges then - transform_by_a_rule - ~debugMode outputs env counter state' + if + Edges.in_same_connected_component + (fst (List.hd nodes.(0))) + (fst (List.hd nodes.(1))) + state.edges + then + transform_by_a_rule ~debug_mode outputs env counter state' event_kind ~path:None rule ~rule_id inj - else Corrected - else - match Edges.are_connected ?max_distance state.edges nodes.(0) nodes.(1) with + else + Corrected + else ( + match + Edges.are_connected ?max_distance state.edges nodes.(0) nodes.(1) + with | None -> Corrected | Some _ as path -> - transform_by_a_rule - ~debugMode outputs env counter state' event_kind ~path rule ~rule_id inj + transform_by_a_rule ~debug_mode outputs env counter state' + event_kind ~path rule ~rule_id inj + )) - let apply_given_instance - ~debugMode ~outputs ?rule_id env counter state event_kind rule = function + let apply_given_instance ~debug_mode ~outputs ?rule_id env counter state + event_kind rule = function | None -> Clash - | Some (inj,rev_roots,_path) -> + | Some (inj, rev_roots, _path) -> let () = assert (not state.outdated) in let () = - if debugMode then + if debug_mode then ( let roots = Tools.array_rev_of_list rev_roots in Format.printf "@[On roots:@ @[%a@]@]@." - (Pp.array Pp.space (fun _ -> Format.pp_print_int)) roots in - match rule.Primitives.unary_rate with + (Pp.array Pp.space (fun _ -> Format.pp_print_int)) + roots + ) + in + (match rule.Primitives.unary_rate with | None -> - transform_by_a_rule - ~debugMode outputs env counter state event_kind rule ?rule_id inj - | Some (_,max_distance) -> - match max_distance with + transform_by_a_rule ~debug_mode outputs env counter state event_kind + rule ?rule_id inj + | Some (_, max_distance) -> + (match max_distance with | None -> (match rev_roots with - | root1 :: root0 :: [] -> - if Edges.in_same_connected_component root0 root1 state.edges then - Corrected - else - transform_by_a_rule - ~debugMode outputs env counter state - event_kind rule ?rule_id inj - | _ -> failwith "apply_given_rule unary rule without 2 patterns") + | [ root1; root0 ] -> + if Edges.in_same_connected_component root0 root1 state.edges then + Corrected + else + transform_by_a_rule ~debug_mode outputs env counter state + event_kind rule ?rule_id inj + | _ -> failwith "apply_given_rule unary rule without 2 patterns") | Some dist -> let domain = Model.domain env in let dist' = Some (max_dist_to_int counter state dist) in - let nodes = Matching.elements_with_types - domain rule.Primitives.connected_components inj in - match - Edges.are_connected ?max_distance:dist' state.edges nodes.(0) - nodes.(1) with + let nodes = + Matching.elements_with_types domain + rule.Primitives.connected_components inj + in + (match + Edges.are_connected ?max_distance:dist' state.edges nodes.(0) + nodes.(1) + with | None -> - transform_by_a_rule - ~debugMode outputs env counter state event_kind rule ?rule_id inj - | Some _ -> Corrected + transform_by_a_rule ~debug_mode outputs env counter state event_kind + rule ?rule_id inj + | Some _ -> Corrected))) - let apply_given_rule - ~debugMode ~outputs ?rule_id env counter state event_kind rule = + let apply_given_rule ~debug_mode ~outputs ?rule_id env counter state + event_kind rule = let domain = Model.domain env in - let inst = pick_a_rule_instance - ~debugMode state state.imp.random_state domain state.edges ?rule_id rule in - apply_given_instance - ~debugMode ~outputs ?rule_id env counter state event_kind rule inst - - let force_rule ~debugMode ~outputs env counter state event_kind ?rule_id rule = - match apply_given_rule - ~debugMode ~outputs ?rule_id env counter state event_kind rule with + let inst = + pick_a_rule_instance ~debug_mode state state.imp.random_state domain + state.edges ?rule_id rule + in + apply_given_instance ~debug_mode ~outputs ?rule_id env counter state + event_kind rule inst + + let force_rule ~debug_mode ~outputs env counter state event_kind ?rule_id rule + = + match + apply_given_rule ~debug_mode ~outputs ?rule_id env counter state + event_kind rule + with | Success out -> Some out | Corrected | Blocked | Clash -> let () = assert (not state.outdated) in - let unary_rate = match rule.Primitives.unary_rate with + let unary_rate = + match rule.Primitives.unary_rate with | None -> None | Some (loc, dist_opt) -> (match dist_opt with - | None -> Some (loc,None) - | Some d -> - Some (loc,Some (max_dist_to_int counter state d))) in - match all_injections ~debugMode ?rule_id - ?unary_rate state.imp.instances (Model.domain env) state.edges - rule.Primitives.connected_components with + | None -> Some (loc, None) + | Some d -> Some (loc, Some (max_dist_to_int counter state d))) + in + (match + all_injections ~debug_mode ?rule_id ?unary_rate state.imp.instances + (Model.domain env) state.edges rule.Primitives.connected_components + with | [] -> let () = outputs (Data.Warning - (None, - fun f -> Format.fprintf f "At t=%f, %a does not apply (anymore)" - (Counter.current_time counter) - (Trace.print_event_kind ~env) event_kind)) in + ( None, + fun f -> + Format.fprintf f "At t=%f, %a does not apply (anymore)" + (Counter.current_time counter) + (Trace.print_event_kind ~env) + event_kind )) + in None | l -> - let (h,_) = List_util.random state.imp.random_state l in + let h, _ = List_util.random state.imp.random_state l in let out = - transform_by_a_rule - ~debugMode outputs env counter state event_kind rule ?rule_id h in - match out with - | Success out -> Some out - | Blocked -> None - | Clash | Corrected -> assert false - - let adjust_rule_instances ~debugMode ~rule_id env counter state rule = + transform_by_a_rule ~debug_mode outputs env counter state event_kind + rule ?rule_id h + in + (match out with + | Success out -> Some out + | Blocked -> None + | Clash | Corrected -> assert false)) + + let adjust_rule_instances ~debug_mode ~rule_id env counter state rule = let () = assert (not state.outdated) in let domain = Model.domain env in - let unary_rate = match rule.Primitives.unary_rate with + let unary_rate = + match rule.Primitives.unary_rate with | None -> None | Some (loc, dist_opt) -> (match dist_opt with - | None -> Some (loc,None) - | Some d -> - Some (loc,Some (max_dist_to_int counter state d))) in - let act,state = - adjust_rule_instances - ~debugMode ~rule_id ?unary_rate state domain state.edges - rule.Primitives.connected_components rule in + | None -> Some (loc, None) + | Some d -> Some (loc, Some (max_dist_to_int counter state d))) + in + let act, state = + adjust_rule_instances ~debug_mode ~rule_id ?unary_rate state domain + state.edges rule.Primitives.connected_components rule + in let () = - store_activity - ~debugMode (fun _ _ _ -> ()) env counter state (2*rule_id) - rule.Primitives.syntactic_rule (fst rule.Primitives.rate) act in + store_activity ~debug_mode + (fun _ _ _ -> ()) + env counter state (2 * rule_id) rule.Primitives.syntactic_rule + (fst rule.Primitives.rate) act + in state (* Redefines `adjust_unary_rule_instances` *) - let adjust_unary_rule_instances ~debugMode ~rule_id env counter state rule = + let adjust_unary_rule_instances ~debug_mode ~rule_id env counter state rule = let () = assert (not state.outdated) in let domain = Model.domain env in let max_distance = Option_util.bind (fun (_, dist_opt) -> - Option_util.map (max_dist_to_int counter state) dist_opt) - rule.Primitives.unary_rate in - let act,state = - adjust_unary_rule_instances - ~debugMode ~rule_id ?max_distance state domain state.edges - rule.Primitives.connected_components rule in + Option_util.map (max_dist_to_int counter state) dist_opt) + rule.Primitives.unary_rate + in + let act, state = + adjust_unary_rule_instances ~debug_mode ~rule_id ?max_distance state + domain state.edges rule.Primitives.connected_components rule + in let () = match rule.Primitives.unary_rate with | None -> assert false | Some (unrate, _) -> - store_activity - ~debugMode (fun _ _ _ -> ()) env counter state (2*rule_id+1) - rule.Primitives.syntactic_rule (fst unrate) act in + store_activity ~debug_mode + (fun _ _ _ -> ()) + env counter state + ((2 * rule_id) + 1) + rule.Primitives.syntactic_rule (fst unrate) act + in state - let incorporate_extra_pattern ~debugMode domain state pattern = + let incorporate_extra_pattern ~debug_mode domain state pattern = let () = assert (not state.outdated) in - let () = Instances.incorporate_extra_pattern - state.imp.instances pattern - (Matching.roots_of ~debugMode domain state.edges pattern) in + let () = + Instances.incorporate_extra_pattern state.imp.instances pattern + (Matching.roots_of ~debug_mode domain state.edges pattern) + in { state with outdated = false } - let snapshot ~debugMode ~raw env counter state = { - Data.snapshot_event = Counter.current_event counter; - Data.snapshot_time = Counter.current_time counter; - Data.snapshot_agents = - Edges.build_user_snapshot - ~debugMode ~raw (Model.signatures env) state.edges; - Data.snapshot_tokens = Array.mapi (fun i x -> - (Format.asprintf "%a" (Model.print_token ~env) i,x)) state.imp.tokens; - } + let snapshot ~debug_mode ~raw env counter state = + { + Data.snapshot_event = Counter.current_event counter; + Data.snapshot_time = Counter.current_time counter; + Data.snapshot_agents = + Edges.build_user_snapshot ~debug_mode ~raw (Model.signatures env) + state.edges; + Data.snapshot_tokens = + Array.mapi + (fun i x -> Format.asprintf "%a" (Model.print_token ~env) i, x) + state.imp.tokens; + } - let pick_an_instance ~debugMode env state = + let pick_an_instance ~debug_mode env state = let choice = pick_rule state.imp.random_state state in - let rule_id = choice/2 in + let rule_id = choice / 2 in let rule = Model.get_rule env rule_id in let domain = Model.domain env in - (choice mod 2 = 1,rule_id, - if choice mod 2 = 1 - then pick_a_unary_rule_instance - ~debugMode state state.imp.random_state domain state.edges ~rule_id rule - else pick_a_rule_instance - ~debugMode state state.imp.random_state domain state.edges ~rule_id rule) - - let is_correct_instance env graph (is_unary,rule_id,instance) = + ( choice mod 2 = 1, + rule_id, + if choice mod 2 = 1 then + pick_a_unary_rule_instance ~debug_mode state state.imp.random_state + domain state.edges ~rule_id rule + else + pick_a_rule_instance ~debug_mode state state.imp.random_state domain + state.edges ~rule_id rule ) + + let is_correct_instance env graph (is_unary, rule_id, instance) = match instance with | None -> true - | Some (_inj,inv_roots,path) -> + | Some (_inj, inv_roots, path) -> let rule = Model.get_rule env rule_id in let pats = rule.Primitives.connected_components in - Tools.array_fold_left2i (fun _ b cc r -> - b && Instances.is_valid graph.imp.instances cc r) - true pats (Tools.array_rev_of_list inv_roots) && - (not is_unary || match path with - | Some p -> Edges.is_valid_path p graph.edges - | None -> match inv_roots with - | [ x; y ] -> Edges.in_same_connected_component x y graph.edges - | _ -> assert false) - - let apply_instance - ~debugMode ~outputs ?maxConsecutiveBlocked ~maxConsecutiveClash - env counter graph (is_unary,rule_id,instance) = + Tools.array_fold_left2i + (fun _ b cc r -> b && Instances.is_valid graph.imp.instances cc r) + true pats + (Tools.array_rev_of_list inv_roots) + && ((not is_unary) + || + match path with + | Some p -> Edges.is_valid_path p graph.edges + | None -> + (match inv_roots with + | [ x; y ] -> Edges.in_same_connected_component x y graph.edges + | _ -> assert false)) + + let apply_instance ~debug_mode ~outputs ?maxConsecutiveBlocked + ~maxConsecutiveClash env counter graph (is_unary, rule_id, instance) = let cause = Trace.RULE rule_id in let rule = Model.get_rule env rule_id in let () = - if debugMode then - Format.printf - "@[@[Applied@ %t%i:@]@ @[%a@]@]@." - (fun f -> if is_unary then Format.fprintf f "unary@ ") rule_id - (Kappa_printer.decompiled_rule ~noCounters:true ~full:true env) rule - (*Rule_interpreter.print_dist env graph rule_id*) in + if debug_mode then + Format.printf "@[@[Applied@ %t%i:@]@ @[%a@]@]@." + (fun f -> if is_unary then Format.fprintf f "unary@ ") + rule_id + (Kappa_printer.decompiled_rule ~noCounters:true ~full:true env) + rule + (*Rule_interpreter.print_dist env graph rule_id*) + in let apply_given = - if is_unary - then apply_given_unary_instance ~debugMode ~outputs ~rule_id - else apply_given_instance ~debugMode ~outputs ~rule_id in + if is_unary then + apply_given_unary_instance ~debug_mode ~outputs ~rule_id + else + apply_given_instance ~debug_mode ~outputs ~rule_id + in match apply_given env counter graph cause rule instance with - | Success (graph') -> + | Success graph' -> let final_step = not (Counter.one_constructive_event ~rule_id counter) in - (Some rule.Primitives.syntactic_rule,final_step,graph') + Some rule.Primitives.syntactic_rule, final_step, graph' | (Clash | Corrected | Blocked) as out -> let continue = if out = Clash then Counter.one_clashing_instance_event ~rule_id counter else if out = Blocked then Counter.one_blocked_event counter - else if is_unary - then Counter.one_no_more_unary_event ~rule_id counter - else Counter.one_no_more_binary_event ~rule_id counter in - if Counter.consecutive_null_event ~rule_id counter < maxConsecutiveClash && - (match maxConsecutiveBlocked with - | None -> true - | Some n -> Counter.consecutive_blocked counter < n) - then (None,not continue,graph) + else if is_unary then + Counter.one_no_more_unary_event ~rule_id counter + else + Counter.one_no_more_binary_event ~rule_id counter + in + if + Counter.consecutive_null_event ~rule_id counter < maxConsecutiveClash + && + match maxConsecutiveBlocked with + | None -> true + | Some n -> Counter.consecutive_blocked counter < n + then + None, not continue, graph else - (None,not continue, - (if is_unary then - adjust_unary_rule_instances - ~debugMode ~rule_id env counter graph rule + ( None, + not continue, + if is_unary then + adjust_unary_rule_instances ~debug_mode ~rule_id env counter graph + rule else - adjust_rule_instances - ~debugMode ~rule_id env counter graph rule)) + adjust_rule_instances ~debug_mode ~rule_id env counter graph rule ) let aux_add_tracked patterns name tests state tpattern = let () = state.outdated <- true in let () = Array.iter (fun pattern -> - let acc = Pattern.ObsMap.get tpattern pattern in - Pattern.ObsMap.set tpattern - pattern ((name,patterns,tests)::acc)) - patterns in + let acc = Pattern.ObsMap.get tpattern pattern in + Pattern.ObsMap.set tpattern pattern ((name, patterns, tests) :: acc)) + patterns + in { state with outdated = false } let add_tracked ~outputs patterns name tests state = @@ -1193,67 +1370,79 @@ module Make (Instances:Instances_sig.S) = struct let () = outputs (Data.Warning - (None, - fun f -> Format.fprintf f - "Observable %s should be tracked but the trace is not stored" - name)) in + ( None, + fun f -> + Format.fprintf f + "Observable %s should be tracked but the trace is not stored" + name )) + in state | Some tpattern -> aux_add_tracked patterns name tests state tpattern + let remove_tracked patterns name state = let () = assert (not state.outdated) in match state.imp.story_machinery with | None -> state | Some tpattern -> - match name with + (match name with | None -> let () = state.outdated <- true in - let tester (_,el,_) = - not @@ - Tools.array_fold_lefti - (fun i b x -> b && Pattern.is_equal_canonicals x el.(i)) - true patterns in + let tester (_, el, _) = + not + @@ Tools.array_fold_lefti + (fun i b x -> b && Pattern.is_equal_canonicals x el.(i)) + true patterns + in let () = Array.iter (fun pattern -> - let acc = Pattern.ObsMap.get tpattern pattern in - Pattern.ObsMap.set tpattern pattern (List.filter tester acc)) - patterns in + let acc = Pattern.ObsMap.get tpattern pattern in + Pattern.ObsMap.set tpattern pattern (List.filter tester acc)) + patterns + in { state with outdated = false } | Some name -> let () = state.outdated <- true in - let tester (n,_,_) = not((String.compare name n) = 0) in + let tester (n, _, _) = not (String.compare name n = 0) in let () = Pattern.ObsMap.iteri (fun cc_id plist -> - Pattern.ObsMap.set tpattern cc_id (List.filter tester plist)) - tpattern in - { state with outdated = false } + Pattern.ObsMap.set tpattern cc_id (List.filter tester plist)) + tpattern + in + { state with outdated = false }) let add_tracked_species patterns name tests state = aux_add_tracked patterns name tests state state.imp.species let remove_tracked_species name state = let () = state.outdated <- true in - let tester (n,_,_) = not((String.compare name n) = 0) in + let tester (n, _, _) = not (String.compare name n = 0) in let () = Pattern.ObsMap.iteri (fun cc_id plist -> - Pattern.ObsMap.set state.imp.species cc_id (List.filter tester plist)) - state.imp.species in + Pattern.ObsMap.set state.imp.species cc_id (List.filter tester plist)) + state.imp.species + in { state with outdated = false } let get_random_state state = state.imp.random_state let send_instances_message msg state = - { state with - imp = { state.imp with - instances = Instances.receive_message msg state.imp.instances } } + { + state with + imp = + { + state.imp with + instances = Instances.receive_message msg state.imp.instances; + }; + } let add_outdated_dependencies new_deps state = let outdated_elements = - Operator.DepSet.union new_deps state.outdated_elements in + Operator.DepSet.union new_deps state.outdated_elements + in { state with outdated_elements } let debug_print_instances f st = Instances.debug_print f st.imp.instances - end diff --git a/core/simulation/generic_rule_interpreter.mli b/core/simulation/generic_rule_interpreter.mli index 68ea4ec92a..cb613b2c33 100644 --- a/core/simulation/generic_rule_interpreter.mli +++ b/core/simulation/generic_rule_interpreter.mli @@ -8,52 +8,71 @@ (**Graph rewriting module*) -module Make (Instances:Instances_sig.S) : sig - type t (**Abstract graph*) +module Make (Instances : Instances_sig.S) : sig + type t + (**Abstract graph*) type instance - type result = Clash | Corrected | Blocked | Success of t - (** Clash means rectangular approximation failure + type result = + | Clash + | Corrected + | Blocked + | Success of t + (** Clash means rectangular approximation failure Corrected means molecular ambiguity failure *) (** {2 Initialisation} *) val empty : - outputs:(Data.t -> unit) ->with_trace:bool -> - Random.State.t -> Model.t -> Counter.t -> t + outputs:(Data.t -> unit) -> + with_trace:bool -> + Random.State.t -> + Model.t -> + Counter.t -> + t (** {2 algebraic expression computation} *) + (** [get_alg] is by default [Model.get_alg] but it is not hard wired because perturbations can redefined alg_expr.*) val value_alg : Counter.t -> t -> Primitives.alg_expr -> Nbr.t val value_bool : - Counter.t -> t -> (Pattern.id array list,int) Alg_expr.bool -> bool + Counter.t -> t -> (Pattern.id array list, int) Alg_expr.bool -> bool val activity : t -> float - val get_edges : t -> Edges.t (** {2 Core} *) val apply_given_rule : - debugMode:bool -> outputs:(Data.t -> unit) -> - ?rule_id:int -> Model.t -> Counter.t -> t -> Trace.event_kind -> - Primitives.elementary_rule -> result + debug_mode:bool -> + outputs:(Data.t -> unit) -> + ?rule_id:int -> + Model.t -> + Counter.t -> + t -> + Trace.event_kind -> + Primitives.elementary_rule -> + result (** Returns the graph obtained by applying the rule. [rule_id] is mandatory if the rule has an unary rate.*) - val pick_an_instance : - debugMode:bool -> Kappa_terms.Model.t -> t -> instance - + val pick_an_instance : debug_mode:bool -> Kappa_terms.Model.t -> t -> instance val is_correct_instance : Model.t -> t -> instance -> bool val apply_instance : - debugMode:bool -> outputs:(Data.t -> unit) -> - ?maxConsecutiveBlocked:int -> maxConsecutiveClash:int -> - Model.t -> Counter.t -> t -> instance -> int option * bool * t + debug_mode:bool -> + outputs:(Data.t -> unit) -> + ?maxConsecutiveBlocked:int -> + maxConsecutiveClash:int -> + Model.t -> + Counter.t -> + t -> + instance -> + int option * bool * t (** [apply_rule ~outputs ~maxConsecutiveClash ?is_blocked model counter st] Returns [(corresponding_syntactic_rule, is_final_step, new_state)]. [is_final_step] is determined by the counter. @@ -61,20 +80,32 @@ module Make (Instances:Instances_sig.S) : sig a null event occured *) val force_rule : - debugMode:bool -> outputs:(Data.t -> unit) -> - Model.t -> Counter.t -> t -> Trace.event_kind -> - ?rule_id:int -> Primitives.elementary_rule -> t option + debug_mode:bool -> + outputs:(Data.t -> unit) -> + Model.t -> + Counter.t -> + t -> + Trace.event_kind -> + ?rule_id:int -> + Primitives.elementary_rule -> + t option (** Apply the rule for sure if it is possible. Try [apply_rule] but in case of null_event, it computes the exact injections of the left hand side to do apply the rule and returns the remaining exact injections. *) val incorporate_extra_pattern : - debugMode:bool -> Pattern.Env.t -> t -> Pattern.id -> t + debug_mode:bool -> Pattern.Env.t -> t -> Pattern.id -> t val overwrite_var : int -> Counter.t -> t -> Primitives.alg_expr -> t + val update_outdated_activities : - debugMode:bool -> (int -> float -> float -> unit) -> - Model.t -> Counter.t -> t -> int list -> (t * int list) + debug_mode:bool -> + (int -> float -> float -> unit) -> + Model.t -> + Counter.t -> + t -> + int list -> + t * int list (** Resynchronize the state after a rule application. It takes the function to store the new activities as an argument whose @@ -86,27 +117,32 @@ module Make (Instances:Instances_sig.S) : sig takes the list of perturbations to be tried and returns it updated *) - val snapshot: - debugMode:bool -> raw:bool -> Model.t -> Counter.t -> t -> Data.snapshot + val snapshot : + debug_mode:bool -> raw:bool -> Model.t -> Counter.t -> t -> Data.snapshot val print : Model.t -> Format.formatter -> t -> unit - val get_random_state : t -> Random.State.t val update_edges_from_actions : - debugMode:bool -> outputs:(Data.t -> unit) -> - Signature.s -> Counter.t -> Pattern.Env.t -> - t -> Instantiation.concrete Instantiation.action list * - Instantiation.concrete Instantiation.site list -> t + debug_mode:bool -> + outputs:(Data.t -> unit) -> + Signature.s -> + Counter.t -> + Pattern.Env.t -> + t -> + Instantiation.concrete Instantiation.action list + * Instantiation.concrete Instantiation.site list -> + t val send_instances_message : Instances.message -> t -> t (** {2 Blocking events} *) type event_predicate = - int option -> Matching.t -> - (Instantiation.concrete Instantiation.test) list -> - (Instantiation.concrete Instantiation.action) list -> + int option -> + Matching.t -> + Instantiation.concrete Instantiation.test list -> + Instantiation.concrete Instantiation.action list -> bool val set_events_to_block : event_predicate option -> t -> t @@ -114,55 +150,73 @@ module Make (Instances:Instances_sig.S) : sig (** {2 Stories} *) val add_tracked : - outputs:(Data.t -> unit) -> Pattern.id array -> string -> - Instantiation.abstract Instantiation.test list list -> t -> t + outputs:(Data.t -> unit) -> + Pattern.id array -> + string -> + Instantiation.abstract Instantiation.test list list -> + t -> + t + val remove_tracked : Pattern.id array -> string option -> t -> t (** {2 Species} *) val add_tracked_species : - Pattern.id array -> string -> - Instantiation.abstract Instantiation.test list list -> t -> t + Pattern.id array -> + string -> + Instantiation.abstract Instantiation.test list list -> + t -> + t + val remove_tracked_species : string -> t -> t (** {2 Debugging} *) - type stats = { mixture_stats : Edges.stats } + type stats = { mixture_stats: Edges.stats } val stats : t -> stats val print_stats : Format.formatter -> t -> unit - val debug_print : Format.formatter -> t -> unit - (** {2 Internals } *) val apply_negative_transformation : - ?mod_connectivity_store:Roots.mod_ccs_cache -> Instances.t -> - (Instantiation.concrete Instantiation.site) list * Edges.t -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + Instances.t -> + Instantiation.concrete Instantiation.site list * Edges.t -> Instantiation.concrete Primitives.Transformation.t -> - (Instantiation.concrete Instantiation.site) list * Edges.t + Instantiation.concrete Instantiation.site list * Edges.t + (** {2 Internals } *) + val apply_positive_transformation : - debugMode:bool -> - Signature.s -> ?mod_connectivity_store:Roots.mod_ccs_cache -> Instances.t -> - (Matching.t * int Mods.IntMap.t) * - (Instantiation.concrete Instantiation.site) list * - Edges.t -> + debug_mode:bool -> + Signature.s -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + Instances.t -> + (Matching.t * int Mods.IntMap.t) + * Instantiation.concrete Instantiation.site list + * Edges.t -> Instantiation.abstract Primitives.Transformation.t -> - ((Matching.t * int Mods.IntMap.t) * - (Instantiation.concrete Instantiation.site) list * Edges.t) * - Instantiation.concrete Primitives.Transformation.t - val apply_concrete_positive_transformation : - Signature.s -> ?mod_connectivity_store:Roots.mod_ccs_cache -> Instances.t -> - Edges.t -> Instantiation.concrete Primitives.Transformation.t -> Edges.t - -val obs_from_transformations : - debugMode:bool -> Pattern.Env.t -> Edges.t -> - Instantiation.concrete Primitives.Transformation.t list -> - (Pattern.id * Agent.t) list * Operator.DepSet.t -(** [obs_from_transformations domain state transformations] - @return [(obs, deps)] *) + ((Matching.t * int Mods.IntMap.t) + * Instantiation.concrete Instantiation.site list + * Edges.t) + * Instantiation.concrete Primitives.Transformation.t -val add_outdated_dependencies : Operator.DepSet.t -> t -> t + val apply_concrete_positive_transformation : + Signature.s -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + Instances.t -> + Edges.t -> + Instantiation.concrete Primitives.Transformation.t -> + Edges.t -val debug_print_instances : Format.formatter -> t -> unit + val obs_from_transformations : + debug_mode:bool -> + Pattern.Env.t -> + Edges.t -> + Instantiation.concrete Primitives.Transformation.t list -> + (Pattern.id * Agent.t) list * Operator.DepSet.t + (** [obs_from_transformations domain state transformations] + @return [(obs, deps)] *) + val add_outdated_dependencies : Operator.DepSet.t -> t -> t + val debug_print_instances : Format.formatter -> t -> unit end diff --git a/core/simulation/instances.ml b/core/simulation/instances.ml index fee0012e23..5acd5ef672 100644 --- a/core/simulation/instances.ml +++ b/core/simulation/instances.ml @@ -8,16 +8,13 @@ type t = { (* For counterfactual simulation, there would be two of these. *) - roots : Roots.t ; + roots: Roots.t; } type message = unit let receive_message _ st = st - -let empty env = { - roots = Roots.empty env ; -} +let empty env = { roots = Roots.empty env } let incorporate_extra_pattern state pattern matchings = Roots.incorporate_extra_pattern state.roots pattern matchings @@ -29,8 +26,8 @@ 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 + Roots.update_roots state.roots is_add unary_ccs edges mod_connectivity pattern + root (** {2 Checking instances} *) @@ -41,8 +38,8 @@ let is_valid state pat root = let number_of_instances ?rule_id:_ st pats = Array.fold_left - (fun acc pattern -> acc * (Roots.number st.roots pattern)) 1 pats - + (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 @@ -52,7 +49,6 @@ let number_of_unary_instances_in_cc ?rule_id:_ st (pat1, pat2) = let set2 = Mods.IntMap.find_default Mods.IntSet.empty cc map2 in Mods.IntSet.size set1 * Mods.IntSet.size set2 - (* {6 Pick instances } *) let pick_unary_instance_in_cc ?rule_id:_ st random_state (pat1, pat2) = @@ -62,48 +58,50 @@ let pick_unary_instance_in_cc ?rule_id:_ st random_state (pat1, pat2) = let root1 = Option_util.unsome (-1) (Mods.IntSet.random random_state - (Mods.IntMap.find_default Mods.IntSet.empty cc map1)) in + (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) - + (Mods.IntMap.find_default Mods.IntSet.empty cc map2)) + in + root1, root2 -(* We provide a custom monadic fold function to be +(* We provide a custom monadic fold function to be lazy in drawing random numbers *) -let fold_picked_instance ?rule_id:_ st random_state pats ~init f = +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 + if i >= Array.length pats then + acc + else ( + match acc with | None -> None - | Some acc -> + | Some acc -> let pat = pats.(i) in - let root_opt = IntCollection.random random_state - (Roots.of_pattern pat st.roots) in - begin match root_opt with - | None -> None - | Some root -> - let acc = f i pat root acc in - aux (i+1) acc - end - in aux 0 (Some init) - + 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 - + | 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 (* This is the legitimate and efficient version. *) 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 @@ -111,14 +109,19 @@ let fold_instances ?rule_id:_ ?excp st pats ~init f = let rec aux i acc = if i >= n then f tab acc - else - if sent_to_excp_root i then begin tab.(i) <- excp_root ; aux (i+1) acc end 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 + 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 () () @@ -130,13 +133,10 @@ 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 - ) - + Mods.IntSet.fold + (fun root1 acc -> + Mods.IntSet.fold (fun root2 acc -> f (root1, root2) acc) set2 acc) + set1 acc) (** {6 Debug functions} *) diff --git a/core/simulation/instances_sig.ml b/core/simulation/instances_sig.ml index 3dfa20dc1a..e2d99dbefb 100644 --- a/core/simulation/instances_sig.ml +++ b/core/simulation/instances_sig.ml @@ -7,82 +7,107 @@ (******************************************************************************) (** Collection of rectangular instances. *) + (** Two implementations are available for this signature. *) module type S = sig - -type t - -type message - -val receive_message : message -> t -> t - -val empty : Model.t -> t - -val debug_print : Format.formatter -> t -> unit - - -(** {6 Updating the roots} *) - -val incorporate_extra_pattern : t -> Pattern.id -> IntCollection.t -> unit - -val break_apart_cc : - t -> Edges.t -> ?mod_connectivity_store:Roots.mod_ccs_cache -> - (int * int) option -> unit - -val merge_cc : - t -> ?mod_connectivity_store:Roots.mod_ccs_cache -> (int * int) option -> unit - -val update_roots : - t -> bool -> Pattern.Set.t -> Edges.t -> - Roots.mod_ccs_cache -> Pattern.id -> int -> unit - -(** {6 Checking instances} *) - -val is_valid : t -> Pattern.id -> int -> bool - -(** {6 Counting instances} *) - -val number_of_instances : ?rule_id:int -> t -> Pattern.id array -> int -(** [number_of_instances ?rule_id state patterns] *) - -val number_of_unary_instances_in_cc : - ?rule_id:int -> t -> Pattern.id * Pattern.id -> int -> int -(** [number_of_unary_instances_in_cc ?rule_id state (pat1, pat2) cc] *) - -(** {6 Picking instances} *) - -val pick_unary_instance_in_cc : -?rule_id:int -> t -> Random.State.t -> Pattern.id * Pattern.id -> int -> int * int -(** [pick_unary_instance_in_cc state random_state (pat1, pat2) cc] + type t + type message + + val receive_message : message -> t -> t + val empty : Model.t -> t + val debug_print : Format.formatter -> t -> unit + + (** {6 Updating the roots} *) + + val incorporate_extra_pattern : t -> Pattern.id -> IntCollection.t -> unit + + val break_apart_cc : + t -> + Edges.t -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + (int * int) option -> + unit + + val merge_cc : + t -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + (int * int) option -> + unit + + val update_roots : + t -> + bool -> + Pattern.Set.t -> + Edges.t -> + Roots.mod_ccs_cache -> + Pattern.id -> + int -> + unit + + (** {6 Checking instances} *) + + val is_valid : t -> Pattern.id -> int -> bool + + (** {6 Counting instances} *) + + val number_of_instances : ?rule_id:int -> t -> Pattern.id array -> int + (** [number_of_instances ?rule_id state patterns] *) + + val number_of_unary_instances_in_cc : + ?rule_id:int -> t -> Pattern.id * Pattern.id -> int -> int + (** [number_of_unary_instances_in_cc ?rule_id state (pat1, pat2) cc] *) + + (** {6 Picking instances} *) + + val pick_unary_instance_in_cc : + ?rule_id:int -> + t -> + Random.State.t -> + Pattern.id * Pattern.id -> + int -> + int * int + (** [pick_unary_instance_in_cc state random_state (pat1, pat2) cc] Returns a pair of roots corresponding to [pat1] and [pat2] respectively. Optimized for currying before the [cc] argument. In case of failure, one of the resulting roots is set to [(-1)]. *) -val fold_picked_instance : - ?rule_id:int -> t -> Random.State.t -> Pattern.id array -> - init:'a -> (int -> Pattern.id -> int -> 'a -> 'a option) -> 'a option -(** [fold_picked_instances state random_state patterns ~init f] + val fold_picked_instance : + ?rule_id:int -> + t -> + Random.State.t -> + Pattern.id array -> + init:'a -> + (int -> Pattern.id -> int -> 'a -> 'a option) -> + 'a option + (** [fold_picked_instances state random_state patterns ~init f] with [f pat_id_in_array pat corresponding_root acc]. Monadic fold function that calls [f] for every root of a random embedding from [patterns] in the mixture. This function is lazy in the sense it stops to draw roots when the accumulator besomes `None`. *) - -(** {6 Enumerating instances} *) - -val fold_instances : - ?rule_id:int -> ?excp:(Pattern.id * int) -> - t -> Pattern.id array -> init:'a -> (int array -> 'a -> 'a) -> 'a -(** [fold_enumerated_instances state patterns ~init f] + (** {6 Enumerating instances} *) + + val fold_instances : + ?rule_id:int -> + ?excp:Pattern.id * int -> + t -> + Pattern.id array -> + init:'a -> + (int array -> 'a -> 'a) -> + 'a + (** [fold_enumerated_instances state patterns ~init f] with [f roots acc]. Folds through every rectangular instance of an array of patterns. *) -val fold_unary_instances : - ?rule_id:int -> t -> Pattern.id * Pattern.id -> - init:'a -> (int * int -> 'a -> 'a) -> 'a -(** [fold_unary_instances state (pat1, pat2) ~init f ] + val fold_unary_instances : + ?rule_id:int -> + t -> + Pattern.id * Pattern.id -> + init:'a -> + (int * int -> 'a -> 'a) -> + 'a + (** [fold_unary_instances state (pat1, pat2) ~init f ] with [f (root1, root2) acc]. *) - end diff --git a/core/simulation/instances_sig.mli b/core/simulation/instances_sig.mli index 91f3672b78..2e9151867f 100644 --- a/core/simulation/instances_sig.mli +++ b/core/simulation/instances_sig.mli @@ -7,83 +7,107 @@ (******************************************************************************) (** Collection of rectangular instances. *) + (** Two implementations are available for this signature. *) module type S = sig - -type t - -type message - -val receive_message : message -> t -> t - -val empty : Model.t -> t - -val debug_print : Format.formatter -> t -> unit - - -(** {2 Updating the roots} *) - -val incorporate_extra_pattern : t -> Pattern.id -> IntCollection.t -> unit - -val break_apart_cc : - t -> Edges.t -> ?mod_connectivity_store:Roots.mod_ccs_cache -> - (int * int) option -> unit - -val merge_cc : - t -> ?mod_connectivity_store:Roots.mod_ccs_cache -> (int * int) option -> unit - -val update_roots : - t -> bool -> Pattern.Set.t -> Edges.t -> - Roots.mod_ccs_cache -> Pattern.id -> int -> unit - -(** {2 Checking instances} *) - -val is_valid : t -> Pattern.id -> int -> bool - -(** {2 Counting instances} *) - -val number_of_instances : ?rule_id:int -> t -> Pattern.id array -> int -(** [number_of_instances ?rule_id state patterns] *) - -val number_of_unary_instances_in_cc : - ?rule_id:int -> t -> Pattern.id * Pattern.id -> int -> int -(** [number_of_unary_instances_in_cc ?rule_id state (pat1, pat2) cc] *) - - -(** {2 Picking instances} *) - -val pick_unary_instance_in_cc : -?rule_id:int -> t -> Random.State.t -> Pattern.id * Pattern.id -> int -> int * int -(** [pick_unary_instance_in_cc state random_state (pat1, pat2) cc] + type t + type message + + val receive_message : message -> t -> t + val empty : Model.t -> t + val debug_print : Format.formatter -> t -> unit + + (** {2 Updating the roots} *) + + val incorporate_extra_pattern : t -> Pattern.id -> IntCollection.t -> unit + + val break_apart_cc : + t -> + Edges.t -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + (int * int) option -> + unit + + val merge_cc : + t -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + (int * int) option -> + unit + + val update_roots : + t -> + bool -> + Pattern.Set.t -> + Edges.t -> + Roots.mod_ccs_cache -> + Pattern.id -> + int -> + unit + + (** {2 Checking instances} *) + + val is_valid : t -> Pattern.id -> int -> bool + + (** {2 Counting instances} *) + + val number_of_instances : ?rule_id:int -> t -> Pattern.id array -> int + (** [number_of_instances ?rule_id state patterns] *) + + val number_of_unary_instances_in_cc : + ?rule_id:int -> t -> Pattern.id * Pattern.id -> int -> int + (** [number_of_unary_instances_in_cc ?rule_id state (pat1, pat2) cc] *) + + (** {2 Picking instances} *) + + val pick_unary_instance_in_cc : + ?rule_id:int -> + t -> + Random.State.t -> + Pattern.id * Pattern.id -> + int -> + int * int + (** [pick_unary_instance_in_cc state random_state (pat1, pat2) cc] Returns a pair of roots corresponding to [pat1] and [pat2] respectively. Optimized for currying before the [cc] argument. In case of failure, one of the resulting roots is set to [(-1)]. *) -val fold_picked_instance : - ?rule_id:int -> t -> Random.State.t -> Pattern.id array -> - init:'a -> (int -> Pattern.id -> int -> 'a -> 'a option) -> 'a option -(** [fold_picked_instances state random_state patterns ~init f] + val fold_picked_instance : + ?rule_id:int -> + t -> + Random.State.t -> + Pattern.id array -> + init:'a -> + (int -> Pattern.id -> int -> 'a -> 'a option) -> + 'a option + (** [fold_picked_instances state random_state patterns ~init f] with [f pat_id_in_array pat corresponding_root acc]. Monadic fold function that calls [f] for every root of a random embedding from [patterns] in the mixture. This function is lazy in the sense it stops to draw roots when the accumulator besomes `None`. *) - -(** {2 Enumerating instances} *) - -val fold_instances : - ?rule_id:int -> ?excp:(Pattern.id * int) -> - t -> Pattern.id array -> init:'a -> (int array -> 'a -> 'a) -> 'a -(** [fold_enumerated_instances state patterns ~init f] + (** {2 Enumerating instances} *) + + val fold_instances : + ?rule_id:int -> + ?excp:Pattern.id * int -> + t -> + Pattern.id array -> + init:'a -> + (int array -> 'a -> 'a) -> + 'a + (** [fold_enumerated_instances state patterns ~init f] with [f roots acc]. Folds through every rectangular instance of an array of patterns. *) -val fold_unary_instances : - ?rule_id:int -> t -> Pattern.id * Pattern.id -> - init:'a -> (int * int -> 'a -> 'a) -> 'a -(** [fold_unary_instances state (pat1, pat2) ~init f ] + val fold_unary_instances : + ?rule_id:int -> + t -> + Pattern.id * Pattern.id -> + init:'a -> + (int * int -> 'a -> 'a) -> + 'a + (** [fold_unary_instances state (pat1, pat2) ~init f ] with [f (root1, root2) acc]. *) - end diff --git a/core/simulation/replay.ml b/core/simulation/replay.ml index a39be3430a..2b668a667a 100644 --- a/core/simulation/replay.ml +++ b/core/simulation/replay.ml @@ -7,155 +7,177 @@ (******************************************************************************) type state = { - graph : Edges.t; - time : float; - event : int; - connected_components : Agent.SetMap.Set.t Mods.IntMap.t option; + graph: Edges.t; + time: float; + event: int; + connected_components: Agent.SetMap.Set.t Mods.IntMap.t option; } -type summary = { - unary_distances : (int * int) option -} +type summary = { unary_distances: (int * int) option } -let init_state ~with_connected_components = { - graph = Edges.empty ~with_connected_components; - time = 0.; - event = 0; - connected_components = - if with_connected_components then Some Mods.IntMap.empty else None; -} +let init_state ~with_connected_components = + { + graph = Edges.empty ~with_connected_components; + time = 0.; + event = 0; + connected_components = + (if with_connected_components then + Some Mods.IntMap.empty + else + None); + } let cc_of_agent ag e work = let rec fold_arity_list f x arity acc = - if (x = arity) then acc - else fold_arity_list f (succ x) arity (f acc x) in + if x = arity then + acc + else + fold_arity_list f (succ x) arity (f acc x) + in - let add_agent a e (work,morphism,todos) = + let add_agent a e (work, morphism, todos) = let aid = Agent.id a in let atype = Agent.sort a in let arity = Edges.get_sites aid e in - let (w_agent,work') = Pattern.new_node work atype in - let todos' = fold_arity_list (fun acc x -> (aid,x)::acc) 0 arity todos in + let w_agent, work' = Pattern.new_node work atype in + let todos' = fold_arity_list (fun acc x -> (aid, x) :: acc) 0 arity todos in let work'' = fold_arity_list (fun w x -> try - (let internal = Edges.get_internal aid x e in - Pattern.new_internal_state w (w_agent,x) internal) + let internal = Edges.get_internal aid x e in + Pattern.new_internal_state w (w_agent, x) internal with Failure _ -> w) - 0 arity work' in - (w_agent,work'',(aid,w_agent)::morphism,todos') in + 0 arity work' + in + w_agent, work'', (aid, w_agent) :: morphism, todos' + in - let add_links (work,morphism,todos) (aid,x) e = - let (_,w_agent) = List.find (fun (id,_) -> id = aid) morphism in - let not_agent (id,s) = not((id=aid)&&(x=s)) in - match (Edges.link_destination aid x e) with + let add_links (work, morphism, todos) (aid, x) e = + let _, w_agent = List.find (fun (id, _) -> id = aid) morphism in + let not_agent (id, s) = not (id = aid && x = s) in + match Edges.link_destination aid x e with | None -> - let work' = Pattern.new_free work (w_agent,x) in - let todos' = List.filter (not_agent) todos in - (work',morphism,todos') - | Some (b,y) -> - let bid = Agent.id b in - let not_agents (id,s) = - ((not_agent (id,s)) && not((id=(Agent.id b))&&(s=y))) in - try - (let (_,wb_agent) = List.find (fun (id,_) -> id = bid) morphism in - let work' = Pattern.new_link work (w_agent,x) (wb_agent,y) in - let todos' = List.filter (not_agents) todos in - (work',morphism,todos')) + let work' = Pattern.new_free work (w_agent, x) in + let todos' = List.filter not_agent todos in + work', morphism, todos' + | Some (b, y) -> + let bid = Agent.id b in + let not_agents (id, s) = + not_agent (id, s) && not (id = Agent.id b && s = y) + in + (try + let _, wb_agent = List.find (fun (id, _) -> id = bid) morphism in + let work' = Pattern.new_link work (w_agent, x) (wb_agent, y) in + let todos' = List.filter not_agents todos in + work', morphism, todos' with Not_found -> - (let (wb_agent,work',morphism',todos') = - add_agent b e (work,morphism,todos) in - let work'' = Pattern.new_link work' (w_agent,x) (wb_agent,y) in - let todos'' = List.filter (not_agents) todos' in - (work'',morphism',todos'')) in + let wb_agent, work', morphism', todos' = + add_agent b e (work, morphism, todos) + in + let work'' = Pattern.new_link work' (w_agent, x) (wb_agent, y) in + let todos'' = List.filter not_agents todos' in + work'', morphism', todos'') + in - let rec working_todo (work,morphism,todo) = match todo with - | [] -> (morphism,work) - | port::_ -> - let (work',morphism',todo') = add_links (work,morphism,todo) port e in - working_todo (work',morphism',todo') in + let rec working_todo (work, morphism, todo) = + match todo with + | [] -> morphism, work + | port :: _ -> + let work', morphism', todo' = add_links (work, morphism, todo) port e in + working_todo (work', morphism', todo') + in - let (_,w,m,t) = add_agent ag e (work,[],[]) in - working_todo (w,m,t) + let _, w, m, t = add_agent ag e (work, [], []) in + working_todo (w, m, t) -let cc_of_state ~debugMode s env = +let cc_of_state ~debug_mode s env = let cc_of_root agent e' = let work = Pattern.begin_new e' in - let (morphism,work') = cc_of_agent agent s.graph work in - let (en,_,c,i) = Pattern.finish_new ~debugMode work' in - (en,(List.map (fun (cid,(aid,_)) -> (cid,aid)) morphism),c,i) in + let morphism, work' = cc_of_agent agent s.graph work in + let en, _, c, i = Pattern.finish_new ~debug_mode work' in + en, List.map (fun (cid, (aid, _)) -> cid, aid) morphism, c, i + in match s.connected_components with | Some cc_maps -> - Mods.IntMap.fold - (fun root cc_map (e,acc) -> - Agent.SetMap.Set.fold - (fun agent (e',acc') -> - if ((Agent.id agent)=root) then - let (en,r,c,i) = cc_of_root agent e' in - (en,((r,c,i)::acc')) - else (e',acc')) - cc_map (e,acc)) - cc_maps (env,[]) - | None -> (env,[]) + Mods.IntMap.fold + (fun root cc_map (e, acc) -> + Agent.SetMap.Set.fold + (fun agent (e', acc') -> + if Agent.id agent = root then ( + let en, r, c, i = cc_of_root agent e' in + en, (r, c, i) :: acc' + ) else + e', acc') + cc_map (e, acc)) + cc_maps (env, []) + | None -> env, [] let break_apart_cc graph ccs = function | None -> ccs - | Some (origin_cc,new_cc) -> + | Some (origin_cc, new_cc) -> let set = Mods.IntMap.find_default Agent.SetMap.Set.empty origin_cc ccs in - if Agent.SetMap.Set.is_empty set then ccs - else - let nset,oset' = + if Agent.SetMap.Set.is_empty set then + ccs + else ( + let nset, oset' = Agent.SetMap.Set.partition - (fun (x,_) -> Edges.get_connected_component x graph = Some new_cc) - set in + (fun (x, _) -> Edges.get_connected_component x graph = Some new_cc) + set + in Mods.IntMap.add new_cc nset (Mods.IntMap.add origin_cc oset' ccs) + ) let merge_cc ccs = function | None -> ccs - | Some (cc1,cc2) -> + | Some (cc1, cc2) -> let set1 = Mods.IntMap.find_default Agent.SetMap.Set.empty cc1 ccs in - match Mods.IntMap.pop cc2 ccs with + (match Mods.IntMap.pop cc2 ccs with | None, _ -> ccs - | Some set2,ccs' -> Mods.IntMap.add cc1 (Agent.SetMap.Set.union set1 set2) ccs' + | Some set2, ccs' -> + Mods.IntMap.add cc1 (Agent.SetMap.Set.union set1 set2) ccs') -let do_negative_part ((a,_),s) (graph,ccs) = +let do_negative_part ((a, _), s) (graph, ccs) = match Edges.link_destination a s graph with - | None -> (Edges.remove_free a s graph,ccs) - | Some ((a',_),s') -> - let graph',cc_change = Edges.remove_link a s a' s' graph in - (graph',match ccs with + | None -> Edges.remove_free a s graph, ccs + | Some ((a', _), s') -> + let graph', cc_change = Edges.remove_link a s a' s' graph in + ( graph', + (match ccs with | None -> None - |Some ccs -> Some (break_apart_cc graph' ccs cc_change)) + | Some ccs -> Some (break_apart_cc graph' ccs cc_change)) ) -let do_action sigs (graph,ccs as pack) = function - | Instantiation.Create ((id,ty as ag),_graphs) -> - (snd @@ Edges.add_agent ~id sigs ty graph, - Option_util.map (Mods.IntMap.add id (Agent.SetMap.Set.singleton ag)) ccs) - | Instantiation.Mod_internal (((a,_),s),i) -> - (Edges.add_internal a s i graph,ccs) - | Instantiation.Bind ((a1,s1 as x1),(a2,s2 as x2)) - | Instantiation.Bind_to ((a1,s1 as x1),(a2,s2 as x2)) -> - let graph',ccs' = do_negative_part x2 (do_negative_part x1 pack) in - let graph'',cc_change = Edges.add_link a1 s1 a2 s2 graph' in - (graph'',match ccs' with +let do_action sigs ((graph, ccs) as pack) = function + | Instantiation.Create (((id, ty) as ag), _graphs) -> + ( snd @@ Edges.add_agent ~id sigs ty graph, + Option_util.map (Mods.IntMap.add id (Agent.SetMap.Set.singleton ag)) ccs ) + | Instantiation.Mod_internal (((a, _), s), i) -> + Edges.add_internal a s i graph, ccs + | Instantiation.Bind (((a1, s1) as x1), ((a2, s2) as x2)) + | Instantiation.Bind_to (((a1, s1) as x1), ((a2, s2) as x2)) -> + let graph', ccs' = do_negative_part x2 (do_negative_part x1 pack) in + let graph'', cc_change = Edges.add_link a1 s1 a2 s2 graph' in + ( graph'', + (match ccs' with | None -> None - | Some ccs' -> Some (merge_cc ccs' cc_change)) - | Instantiation.Free ((a,_),s as x) -> - let graph',ccs' = do_negative_part x pack in - (Edges.add_free a s graph',ccs') - | Instantiation.Remove (id,ty as a) -> - let graph',ccs' = - Tools.recti (fun st s -> do_negative_part (a,s) st) - pack (Signature.arity sigs ty) in - match ccs' with - | None -> (Edges.remove_agent id graph',None) + | Some ccs' -> Some (merge_cc ccs' cc_change)) ) + | Instantiation.Free (((a, _), s) as x) -> + let graph', ccs' = do_negative_part x pack in + Edges.add_free a s graph', ccs' + | Instantiation.Remove ((id, ty) as a) -> + let graph', ccs' = + Tools.recti + (fun st s -> do_negative_part (a, s) st) + pack (Signature.arity sigs ty) + in + (match ccs' with + | None -> Edges.remove_agent id graph', None | Some ccs' -> - match Mods.IntMap.pop id ccs' with - | None,_ -> assert false - | Some x,ccs'' -> + (match Mods.IntMap.pop id ccs' with + | None, _ -> assert false + | Some x, ccs'' -> let () = assert (Agent.SetMap.Set.is_singleton x) in - (Edges.remove_agent id graph',Some ccs'') + Edges.remove_agent id graph', Some ccs'')) let involved_agents l = List_util.map_option @@ -163,95 +185,130 @@ let involved_agents l = | Instantiation.Is_Here a -> Some a | Instantiation.Is_Free _ | Instantiation.Has_Internal _ | Instantiation.Is_Bound _ | Instantiation.Is_Bound_to _ - | Instantiation.Has_Binding_type _ -> None) l + | Instantiation.Has_Binding_type _ -> + None) + l let store_distances r graph = function | [] | [ _ ] | _ :: _ :: _ :: _ -> None | [ cc1; cc2 ] -> let cc1_ags = involved_agents cc1 in let cc2_ags = involved_agents cc2 in - match Edges.are_connected graph cc1_ags cc2_ags with + (match Edges.are_connected graph cc1_ags cc2_ags with | None -> None - | Some path -> Some (r,List.length path) - + | Some path -> Some (r, List.length path)) let test_pass_on graph = function | Instantiation.Is_Here ag -> Edges.is_agent ag graph | Instantiation.Has_Internal ((ag, s), st) -> - Edges.is_agent ag graph - && Edges.is_internal st (Agent.id ag) s graph + Edges.is_agent ag graph && Edges.is_internal st (Agent.id ag) s graph | Instantiation.Is_Free (ag, s) -> - Edges.is_agent ag graph - && Edges.is_free (Agent.id ag) s graph + Edges.is_agent ag graph && Edges.is_free (Agent.id ag) s graph | Instantiation.Is_Bound (ag, s) -> - Edges.is_agent ag graph - && not (Edges.is_free (Agent.id ag) s graph) + Edges.is_agent ag graph && not (Edges.is_free (Agent.id ag) s graph) | Instantiation.Is_Bound_to ((ag, s), (ag', s')) -> Edges.is_agent ag graph && Edges.is_agent ag' graph && Edges.link_exists (Agent.id ag) s (Agent.id ag') s' graph | Instantiation.Has_Binding_type ((ag, s), (ag_ty, s')) -> - Edges.is_agent ag graph && - begin match Edges.link_destination (Agent.id ag) s graph with + Edges.is_agent ag graph + && + (match Edges.link_destination (Agent.id ag) s graph with | None -> false - | Some ((_, dst_ag_ty), dst_s) -> dst_ag_ty = ag_ty && dst_s = s' - end + | Some ((_, dst_ag_ty), dst_s) -> dst_ag_ty = ag_ty && dst_s = s') let tests_pass_on graph tests = List.for_all (test_pass_on graph) (List.concat tests) let is_step_triggerable_on_edges graph = function - | Trace.Subs _ | Trace.Init _ - | Trace.Pert _ | Trace.Dummy _ -> true + | Trace.Subs _ | Trace.Init _ | Trace.Pert _ | Trace.Dummy _ -> true | Trace.Rule (_r, event, _info) -> tests_pass_on graph event.Instantiation.tests | Trace.Obs (_, tests, _) -> tests_pass_on graph tests let is_step_triggerable state = is_step_triggerable_on_edges state.graph +(* There is a subtelty when executing a sequence of actions. Indeed, + whenever a rule both creates and removes agents, there is currently + no guarantee that the creation actions are placed before the removal + actions in [event.Instantiation.actions]. This can be an issue in a + case where an event performs the following two actions for example: + ["create agent with id 8", "remove agent with id 8"]. In this case, + agent id 8 is not available when the creation action is performed and + so the [Edges] module throws an exception. + + As a temporary fix, we make sure that all deletion actions are + executed first. This implicitly assumes that a step deleting an agent + cannot perform any other action involving this agent. + + TODO: Shouldn't we rather ensure that actions are properly sorted in + the trace file in the first place? *) +let do_actions sigs st actions = + let is_removal = + let open Instantiation in + function + | Remove _ -> true + | Create _ | Mod_internal _ | Bind _ | Bind_to _ | Free _ -> false + in + let removals, others = List.partition is_removal actions in + let do_in_order actions st = List.fold_left (do_action sigs) st actions in + st |> do_in_order removals |> do_in_order others + let do_step sigs state = function - | Trace.Subs _ -> state,{ unary_distances = None } - | Trace.Rule (kind,event,info) -> + | Trace.Subs _ -> state, { unary_distances = None } + | Trace.Rule (kind, event, info) -> let unary_distances = - if state.connected_components = None then None - else store_distances kind state.graph event.Instantiation.tests in - let pregraph,connected_components = - List.fold_left - (do_action sigs) (state.graph,state.connected_components) - event.Instantiation.actions in + if state.connected_components = None then + None + else + store_distances kind state.graph event.Instantiation.tests + in + let pregraph, connected_components = + do_actions sigs + (state.graph, state.connected_components) + event.Instantiation.actions + in let graph = List.fold_left - (fun graph ((id,_),s) -> Edges.add_free id s graph) - pregraph event.Instantiation.side_effects_dst in - { - graph; connected_components; - time = info.Trace.Simulation_info.story_time; - event = info.Trace.Simulation_info.story_event; - },{unary_distances} - | Trace.Pert (_,event,info) -> - let pregraph,connected_components = - List.fold_left - (do_action sigs) (state.graph,state.connected_components) - event.Instantiation.actions in + (fun graph ((id, _), s) -> Edges.add_free id s graph) + pregraph event.Instantiation.side_effects_dst + in + ( { + graph; + connected_components; + time = info.Trace.Simulation_info.story_time; + event = info.Trace.Simulation_info.story_event; + }, + { unary_distances } ) + | Trace.Pert (_, event, info) -> + let pregraph, connected_components = + do_actions sigs + (state.graph, state.connected_components) + event.Instantiation.actions + in let graph = List.fold_left - (fun graph ((id,_),s) -> Edges.add_free id s graph) - pregraph event.Instantiation.side_effects_dst in - { - graph; connected_components; - time = info.Trace.Simulation_info.story_time; - event = info.Trace.Simulation_info.story_event; - },{ unary_distances = None } + (fun graph ((id, _), s) -> Edges.add_free id s graph) + pregraph event.Instantiation.side_effects_dst + in + ( { + graph; + connected_components; + time = info.Trace.Simulation_info.story_time; + event = info.Trace.Simulation_info.story_event; + }, + { unary_distances = None } ) | Trace.Init actions -> - let graph,connected_components = - List.fold_left - (do_action sigs) (state.graph, state.connected_components) actions in - { graph; connected_components; time = state.time; event = state.event; }, - { unary_distances = None } - | Trace.Obs (_,_,info) -> - { - graph = state.graph; - time = info.Trace.Simulation_info.story_time; - event = info.Trace.Simulation_info.story_event; - connected_components = state.connected_components; - },{ unary_distances = None } - | Trace.Dummy _ -> state,{ unary_distances = None } + let graph, connected_components = + do_actions sigs (state.graph, state.connected_components) actions + in + ( { graph; connected_components; time = state.time; event = state.event }, + { unary_distances = None } ) + | Trace.Obs (_, _, info) -> + ( { + graph = state.graph; + time = info.Trace.Simulation_info.story_time; + event = info.Trace.Simulation_info.story_event; + connected_components = state.connected_components; + }, + { unary_distances = None } ) + | Trace.Dummy _ -> state, { unary_distances = None } diff --git a/core/simulation/replay.mli b/core/simulation/replay.mli index 902e0a50ed..16e4121978 100644 --- a/core/simulation/replay.mli +++ b/core/simulation/replay.mli @@ -9,15 +9,13 @@ (** Utilities to make mixtures from traces *) type state = { - graph : Edges.t; - time : float; - event : int; - connected_components : Agent.SetMap.Set.t Mods.IntMap.t option; + graph: Edges.t; + time: float; + event: int; + connected_components: Agent.SetMap.Set.t Mods.IntMap.t option; } -type summary = { - unary_distances : (int * int) option; -} +type summary = { unary_distances: (int * int) option } val init_state : with_connected_components:bool -> state @@ -33,10 +31,12 @@ val is_step_triggerable : state -> Trace.step -> bool val is_step_triggerable_on_edges : Edges.t -> Trace.step -> bool (** same function but takes a graph of type Edges.t directly. *) -val tests_pass_on : Edges.t -> - Instantiation.concrete Instantiation.test list list -> bool +val tests_pass_on : + Edges.t -> Instantiation.concrete Instantiation.test list list -> bool (** exported for convenience. *) val cc_of_state : - debugMode:bool -> state -> Pattern.PreEnv.t -> - Pattern.PreEnv.t * ((int*int) list * Pattern.cc * Pattern.id) list + debug_mode:bool -> + state -> + Pattern.PreEnv.t -> + Pattern.PreEnv.t * ((int * int) list * Pattern.cc * Pattern.id) list diff --git a/core/simulation/resource_strings.mli b/core/simulation/resource_strings.mli index 358c211fba..1814eb68ac 100644 --- a/core/simulation/resource_strings.mli +++ b/core/simulation/resource_strings.mli @@ -1,2 +1,2 @@ -val common_js: string -val flux_js: string +val common_js : string +val flux_js : string diff --git a/core/simulation/roots.ml b/core/simulation/roots.ml index 420d4dc5de..273b36fd25 100644 --- a/core/simulation/roots.ml +++ b/core/simulation/roots.ml @@ -7,82 +7,85 @@ (******************************************************************************) type t = { - (* pat -> set of roots *) of_patterns: IntCollection.t Pattern.ObsMap.t; - (* pat -> cc -> set of roots *) - of_unary_patterns: - Mods.IntSet.t Mods.IntMap.t Pattern.ObsMap.t; + of_unary_patterns: Mods.IntSet.t Mods.IntMap.t Pattern.ObsMap.t; } type mod_ccs_cache = (int, unit) Hashtbl.t -let empty env = { - of_patterns = Pattern.Env.new_obs_map - (Model.domain env) (fun _ -> IntCollection.create 64); - of_unary_patterns = Pattern.Env.new_obs_map - (Model.domain env) (fun _ -> Mods.IntMap.empty); -} +let empty env = + { + of_patterns = + Pattern.Env.new_obs_map (Model.domain env) (fun _ -> + IntCollection.create 64); + of_unary_patterns = + Pattern.Env.new_obs_map (Model.domain env) (fun _ -> Mods.IntMap.empty); + } let incorporate_extra_pattern state pattern matchings = - if IntCollection.is_empty - (Pattern.ObsMap.get state.of_patterns pattern) then + if IntCollection.is_empty (Pattern.ObsMap.get state.of_patterns pattern) then Pattern.ObsMap.set state.of_patterns pattern matchings let add_intset_in_intmap id set map = - if Mods.IntSet.is_empty set - then Mods.IntMap.remove id map - else Mods.IntMap.add id set map - -(* Break apart connected component: - Update "roots of unary patterns" - Easy, I should not have to rewrite this. - Should caches be handled at this level ? I do nt think so - and I will probably clean this. + if Mods.IntSet.is_empty set then + Mods.IntMap.remove id map + else + Mods.IntMap.add id set map + +(* Break apart connected component: + Update "roots of unary patterns" + Easy, I should not have to rewrite this. + Should caches be handled at this level ? I do nt think so + and I will probably clean this. *) let break_apart_cc state edges ?mod_connectivity_store = function | None -> () - | Some (origin_cc,new_cc) -> - let () = match mod_connectivity_store with + | Some (origin_cc, new_cc) -> + let () = + match mod_connectivity_store with | None -> () | Some mod_conn -> let () = Hashtbl.replace mod_conn new_cc () in - Hashtbl.replace mod_conn origin_cc () in + Hashtbl.replace mod_conn origin_cc () + in Pattern.ObsMap.iteri (fun cc_id cc_map -> - let oset = - Mods.IntMap.find_default Mods.IntSet.empty origin_cc cc_map in - if not (Mods.IntSet.is_empty oset) then - let nset,oset' = - Mods.IntSet.partition - (fun x -> Edges.get_connected_component x edges = Some new_cc) - oset in - Pattern.ObsMap.set - state.of_unary_patterns cc_id - (add_intset_in_intmap - new_cc nset (add_intset_in_intmap origin_cc oset' cc_map)) - ) + let oset = + Mods.IntMap.find_default Mods.IntSet.empty origin_cc cc_map + in + if not (Mods.IntSet.is_empty oset) then ( + let nset, oset' = + Mods.IntSet.partition + (fun x -> Edges.get_connected_component x edges = Some new_cc) + oset + in + Pattern.ObsMap.set state.of_unary_patterns cc_id + (add_intset_in_intmap new_cc nset + (add_intset_in_intmap origin_cc oset' cc_map)) + )) state.of_unary_patterns (* Same: not very subtle. You just propagate. *) let merge_cc state ?mod_connectivity_store = function | None -> () - | Some (cc1,cc2) -> - let () = match mod_connectivity_store with + | Some (cc1, cc2) -> + let () = + match mod_connectivity_store with | None -> () | Some mod_connectivity -> let () = Hashtbl.replace mod_connectivity cc2 () in - Hashtbl.replace mod_connectivity cc1 () in + Hashtbl.replace mod_connectivity cc1 () + in Pattern.ObsMap.iteri (fun cc_id cc_map -> - match Mods.IntMap.pop cc2 cc_map with - | None,_ -> () - | Some set2, cc_map' -> - let set1 = Mods.IntMap.find_default Mods.IntSet.empty cc1 cc_map in - Pattern.ObsMap.set - state.of_unary_patterns cc_id - (add_intset_in_intmap cc1 (Mods.IntSet.union set1 set2) cc_map')) + match Mods.IntMap.pop cc2 cc_map with + | None, _ -> () + | Some set2, cc_map' -> + let set1 = Mods.IntMap.find_default Mods.IntSet.empty cc1 cc_map in + Pattern.ObsMap.set state.of_unary_patterns cc_id + (add_intset_in_intmap cc1 (Mods.IntSet.union set1 set2) cc_map')) state.of_unary_patterns (* Most of the code is to deal with unary_instances. @@ -91,52 +94,55 @@ let merge_cc state ?mod_connectivity_store = function let update_roots state is_add unary_ccs edges mod_connectivity pattern root = let va = Pattern.ObsMap.get state.of_patterns pattern in let () = - (if is_add then IntCollection.add else IntCollection.remove) root va in - if Pattern.Set.mem pattern unary_ccs then - let cc_map = - Pattern.ObsMap.get state.of_unary_patterns pattern in + (if is_add then + IntCollection.add + else + IntCollection.remove) + root va + in + if Pattern.Set.mem pattern unary_ccs then ( + let cc_map = Pattern.ObsMap.get state.of_unary_patterns pattern in let cc_id = (* The only case where get_connected_component is None is when [not is_add] and [root] has just been erased! But, just before being erased, we know that an agent is in its own connected component... *) - Option_util.unsome root (Edges.get_connected_component root edges) in + Option_util.unsome root (Edges.get_connected_component root edges) + in let () = Hashtbl.replace mod_connectivity cc_id () in let set = Mods.IntMap.find_default Mods.IntSet.empty cc_id cc_map in let set' = - (if is_add then Mods.IntSet.add else Mods.IntSet.remove) root set in + (if is_add then + Mods.IntSet.add + else + Mods.IntSet.remove) + root set + in let cc_map' = add_intset_in_intmap cc_id set' cc_map in Pattern.ObsMap.set state.of_unary_patterns pattern cc_map' + ) -let number r pat = - IntCollection.size (Pattern.ObsMap.get r.of_patterns pat) +let number r pat = IntCollection.size (Pattern.ObsMap.get r.of_patterns pat) let print_injections ~noCounters ?domain f roots_of_patterns = - Format.fprintf - f "@[%a@]" - (Pattern.ObsMap.print Pp.space - (fun pattern f roots -> - if IntCollection.size roots > 0 then - Format.fprintf - f "@[# @[%a@] ==>@ @[%a@]@]" - (Pattern.print ~noCounters ?domain ~with_id:true) pattern - IntCollection.print roots - ) - ) roots_of_patterns + Format.fprintf f "@[%a@]" + (Pattern.ObsMap.print Pp.space (fun pattern f roots -> + if IntCollection.size roots > 0 then + Format.fprintf f "@[# @[%a@] ==>@ @[%a@]@]" + (Pattern.print ~noCounters ?domain ~with_id:true) + pattern IntCollection.print roots)) + roots_of_patterns let print_unary_injections ~noCounters ?domain f roots_of_patterns = - Format.fprintf - f "@[%a@]" - (Pattern.ObsMap.print Pp.space - (fun pattern f root_maps -> - Format.fprintf - f "@[# @[%a@] ==>@ @[%a@]@]" - (Pattern.print ~noCounters ?domain ~with_id:true) pattern - (Pp.set Mods.IntMap.bindings Pp.space - (fun f (_cc_id, roots) -> Mods.IntSet.print f roots)) - root_maps - ) - ) roots_of_patterns + Format.fprintf f "@[%a@]" + (Pattern.ObsMap.print Pp.space (fun pattern f root_maps -> + Format.fprintf f "@[# @[%a@] ==>@ @[%a@]@]" + (Pattern.print ~noCounters ?domain ~with_id:true) + pattern + (Pp.set Mods.IntMap.bindings Pp.space (fun f (_cc_id, roots) -> + Mods.IntSet.print f roots)) + root_maps)) + roots_of_patterns let debug_print f state = let noCounters = true in diff --git a/core/simulation/roots.mli b/core/simulation/roots.mli index 8fab56909d..679572d63e 100644 --- a/core/simulation/roots.mli +++ b/core/simulation/roots.mli @@ -7,28 +7,32 @@ (******************************************************************************) type t - type mod_ccs_cache = (int, unit) Hashtbl.t val empty : Model.t -> t - val incorporate_extra_pattern : t -> Pattern.id -> IntCollection.t -> unit val break_apart_cc : - t -> Edges.t -> ?mod_connectivity_store:mod_ccs_cache -> - (int * int) option -> unit + t -> + Edges.t -> + ?mod_connectivity_store:mod_ccs_cache -> + (int * int) option -> + unit val merge_cc : t -> ?mod_connectivity_store:mod_ccs_cache -> (int * int) option -> unit val update_roots : - t -> bool -> Pattern.Set.t -> Edges.t -> - mod_ccs_cache -> Pattern.id -> int -> unit + t -> + bool -> + Pattern.Set.t -> + Edges.t -> + mod_ccs_cache -> + Pattern.id -> + int -> + unit val number : t -> Pattern.id -> int - val debug_print : Format.formatter -> t -> unit - val of_pattern : Pattern.id -> t -> IntCollection.t - val of_unary_pattern : Pattern.id -> t -> Mods.IntSet.t Mods.IntMap.t diff --git a/core/simulation/rule_interpreter.ml b/core/simulation/rule_interpreter.ml index 7405b8bde1..70b75ab89e 100644 --- a/core/simulation/rule_interpreter.ml +++ b/core/simulation/rule_interpreter.ml @@ -6,4 +6,4 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -include (Generic_rule_interpreter.Make(Instances)) +include Generic_rule_interpreter.Make (Instances) diff --git a/core/simulation/rule_interpreter.mli b/core/simulation/rule_interpreter.mli index 91304f87f2..2b052d1f59 100644 --- a/core/simulation/rule_interpreter.mli +++ b/core/simulation/rule_interpreter.mli @@ -2,93 +2,130 @@ type t type instance type result = Clash | Corrected | Blocked | Success of t -val value_alg: - Counter.t -> t -> Primitives.alg_expr -> Nbr.t +val value_alg : Counter.t -> t -> Primitives.alg_expr -> Nbr.t -val empty: - outputs:(Data.t -> unit) -> - with_trace:bool -> - Random.State.t -> - Kappa_terms.Model.t -> Counter.t -> t +val empty : + outputs:(Data.t -> unit) -> + with_trace:bool -> + Random.State.t -> + Kappa_terms.Model.t -> + Counter.t -> + t val force_rule : - debugMode:bool -> + debug_mode:bool -> outputs:(Data.t -> unit) -> - Model.t -> Counter.t -> t -> Trace.event_kind -> - ?rule_id:int -> Primitives.elementary_rule -> t option - - val update_outdated_activities : - debugMode:bool -> (int -> float -> float -> unit) -> - Model.t -> Counter.t -> t -> int list -> (t * int list) + Model.t -> + Counter.t -> + t -> + Trace.event_kind -> + ?rule_id:int -> + Primitives.elementary_rule -> + t option + +val update_outdated_activities : + debug_mode:bool -> + (int -> float -> float -> unit) -> + Model.t -> + Counter.t -> + t -> + int list -> + t * int list val overwrite_var : int -> Counter.t -> t -> Primitives.alg_expr -> t -val snapshot: - debugMode:bool -> raw:bool -> Model.t -> Counter.t -> t -> Data.snapshot +val snapshot : + debug_mode:bool -> raw:bool -> Model.t -> Counter.t -> t -> Data.snapshot val add_tracked : - outputs:(Data.t -> unit) -> Pattern.id array -> string -> - Instantiation.abstract Instantiation.test list list -> t -> t + outputs:(Data.t -> unit) -> + Pattern.id array -> + string -> + Instantiation.abstract Instantiation.test list list -> + t -> + t val remove_tracked : Pattern.id array -> string option -> t -> t val add_tracked_species : - Pattern.id array -> string -> - Instantiation.abstract Instantiation.test list list -> t -> t + Pattern.id array -> + string -> + Instantiation.abstract Instantiation.test list list -> + t -> + t + val remove_tracked_species : string -> t -> t val value_bool : - Counter.t -> t -> (Pattern.id array list,int) Alg_expr.bool -> bool + Counter.t -> t -> (Pattern.id array list, int) Alg_expr.bool -> bool - val apply_given_rule : - debugMode:bool -> outputs:(Data.t -> unit) -> - ?rule_id:int -> Model.t -> Counter.t -> t -> Trace.event_kind -> - Primitives.elementary_rule -> result +val apply_given_rule : + debug_mode:bool -> + outputs:(Data.t -> unit) -> + ?rule_id:int -> + Model.t -> + Counter.t -> + t -> + Trace.event_kind -> + Primitives.elementary_rule -> + result val incorporate_extra_pattern : - debugMode:bool -> Pattern.Env.t -> t -> Pattern.id -> t + debug_mode:bool -> Pattern.Env.t -> t -> Pattern.id -> t val activity : t -> float val apply_instance : - debugMode:bool -> outputs:(Data.t -> unit) -> - ?maxConsecutiveBlocked:int -> maxConsecutiveClash:int -> - Model.t -> Counter.t -> t -> instance -> int option * bool * t + debug_mode:bool -> + outputs:(Data.t -> unit) -> + ?maxConsecutiveBlocked:int -> + maxConsecutiveClash:int -> + Model.t -> + Counter.t -> + t -> + instance -> + int option * bool * t val apply_concrete_positive_transformation : - Signature.s -> ?mod_connectivity_store:Roots.mod_ccs_cache -> Instances.t -> - Edges.t -> Instantiation.concrete Primitives.Transformation.t -> Edges.t - -val print: Model.t -> Format.formatter -> t -> unit - -val pick_an_instance: debugMode:bool -> Kappa_terms.Model.t -> t -> instance -val is_correct_instance: Kappa_terms.Model.t -> t -> instance -> bool - -val get_random_state: t -> Random.State.t -val obs_from_transformations: -debugMode:bool -> - Kappa_terms.Pattern.Env.t -> - Kappa_mixtures.Edges.t -> - Instantiation.concrete Primitives.Transformation.t list -> - (Kappa_terms.Pattern.id * Instantiation.concrete) list * - Kappa_generic_toolset.Operator.DepSet.t - - val print_stats: Format.formatter -> t -> unit - val apply_negative_transformation: ?mod_connectivity_store:Roots.mod_ccs_cache -> - Instances.t -> - Agent.t Instantiation.site list * Kappa_mixtures.Edges.t -> - Agent.t Primitives.Transformation.t -> - Agent.t Instantiation.site list * Kappa_mixtures.Edges.t - - val apply_positive_transformation: - debugMode:bool -> - Kappa_mixtures.Signature.s -> - ?mod_connectivity_store:Roots.mod_ccs_cache -> - Instances.t -> - (Kappa_terms.Matching.t * int Kappa_generic_toolset.Mods.IntMap.t) * - Agent.t Instantiation.site list * Kappa_mixtures.Edges.t -> - Instantiation.abstract Primitives.Transformation.t -> - ((Kappa_terms.Matching.t * - int Kappa_generic_toolset.Mods.IntMap.t) * - Agent.t Instantiation.site list * Kappa_mixtures.Edges.t) * - Agent.t Primitives.Transformation.t + Signature.s -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + Instances.t -> + Edges.t -> + Instantiation.concrete Primitives.Transformation.t -> + Edges.t + +val print : Model.t -> Format.formatter -> t -> unit +val pick_an_instance : debug_mode:bool -> Kappa_terms.Model.t -> t -> instance +val is_correct_instance : Kappa_terms.Model.t -> t -> instance -> bool +val get_random_state : t -> Random.State.t + +val obs_from_transformations : + debug_mode:bool -> + Kappa_terms.Pattern.Env.t -> + Kappa_mixtures.Edges.t -> + Instantiation.concrete Primitives.Transformation.t list -> + (Kappa_terms.Pattern.id * Instantiation.concrete) list + * Kappa_generic_toolset.Operator.DepSet.t + +val print_stats : Format.formatter -> t -> unit + +val apply_negative_transformation : + ?mod_connectivity_store:Roots.mod_ccs_cache -> + Instances.t -> + Agent.t Instantiation.site list * Kappa_mixtures.Edges.t -> + Agent.t Primitives.Transformation.t -> + Agent.t Instantiation.site list * Kappa_mixtures.Edges.t + +val apply_positive_transformation : + debug_mode:bool -> + Kappa_mixtures.Signature.s -> + ?mod_connectivity_store:Roots.mod_ccs_cache -> + Instances.t -> + (Kappa_terms.Matching.t * int Kappa_generic_toolset.Mods.IntMap.t) + * Agent.t Instantiation.site list + * Kappa_mixtures.Edges.t -> + Instantiation.abstract Primitives.Transformation.t -> + ((Kappa_terms.Matching.t * int Kappa_generic_toolset.Mods.IntMap.t) + * Agent.t Instantiation.site list + * Kappa_mixtures.Edges.t) + * Agent.t Primitives.Transformation.t diff --git a/core/simulation/state_interpreter.ml b/core/simulation/state_interpreter.ml index d395f3ec25..027adbd53f 100644 --- a/core/simulation/state_interpreter.ml +++ b/core/simulation/state_interpreter.ml @@ -7,20 +7,23 @@ (******************************************************************************) type t = { - init_stopping_times : (Nbr.t * int) list; - mutable stopping_times : (Nbr.t * int) list; - perturbations_alive : bool array; - time_dependent_perts : int list; - mutable force_test_perturbations : int list; - perturbations_not_done_yet : bool array; + init_stopping_times: (Nbr.t * int) list; + mutable stopping_times: (Nbr.t * int) list; + perturbations_alive: bool array; + time_dependent_perts: int list; + mutable force_test_perturbations: int list; + perturbations_not_done_yet: bool array; (* internal array for perturbate function (global to avoid useless alloc) *) - mutable flux: (string*Data.din_data) list; - with_delta_activities : bool; + mutable flux: (string * Data.din_data) list; + with_delta_activities: bool; } -let compare_stops (t1,p1) (t2,p2) = +let compare_stops (t1, p1) (t2, p2) = let t = Nbr.compare t1 t2 in - if t = 0 then compare p1 p2 else t + if t = 0 then + compare p1 p2 + else + t let empty ~with_delta_activities counter env = let t0 = Counter.init_time counter in @@ -28,268 +31,333 @@ let empty ~with_delta_activities counter env = let algs_deps = Model.all_dependencies env in Model.fold_perturbations (fun i acc x -> - match x.Primitives.alarm with - | Some n -> - let k = 1. +. floor (t0 /. Option_util.unsome 0. (Nbr.to_float n)) in - (Nbr.mult (Nbr.F k) n,i)::acc - | None -> - let () = - if (Alg_expr.is_equality_test_time - algs_deps (fst x.Primitives.precondition)) then - raise - (ExceptionDefn.Malformed_Decl - ("Equality test on time requires an alarm", - (snd x.Primitives.precondition))) - in - let () = - if (Alg_expr.is_equality_test_time - algs_deps (fst x.Primitives.repeat)) then - raise - (ExceptionDefn.Malformed_Decl - ("Equality test on time requires an alarm", - (snd x.Primitives.repeat))) in - acc) - [] env in + match x.Primitives.alarm with + | Some n -> + let k = 1. +. floor (t0 /. Option_util.unsome 0. (Nbr.to_float n)) in + (Nbr.mult (Nbr.F k) n, i) :: acc + | None -> + let () = + if + Alg_expr.is_equality_test_time algs_deps + (fst x.Primitives.precondition) + then + raise + (ExceptionDefn.Malformed_Decl + ( "Equality test on time requires an alarm", + snd x.Primitives.precondition )) + in + let () = + if + Alg_expr.is_equality_test_time algs_deps (fst x.Primitives.repeat) + then + raise + (ExceptionDefn.Malformed_Decl + ( "Equality test on time requires an alarm", + snd x.Primitives.repeat )) + in + acc) + [] env + in let stops = List.sort compare_stops stopping_times in let time_dependent_perts = let rec aux dep acc = Operator.DepSet.fold (fun dep perts -> - match dep with - | Operator.ALG j -> - aux (Model.get_alg_reverse_dependencies env j) perts - | Operator.MODIF p -> - List_util.merge_uniq Mods.int_compare [p] perts - | Operator.RULE _ -> perts) - dep acc in - aux (let x,_,_,_ = Model.all_dependencies env in x) [] in + match dep with + | Operator.ALG j -> + aux (Model.get_alg_reverse_dependencies env j) perts + | Operator.MODIF p -> + List_util.merge_uniq Mods.int_compare [ p ] perts + | Operator.RULE _ -> perts) + dep acc + in + aux + (let x, _, _, _ = Model.all_dependencies env in + x) + [] + in { init_stopping_times = stops; stopping_times = stops; - perturbations_alive = - Array.make (Model.nb_perturbations env) true; + perturbations_alive = Array.make (Model.nb_perturbations env) true; force_test_perturbations = []; time_dependent_perts; - perturbations_not_done_yet = - Array.make (Model.nb_perturbations env) true; + perturbations_not_done_yet = Array.make (Model.nb_perturbations env) true; flux = []; with_delta_activities; } let observables_values env graph counter = - Model.map_observables - (Rule_interpreter.value_alg counter graph) - env + Model.map_observables (Rule_interpreter.value_alg counter graph) env -let do_modification - ~debugMode ~outputs env counter graph state extra modification = +let do_modification ~debug_mode ~outputs env counter graph state extra + modification = let print_expr_val = - Kappa_printer.print_expr_val - (Rule_interpreter.value_alg counter graph) in + Kappa_printer.print_expr_val (Rule_interpreter.value_alg counter graph) + in match modification with - | Primitives.ITER_RULE ((v,_),r) -> + | Primitives.ITER_RULE ((v, _), r) -> let text = - Format.asprintf - "@[%a@]" - (Kappa_printer.modification ~noCounters:debugMode ~env) modification in + Format.asprintf "@[%a@]" + (Kappa_printer.modification ~noCounters:debug_mode ~env) + modification + in let graph' = Nbr.maybe_iteri (fun _ g -> - Rule_interpreter.force_rule - ~debugMode ~outputs env counter g (Trace.PERT text) r) - graph (Rule_interpreter.value_alg counter graph v) in - let graph'',extra' = - Rule_interpreter.update_outdated_activities - ~debugMode (fun _ _ _ -> ()) env counter graph' extra in - (false,graph'',state, extra') - | Primitives.UPDATE (i,(expr,_)) -> + Rule_interpreter.force_rule ~debug_mode ~outputs env counter g + (Trace.PERT text) r) + graph + (Rule_interpreter.value_alg counter graph v) + in + let graph'', extra' = + Rule_interpreter.update_outdated_activities ~debug_mode + (fun _ _ _ -> ()) + env counter graph' extra + in + false, graph'', state, extra' + | Primitives.UPDATE (i, (expr, _)) -> let graph' = Rule_interpreter.overwrite_var i counter graph expr in - let graph'',extra' = - Rule_interpreter.update_outdated_activities - ~debugMode (fun _ _ _ -> ()) env counter graph' extra in - (false, graph'', state, extra') + let graph'', extra' = + Rule_interpreter.update_outdated_activities ~debug_mode + (fun _ _ _ -> ()) + env counter graph' extra + in + false, graph'', state, extra' | Primitives.STOP pexpr -> - let () = if pexpr <> [] then + let () = + if pexpr <> [] then ( let file = Format.asprintf "@[%a@]" print_expr_val pexpr in - outputs (Data.Snapshot - (file, Rule_interpreter.snapshot - ~debugMode ~raw:false env counter graph)) in - (true,graph,state,extra) - | Primitives.PRINT (pe_file,pe_expr) -> + outputs + (Data.Snapshot + ( file, + Rule_interpreter.snapshot ~debug_mode ~raw:false env counter + graph )) + ) + in + true, graph, state, extra + | Primitives.PRINT (pe_file, pe_expr) -> let file_opt = match pe_file with - [] -> None + | [] -> None | _ -> Some (Format.asprintf "@[%a@]" print_expr_val pe_file) in let line = Format.asprintf "@[%a@]" print_expr_val pe_expr in - let () = outputs + let () = + outputs (Data.Print - {Data.file_line_name = file_opt ; Data.file_line_text = line;}) in - (false, graph, state,extra) + { Data.file_line_name = file_opt; Data.file_line_text = line }) + in + false, graph, state, extra | Primitives.PLOTENTRY -> let () = outputs (Data.Plot (observables_values env graph counter)) in - (false, graph, state,extra) - | Primitives.SNAPSHOT (raw,pexpr) -> + false, graph, state, extra + | Primitives.SNAPSHOT (raw, pexpr) -> let file = - if pexpr = [] then "snap.ka" - else Format.asprintf "@[%a@]" print_expr_val pexpr in - let () = outputs + if pexpr = [] then + "snap.ka" + else + Format.asprintf "@[%a@]" print_expr_val pexpr + in + let () = + outputs (Data.Snapshot - (file,Rule_interpreter.snapshot ~debugMode ~raw env counter graph)) in - (false, graph, state,extra) - | Primitives.CFLOW (name,cc,tests) -> - let name = match name with + (file, Rule_interpreter.snapshot ~debug_mode ~raw env counter graph)) + in + false, graph, state, extra + | Primitives.CFLOW (name, cc, tests) -> + let name = + match name with | Some s -> s | None -> let domain = Model.domain env in - Format.asprintf - "@[%a@]" - (Pp.array - Pp.comma - (fun _ -> - Pattern.print ~noCounters:debugMode ~domain ~with_id:false)) - cc in - (false, + Format.asprintf "@[%a@]" + (Pp.array Pp.comma (fun _ -> + Pattern.print ~noCounters:debug_mode ~domain ~with_id:false)) + cc + in + ( false, Rule_interpreter.add_tracked ~outputs cc name tests graph, state, - extra) - | Primitives.CFLOWOFF (name,cc) -> - (false, Rule_interpreter.remove_tracked cc name graph, state,extra) + extra ) + | Primitives.CFLOWOFF (name, cc) -> + false, Rule_interpreter.remove_tracked cc name graph, state, extra | Primitives.SPECIES_OFF fn -> let file = Format.asprintf "@[%a@]" print_expr_val fn in - (false, Rule_interpreter.remove_tracked_species file graph, state,extra) - | Primitives.DIN (rel,s) -> + false, Rule_interpreter.remove_tracked_species file graph, state, extra + | Primitives.DIN (rel, s) -> let file = Format.asprintf "@[%a@]" print_expr_val s in let () = - if List.exists - (fun (name,x) -> file = name && x.Data.din_kind = rel) + if + List.exists + (fun (name, x) -> file = name && x.Data.din_kind = rel) state.flux - then outputs + then + outputs (Data.Warning - (None, - fun f -> - Format.fprintf - f "At t=%f, e=%i: tracking DIN into \"%s\" was already on" - (Counter.current_time counter) - (Counter.current_event counter) file)) in - let () = state.flux <- - (file,Fluxmap.create_flux env counter rel)::state.flux in - (false, graph, state,extra) + ( None, + fun f -> + Format.fprintf f + "At t=%f, e=%i: tracking DIN into \"%s\" was already on" + (Counter.current_time counter) + (Counter.current_event counter) + file )) + in + let () = + state.flux <- (file, Fluxmap.create_flux env counter rel) :: state.flux + in + false, graph, state, extra | Primitives.DINOFF s -> let file = Format.asprintf "@[%a@]" print_expr_val s in - let (these,others) = - List.partition (fun (name,_) -> name = file) state.flux in - let () = List.iter - (fun (name,x) -> outputs (Data.DIN (name,Fluxmap.stop_flux env counter x))) - these in + let these, others = + List.partition (fun (name, _) -> name = file) state.flux + in + let () = + List.iter + (fun (name, x) -> + outputs (Data.DIN (name, Fluxmap.stop_flux env counter x))) + these + in let () = state.flux <- others in - (false, graph, state,extra) - | Primitives.SPECIES (s,cc,tests) -> + false, graph, state, extra + | Primitives.SPECIES (s, cc, tests) -> let file = Format.asprintf "@[%a@]" print_expr_val s in - (false, - Rule_interpreter.add_tracked_species cc file tests graph, - state, - extra) + ( false, + Rule_interpreter.add_tracked_species cc file tests graph, + state, + extra ) -let rec perturbate - ~debugMode ~outputs ~is_alarm env counter graph state mix_changed = function - | [] -> (false,graph,state,mix_changed) +let rec perturbate ~debug_mode ~outputs ~is_alarm env counter graph state + mix_changed = function + | [] -> false, graph, state, mix_changed | i :: tail -> let pert = Model.get_perturbation env i in - let mod_alarm = match pert.Primitives.alarm with + let mod_alarm = + match pert.Primitives.alarm with | None -> true - | Some _ -> is_alarm in - if state.perturbations_alive.(i) && - state.perturbations_not_done_yet.(i) && - Rule_interpreter.value_bool - counter graph (fst pert.Primitives.precondition) && - mod_alarm - then + | Some _ -> is_alarm + in + if + state.perturbations_alive.(i) + && state.perturbations_not_done_yet.(i) + && Rule_interpreter.value_bool counter graph + (fst pert.Primitives.precondition) + && mod_alarm + then ( let mix_changed = mix_changed && pert.Primitives.needs_backtrack in - let (stop,graph,state,tail') = - List.fold_left (fun (stop,graph,state,extra as acc) effect -> - if stop then acc else - do_modification - ~debugMode ~outputs env counter graph state extra effect) - (false,graph,state,tail) pert.Primitives.effect in + let stop, graph, state, tail' = + List.fold_left + (fun ((stop, graph, state, extra) as acc) effect -> + if stop then + acc + else + do_modification ~debug_mode ~outputs env counter graph state extra + effect) + (false, graph, state, tail) + pert.Primitives.effect + in let () = state.perturbations_not_done_yet.(i) <- false in let alive = - Rule_interpreter.value_bool - counter graph (fst pert.Primitives.repeat) in - let () = if alive&&(pert.Primitives.alarm = None) then - state.force_test_perturbations <- i::state.force_test_perturbations in + Rule_interpreter.value_bool counter graph (fst pert.Primitives.repeat) + in + let () = + if alive && pert.Primitives.alarm = None then + state.force_test_perturbations <- i :: state.force_test_perturbations + in let () = state.perturbations_alive.(i) <- alive in let mix_changed' = mix_changed || pert.Primitives.needs_backtrack in - if stop then (stop,graph,state,mix_changed') else - perturbate - ~debugMode ~outputs ~is_alarm:false - env counter graph state mix_changed' tail' - else - perturbate - ~debugMode ~outputs ~is_alarm:false env counter graph state mix_changed tail + if stop then + stop, graph, state, mix_changed' + else + perturbate ~debug_mode ~outputs ~is_alarm:false env counter graph state + mix_changed' tail' + ) else + perturbate ~debug_mode ~outputs ~is_alarm:false env counter graph state + mix_changed tail -let do_modifications ~debugMode ~outputs env counter graph state list = - let (stop,graph,state,extra) = - List.fold_left (fun (stop,graph,state,extra as acc) effect -> - if stop then acc else - do_modification - ~debugMode ~outputs env counter graph state extra effect) - (false,graph,state,[]) list in - if stop then (stop,graph,state,false) - else perturbate - ~debugMode ~outputs ~is_alarm:false env counter graph state false extra +let do_modifications ~debug_mode ~outputs env counter graph state list = + let stop, graph, state, extra = + List.fold_left + (fun ((stop, graph, state, extra) as acc) effect -> + if stop then + acc + else + do_modification ~debug_mode ~outputs env counter graph state extra + effect) + (false, graph, state, []) list + in + if stop then + stop, graph, state, false + else + perturbate ~debug_mode ~outputs ~is_alarm:false env counter graph state + false extra -let initialize - ~bind ~return ~debugMode ~outputs env counter graph0 state0 init_l = +let initialize ~bind ~return ~debug_mode ~outputs env counter graph0 state0 + init_l = let mgraph = List.fold_left - (fun mstate (alg,compiled_rule) -> - bind - mstate - (fun (stop,state,state0) -> - let value = - Rule_interpreter.value_alg counter state alg in - let actions = - compiled_rule.Primitives.instantiations.Instantiation.actions in - let creations_sort = - List.fold_left - (fun l -> function - | Instantiation.Create (x,_) -> - Matching.Agent.get_type x :: l - | Instantiation.Mod_internal _ | Instantiation.Bind _ - | Instantiation.Bind_to _ | Instantiation.Free _ - | Instantiation.Remove _ -> l) [] actions in - return (stop, + (fun mstate (alg, compiled_rule) -> + bind mstate (fun (stop, state, state0) -> + let value = Rule_interpreter.value_alg counter state alg in + let actions = + compiled_rule.Primitives.instantiations.Instantiation.actions + in + let creations_sort = + List.fold_left + (fun l -> function + | Instantiation.Create (x, _) -> + Matching.Agent.get_type x :: l + | Instantiation.Mod_internal _ | Instantiation.Bind _ + | Instantiation.Bind_to _ | Instantiation.Free _ + | Instantiation.Remove _ -> + l) + [] actions + in + return + ( stop, Nbr.iteri (fun _ s -> - match Rule_interpreter.apply_given_rule - ~debugMode ~outputs env counter s - (Trace.INIT creations_sort) compiled_rule with - | Rule_interpreter.Success s -> s - | (Rule_interpreter.Clash | Rule_interpreter.Corrected - | Rule_interpreter.Blocked) -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot "Bugged initial rule"))) - state value,state0))) (return (false,graph0,state0)) init_l in - bind - mgraph - (fun (_,graph,state0) -> - let mid_graph,_ = - Rule_interpreter.update_outdated_activities - ~debugMode (fun _ _ _ -> ()) env counter graph [] in - let (stop,graph,state,_) = - Tools.array_fold_lefti (fun i (stop,graph,state,mix_changed as acc) _ -> - if stop then acc else - perturbate - ~debugMode ~outputs ~is_alarm:true - env counter graph state mix_changed [i]) - (false,mid_graph,state0,false) state0.perturbations_alive in - let () = - Array.iteri (fun i _ -> state0.perturbations_not_done_yet.(i) <- true) - state0.perturbations_not_done_yet in - return (stop,graph,state)) + match + Rule_interpreter.apply_given_rule ~debug_mode ~outputs env + counter s (Trace.INIT creations_sort) compiled_rule + with + | Rule_interpreter.Success s -> s + | Rule_interpreter.Clash | Rule_interpreter.Corrected + | Rule_interpreter.Blocked -> + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy "Bugged initial rule"))) + state value, + state0 ))) + (return (false, graph0, state0)) + init_l + in + bind mgraph (fun (_, graph, state0) -> + let mid_graph, _ = + Rule_interpreter.update_outdated_activities ~debug_mode + (fun _ _ _ -> ()) + env counter graph [] + in + let stop, graph, state, _ = + Tools.array_fold_lefti + (fun i ((stop, graph, state, mix_changed) as acc) _ -> + if stop then + acc + else + perturbate ~debug_mode ~outputs ~is_alarm:true env counter graph + state mix_changed [ i ]) + (false, mid_graph, state0, false) + state0.perturbations_alive + in + let () = + Array.iteri + (fun i _ -> state0.perturbations_not_done_yet.(i) <- true) + state0.perturbations_not_done_yet + in + return (stop, graph, state)) -let one_rule ~debugMode ~outputs ~maxConsecutiveClash env counter graph state instance = +let one_rule ~debug_mode ~outputs ~maxConsecutiveClash env counter graph state + instance = let prev_activity = Rule_interpreter.activity graph in let act_stack = ref [] in let finalize_registration my_syntax_rd_id = @@ -298,252 +366,313 @@ let one_rule ~debugMode ~outputs ~maxConsecutiveClash env counter graph state in | l, _ -> let () = if state.with_delta_activities then - outputs (Data.DeltaActivities - (my_syntax_rd_id,!act_stack)) in + outputs (Data.DeltaActivities (my_syntax_rd_id, !act_stack)) + in let n_activity = Rule_interpreter.activity graph in let () = List.iter - (fun (_,fl) -> - let () = Fluxmap.incr_flux_hit my_syntax_rd_id fl in - match fl.Data.din_kind with - | Primitives.ABSOLUTE | Primitives.RELATIVE -> () - | Primitives.PROBABILITY -> - List.iter - (fun (syntax_rd_id,(_,new_act)) -> - Fluxmap.incr_flux_flux - my_syntax_rd_id syntax_rd_id - (let cand = new_act /. n_activity in - match classify_float cand with - | (FP_nan | FP_infinite) -> - let () = - let ct = Counter.current_time counter in - outputs - (Data.Warning - (None, - fun f -> Format.fprintf - f "An infinite (or NaN) activity variation has been ignored at t=%f" - ct)) in 0. - | (FP_zero | FP_normal | FP_subnormal) -> cand) fl) - !act_stack) l in - act_stack := [] in + (fun (_, fl) -> + let () = Fluxmap.incr_flux_hit my_syntax_rd_id fl in + match fl.Data.din_kind with + | Primitives.ABSOLUTE | Primitives.RELATIVE -> () + | Primitives.PROBABILITY -> + List.iter + (fun (syntax_rd_id, (_, new_act)) -> + Fluxmap.incr_flux_flux my_syntax_rd_id syntax_rd_id + (let cand = new_act /. n_activity in + match classify_float cand with + | FP_nan | FP_infinite -> + let () = + let ct = Counter.current_time counter in + outputs + (Data.Warning + ( None, + fun f -> + Format.fprintf f + "An infinite (or NaN) activity variation \ + has been ignored at t=%f" + ct )) + in + 0. + | FP_zero | FP_normal | FP_subnormal -> cand) + fl) + !act_stack) + l + in + act_stack := [] + in (* let () = *) (* Format.eprintf "%a@." (Rule_interpreter.print_injections env) graph in *) - let applied_rid_syntax,final_step,graph' = - Rule_interpreter.apply_instance - ~debugMode ~outputs ~maxConsecutiveClash env counter graph instance in + let applied_rid_syntax, final_step, graph' = + Rule_interpreter.apply_instance ~debug_mode ~outputs ~maxConsecutiveClash + env counter graph instance + in match applied_rid_syntax with - | None -> (final_step,graph',state) + | None -> final_step, graph', state | Some syntax_rid -> let register_new_activity syntax_rd_id old_act new_act = match state.flux, state.with_delta_activities with | [], false -> () - | l,_ -> - let () = act_stack := (syntax_rd_id,(old_act,new_act))::!act_stack in + | l, _ -> + let () = + act_stack := (syntax_rd_id, (old_act, new_act)) :: !act_stack + in List.iter - (fun (_,fl) -> - Fluxmap.incr_flux_flux syntax_rid syntax_rd_id - ( - let cand = - match fl.Data.din_kind with - | Primitives.ABSOLUTE -> new_act -. old_act - | Primitives.PROBABILITY -> - -. (old_act /. prev_activity) - | Primitives.RELATIVE -> - if (match classify_float old_act with - | (FP_zero | FP_nan | FP_infinite) -> false - | (FP_normal | FP_subnormal) -> true) - then (new_act -. old_act) /. old_act - else (new_act -. old_act) in - match classify_float cand with - | (FP_nan | FP_infinite) -> - let () = - let ct = Counter.current_time counter in - outputs - (Data.Warning - (None, - fun f -> Format.fprintf - f "An infinite (or NaN) activity variation has been ignored at t=%f" - ct)) in 0. - | (FP_zero | FP_normal | FP_subnormal) -> cand) fl) - l in + (fun (_, fl) -> + Fluxmap.incr_flux_flux syntax_rid syntax_rd_id + (let cand = + match fl.Data.din_kind with + | Primitives.ABSOLUTE -> new_act -. old_act + | Primitives.PROBABILITY -> -.(old_act /. prev_activity) + | Primitives.RELATIVE -> + if + match classify_float old_act with + | FP_zero | FP_nan | FP_infinite -> false + | FP_normal | FP_subnormal -> true + then + (new_act -. old_act) /. old_act + else + new_act -. old_act + in + match classify_float cand with + | FP_nan | FP_infinite -> + let () = + let ct = Counter.current_time counter in + outputs + (Data.Warning + ( None, + fun f -> + Format.fprintf f + "An infinite (or NaN) activity variation has \ + been ignored at t=%f" + ct )) + in + 0. + | FP_zero | FP_normal | FP_subnormal -> cand) + fl) + l + in let force_tested = state.force_test_perturbations in let () = state.force_test_perturbations <- [] in - let graph'',extra_pert = - Rule_interpreter.update_outdated_activities - ~debugMode register_new_activity env counter graph' force_tested in + let graph'', extra_pert = + Rule_interpreter.update_outdated_activities ~debug_mode + register_new_activity env counter graph' force_tested + in let () = finalize_registration syntax_rid in - let (stop,graph''',state',_mix_changed) = - perturbate - ~debugMode ~outputs ~is_alarm:false env counter graph'' state false extra_pert in + let stop, graph''', state', _mix_changed = + perturbate ~debug_mode ~outputs ~is_alarm:false env counter graph'' state + false extra_pert + in let () = - Array.iteri (fun i _ -> state.perturbations_not_done_yet.(i) <- true) - state.perturbations_not_done_yet in + Array.iteri + (fun i _ -> state.perturbations_not_done_yet.(i) <- true) + state.perturbations_not_done_yet + in let () = - if debugMode then - Format.printf "@[Obtained@ %a@]@." (Rule_interpreter.print env) graph''' in - (final_step||stop,graph''',state') + if debug_mode then + Format.printf "@[Obtained@ %a@]@." + (Rule_interpreter.print env) + graph''' + in + final_step || stop, graph''', state' -let rec perturbate_until_first_backtrack - ~debugMode env counter ~outputs (stop,graph,state,dt) = +let rec perturbate_until_first_backtrack ~debug_mode env counter ~outputs + (stop, graph, state, dt) = match state.stopping_times with - | [] -> (stop,graph,state,dt,false) - | (ti,pe) :: tail -> - if (Nbr.is_smaller ti (Nbr.F (Counter.current_time counter +. dt))) then - let pert = Model.get_perturbation env pe in - if not(pert.Primitives.needs_backtrack) then - let stop',graph',state',dt' = - match Nbr.to_float - (Nbr.sub ti (Nbr.F (Counter.current_time counter))) with - | None -> false,graph,state,dt - | Some dti -> - let dt' = dt -. dti in - (*set time for perturbate *) - if Counter.one_time_advance counter dti then - let stop',graph',state',_ = - perturbate - ~debugMode ~outputs ~is_alarm:true - env counter graph state false [pe] in - let tail' = match pert.Primitives.alarm with - | None -> tail - | Some n -> - if state.perturbations_alive.(pe) then - List_util.merge_uniq compare_stops [((Nbr.add ti n),pe)] tail - else tail in - let () = state'.stopping_times <- tail' in - let () = state'.perturbations_not_done_yet.(pe) <- true in - (* Argument to reset only pe and not all perts is "if - you're not backtracking, nothing depends upon - you"... We'd better get sure of that :-) *) - stop',graph',state',dt' - else true, graph, state, dt' in - - perturbate_until_first_backtrack - ~debugMode env counter ~outputs (stop',graph',state',dt') + | [] -> stop, graph, state, dt, false + | (ti, pe) :: tail -> + if Nbr.is_smaller ti (Nbr.F (Counter.current_time counter +. dt)) then ( + let pert = Model.get_perturbation env pe in + if not pert.Primitives.needs_backtrack then ( + let stop', graph', state', dt' = + match + Nbr.to_float (Nbr.sub ti (Nbr.F (Counter.current_time counter))) + with + | None -> false, graph, state, dt + | Some dti -> + let dt' = dt -. dti in + (*set time for perturbate *) + if Counter.one_time_advance counter dti then ( + let stop', graph', state', _ = + perturbate ~debug_mode ~outputs ~is_alarm:true env counter graph + state false [ pe ] + in + let tail' = + match pert.Primitives.alarm with + | None -> tail + | Some n -> + if state.perturbations_alive.(pe) then + List_util.merge_uniq compare_stops [ Nbr.add ti n, pe ] tail + else + tail + in + let () = state'.stopping_times <- tail' in + let () = state'.perturbations_not_done_yet.(pe) <- true in + (* Argument to reset only pe and not all perts is "if + you're not backtracking, nothing depends upon + you"... We'd better get sure of that :-) *) + stop', graph', state', dt' + ) else + true, graph, state, dt' + in - (* if some perturbation needs backtrack, return the perturbation *) - else (stop,graph,state,dt,true) - else (stop,graph,state,dt,false) + perturbate_until_first_backtrack ~debug_mode env counter ~outputs + (stop', graph', state', dt') + (* if some perturbation needs backtrack, return the perturbation *) + ) else + stop, graph, state, dt, true + ) else + stop, graph, state, dt, false -let perturbate_with_backtrack - ~debugMode ~outputs env counter graph state = function +let perturbate_with_backtrack ~debug_mode ~outputs env counter graph state = + function | [] -> assert false - | (ti,pe) :: tail -> - let tail' = match (Model.get_perturbation env pe).Primitives.alarm with + | (ti, pe) :: tail -> + let tail' = + match (Model.get_perturbation env pe).Primitives.alarm with | None -> tail - | Some n -> - List_util.merge_uniq - compare_stops [((Nbr.add ti n),pe)] tail in + | Some n -> List_util.merge_uniq compare_stops [ Nbr.add ti n, pe ] tail + in let () = state.stopping_times <- tail' in - if Counter.one_time_correction_event ~ti counter then + if Counter.one_time_correction_event ~ti counter then ( let () = let outputs counter' time = let cand = - observables_values env graph (Counter.fake_time counter' time) in - if Array.length cand > 1 then outputs (Data.Plot cand) in - Counter.fill ~outputs counter ~dt:0. in - let stop,graph',state',_ = - perturbate - ~debugMode ~outputs ~is_alarm:true env counter graph state false [pe] in + observables_values env graph (Counter.fake_time counter' time) + in + if Array.length cand > 1 then outputs (Data.Plot cand) + in + Counter.fill ~outputs counter ~dt:0. + in + let stop, graph', state', _ = + perturbate ~debug_mode ~outputs ~is_alarm:true env counter graph state + false [ pe ] + in let () = - Array.iteri (fun i _ -> state'.perturbations_not_done_yet.(i) <- true) - state'.perturbations_not_done_yet in - (stop,graph',state') - else (true,graph,state) + Array.iteri + (fun i _ -> state'.perturbations_not_done_yet.(i) <- true) + state'.perturbations_not_done_yet + in + stop, graph', state' + ) else + true, graph, state -let regular_loop_body - ~debugMode ~outputs ~maxConsecutiveClash env counter graph state dt = +let regular_loop_body ~debug_mode ~outputs ~maxConsecutiveClash env counter + graph state dt = let () = let outputs counter' time = let cand = - observables_values env graph (Counter.fake_time counter' time) in - if Array.length cand > 1 then outputs (Data.Plot cand) in - Counter.fill ~outputs counter ~dt in + observables_values env graph (Counter.fake_time counter' time) + in + if Array.length cand > 1 then outputs (Data.Plot cand) + in + Counter.fill ~outputs counter ~dt + in let continue = Counter.one_time_advance counter dt in let picked_instance = - Rule_interpreter.pick_an_instance ~debugMode env graph in - let (stop,graph',state',mix_changed) = perturbate - ~debugMode ~outputs ~is_alarm:false - env counter graph state false state.time_dependent_perts in - if (not continue)||stop then (true,graph',state') else - if (not mix_changed) || - Rule_interpreter.is_correct_instance env graph' picked_instance then - one_rule - ~debugMode ~outputs ~maxConsecutiveClash - env counter graph' state' picked_instance - else (Counter.one_time_correction_event counter,graph',state') + Rule_interpreter.pick_an_instance ~debug_mode env graph + in + let stop, graph', state', mix_changed = + perturbate ~debug_mode ~outputs ~is_alarm:false env counter graph state + false state.time_dependent_perts + in + if (not continue) || stop then + true, graph', state' + else if + (not mix_changed) + || Rule_interpreter.is_correct_instance env graph' picked_instance + then + one_rule ~debug_mode ~outputs ~maxConsecutiveClash env counter graph' state' + picked_instance + else + Counter.one_time_correction_event counter, graph', state' -let a_loop ~debugMode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash - env counter graph state = +let a_loop ~debug_mode ~outputs ~dumpIfDeadlocked ~maxConsecutiveClash env + counter graph state = let activity = Rule_interpreter.activity graph in let rd = Random.State.float (Rule_interpreter.get_random_state graph) 1.0 in let dt = abs_float (log rd /. activity) in let out = (*Activity is null or dt is infinite*) - if not (activity > 0.) || classify_float dt = FP_infinite then - if List.exists - (fun (_,pe) -> - (Model.get_perturbation env pe).Primitives.needs_backtrack) - state.stopping_times then - perturbate_with_backtrack - ~debugMode ~outputs env counter graph state state.stopping_times - else + if (not (activity > 0.)) || classify_float dt = FP_infinite then + if + List.exists + (fun (_, pe) -> + (Model.get_perturbation env pe).Primitives.needs_backtrack) + state.stopping_times + then + perturbate_with_backtrack ~debug_mode ~outputs env counter graph state + state.stopping_times + else ( let () = if dumpIfDeadlocked then outputs (Data.Snapshot - ("deadlock.ka",Rule_interpreter.snapshot - ~debugMode ~raw:false env counter graph)) in + ( "deadlock.ka", + Rule_interpreter.snapshot ~debug_mode ~raw:false env counter + graph )) + in let () = outputs (Data.Warning - (None, - fun f -> - Format.fprintf f - "A deadlock was reached after %d events and %Es (Activity = %.5f)" - (Counter.current_event counter) - (Counter.current_time counter) activity)) in - (true,graph,state) - - else + ( None, + fun f -> + Format.fprintf f + "A deadlock was reached after %d events and %Es (Activity \ + = %.5f)" + (Counter.current_event counter) + (Counter.current_time counter) + activity )) + in + true, graph, state + ) + else ( (*activity is positive*) match state.stopping_times with - | (ti,_) :: _ + | (ti, _) :: _ when Nbr.is_smaller ti (Nbr.F (Counter.current_time counter +. dt)) -> - let (stop,graph',state',dt',needs_backtrack) = - perturbate_until_first_backtrack - ~debugMode env counter ~outputs (false,graph,state,dt) in + let stop, graph', state', dt', needs_backtrack = + perturbate_until_first_backtrack ~debug_mode env counter ~outputs + (false, graph, state, dt) + in if needs_backtrack then - perturbate_with_backtrack - ~debugMode ~outputs env counter graph' state' state'.stopping_times - else - if stop then (stop,graph',state') + perturbate_with_backtrack ~debug_mode ~outputs env counter graph' + state' state'.stopping_times + else if stop then + stop, graph', state' else - regular_loop_body - ~debugMode ~outputs ~maxConsecutiveClash env counter graph' state' dt' + regular_loop_body ~debug_mode ~outputs ~maxConsecutiveClash env + counter graph' state' dt' | _ -> - regular_loop_body - ~debugMode ~outputs ~maxConsecutiveClash env counter graph state dt in + regular_loop_body ~debug_mode ~outputs ~maxConsecutiveClash env counter + graph state dt + ) + in out let end_of_simulation ~outputs env counter graph state = - let _ = state.init_stopping_times in + let _ = state.init_stopping_times in let () = let outputs counter' time = let cand = - observables_values env graph (Counter.fake_time counter' time) in - if Array.length cand > 1 then outputs (Data.Plot cand) in - Counter.fill ~outputs counter ~dt:0. in + observables_values env graph (Counter.fake_time counter' time) + in + if Array.length cand > 1 then outputs (Data.Plot cand) + in + Counter.fill ~outputs counter ~dt:0. + in List.iter - (fun (name,e) -> - let () = - outputs - (Data.Warning - (None, + (fun (name, e) -> + let () = + outputs + (Data.Warning + ( None, fun f -> - Format.fprintf - f - "Tracking DIN into \"%s\" was not stopped before end of simulation" - name)) in - outputs (Data.DIN (name,Fluxmap.stop_flux env counter e))) + Format.fprintf f + "Tracking DIN into \"%s\" was not stopped before end of \ + simulation" + name )) + in + outputs (Data.DIN (name, Fluxmap.stop_flux env counter e))) state.flux diff --git a/core/simulation/state_interpreter.mli b/core/simulation/state_interpreter.mli index 4f518fa0f0..589eea56d1 100644 --- a/core/simulation/state_interpreter.mli +++ b/core/simulation/state_interpreter.mli @@ -8,16 +8,23 @@ (**Event loop module*) -type t (** Abstract state *) +type t +(** Abstract state *) val empty : with_delta_activities:bool -> Counter.t -> Model.t -> t (** [empty ~with_delta_activities env] *) val initialize : bind:('a -> (bool * Rule_interpreter.t * t -> 'a) -> 'a) -> - return:(bool * Rule_interpreter.t * t -> 'a) -> debugMode:bool -> - outputs:(Data.t -> unit) -> Model.t -> Counter.t -> Rule_interpreter.t -> t -> - (Primitives.alg_expr * Primitives.elementary_rule) list -> 'a + return:(bool * Rule_interpreter.t * t -> 'a) -> + debug_mode:bool -> + outputs:(Data.t -> unit) -> + Model.t -> + Counter.t -> + Rule_interpreter.t -> + t -> + (Primitives.alg_expr * Primitives.elementary_rule) list -> + 'a (** [initial env counter graph state] builds up the initial state *) val observables_values : @@ -26,17 +33,32 @@ val observables_values : values of observables) *) val do_modifications : - debugMode:bool -> outputs:(Data.t -> unit) -> Model.t -> Counter.t -> - Rule_interpreter.t -> t -> Primitives.modification list -> - (bool * Rule_interpreter.t * t * bool) + debug_mode:bool -> + outputs:(Data.t -> unit) -> + Model.t -> + Counter.t -> + Rule_interpreter.t -> + t -> + Primitives.modification list -> + bool * Rule_interpreter.t * t * bool val a_loop : - debugMode:bool -> outputs:(Data.t -> unit) -> dumpIfDeadlocked:bool -> - maxConsecutiveClash:int -> Model.t -> Counter.t -> - Rule_interpreter.t -> t -> (bool * Rule_interpreter.t * t) + debug_mode:bool -> + outputs:(Data.t -> unit) -> + dumpIfDeadlocked:bool -> + maxConsecutiveClash:int -> + Model.t -> + Counter.t -> + Rule_interpreter.t -> + t -> + bool * Rule_interpreter.t * t (** One event loop *) val end_of_simulation : outputs:(Data.t -> unit) -> - Model.t -> Counter.t -> Rule_interpreter.t -> t -> unit + Model.t -> + Counter.t -> + Rule_interpreter.t -> + t -> + unit (** What to do after stopping simulation. *) diff --git a/core/simulation/trace.ml b/core/simulation/trace.ml index 91a44726e5..d7825c1d37 100644 --- a/core/simulation/trace.ml +++ b/core/simulation/trace.ml @@ -7,66 +7,65 @@ (******************************************************************************) module Simulation_info = struct - type 'a t = - { - story_id: int ; - story_time: float ; - story_event: int ; - profiling_info: 'a; - } + type 'a t = { + story_id: int; + story_time: float; + story_event: int; + profiling_info: 'a; + } (* type of data to be given with observables for story compression (such as date when the obs is triggered*) let update_profiling_info a info = { - story_id = info.story_id ; - story_time = info.story_time ; - story_event = info.story_event ; - profiling_info = a + story_id = info.story_id; + story_time = info.story_time; + story_event = info.story_event; + profiling_info = a; } let event a = a.story_event let story_id a = a.story_id - let compare_by_story_id x y = Mods.int_compare x.story_id y.story_id - let dummy a = { - story_id = 0 ; story_time = 0. ; - story_event = 0 ; profiling_info = a; - } + let dummy a = + { story_id = 0; story_time = 0.; story_event = 0; profiling_info = a } let json_dictionnary = "\"simulation_info\":{\"id\":0,\"time\":1,\"event\":2,\"profiling\":3}" let to_json f x = - `List [ - `Int x.story_id; - `Float x.story_time; - `Int x.story_event; - f x.profiling_info ] + `List + [ + `Int x.story_id; + `Float x.story_time; + `Int x.story_event; + f x.profiling_info; + ] let of_json f = function | `List [ `Int story_id; `Float story_time; `Int story_event; info ] -> - { story_id; story_time; story_event; profiling_info = f info; } - | x -> raise (Yojson.Basic.Util.Type_error ("Not a simulation_info",x)) + { story_id; story_time; story_event; profiling_info = f info } + | x -> raise (Yojson.Basic.Util.Type_error ("Not a simulation_info", x)) let write_json f ob x = JsonUtil.write_sequence ob - [ (fun o -> Yojson.Basic.write_int o x.story_id); + [ + (fun o -> Yojson.Basic.write_int o x.story_id); (fun o -> Yojson.Basic.write_float o x.story_time); (fun o -> Yojson.Basic.write_int o x.story_event); - (fun o -> f o x.profiling_info) ] + (fun o -> f o x.profiling_info); + ] let read_json f st b = - JsonUtil.read_variant - Yojson.Basic.read_int + JsonUtil.read_variant Yojson.Basic.read_int (fun st b story_id -> - let story_time = - JsonUtil.read_next_item Yojson.Basic.read_number st b in - let story_event = - JsonUtil.read_next_item Yojson.Basic.read_int st b in - let profiling_info = JsonUtil.read_next_item f st b in - { story_id; story_time; story_event; profiling_info }) + let story_time = + JsonUtil.read_next_item Yojson.Basic.read_number st b + in + let story_event = JsonUtil.read_next_item Yojson.Basic.read_int st b in + let profiling_info = JsonUtil.read_next_item f st b in + { story_id; story_time; story_event; profiling_info }) st b end @@ -79,158 +78,159 @@ let print_event_kind ?env f x = match env with | None -> (match x with - | RULE i -> Format.fprintf f "RULE(%i)" i - | INIT l -> - Format.fprintf f "INIT(%a)" (Pp.list Pp.comma Format.pp_print_int) l - | PERT s -> Format.fprintf f "PERT(%s)" s) + | RULE i -> Format.fprintf f "RULE(%i)" i + | INIT l -> + Format.fprintf f "INIT(%a)" (Pp.list Pp.comma Format.pp_print_int) l + | PERT s -> Format.fprintf f "PERT(%s)" s) | Some env -> - match x with + (match x with | PERT s -> Format.pp_print_string f s - | RULE r_id -> - Model.print_rule ~noCounters:false ~env f r_id + | RULE r_id -> Model.print_rule ~noCounters:false ~env f r_id | INIT s -> - Format.fprintf - f "Intro @[%a@]" - (Pp.list Pp.comma (Model.print_agent ~env)) s + Format.fprintf f "Intro @[%a@]" + (Pp.list Pp.comma (Model.print_agent ~env)) + s) let print_event_kind_dot_annot env f = function - | RULE r_id -> - Format.fprintf - f "[label=\"%a\", shape=%s, style=%s, fillcolor = %s]" - (Model.print_rule ~noCounters:false ~env) r_id - "invhouse" "filled" "lightblue" + | RULE r_id -> + Format.fprintf f "[label=\"%a\", shape=%s, style=%s, fillcolor = %s]" + (Model.print_rule ~noCounters:false ~env) + r_id "invhouse" "filled" "lightblue" | INIT s -> - Format.fprintf - f "[label=\"Intro @[%a@]\", shape=%s, style=%s, fillcolor=green]" - (Pp.list Pp.comma (Model.print_agent ~env)) s "house" "filled" + Format.fprintf f + "[label=\"Intro @[%a@]\", shape=%s, style=%s, fillcolor=green]" + (Pp.list Pp.comma (Model.print_agent ~env)) + s "house" "filled" | PERT s -> - Format.fprintf - f "[label=\"%s\", shape=%s, style=%s, fillcolor = %s]" - s "invhouse" "filled" "green" + Format.fprintf f "[label=\"%s\", shape=%s, style=%s, fillcolor = %s]" s + "invhouse" "filled" "green" type step = | Subs of int * int | Rule of - int * - Instantiation.concrete Instantiation.event * - unit Simulation_info.t + int * Instantiation.concrete Instantiation.event * unit Simulation_info.t | Pert of - string * - Instantiation.concrete Instantiation.event * - unit Simulation_info.t + string + * Instantiation.concrete Instantiation.event + * unit Simulation_info.t | Init of Instantiation.concrete Instantiation.action list | Obs of - string * - Instantiation.concrete Instantiation.test list list * - unit Simulation_info.t - | Dummy of string + string + * Instantiation.concrete Instantiation.test list list + * unit Simulation_info.t + | Dummy of string type t = step list -let subs_step a b = Subs (a,b) +let subs_step a b = Subs (a, b) let dummy_step x = Dummy x +let print_subs _f (_a, _b) = () -let print_subs _f (_a,_b) = () - -let print_site ?env f ((ag_id,ag),s) = - Format.fprintf - f "%a_%i.%a" - (Model.print_agent ?env) ag ag_id +let print_site ?env f ((ag_id, ag), s) = + Format.fprintf f "%a_%i.%a" (Model.print_agent ?env) ag ag_id (match env with - | Some env -> - Signature.print_site (Model.signatures env) ag - | None -> Format.pp_print_int) s + | Some env -> Signature.print_site (Model.signatures env) ag + | None -> Format.pp_print_int) + s let print_init ~compact ?env log actions = - let sigs = match env with + let sigs = + match env with | None -> None - | Some env -> Some (Model.signatures env) in + | Some env -> Some (Model.signatures env) + in if compact then - Format.fprintf - log "INIT" + Format.fprintf log "INIT" else - Format.fprintf - log "***@[<1>INIT:%a@]***" - (Pp.list Pp.space (Instantiation.print_concrete_action ?sigs)) actions + Format.fprintf log "***@[<1>INIT:%a@]***" + (Pp.list Pp.space (Instantiation.print_concrete_action ?sigs)) + actions let print_side_effects ?env = Pp.list (fun f -> Format.pp_print_string f " ") - (fun f (site,state) -> - Format.fprintf - f "Side_effects(%a,%a)" - (print_site ?env) site - (Instantiation.print_concrete_binding_state - ?sigs:(Option_util.map Model.signatures env)) state) - -let print_event ~compact ?env log (ev_kind,e) = - let sigs = match env with + (fun f (site, state) -> + Format.fprintf f "Side_effects(%a,%a)" (print_site ?env) site + (Instantiation.print_concrete_binding_state + ?sigs:(Option_util.map Model.signatures env)) + state) + +let print_event ~compact ?env log (ev_kind, e) = + let sigs = + match env with | None -> None - | Some env -> Some (Model.signatures env) in - if compact then print_event_kind ?env log ev_kind + | Some env -> Some (Model.signatures env) + in + if compact then + print_event_kind ?env log ev_kind else - Format.fprintf - log "@[***Refined event:***@,* Kappa_rule %a Story encoding:%a%a%a@]" + Format.fprintf log + "@[***Refined event:***@,* Kappa_rule %a Story encoding:%a%a%a@]" (print_event_kind ?env) ev_kind (Pp.list Pp.empty (Pp.list Pp.empty (Instantiation.print_concrete_test ?sigs))) - (e.Instantiation.tests @ [e.Instantiation.connectivity_tests]) + (e.Instantiation.tests @ [ e.Instantiation.connectivity_tests ]) (Pp.list Pp.empty (Instantiation.print_concrete_action ?sigs)) - e.Instantiation.actions - (print_side_effects ?env) e.Instantiation.side_effects_src + e.Instantiation.actions (print_side_effects ?env) + e.Instantiation.side_effects_src -let print_obs ~compact ?env f (ev_kind,tests,_) = - let sigs = match env with +let print_obs ~compact ?env f (ev_kind, tests, _) = + let sigs = + match env with | None -> None - | Some env -> Some (Model.signatures env) in + | Some env -> Some (Model.signatures env) + in if compact then Format.fprintf f "OBS %s" ev_kind else - Format.fprintf - f "***@[<1>OBS %s:%a@]***" ev_kind + Format.fprintf f "***@[<1>OBS %s:%a@]***" ev_kind (Pp.list Pp.space (Pp.list Pp.space (Instantiation.print_concrete_test ?sigs))) tests -let print_step ?(compact=false) ?env f = function - | Subs (a,b) -> print_subs f (a,b) - | Rule (x,y,_z) -> print_event ~compact ?env f (RULE x,y) - | Pert (x,y,_z) -> print_event ~compact ?env f (PERT x,y) +let print_step ?(compact = false) ?env f = function + | Subs (a, b) -> print_subs f (a, b) + | Rule (x, y, _z) -> print_event ~compact ?env f (RULE x, y) + | Pert (x, y, _z) -> print_event ~compact ?env f (PERT x, y) | Init a -> print_init ~compact ?env f a - | Obs (a,b,c) -> print_obs ~compact ?env f (a,b,c) - | Dummy _ -> () + | Obs (a, b, c) -> print_obs ~compact ?env f (a, b, c) + | Dummy _ -> () let get_types_from_init a = List.fold_left (fun acc action -> match action with - Instantiation.Create ((_,atype),_) -> atype::acc + | Instantiation.Create ((_, atype), _) -> atype :: acc | Instantiation.Mod_internal _ | Instantiation.Bind _ - | Instantiation.Bind_to _ | Instantiation.Free _ - | Instantiation.Remove _ -> acc) [] a + | Instantiation.Bind_to _ | Instantiation.Free _ | Instantiation.Remove _ + -> + acc) + [] a -let print_label_of_step ?env f x = match env with +let print_label_of_step ?env f x = + match env with | None -> - (match x with - | Subs _ -> () - | Rule (x,_,_) -> Format.fprintf f "%i" x - | Pert (x,_,_) -> Format.fprintf f "%s" x - | Init a -> - let l = get_types_from_init a in - Format.fprintf f "INIT(%a)" (Pp.list Pp.comma Format.pp_print_int) l - | Obs (x,_,_) -> Format.fprintf f "%s" x - | Dummy _ -> ()) - | Some env -> match x with - | Subs _ -> () - | Rule (x,_,_) -> Model.print_rule ~noCounters:false ~env f x - | Pert (x,_,_) -> Format.pp_print_string f x - | Init a -> - let l = get_types_from_init a in - Format.fprintf - f "Intro @[%a@]" - (Pp.list Pp.comma (Model.print_agent ~env)) l - | Obs (x,_,_) -> Format.pp_print_string f x - | Dummy _ -> () + (match x with + | Subs _ -> () + | Rule (x, _, _) -> Format.fprintf f "%i" x + | Pert (x, _, _) -> Format.fprintf f "%s" x + | Init a -> + let l = get_types_from_init a in + Format.fprintf f "INIT(%a)" (Pp.list Pp.comma Format.pp_print_int) l + | Obs (x, _, _) -> Format.fprintf f "%s" x + | Dummy _ -> ()) + | Some env -> + (match x with + | Subs _ -> () + | Rule (x, _, _) -> Model.print_rule ~noCounters:false ~env f x + | Pert (x, _, _) -> Format.pp_print_string f x + | Init a -> + let l = get_types_from_init a in + Format.fprintf f "Intro @[%a@]" + (Pp.list Pp.comma (Model.print_agent ~env)) + l + | Obs (x, _, _) -> Format.pp_print_string f x + | Dummy _ -> ()) let json_dictionnary = "\"step\":[\"Subs\",\"Rule\",\"Pert\",\"Init\",\"Obs\",\"Dummy\"]" @@ -238,99 +238,140 @@ let json_dictionnary = let write_step ob s = JsonUtil.write_sequence ob (match s with - | Subs (a,b) -> - [ (fun o -> Yojson.Basic.write_int o 0); - (fun o -> Yojson.Basic.write_int o a); - (fun o -> Yojson.Basic.write_int o b) ] - | Rule (x,y,z) -> - [ (fun o -> Yojson.Basic.write_int o 1); - (fun o -> Yojson.Basic.write_int o x); - (fun o -> Instantiation.write_event Agent.write_json o y); - (fun o -> Simulation_info.write_json Yojson.Basic.write_null o z) ] - | Pert (x,y,z) -> - [ (fun o -> Yojson.Basic.write_int o 2); - (fun o -> Yojson.Basic.write_string o x); - (fun o -> Instantiation.write_event Agent.write_json o y); - (fun o -> Simulation_info.write_json Yojson.Basic.write_null o z) ] - | Init a -> - [ (fun o -> Yojson.Basic.write_int o 3); - (fun o -> - JsonUtil.write_list (Instantiation.write_action Agent.write_json) o a) ] - | Obs (x,y,z) -> - [ (fun o -> Yojson.Basic.write_int o 4); - (fun o -> Yojson.Basic.write_string o x); - (fun o -> - JsonUtil.write_list - (JsonUtil.write_list (Instantiation.write_test Agent.write_json)) - o y); - (fun o -> Simulation_info.write_json Yojson.Basic.write_null o z) ] - | Dummy _ -> [ (fun o -> Yojson.Basic.write_int o 5) ]) + | Subs (a, b) -> + [ + (fun o -> Yojson.Basic.write_int o 0); + (fun o -> Yojson.Basic.write_int o a); + (fun o -> Yojson.Basic.write_int o b); + ] + | Rule (x, y, z) -> + [ + (fun o -> Yojson.Basic.write_int o 1); + (fun o -> Yojson.Basic.write_int o x); + (fun o -> Instantiation.write_event Agent.write_json o y); + (fun o -> Simulation_info.write_json Yojson.Basic.write_null o z); + ] + | Pert (x, y, z) -> + [ + (fun o -> Yojson.Basic.write_int o 2); + (fun o -> Yojson.Basic.write_string o x); + (fun o -> Instantiation.write_event Agent.write_json o y); + (fun o -> Simulation_info.write_json Yojson.Basic.write_null o z); + ] + | Init a -> + [ + (fun o -> Yojson.Basic.write_int o 3); + (fun o -> + JsonUtil.write_list (Instantiation.write_action Agent.write_json) o a); + ] + | Obs (x, y, z) -> + [ + (fun o -> Yojson.Basic.write_int o 4); + (fun o -> Yojson.Basic.write_string o x); + (fun o -> + JsonUtil.write_list + (JsonUtil.write_list (Instantiation.write_test Agent.write_json)) + o y); + (fun o -> Simulation_info.write_json Yojson.Basic.write_null o z); + ] + | Dummy _ -> [ (fun o -> Yojson.Basic.write_int o 5) ]) + let read_step st b = JsonUtil.read_variant Yojson.Basic.read_int (fun st b -> function - | 0 -> - let a = JsonUtil.read_next_item Yojson.Basic.read_int st b in - let b = JsonUtil.read_next_item Yojson.Basic.read_int st b in - Subs (a,b) - | 1 -> - let x = JsonUtil.read_next_item Yojson.Basic.read_int st b in - let y = JsonUtil.read_next_item - (Instantiation.read_event Agent.read_json) st b in - let z = JsonUtil.read_next_item - (Simulation_info.read_json Yojson.Basic.read_null) st b in - Rule (x,y,z) - | 2 -> - let x = JsonUtil.read_next_item Yojson.Basic.read_string st b in - let y = JsonUtil.read_next_item - (Instantiation.read_event Agent.read_json) st b in - let z = JsonUtil.read_next_item - (Simulation_info.read_json Yojson.Basic.read_null) st b in - Pert (x,y,z) - | 3 -> - let l = JsonUtil.read_next_item - (Yojson.Basic.read_list_rev - (Instantiation.read_action Agent.read_json)) - st b in - Init (List.rev l) - | 4 -> - let x = JsonUtil.read_next_item Yojson.Basic.read_string st b in - let y = JsonUtil.read_next_item - (Yojson.Basic.read_list - (Yojson.Basic.read_list - (Instantiation.read_test Agent.read_json))) - st b in - let z = JsonUtil.read_next_item - (Simulation_info.read_json Yojson.Basic.read_null) st b in - Obs (x,y,z) - | 5 -> Dummy "" - | _ -> raise (Yojson.json_error "Invalid step") (*st b*)) + | 0 -> + let a = JsonUtil.read_next_item Yojson.Basic.read_int st b in + let b = JsonUtil.read_next_item Yojson.Basic.read_int st b in + Subs (a, b) + | 1 -> + let x = JsonUtil.read_next_item Yojson.Basic.read_int st b in + let y = + JsonUtil.read_next_item + (Instantiation.read_event Agent.read_json) + st b + in + let z = + JsonUtil.read_next_item + (Simulation_info.read_json Yojson.Basic.read_null) + st b + in + Rule (x, y, z) + | 2 -> + let x = JsonUtil.read_next_item Yojson.Basic.read_string st b in + let y = + JsonUtil.read_next_item + (Instantiation.read_event Agent.read_json) + st b + in + let z = + JsonUtil.read_next_item + (Simulation_info.read_json Yojson.Basic.read_null) + st b + in + Pert (x, y, z) + | 3 -> + let l = + JsonUtil.read_next_item + (Yojson.Basic.read_list_rev + (Instantiation.read_action Agent.read_json)) + st b + in + Init (List.rev l) + | 4 -> + let x = JsonUtil.read_next_item Yojson.Basic.read_string st b in + let y = + JsonUtil.read_next_item + (Yojson.Basic.read_list + (Yojson.Basic.read_list + (Instantiation.read_test Agent.read_json))) + st b + in + let z = + JsonUtil.read_next_item + (Simulation_info.read_json Yojson.Basic.read_null) + st b + in + Obs (x, y, z) + | 5 -> Dummy "" + | _ -> raise (Yojson.json_error "Invalid step") + (*st b*)) st b let step_to_yojson = function - | Subs (a,b) -> `List [`Int 0; `Int a; `Int b] - | Rule (x,y,z) -> - `List [`Int 1; - `Int x; - Instantiation.event_to_json Agent.to_json y; - Simulation_info.to_json (fun () -> `Null) z] - | Pert (x,y,z) -> - `List [`Int 2; - `String x; - Instantiation.event_to_json Agent.to_json y; - Simulation_info.to_json (fun () -> `Null) z] + | Subs (a, b) -> `List [ `Int 0; `Int a; `Int b ] + | Rule (x, y, z) -> + `List + [ + `Int 1; + `Int x; + Instantiation.event_to_json Agent.to_json y; + Simulation_info.to_json (fun () -> `Null) z; + ] + | Pert (x, y, z) -> + `List + [ + `Int 2; + `String x; + Instantiation.event_to_json Agent.to_json y; + Simulation_info.to_json (fun () -> `Null) z; + ] | Init a -> let rev_actions = - List.rev_map (Instantiation.action_to_json Agent.to_json) a in + List.rev_map (Instantiation.action_to_json Agent.to_json) a + in + `List [ `Int 3; `List (List.rev rev_actions) ] + | Obs (x, y, z) -> `List - [`Int 3; `List (List.rev rev_actions)] - | Obs (x,y,z) -> - `List [`Int 4; - `String x; - `List - (List.map (fun z -> - `List (List.map (Instantiation.test_to_json Agent.to_json) - z)) y); - Simulation_info.to_json (fun () -> `Null) z] + [ + `Int 4; + `String x; + `List + (List.map + (fun z -> + `List (List.map (Instantiation.test_to_json Agent.to_json) z)) + y); + Simulation_info.to_json (fun () -> `Null) z; + ] | Dummy _ -> `List [ `Int 5 ] let write_json = JsonUtil.write_list write_step @@ -347,57 +388,66 @@ let step_of_string s = let step_is_obs = function | Obs _ -> true | Rule _ | Pert _ | Subs _ | Dummy _ | Init _ -> false + let step_is_init = function | Init _ -> true | Rule _ | Pert _ | Subs _ | Dummy _ | Obs _ -> false + let step_is_subs = function | Subs _ -> true | Rule _ | Pert _ | Init _ | Dummy _ | Obs _ -> false + let step_is_rule = function | Rule _ -> true | Pert _ | Init _ | Subs _ | Dummy _ | Obs _ -> false + let step_is_pert = function | Pert _ -> true | Rule _ | Init _ | Subs _ | Dummy _ | Obs _ -> false let simulation_info_of_step = function - | Obs (_,_,info) | Rule (_,_,info) | Pert (_,_,info) -> Some info + | Obs (_, _, info) | Rule (_, _, info) | Pert (_, _, info) -> Some info | Init _ -> Some (Simulation_info.dummy ()) | Subs _ | Dummy _ -> None let creation_of_actions op actions = List.fold_left (fun l -> function - | Instantiation.Create (x,_) -> op x :: l - | (Instantiation.Mod_internal _ | Instantiation.Bind _ - | Instantiation.Bind_to _ | Instantiation.Free _ - | Instantiation.Remove _) -> l) [] actions + | Instantiation.Create (x, _) -> op x :: l + | Instantiation.Mod_internal _ | Instantiation.Bind _ + | Instantiation.Bind_to _ | Instantiation.Free _ | Instantiation.Remove _ + -> + l) + [] actions + let creation_of_step = function - | (Rule (_,{ Instantiation.actions = ac; _ },_) - | Pert (_,{ Instantiation.actions = ac; _ },_) - | Init ac) -> creation_of_actions fst ac + | Rule (_, { Instantiation.actions = ac; _ }, _) + | Pert (_, { Instantiation.actions = ac; _ }, _) + | Init ac -> + creation_of_actions fst ac | Obs _ | Dummy _ | Subs _ -> [] + let has_creation_of_step x = creation_of_step x <> [] let tests_of_step = function | Subs _ -> [] - | Rule (_,e,_) | Pert (_,e,_) -> - List.fold_right - List.append e.Instantiation.tests e.Instantiation.connectivity_tests + | Rule (_, e, _) | Pert (_, e, _) -> + List.fold_right List.append e.Instantiation.tests + e.Instantiation.connectivity_tests | Init _ -> [] - | Obs (_,x,_) -> List.concat x + | Obs (_, x, _) -> List.concat x | Dummy _ -> [] let actions_of_step = function - | Subs _ -> ([],[]) - | Rule (_,e,_) | Pert (_,e,_) -> - (e.Instantiation.actions,e.Instantiation.side_effects_src) - | Init y -> (y,[]) - | Obs (_,_,_) -> ([],[]) - | Dummy _ -> ([],[]) + | Subs _ -> [], [] + | Rule (_, e, _) | Pert (_, e, _) -> + e.Instantiation.actions, e.Instantiation.side_effects_src + | Init y -> y, [] + | Obs (_, _, _) -> [], [] + | Dummy _ -> [], [] let side_effects_of_step = function - | Rule ((_,e,_)) | Pert ((_,e,_)) -> e.Instantiation.side_effects_dst + | Rule (_, e, _) | Pert (_, e, _) -> e.Instantiation.side_effects_dst | Subs _ | Obs _ | Dummy _ | Init _ -> [] let init_trace_file ~uuid env desc = @@ -418,19 +468,23 @@ let init_trace_file ~uuid env desc = let assert_field ident x = if ident <> x then Yojson.json_error - ("trace lacks the field \""^x^"\" (at the right place)") + ("trace lacks the field \"" ^ x ^ "\" (at the right place)") let read_trace_headers lex_st lex_buf = let ident = - JsonUtil.read_between_spaces Yojson.Basic.read_ident lex_st lex_buf in - let ident',uuid = - if ident = "uuid" then + JsonUtil.read_between_spaces Yojson.Basic.read_ident lex_st lex_buf + in + let ident', uuid = + if ident = "uuid" then ( let () = Yojson.Basic.read_colon lex_st lex_buf in let uuid = - JsonUtil.read_between_spaces Yojson.Basic.read_string lex_st lex_buf in + JsonUtil.read_between_spaces Yojson.Basic.read_string lex_st lex_buf + in let uuid = try Some (int_of_string uuid) with _ -> None in - (JsonUtil.read_next_item Yojson.Basic.read_ident lex_st lex_buf, uuid) - else (ident, None) in + JsonUtil.read_next_item Yojson.Basic.read_ident lex_st lex_buf, uuid + ) else + ident, None + in let () = assert_field ident' "dict" in let () = Yojson.Basic.read_colon lex_st lex_buf in let () = JsonUtil.read_between_spaces Yojson.Basic.skip_json lex_st lex_buf in @@ -442,19 +496,24 @@ let fold_trace f init lex_st lex_buf = let ident = JsonUtil.read_next_item Yojson.Basic.read_ident lex_st lex_buf in let () = assert_field ident "model" in let () = Yojson.Basic.read_colon lex_st lex_buf in - let env = Model.of_yojson - (JsonUtil.read_between_spaces Yojson.Basic.read_json lex_st lex_buf) in + let env = + Model.of_yojson + (JsonUtil.read_between_spaces Yojson.Basic.read_json lex_st lex_buf) + in let ident = JsonUtil.read_next_item Yojson.Basic.read_ident lex_st lex_buf in let () = assert_field ident "trace" in - let () =Yojson.Basic.read_colon lex_st lex_buf in + let () = Yojson.Basic.read_colon lex_st lex_buf in let out = JsonUtil.read_between_spaces (Yojson.Basic.read_sequence (fun acc x y -> f env acc (read_step x y)) - (init env)) lex_st lex_buf in - let () = try Yojson.Basic.read_object_end lex_buf - with Yojson.End_of_object -> () in - (env,out) + (init env)) + lex_st lex_buf + in + let () = + try Yojson.Basic.read_object_end lex_buf with Yojson.End_of_object -> () + in + env, out let fold_trace_file f init fname = let desc = open_in fname in @@ -473,7 +532,9 @@ let get_headers_from_file fname = let ident = JsonUtil.read_next_item Yojson.Basic.read_ident lex_st lex_buf in let () = assert_field ident "model" in let () = Yojson.Basic.read_colon lex_st lex_buf in - let env = Model.of_yojson - (JsonUtil.read_between_spaces Yojson.Basic.read_json lex_st lex_buf) in + let env = + Model.of_yojson + (JsonUtil.read_between_spaces Yojson.Basic.read_json lex_st lex_buf) + in let () = close_in desc in - (uuid,env) + uuid, env diff --git a/core/simulation/trace.mli b/core/simulation/trace.mli index 563ac3ad2f..539ece165e 100644 --- a/core/simulation/trace.mli +++ b/core/simulation/trace.mli @@ -9,23 +9,19 @@ (** Trace of simulation *) module Simulation_info : sig - type 'a t = - { - story_id: int ; - story_time: float ; - story_event: int ; - profiling_info: 'a; - } + type 'a t = { + story_id: int; + story_time: float; + story_event: int; + profiling_info: 'a; + } (** type of data to be given with observables for story compression (such as date when the obs is triggered*) val compare_by_story_id : 'a t -> 'a t -> int - val update_profiling_info : 'a -> 'b t -> 'a t - val event : 'a t -> int val story_id : 'a t -> int - val json_dictionnary : string val to_json : ('a -> Yojson.Basic.t) -> 'a t -> Yojson.Basic.t val of_json : (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a t @@ -33,95 +29,90 @@ end type event_kind = | RULE of int - | INIT of int list (** the agents *) - | PERT of string (** the rule *) + | INIT of int list (** the agents *) + | PERT of string (** the rule *) + +val print_event_kind : ?env:Model.t -> Format.formatter -> event_kind -> unit -val print_event_kind : - ?env:Model.t -> Format.formatter -> event_kind -> unit val print_event_kind_dot_annot : Model.t -> Format.formatter -> event_kind -> unit type step = | Subs of int * int | Rule of - int * - Instantiation.concrete Instantiation.event * - unit Simulation_info.t + int * Instantiation.concrete Instantiation.event * unit Simulation_info.t | Pert of - string * - Instantiation.concrete Instantiation.event * - unit Simulation_info.t + string + * Instantiation.concrete Instantiation.event + * unit Simulation_info.t | Init of Instantiation.concrete Instantiation.action list | Obs of - string * - Instantiation.concrete Instantiation.test list list * - unit Simulation_info.t - | Dummy of string + string + * Instantiation.concrete Instantiation.test list list + * unit Simulation_info.t + | Dummy of string type t = step list val dummy_step : string -> step val subs_step : int -> int -> step - val step_is_obs : step -> bool val step_is_init : step -> bool val step_is_subs : step -> bool val step_is_rule : step -> bool val step_is_pert : step -> bool -val has_creation_of_step: step -> bool +val has_creation_of_step : step -> bool +val tests_of_step : step -> Instantiation.concrete Instantiation.test list -val tests_of_step : - step -> Instantiation.concrete Instantiation.test list val actions_of_step : step -> - (Instantiation.concrete Instantiation.action list * - (Instantiation.concrete Instantiation.site * - Instantiation.concrete Instantiation.binding_state) list) + Instantiation.concrete Instantiation.action list + * (Instantiation.concrete Instantiation.site + * Instantiation.concrete Instantiation.binding_state) + list (** @return (actions, side_effects) *) val side_effects_of_step : step -> Instantiation.concrete Instantiation.site list -val simulation_info_of_step: step -> unit Simulation_info.t option -val creation_of_actions : - ('a -> 'b) -> 'a Instantiation.action list -> 'b list +val simulation_info_of_step : step -> unit Simulation_info.t option +val creation_of_actions : ('a -> 'b) -> 'a Instantiation.action list -> 'b list val creation_of_step : step -> int list -val print_step: +val print_step : ?compact:bool -> ?env:Model.t -> Format.formatter -> step -> unit -val print_label_of_step: - ?env:Model.t -> Format.formatter -> step -> unit +val print_label_of_step : ?env:Model.t -> Format.formatter -> step -> unit val step_to_yojson : step -> Yojson.Basic.t - val json_dictionnary : string val write_step : Buffer.t -> step -> unit - (** Output a JSON value of type {!step}. *) +(** Output a JSON value of type {!step}. *) val string_of_step : ?len:int -> step -> string - (** Serialize a value of type {!step} into a JSON string. +(** Serialize a value of type {!step} into a JSON string. @param len specifies the initial length of the buffer used internally. Default: 1024. *) -val read_step : - Yojson.Safe.lexer_state -> Lexing.lexbuf -> step - (** Input JSON data of type {!step}. *) +val read_step : Yojson.Safe.lexer_state -> Lexing.lexbuf -> step +(** Input JSON data of type {!step}. *) val step_of_string : string -> step - (** Deserialize JSON data of type {!step}. *) +(** Deserialize JSON data of type {!step}. *) val write_json : Buffer.t -> t -> unit val read_json : Yojson.Safe.lexer_state -> Lexing.lexbuf -> t - val init_trace_file : uuid:int -> Model.t -> out_channel -> unit val fold_trace : - (Model.t -> 'a -> step -> 'a) -> (Model.t -> 'a) -> - Yojson.Safe.lexer_state -> Lexing.lexbuf -> (Model.t * 'a) + (Model.t -> 'a -> step -> 'a) -> + (Model.t -> 'a) -> + Yojson.Safe.lexer_state -> + Lexing.lexbuf -> + Model.t * 'a val fold_trace_file : - (Model.t -> 'a -> step -> 'a) -> (Model.t -> 'a) -> string -> (Model.t * 'a) + (Model.t -> 'a -> step -> 'a) -> (Model.t -> 'a) -> string -> Model.t * 'a val get_headers_from_file : string -> int option * Model.t diff --git a/core/siteGraphs/agent.ml b/core/siteGraphs/agent.ml index 79d6816bb6..83bad7565c 100644 --- a/core/siteGraphs/agent.ml +++ b/core/siteGraphs/agent.ml @@ -11,53 +11,53 @@ type t = int * int type ag = t -let print ?sigs ~with_id f (i,ty) = +let make ~id ~sort = id, sort + +let print ?sigs ~with_id f (i, ty) = match sigs with | Some sigs -> - Format.fprintf f "%a%t" (Signature.print_agent sigs) ty - (fun f -> if with_id then Format.fprintf f "/*%i*/" i) + Format.fprintf f "%a%t" (Signature.print_agent sigs) ty (fun f -> + if with_id then Format.fprintf f "/*%i*/" i) | None -> Format.fprintf f "n%i" i -let print_site ?sigs (i,agent) f id = +let print_site ?sigs (i, agent) f id = match sigs with - | Some sigs -> - Signature.print_site sigs agent f id + | Some sigs -> Signature.print_site sigs agent f id | None -> Format.fprintf f "n%is%i" i id -let print_internal ?sigs (i,agent) site f id = +let print_internal ?sigs (i, agent) site f id = match sigs with - | Some sigs -> - Signature.print_site_internal_state sigs agent site f (Some id) + | Some sigs -> Signature.print_site_internal_state sigs agent site f (Some id) | None -> Format.fprintf f "n%is%i~%i" i site id -let print_raw_internal ?sigs (i,agent) site f id = +let print_raw_internal ?sigs (i, agent) site f id = match sigs with - | Some sigs -> - Signature.print_internal_state sigs agent site f id + | Some sigs -> Signature.print_internal_state sigs agent site f id | None -> Format.fprintf f "n%is%i~%i" i site id -let rename ~debugMode inj (n_id,n_ty) = - Renaming.apply ~debugMode inj n_id,n_ty - -let sort (_,ty) = ty -let id (id,_) = id - -let compare (id1,_) (id2,_) = Mods.int_compare id1 id2 +let rename ~debug_mode inj (n_id, n_ty) = + Renaming.apply ~debug_mode inj n_id, n_ty +let sort (_, ty) = ty +let id (id, _) = id +let compare (id1, _) (id2, _) = Mods.int_compare id1 id2 let json_dictionnary = "\"agent\":{\"id\":0,\"type\":1}" let write_json ob a = JsonUtil.write_compact_pair Yojson.Basic.write_int Yojson.Basic.write_int ob a + let read_json p lb = JsonUtil.read_compact_pair Yojson.Basic.read_int Yojson.Basic.read_int p lb -let to_json (id,ty) = `List [ `Int id; `Int ty] +let to_json (id, ty) = `List [ `Int id; `Int ty ] + let of_json = function - | `List [`Int id; `Int ty] -> (id,ty) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent",x)) + | `List [ `Int id; `Int ty ] -> id, ty + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent", x)) module SetMap = SetMap.Make (struct - type t = ag - let compare = compare - let print = print ?sigs:None ~with_id:true - end) + type t = ag + + let compare = compare + let print = print ?sigs:None ~with_id:true +end) diff --git a/core/siteGraphs/agent.mli b/core/siteGraphs/agent.mli index 84c36515ed..f835a77f6b 100644 --- a/core/siteGraphs/agent.mli +++ b/core/siteGraphs/agent.mli @@ -11,22 +11,20 @@ type t = int * int (** agent_id * agent_type *) +val make : id:int -> sort:int -> t val compare : t -> t -> int - val sort : t -> int val id : t -> int +val print : ?sigs:Signature.s -> with_id:bool -> Format.formatter -> t -> unit +val print_site : ?sigs:Signature.s -> t -> Format.formatter -> int -> unit -val print : - ?sigs:Signature.s -> with_id:bool -> Format.formatter -> t -> unit -val print_site : - ?sigs:Signature.s -> t -> Format.formatter -> int -> unit val print_internal : ?sigs:Signature.s -> t -> int -> Format.formatter -> int -> unit + val print_raw_internal : ?sigs:Signature.s -> t -> int -> Format.formatter -> int -> unit -val rename : debugMode:bool -> Renaming.t -> t -> t - +val rename : debug_mode:bool -> Renaming.t -> t -> t val json_dictionnary : string val write_json : Buffer.t -> t -> unit val read_json : Yojson.Basic.lexer_state -> Lexing.lexbuf -> t diff --git a/core/siteGraphs/dune b/core/siteGraphs/dune index 0cab04640f..6f08d4e32a 100644 --- a/core/siteGraphs/dune +++ b/core/siteGraphs/dune @@ -2,4 +2,5 @@ (name kappa_mixtures) (libraries kappa_generic_toolset) (public_name kappa-library.mixtures) - (flags (:standard -w @a -open Kappa_generic_toolset))) + (flags + (:standard -w @a-40-42 -open Kappa_generic_toolset))) diff --git a/core/siteGraphs/edges.ml b/core/siteGraphs/edges.ml index 70602355d6..f1d3d0325d 100644 --- a/core/siteGraphs/edges.ml +++ b/core/siteGraphs/edges.ml @@ -10,9 +10,12 @@ module Edge = struct type t = Agent.t * int (** agent * site *) - let _compare ((n,_),s) ((n',_),s') = + let _compare ((n, _), s) ((n', _), s') = let c = Mods.int_compare n n' in - if c <> 0 then c else Mods.int_compare s s' + if c <> 0 then + c + else + Mods.int_compare s s' (* let dummy_link = ((-1,-1),-1) *) end @@ -20,154 +23,178 @@ end (* functions using the cache are responsible of reseting the cache at exit *) module Cache = struct type t = { - tests : int Mods.DynArray.t; - bag : int Mods.DynArray.t; - mutable limit : int; + tests: int Mods.DynArray.t; + bag: int Mods.DynArray.t; + mutable limit: int; } let int_l = 31 (*Sys.int_size*) - let create () = { - tests = Mods.DynArray.make 1 0; - bag = Mods.DynArray.make 1 0; - limit = 0; - } + let create () = + { tests = Mods.DynArray.make 1 0; bag = Mods.DynArray.make 1 0; limit = 0 } let mark t i = let x = i / int_l in let old = Mods.DynArray.get t.tests x in - let () = if old = 0 then + let () = + if old = 0 then ( let () = Mods.DynArray.set t.bag t.limit x in - t.limit <- succ t.limit in + t.limit <- succ t.limit + ) + in Mods.DynArray.set t.tests x (old lor (1 lsl (i mod int_l))) let test t i = - (Mods.DynArray.get t.tests (i / int_l)) land (1 lsl (i mod int_l)) <> 0 + Mods.DynArray.get t.tests (i / int_l) land (1 lsl (i mod int_l)) <> 0 let reset t = let () = Tools.iteri (fun i -> Mods.DynArray.set t.tests (Mods.DynArray.get t.bag i) 0) - t.limit in + t.limit + in t.limit <- 0 let iteri_reset f t = let () = - Tools.iteri - (fun k -> - let i = Mods.DynArray.get t.bag k in - let v = Mods.DynArray.get t.tests i in - if v <> 0 then - let acc = int_l * i in - let () = - Tools.iteri - (fun j -> if v land (1 lsl j) <> 0 then f (acc+j)) - int_l in - Mods.DynArray.set t.tests i 0) - t.limit in + Tools.iteri + (fun k -> + let i = Mods.DynArray.get t.bag k in + let v = Mods.DynArray.get t.tests i in + if v <> 0 then ( + let acc = int_l * i in + let () = + Tools.iteri + (fun j -> if v land (1 lsl j) <> 0 then f (acc + j)) + int_l + in + Mods.DynArray.set t.tests i 0 + )) + t.limit + in t.limit <- 0 end let glue_connected_component links cache ccs node1 node2 = let cc_id_op = Mods.DynArray.get ccs node2 in let rec explore_site id site next = - if site = 0 then next else + if site = 0 then + next + else ( match (Mods.DynArray.get links id).(pred site) with | None -> explore_site id (pred site) next - | Some ((id',_),_) -> - if Mods.DynArray.get ccs id' = cc_id_op || - Cache.test cache id' then explore_site id (pred site) next - else + | Some ((id', _), _) -> + if Mods.DynArray.get ccs id' = cc_id_op || Cache.test cache id' then + explore_site id (pred site) next + else ( let () = Cache.mark cache id' in - explore_site id (pred site) (id'::next) in + explore_site id (pred site) (id' :: next) + ) + ) + in let rec is_in_cc next = function - | id ::todos -> + | id :: todos -> is_in_cc (explore_site id (Array.length (Mods.DynArray.get links id)) next) todos - | [] -> match next with + | [] -> + (match next with | [] -> Cache.iteri_reset (fun i -> Mods.DynArray.set ccs i cc_id_op) cache - | _ -> is_in_cc [] next in + | _ -> is_in_cc [] next) + in let () = Cache.mark cache node1 in - is_in_cc [] [node1] + is_in_cc [] [ node1 ] -let separate_connected_component links (cache1,cache2) ccs node1 node2 = +let separate_connected_component links (cache1, cache2) ccs node1 node2 = let old_cc_id = Option_util.unsome (-1) (Mods.DynArray.get ccs node1) in let rec inspect_site cache ?dst_cache id site next = - if site = 0 then Some next else + if site = 0 then + Some next + else ( match (Mods.DynArray.get links id).(pred site) with | None -> inspect_site cache ?dst_cache id (pred site) next - | Some ((id',_),_) -> - if match dst_cache with + | Some ((id', _), _) -> + if + match dst_cache with | None -> false - | Some dc -> Cache.test dc id' then None - else if Cache.test cache id' - then inspect_site cache ?dst_cache id (pred site) next - else + | Some dc -> Cache.test dc id' + then + None + else if Cache.test cache id' then + inspect_site cache ?dst_cache id (pred site) next + else ( let () = Cache.mark cache id' in - inspect_site cache ?dst_cache id (pred site) (id'::next) in + inspect_site cache ?dst_cache id (pred site) (id' :: next) + ) + ) + in let rec mark_new_cc orig cache next = function - | id ::todos -> - begin match - inspect_site - cache id (Array.length (Mods.DynArray.get links id)) next with + | id :: todos -> + (match + inspect_site cache id (Array.length (Mods.DynArray.get links id)) next + with | None -> assert false - | Some next' -> mark_new_cc orig cache next' todos - end - | [] -> match next with + | Some next' -> mark_new_cc orig cache next' todos) + | [] -> + (match next with | [] -> let () = - Cache.iteri_reset - (fun i -> Mods.DynArray.set ccs i (Some orig)) cache in - Some (old_cc_id,orig) - | _ -> mark_new_cc orig cache [] next in - let rec in_same_cc - other_orig other_cache other_next - this_orig this_cache this_next = function - | id ::todos -> - begin match - inspect_site - this_cache ~dst_cache:other_cache id - (Array.length (Mods.DynArray.get links id)) this_next with + Cache.iteri_reset (fun i -> Mods.DynArray.set ccs i (Some orig)) cache + in + Some (old_cc_id, orig) + | _ -> mark_new_cc orig cache [] next) + in + let rec in_same_cc other_orig other_cache other_next this_orig this_cache + this_next = function + | id :: todos -> + (match + inspect_site this_cache ~dst_cache:other_cache id + (Array.length (Mods.DynArray.get links id)) + this_next + with | None -> let () = Cache.reset this_cache in let () = Cache.reset other_cache in None | Some next' -> - in_same_cc - other_orig other_cache other_next this_orig this_cache next' todos - end - | [] -> match this_next with + in_same_cc other_orig other_cache other_next this_orig this_cache next' + todos) + | [] -> + (match this_next with | [] -> - if Cache.test this_cache old_cc_id then + if Cache.test this_cache old_cc_id then ( let () = Cache.reset this_cache in mark_new_cc other_orig other_cache [] other_next - else + ) else ( let () = Cache.reset other_cache in let () = Cache.iteri_reset - (fun i -> Mods.DynArray.set ccs i (Some this_orig)) this_cache in - Some (old_cc_id,this_orig) + (fun i -> Mods.DynArray.set ccs i (Some this_orig)) + this_cache + in + Some (old_cc_id, this_orig) + ) | _ -> - in_same_cc - this_orig this_cache this_next other_orig other_cache [] other_next in + in_same_cc this_orig this_cache this_next other_orig other_cache [] + other_next) + in let () = Cache.mark cache1 node1 in let () = Cache.mark cache2 node2 in - in_same_cc node1 cache1 [node1] node2 cache2 [] [node2] + in_same_cc node1 cache1 [ node1 ] node2 cache2 [] [ node2 ] type tables = { - connect : Edge.t option array Mods.DynArray.t; - state : int option array Mods.DynArray.t; - sort : int option Mods.DynArray.t; - connected_component : int option Mods.DynArray.t option; - caches : Cache.t * Cache.t; + connect: Edge.t option array Mods.DynArray.t; + state: int option array Mods.DynArray.t; + sort: int option Mods.DynArray.t; + connected_component: int option Mods.DynArray.t option; + caches: Cache.t * Cache.t; } type t = { - mutable tables : tables option; - missings : Mods.Int2Set.t; - free_id : int * int list; + mutable tables: tables option; + missings: Mods.Int2Set.t; + free_id: int * int list; } (** (agent,site -> binding_state; missings); agent,site -> internal_state; agent -> sort; free_id @@ -175,44 +202,49 @@ type t = { let empty ~with_connected_components = { - tables = Some { - connect = Mods.DynArray.make 1 [||]; - state = Mods.DynArray.make 1 [||]; - sort = Mods.DynArray.make 1 None; - connected_component = if with_connected_components - then Some (Mods.DynArray.make 1 None) - else None; - caches = (Cache.create (), Cache.create ()); - }; + tables = + Some + { + connect = Mods.DynArray.make 1 [||]; + state = Mods.DynArray.make 1 [||]; + sort = Mods.DynArray.make 1 None; + connected_component = + (if with_connected_components then + Some (Mods.DynArray.make 1 None) + else + None); + caches = Cache.create (), Cache.create (); + }; missings = Mods.Int2Set.empty; - free_id =(0,[]); + free_id = 0, []; } let copy graph = match graph.tables with | None -> assert false - | Some tables -> { - tables = Some { - connect = Mods.DynArray.map Array.copy tables.connect; - state = Mods.DynArray.map Array.copy tables.state; - sort = Mods.DynArray.copy tables.sort; - connected_component = - (match tables.connected_component with - | None -> None - | Some ccs -> Some (Mods.DynArray.copy ccs)); - caches = (Cache.create (), Cache.create ()); - }; + | Some tables -> + { + tables = + Some + { + connect = Mods.DynArray.map Array.copy tables.connect; + state = Mods.DynArray.map Array.copy tables.state; + sort = Mods.DynArray.copy tables.sort; + connected_component = + (match tables.connected_component with + | None -> None + | Some ccs -> Some (Mods.DynArray.copy ccs)); + caches = Cache.create (), Cache.create (); + }; free_id = graph.free_id; missings = graph.missings; } -type stats = { nb_agents : int } +type stats = { nb_agents: int } let stats graph = - let (top_id, free_ids) = graph.free_id in - { - nb_agents = top_id - List.length free_ids; - } + let top_id, free_ids = graph.free_id in + { nb_agents = top_id - List.length free_ids } let add_agent ?id sigs ty graph = let ar = Signature.arity sigs ty in @@ -222,40 +254,40 @@ let add_agent ?id sigs ty graph = | None -> assert false | Some tables -> let () = graph.tables <- None in - let h,free_id = + let h, free_id = match id with | Some id -> - (id, - let new_id,l = graph.free_id in - if id < new_id then - match List.partition (fun i -> i = id) l with - | [ _ ], t -> (new_id,t) - | _, _ -> - raise - (ExceptionDefn.Internal_Error - (Locality.dummy_annot - ("Try to add an agent with a the free id " - ^string_of_int id))) - else - (succ id, Tools.recti (fun acc k -> (k+new_id)::acc) l (id-new_id)) - ) - | None -> match graph.free_id with - | new_id,h :: t -> h,(new_id,t) - | new_id,[] -> new_id,(succ new_id,[]) in - let missings' = Tools.recti (fun a s -> Mods.Int2Set.add (h,s) a) - graph.missings ar in + ( id, + let new_id, l = graph.free_id in + if id < new_id then ( + match List.partition (fun i -> i = id) l with + | [ _ ], t -> new_id, t + | _, _ -> + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy + ("Try to add an agent with a the free id " + ^ string_of_int id))) + ) else + ( succ id, + Tools.recti (fun acc k -> (k + new_id) :: acc) l (id - new_id) ) ) + | None -> + (match graph.free_id with + | new_id, h :: t -> h, (new_id, t) + | new_id, [] -> new_id, (succ new_id, [])) + in + let missings' = + Tools.recti (fun a s -> Mods.Int2Set.add (h, s) a) graph.missings ar + in let () = Mods.DynArray.set tables.connect h al in let () = Mods.DynArray.set tables.state h ai in let () = Mods.DynArray.set tables.sort h (Some ty) in - let () = match tables.connected_component with + let () = + match tables.connected_component with | None -> () - | Some ccs -> Mods.DynArray.set ccs h (Some h) in - h, - { - tables = Some tables; - missings = missings'; - free_id; - } + | Some ccs -> Mods.DynArray.set ccs h (Some h) + in + h, { tables = Some tables; missings = missings'; free_id } let add_free ag s graph = match graph.tables with @@ -265,7 +297,7 @@ let add_free ag s graph = let () = (Mods.DynArray.get tables.connect ag).(s) <- None in { tables = Some tables; - missings = Mods.Int2Set.remove (ag,s) graph.missings; + missings = Mods.Int2Set.remove (ag, s) graph.missings; free_id = graph.free_id; } @@ -275,34 +307,43 @@ let add_internal ag s i graph = | Some tables -> let () = graph.tables <- None in let () = (Mods.DynArray.get tables.state ag).(s) <- Some i in - { - tables = Some tables; - missings = graph.missings; - free_id = graph.free_id; - } + { tables = Some tables; missings = graph.missings; free_id = graph.free_id } -let add_link (ag,ty) s (ag',ty') s' graph = +let add_link (ag, ty) s (ag', ty') s' graph = match graph.tables with | None -> assert false | Some tables -> let () = graph.tables <- None in - let () = (Mods.DynArray.get tables.connect ag).(s) <- Some ((ag',ty'),s') in - let () = (Mods.DynArray.get tables.connect ag').(s') <- Some ((ag,ty),s) in - let out = match tables.connected_component with + let () = + (Mods.DynArray.get tables.connect ag).(s) <- Some ((ag', ty'), s') + in + let () = + (Mods.DynArray.get tables.connect ag').(s') <- Some ((ag, ty), s) + in + let out = + match tables.connected_component with | None -> None | Some ccs -> let i = Option_util.unsome (-1) (Mods.DynArray.get ccs ag) in let j = Option_util.unsome (-2) (Mods.DynArray.get ccs ag') in - if i = j then None else - let () = glue_connected_component - tables.connect (fst tables.caches) ccs ag ag' in - Some (j,i) in - { - tables = Some tables; - missings = - Mods.Int2Set.remove (ag,s) (Mods.Int2Set.remove (ag',s') graph.missings); - free_id = graph.free_id; - },out + if i = j then + None + else ( + let () = + glue_connected_component tables.connect (fst tables.caches) ccs ag + ag' + in + Some (j, i) + ) + in + ( { + tables = Some tables; + missings = + Mods.Int2Set.remove (ag, s) + (Mods.Int2Set.remove (ag', s') graph.missings); + free_id = graph.free_id; + }, + out ) let remove_agent ag graph = match graph.tables with @@ -312,13 +353,17 @@ let remove_agent ag graph = let () = Mods.DynArray.set tables.connect ag [||] in let () = Mods.DynArray.set tables.state ag [||] in let () = Mods.DynArray.set tables.sort ag None in - let () = match tables.connected_component with + let () = + match tables.connected_component with | None -> () - | Some ccs -> Mods.DynArray.set ccs ag None in + | Some ccs -> Mods.DynArray.set ccs ag None + in { tables = Some tables; - missings = Mods.Int2Set.filter (fun (ag',_) -> ag <> ag') graph.missings; - free_id = (let new_id,ids = graph.free_id in (new_id,ag::ids)); + missings = Mods.Int2Set.filter (fun (ag', _) -> ag <> ag') graph.missings; + free_id = + (let new_id, ids = graph.free_id in + new_id, ag :: ids); } let remove_free ag s graph = @@ -329,7 +374,7 @@ let remove_free ag s graph = let () = assert ((Mods.DynArray.get tables.connect ag).(s) = None) in { tables = Some tables; - missings = Mods.Int2Set.add (ag,s) graph.missings; + missings = Mods.Int2Set.add (ag, s) graph.missings; free_id = graph.free_id; } @@ -337,11 +382,12 @@ let get_internal ag s graph = match graph.tables with | None -> assert false | Some tables -> - match (Mods.DynArray.get tables.state ag).(s) with + (match (Mods.DynArray.get tables.state ag).(s) with | Some i -> i | None -> - failwith ("Site "^string_of_int s^ " of agent "^string_of_int ag^ - " has no internal state in the current graph.") + failwith + ("Site " ^ string_of_int s ^ " of agent " ^ string_of_int ag + ^ " has no internal state in the current graph.")) let get_sites ag graph = match graph.tables with @@ -354,11 +400,11 @@ let get_sort ag graph = match graph.tables with | None -> assert false | Some tables -> - match Mods.DynArray.get tables.sort ag with + (match Mods.DynArray.get tables.sort ag with | Some ty -> ty | None -> - failwith ("Agent "^string_of_int ag^ - " has no type in the current graph.") + failwith + ("Agent " ^ string_of_int ag ^ " has no type in the current graph.")) let remove_internal ag s graph = match graph.tables with @@ -367,14 +413,15 @@ let remove_internal ag s graph = let () = graph.tables <- None in let i = (Mods.DynArray.get tables.state ag).(s) in let () = (Mods.DynArray.get tables.state ag).(s) <- None in - match i with - None -> assert false + (match i with + | None -> assert false | Some i -> - i, { - tables = Some tables; - missings = graph.missings; - free_id = graph.free_id; - } + ( i, + { + tables = Some tables; + missings = graph.missings; + free_id = graph.free_id; + } )) let remove_link ag s ag' s' graph = match graph.tables with @@ -383,51 +430,69 @@ let remove_link ag s ag' s' graph = let () = graph.tables <- None in let () = (Mods.DynArray.get tables.connect ag).(s) <- None in let () = (Mods.DynArray.get tables.connect ag').(s') <- None in - let out = match tables.connected_component with + let out = + match tables.connected_component with | None -> None | Some ccs -> - separate_connected_component - tables.connect tables.caches ccs ag ag' in - { - tables = Some tables; - missings = - Mods.Int2Set.add (ag,s) (Mods.Int2Set.add (ag',s') graph.missings); - free_id = graph.free_id; - },out + separate_connected_component tables.connect tables.caches ccs ag ag' + in + ( { + tables = Some tables; + missings = + Mods.Int2Set.add (ag, s) (Mods.Int2Set.add (ag', s') graph.missings); + free_id = graph.free_id; + }, + out ) -let is_agent (ag,ty) graph = +let is_agent (ag, ty) graph = match graph.tables with | None -> assert false | Some tables -> let () = assert (Mods.Int2Set.is_empty graph.missings) in - match Mods.DynArray.get tables.sort ag with - | Some ty' -> let () = assert (ty = ty') in true - | None -> false + (match Mods.DynArray.get tables.sort ag with + | Some ty' -> + let () = assert (ty = ty') in + true + | None -> false) + +let is_agent_id ag graph = + match graph.tables with + | None -> assert false + | Some tables -> + let () = assert (Mods.Int2Set.is_empty graph.missings) in + Mods.DynArray.get tables.sort ag <> None + let is_free ag s graph = match graph.tables with | None -> assert false | Some tables -> let () = assert (Mods.Int2Set.is_empty graph.missings) in - let t = Mods.DynArray.get tables.connect ag in t <> [||] && t.(s) = None + let t = Mods.DynArray.get tables.connect ag in + t <> [||] && t.(s) = None + let is_internal i ag s graph = match graph.tables with | None -> assert false | Some tables -> let () = assert (Mods.Int2Set.is_empty graph.missings) in let t = Mods.DynArray.get tables.state ag in - t <> [||] && match t.(s) with + t <> [||] + && + (match t.(s) with | Some j -> j = i - | None -> false + | None -> false) + let link_exists ag s ag' s' graph = match graph.tables with | None -> assert false | Some tables -> let () = assert (Mods.Int2Set.is_empty graph.missings) in let t = Mods.DynArray.get tables.connect ag in - t <> [||] && - match t.(s) with - | Some ((ag'',_),s'') -> ag'=ag'' && s'=s'' - | None -> false + t <> [||] + && + (match t.(s) with + | Some ((ag'', _), s'') -> ag' = ag'' && s' = s'' + | None -> false) let exists_fresh ag s ty s' graph = match graph.tables with @@ -435,164 +500,193 @@ let exists_fresh ag s ty s' graph = | Some tables -> let () = assert (Mods.Int2Set.is_empty graph.missings) in let t = Mods.DynArray.get tables.connect ag in - if t = [||] then None else + if t = [||] then + None + else ( match t.(s) with - | Some ((ag',ty'),s'') -> - if ty'=ty && s'=s'' then Some ag' else None + | Some ((ag', ty'), s'') -> + if ty' = ty && s' = s'' then + Some ag' + else + None | None -> None + ) let link_destination ag s graph = + match graph.tables with + | None -> assert false + | Some tables -> (Mods.DynArray.get tables.connect ag).(s) + +let iter_neighbors f ag graph = match graph.tables with | None -> assert false | Some tables -> - (Mods.DynArray.get tables.connect ag).(s) + let ag_table = Mods.DynArray.get tables.connect ag in + Array.iter + (function + | None -> () + | Some s -> f (fst s)) + ag_table let all_agents_where f graph = match graph.tables with | None -> assert false | Some tables -> let out = IntCollection.create 0 in - let () = Mods.DynArray.iteri + let () = + Mods.DynArray.iteri (fun id -> function - | Some ty when f (id,ty) -> IntCollection.add id out - | _ -> ()) - tables.sort in + | Some ty when f (id, ty) -> IntCollection.add id out + | _ -> ()) + tables.sort + in out let in_same_connected_component ag ag' graph = match graph.tables with | None -> assert false - | Some tables -> match tables.connected_component with + | Some tables -> + (match tables.connected_component with | None -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - "in_same_connected_component while not tracking ccs")) - | Some ccs -> - Mods.DynArray.get ccs ag = Mods.DynArray.get ccs ag' + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy + "in_same_connected_component while not tracking ccs")) + | Some ccs -> Mods.DynArray.get ccs ag = Mods.DynArray.get ccs ag') let get_connected_component ag graph = match graph.tables with | None -> assert false - | Some tables -> match tables.connected_component with + | Some tables -> + (match tables.connected_component with | None -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - "get_connected_component while not tracking ccs")) - | Some ccs -> Mods.DynArray.get ccs ag + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy + "get_connected_component while not tracking ccs")) + | Some ccs -> Mods.DynArray.get ccs ag) (** The snapshot machinery *) let one_connected_component sigs ty node graph = - let rec build id acc known = - function - | [] -> Tools.array_rev_map_of_list - (fun (node_id_in_witness,node_type,sites) -> { - Snapshot.node_id_in_witness; - Snapshot.node_type; - Snapshot.node_sites = - Tools.array_map_of_list - (fun (link,site_state) -> { - Snapshot.site_link = - Option_util.map - (fun ((n,_),s) -> - Mods.IntMap.find_default (-1) n known,s) - link; - Snapshot.site_state; - }) - sites; - }) acc - | (node,ty) :: todos -> - if Cache.test (fst graph.caches) node - then build id acc known todos - else match Mods.DynArray.get graph.sort node with + let rec build id acc known = function + | [] -> + Tools.array_rev_map_of_list + (fun (node_id_in_witness, node_type, sites) -> + { + Snapshot.node_id_in_witness; + Snapshot.node_type; + Snapshot.node_sites = + Tools.array_map_of_list + (fun (link, site_state) -> + { + Snapshot.site_link = + Option_util.map + (fun ((n, _), s) -> + Mods.IntMap.find_default (-1) n known, s) + link; + Snapshot.site_state; + }) + sites; + }) + acc + | (node, ty) :: todos -> + if Cache.test (fst graph.caches) node then + build id acc known todos + else ( + match Mods.DynArray.get graph.sort node with | None -> failwith "Edges.one_connected_component" | Some _ -> let () = Cache.mark (fst graph.caches) node in let known' = Mods.IntMap.add node id known in let arity = Signature.arity sigs ty in - let todos',ports = + let todos', ports = Tools.recti - (fun (todos,acc) i -> - let link = (Mods.DynArray.get graph.connect node).(i) in - (match link with + (fun (todos, acc) i -> + let link = (Mods.DynArray.get graph.connect node).(i) in + ( (match link with | None -> todos - | Some ((n',_ as p),_) -> - if Mods.IntMap.mem n' known' then todos else (p::todos)), - ((link, - (Mods.DynArray.get graph.state node).(i)))::acc) - (todos,[]) arity in - build (succ id) ((node,ty,ports)::acc) known' todos' in - build 0 [] Mods.IntMap.empty [node,ty] - -let species ~debugMode sigs root graph = + | Some (((n', _) as p), _) -> + if Mods.IntMap.mem n' known' then + todos + else + p :: todos), + (link, (Mods.DynArray.get graph.state node).(i)) :: acc )) + (todos, []) arity + in + build (succ id) ((node, ty, ports) :: acc) known' todos' + ) + in + build 0 [] Mods.IntMap.empty [ node, ty ] + +let species ~debug_mode sigs root graph = match graph.tables with | None -> assert false | Some tables -> - let specie = match Mods.DynArray.get tables.sort root with + let specie = + match Mods.DynArray.get tables.sort root with | None -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - ("Sort of node unavailable "^string_of_int root))) + (Loc.annot_with_dummy + ("Sort of node unavailable " ^ string_of_int root))) | Some ty -> - Snapshot.cc_to_user_cc - ~debugMode ~raw:true sigs (one_connected_component sigs ty root tables) in + Snapshot.cc_to_user_cc ~debug_mode ~raw:true sigs + (one_connected_component sigs ty root tables) + in let () = Cache.reset (fst tables.caches) in specie let rec aux_build_snapshot raw sigs tables ccs node = - if node = Mods.DynArray.length tables.sort then + if node = Mods.DynArray.length tables.sort then ( let () = Cache.reset (fst tables.caches) in ccs - else - if Cache.test (fst tables.caches) node - then aux_build_snapshot raw sigs tables ccs (succ node) - else match Mods.DynArray.get tables.sort node with + ) else if Cache.test (fst tables.caches) node then + aux_build_snapshot raw sigs tables ccs (succ node) + else ( + match Mods.DynArray.get tables.sort node with | None -> aux_build_snapshot raw sigs tables ccs (succ node) | Some ty -> - let out = - one_connected_component sigs ty node tables in - aux_build_snapshot - raw sigs tables - (Snapshot.increment_in_snapshot ~raw sigs out ccs) (succ node) + let out = one_connected_component sigs ty node tables in + aux_build_snapshot raw sigs tables + (Snapshot.increment_in_snapshot ~raw sigs out ccs) + (succ node) + ) let build_snapshot ~raw sigs graph = match graph.tables with | None -> assert false - | Some tables -> - aux_build_snapshot raw sigs tables Snapshot.empty 0 + | Some tables -> aux_build_snapshot raw sigs tables Snapshot.empty 0 -let build_user_snapshot ~debugMode ~raw sigs graph = - Snapshot.export ~debugMode ~raw sigs (build_snapshot ~raw sigs graph) +let build_user_snapshot ~debug_mode ~raw sigs graph = + Snapshot.export ~debug_mode ~raw sigs (build_snapshot ~raw sigs graph) let debug_print f graph = match graph.tables with | None -> Format.fprintf f "OUTDATED@ " | Some tables -> let print_sites ag = - (Pp.array Pp.comma - (fun s f l -> - Format.fprintf - f "%i%t%t" s - (match (Mods.DynArray.get tables.state ag).(s) with - | Some int -> fun f -> Format.fprintf f "~%i" int - | None -> fun _ -> ()) - (fun f -> match l with - | None -> - if Mods.Int2Set.mem (ag,s) graph.missings - then Format.pp_print_string f "?" - | Some ((ag',ty'),s') -> - Format.fprintf f "->%i:%i.%i" ag' ty' s'))) in - Mods.DynArray.print - Pp.empty + Pp.array Pp.comma (fun s f l -> + Format.fprintf f "%i%t%t" s + (match (Mods.DynArray.get tables.state ag).(s) with + | Some int -> fun f -> Format.fprintf f "~%i" int + | None -> fun _ -> ()) + (fun f -> + match l with + | None -> + if Mods.Int2Set.mem (ag, s) graph.missings then + Format.pp_print_string f "?" + | Some ((ag', ty'), s') -> + Format.fprintf f "->%i:%i.%i" ag' ty' s')) + in + Mods.DynArray.print Pp.empty (fun ag f a -> - match Mods.DynArray.get tables.sort ag with - | Some ty -> - Format.fprintf - f "%i:%i(@[%a@])@ " ag ty (print_sites ag) a - | None -> if a = [||] then () - else Format.fprintf - f "%i:NOTYPE(@[%a@])@ " ag (print_sites ag) a - ) + match Mods.DynArray.get tables.sort ag with + | Some ty -> Format.fprintf f "%i:%i(@[%a@])@ " ag ty (print_sites ag) a + | None -> + if a = [||] then + () + else + Format.fprintf f "%i:NOTYPE(@[%a@])@ " ag (print_sites ag) a) f tables.connect type path = ((Agent.t * int) * (Agent.t * int)) list @@ -600,61 +694,91 @@ type path = ((Agent.t * int) * (Agent.t * int)) list let rec print_path ?sigs f = function | [] -> Pp.empty_set f - | [(ag,s),(ag',s')] -> + | [ ((ag, s), (ag', s')) ] -> Format.fprintf f "%a.%a@,-%a.%a" - (Agent.print ?sigs ~with_id:true) ag (Agent.print_site ?sigs ag) s - (Agent.print_site ?sigs ag') s' (Agent.print ?sigs ~with_id:true) ag' - | ((ag,s),((p',_ as ag'),s'))::((((p'',_),_),_)::_ as l) -> + (Agent.print ?sigs ~with_id:true) + ag + (Agent.print_site ?sigs ag) + s + (Agent.print_site ?sigs ag') + s' + (Agent.print ?sigs ~with_id:true) + ag' + | ((ag, s), (((p', _) as ag'), s')) :: ((((p'', _), _), _) :: _ as l) -> Format.fprintf f "%a.%a@,-%a.%t%a" - (Agent.print ?sigs ~with_id:true) ag (Agent.print_site ?sigs ag) s - (Agent.print_site ?sigs ag') s' + (Agent.print ?sigs ~with_id:true) + ag + (Agent.print_site ?sigs ag) + s + (Agent.print_site ?sigs ag') + s' (fun f -> - if p' <> p'' then - Format.fprintf f "%a##" (Agent.print ?sigs ~with_id:true) ag') + if p' <> p'' then + Format.fprintf f "%a##" (Agent.print ?sigs ~with_id:true) ag') (print_path ?sigs) l let empty_path = [] -let singleton_path n s n' s' = [(n,s),(n',s')] -let rev_path l = List.rev_map (fun (x,y) -> (y,x)) l +let singleton_path n s n' s' = [ (n, s), (n', s') ] +let rev_path l = List.rev_map (fun (x, y) -> y, x) l let is_valid_path p graph = - List.for_all (fun (((ag,_),s),((ag',_),s')) -> link_exists ag s ag' s' graph) p - -let breadth_first_traversal - ~looping ?max_distance stop_on_find is_interesting links cache out todos = - let rec look_each_site ((id,_ as ag),path as x) site (out,next as acc) = - if site = 0 then Some (false,out,next) else + List.for_all + (fun (((ag, _), s), ((ag', _), s')) -> link_exists ag s ag' s' graph) + p + +let breadth_first_traversal ~looping ?max_distance stop_on_find is_interesting + links cache out todos = + let rec look_each_site ((((id, _) as ag), path) as x) site + ((out, next) as acc) = + if site = 0 then + Some (false, out, next) + else ( match (Mods.DynArray.get links id).(pred site) with | None -> look_each_site x (pred site) acc - | Some ((id',_ as ag'),site' as y) -> - if ag' = fst looping && site' <> snd looping then None - else if Cache.test cache id' then look_each_site x (pred site) acc - else + | Some ((((id', _) as ag'), site') as y) -> + if ag' = fst looping && site' <> snd looping then + None + else if Cache.test cache id' then + look_each_site x (pred site) acc + else ( let () = Cache.mark cache id' in - let path' = (y,(ag,pred site))::path in - let next' = (ag',path')::next in - let out',store = + let path' = (y, (ag, pred site)) :: path in + let next' = (ag', path') :: next in + let out', store = match is_interesting ag' with - | Some x -> ((x,id'),path')::out,true - | None -> out,false in - if store&&stop_on_find then Some (true,out',next') - else look_each_site x (pred site) (out',next') in + | Some x -> ((x, id'), path') :: out, true + | None -> out, false + in + if store && stop_on_find then + Some (true, out', next') + else + look_each_site x (pred site) (out', next') + ) + ) + in (* depth = number of edges between root and node *) let rec aux depth out next = function - | ((id,_),_ as x)::todos -> - (match look_each_site - x (Array.length (Mods.DynArray.get links id)) (out,next) with - | None -> [] - | Some (stop,out',next') -> - if stop then out' else aux depth out' next' todos) - | [] -> match next with + | (((id, _), _) as x) :: todos -> + (match + look_each_site x (Array.length (Mods.DynArray.get links id)) (out, next) + with + | None -> [] + | Some (stop, out', next') -> + if stop then + out' + else + aux depth out' next' todos) + | [] -> + (match next with | [] -> out (* end when all graph traversed and return the list of paths *) - | _ -> match max_distance with + | _ -> + (match max_distance with | Some d when d <= depth -> out (* stop when the max distance is reached *) - | Some _ -> aux (depth+1) out [] next - | None -> aux depth out [] next in + | Some _ -> aux (depth + 1) out [] next + | None -> aux depth out [] next)) + in aux 1 out [] todos (* nodes_x: agent_id list = (int * int) list @@ -663,21 +787,42 @@ let are_connected ?max_distance graph nodes_x nodes_y = match graph.tables with | None -> assert false | Some tables -> - if in_same_connected_component - (fst (List.hd nodes_x)) (fst (List.hd nodes_y)) graph then + if + in_same_connected_component + (fst (List.hd nodes_x)) + (fst (List.hd nodes_y)) + graph + then ( (* look for the closest node in nodes_y *) - let is_in_nodes_y z = if List.mem z nodes_y then Some () else None in + let is_in_nodes_y z = + if List.mem z nodes_y then + Some () + else + None + in (* breadth first search is called on a list of sites; start the breadth first search with the boundaries of nodes_x, that is all sites that are connected to other nodes in x and with all nodes in nodes_x marked as done *) let prepare = - List.fold_left (fun acc (id,_ as ag) -> + List.fold_left + (fun acc ((id, _) as ag) -> let () = Cache.mark (fst tables.caches) id in - (ag,[])::acc) [] nodes_x in - match breadth_first_traversal ~looping:((-1,-1),-1) ?max_distance true - is_in_nodes_y tables.connect (fst tables.caches) [] prepare - with [] -> let () = Cache.reset (fst tables.caches) in None - | [ _,p ] -> let () = Cache.reset (fst tables.caches) in Some p - | _ :: _ -> failwith "Edges.are_they_connected completely broken" - else None + (ag, []) :: acc) + [] nodes_x + in + match + breadth_first_traversal + ~looping:((-1, -1), -1) + ?max_distance true is_in_nodes_y tables.connect (fst tables.caches) [] + prepare + with + | [] -> + let () = Cache.reset (fst tables.caches) in + None + | [ (_, p) ] -> + let () = Cache.reset (fst tables.caches) in + Some p + | _ :: _ -> failwith "Edges.are_they_connected completely broken" + ) else + None diff --git a/core/siteGraphs/edges.mli b/core/siteGraphs/edges.mli index b776e0ac07..c94499df57 100644 --- a/core/siteGraphs/edges.mli +++ b/core/siteGraphs/edges.mli @@ -10,16 +10,16 @@ type t -val empty : with_connected_components : bool -> t +val empty : with_connected_components:bool -> t val copy : t -> t (** You'd better NOT use that on the state of a simulation *) -type stats = { nb_agents : int } +type stats = { nb_agents: int } val stats : t -> stats -val add_agent : ?id:int -> Signature.s -> int -> t -> int * t +val add_agent : ?id:int -> Signature.s -> int -> t -> int * t (** [add_agent ?id sigs agent_type graph] *) val add_free : int -> int -> t -> t @@ -28,19 +28,23 @@ val add_free : int -> int -> t -> t val add_internal : int -> int -> int -> t -> t (** [add_internal agent_id site internal_state graph] *) -val add_link : Agent.t -> int -> Agent.t -> int -> t -> t * (int*int) option +val add_link : Agent.t -> int -> Agent.t -> int -> t -> t * (int * int) option (** [add_link ag1 s1 ag2 s2 t] Some (i,j) as second returned element means cc j is now merged into cc i *) val remove_agent : int -> t -> t val remove_free : int -> int -> t -> t val remove_internal : int -> int -> t -> int * t -val remove_link : int -> int -> int -> int -> t -> t * (int*int) option + +val remove_link : int -> int -> int -> int -> t -> t * (int * int) option (** Some (i,j) as second returned element means separate "new" cc j from cc i *) val is_agent : Agent.t -> t -> bool (** [is_agent agent graph] *) +val is_agent_id : int -> t -> bool +(** [is_agent_id agent_id graph] *) + val is_free : int -> int -> t -> bool (** [is_free agent_id site graph] *) @@ -60,35 +64,38 @@ val get_internal : int -> int -> t -> int (** [get_internal ag site graph] *) val get_sites : int -> t -> int - val get_sort : int -> t -> int - val get_connected_component : int -> t -> int option - val in_same_connected_component : int -> int -> t -> bool +val iter_neighbors : (Agent.t -> unit) -> int -> t -> unit +(** [iter_neighbors f ag graph] calls function [f] on all direct + neighbors of agent [ag] in [graph]. *) + val all_agents_where : (Agent.t -> bool) -> t -> IntCollection.t type path = ((Agent.t * int) * (Agent.t * int)) list + val empty_path : path val singleton_path : Agent.t -> int -> Agent.t -> int -> path val rev_path : path -> path -val print_path : - ?sigs:Signature.s -> Format.formatter -> path -> unit - +val print_path : ?sigs:Signature.s -> Format.formatter -> path -> unit val is_valid_path : path -> t -> bool val are_connected : - ?max_distance : int -> t -> Agent.t list -> Agent.t list -> path option + ?max_distance:int -> t -> Agent.t list -> Agent.t list -> path option (** [are_connected ?max_distance graph nodes_x nodes_y] *) val species : - debugMode:bool -> Signature.s -> int -> t -> User_graph.connected_component + debug_mode:bool -> Signature.s -> int -> t -> User_graph.connected_component val build_snapshot : raw:bool -> Signature.s -> t -> Snapshot.t val build_user_snapshot : - debugMode:bool -> raw:bool -> Signature.s -> t -> + debug_mode:bool -> + raw:bool -> + Signature.s -> + t -> (int * User_graph.connected_component) list val debug_print : Format.formatter -> t -> unit diff --git a/core/siteGraphs/navigation.ml b/core/siteGraphs/navigation.ml index bc327ca157..3c187009b3 100644 --- a/core/siteGraphs/navigation.ml +++ b/core/siteGraphs/navigation.ml @@ -7,324 +7,402 @@ (******************************************************************************) type abstract = Existing of int | Fresh of Agent.t - type 'a port = 'a * int - type 'a arrow = ToNode of 'a port | ToNothing | ToInternal of int - type 'a step = 'a port * 'a arrow - type 'a t = 'a step list let print_id sigs f = function | Existing id -> Format.pp_print_int f id - | Fresh (id,ty) -> + | Fresh (id, ty) -> Format.fprintf f "!%a-%i" (Signature.print_agent sigs) ty id let print_id_site ?source sigs find_ty n = let ty = match n with - | Fresh (_,ty) -> ty + | Fresh (_, ty) -> ty | Existing id -> - match source with - | Some (Fresh (id',ty)) when id = id' -> ty - | (None | Some (Fresh _ | Existing _)) -> find_ty id in + (match source with + | Some (Fresh (id', ty)) when id = id' -> ty + | None | Some (Fresh _ | Existing _) -> find_ty id) + in Signature.print_site sigs ty let print_id_internal_state sigs find_ty n = - Signature.print_site_internal_state - sigs (match n with Existing id -> find_ty id | Fresh (_,ty) -> ty) + Signature.print_site_internal_state sigs + (match n with + | Existing id -> find_ty id + | Fresh (_, ty) -> ty) let id_up_to_alpha_to_yojson = function | Existing i -> `Int i | Fresh f -> Agent.to_json f + let id_up_to_alpha_of_yojson = function | `Int i -> Existing i | x -> Fresh (Agent.of_json x) -let port_to_yojson (a,s) = `List [id_up_to_alpha_to_yojson a; `Int s] +let port_to_yojson (a, s) = `List [ id_up_to_alpha_to_yojson a; `Int s ] + let port_of_yojson = function - | `List [ a; `Int s] -> (id_up_to_alpha_of_yojson a,s) - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect navigation port",x)) + | `List [ a; `Int s ] -> id_up_to_alpha_of_yojson a, s + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect navigation port", x)) let arrow_to_yojson = function | ToNode p -> port_to_yojson p | ToNothing -> `Null | ToInternal i -> `Int i + let arrow_of_yojson = function | `Null -> ToNothing | `Int i -> ToInternal i | x -> ToNode (port_of_yojson x) -let step_to_yojson (p,a) = `List [port_to_yojson p; arrow_to_yojson a] +let step_to_yojson (p, a) = `List [ port_to_yojson p; arrow_to_yojson a ] + let step_of_yojson = function - | `List [ p ; a ] -> - (port_of_yojson p, arrow_of_yojson a) - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect navigation step",x)) + | `List [ p; a ] -> port_of_yojson p, arrow_of_yojson a + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect navigation step", x)) let to_yojson l = `List (List.map step_to_yojson l) + let of_yojson = function | `List l -> List.map step_of_yojson l - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect navigation",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect navigation", x)) let extend f = function | Existing _ -> f - | Fresh (id,ty) -> fun x -> if x = id then ty else f x + | Fresh (id, ty) -> + fun x -> + if x = id then + ty + else + f x let rec print sigs find_ty f = function | [] -> () - | ((source,site), ToNothing) :: t -> + | ((source, site), ToNothing) :: t -> Format.fprintf f "-%a(%a[.])->%a" (print_id sigs) source - (print_id_site sigs find_ty source) site - (print sigs (extend find_ty source)) t - | ((source,site), ToNode (id,port)) :: t -> + (print_id_site sigs find_ty source) + site + (print sigs (extend find_ty source)) + t + | ((source, site), ToNode (id, port)) :: t -> Format.fprintf f "-%a(%a[%a.%a])->%a" (print_id sigs) source - (print_id_site sigs find_ty source) site - (print_id_site ~source sigs find_ty id) port - (print_id sigs) id - (print sigs (extend (extend find_ty id) source)) t - | ((source,site), ToInternal i) :: t -> - Format.fprintf - f "-%a(%a)->%a" (print_id sigs) source - (print_id_internal_state sigs find_ty source site) (Some i) - (print sigs (extend find_ty source)) t + (print_id_site sigs find_ty source) + site + (print_id_site ~source sigs find_ty id) + port (print_id sigs) id + (print sigs (extend (extend find_ty id) source)) + t + | ((source, site), ToInternal i) :: t -> + Format.fprintf f "-%a(%a)->%a" (print_id sigs) source + (print_id_internal_state sigs find_ty source site) + (Some i) + (print sigs (extend find_ty source)) + t -let compatible_fresh_point ~debugMode e (sid,sty) ssite arrow = - match e,arrow with - | _, ToNode (Existing _,_) -> +let compatible_fresh_point ~debug_mode e (sid, sty) ssite arrow = + match e, arrow with + | _, ToNode (Existing _, _) -> raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - "Navigation.compatible_fresh_point does not deal with existing arrow")) - | ((Fresh (id,ty),site),x), ToNothing -> - if ty = sty && site = ssite && x = ToNothing - then let inj = Renaming.empty () in - if Renaming.imperative_add ~debugMode id sid inj then Some inj else None - else None - | ((Fresh (id,ty),site),x), ToInternal i -> - if ty = sty && site = ssite && x = ToInternal i - then let inj = Renaming.empty () in - if Renaming.imperative_add ~debugMode id sid inj then Some inj else None - else None - | ((Fresh (id,ty),site), ToNode (Fresh (id',ty'),site')), - ToNode (Fresh (sid',sty'),ssite') -> + (Loc.annot_with_dummy + "Navigation.compatible_fresh_point does not deal with existing \ + arrow")) + | ((Fresh (id, ty), site), x), ToNothing -> + if ty = sty && site = ssite && x = ToNothing then ( + let inj = Renaming.empty () in + if Renaming.imperative_add ~debug_mode id sid inj then + Some inj + else + None + ) else + None + | ((Fresh (id, ty), site), x), ToInternal i -> + if ty = sty && site = ssite && x = ToInternal i then ( + let inj = Renaming.empty () in + if Renaming.imperative_add ~debug_mode id sid inj then + Some inj + else + None + ) else + None + | ( ((Fresh (id, ty), site), ToNode (Fresh (id', ty'), site')), + ToNode (Fresh (sid', sty'), ssite') ) -> (* link between 2 agents *) - if ty = sty && site = ssite && ty' = sty' && site' = ssite' then + if ty = sty && site = ssite && ty' = sty' && site' = ssite' then ( let inj = Renaming.empty () in - if Renaming.imperative_add ~debugMode id sid inj then - if Renaming.imperative_add ~debugMode id' sid' inj - then Some inj else None - else None - else if ty = sty' && site = ssite' && ty' = sty && site' = ssite then + if Renaming.imperative_add ~debug_mode id sid inj then + if Renaming.imperative_add ~debug_mode id' sid' inj then + Some inj + else + None + else + None + ) else if ty = sty' && site = ssite' && ty' = sty && site' = ssite then ( let inj = Renaming.empty () in - if Renaming.imperative_add ~debugMode id sid' inj then - if Renaming.imperative_add ~debugMode id' sid inj then Some inj else None - else None - else None - | ((Existing id,site), ToNode (Fresh (id',ty),site') | - (Fresh (id',ty),site), ToNode (Existing id,site')), - ToNode (Fresh (sid',sty'),ssite') -> + if Renaming.imperative_add ~debug_mode id sid' inj then + if Renaming.imperative_add ~debug_mode id' sid inj then + Some inj + else + None + else + None + ) else + None + | ( ( (Existing id, site), ToNode (Fresh (id', ty), site') + | (Fresh (id', ty), site), ToNode (Existing id, site') ), + ToNode (Fresh (sid', sty'), ssite') ) -> (* self-link in agent *) - if ((ssite = site && ssite' = site') || (ssite' = site && ssite = site')) - && id = id' && sid = sid' && ty = sty && sty = sty' - then let inj = Renaming.empty () in - if Renaming.imperative_add ~debugMode id sid inj then Some inj else None - else None - | ((Existing _,_), _), _ -> None - | ((Fresh _,_),(ToNothing | ToInternal _)), ToNode _ -> None + if + ((ssite = site && ssite' = site') || (ssite' = site && ssite = site')) + && id = id' && sid = sid' && ty = sty && sty = sty' + then ( + let inj = Renaming.empty () in + if Renaming.imperative_add ~debug_mode id sid inj then + Some inj + else + None + ) else + None + | ((Existing _, _), _), _ -> None + | ((Fresh _, _), (ToNothing | ToInternal _)), ToNode _ -> None -let compatible_point ~debugMode inj e e' = - match e,e' with - | ((Existing id,site), ToNothing), e -> - if Renaming.mem id inj && - e = ((Existing (Renaming.apply ~debugMode inj id),site),ToNothing) - then Some inj - else None - | ((Existing id,site), ToInternal i), e -> - if Renaming.mem id inj && - e = ((Existing (Renaming.apply ~debugMode inj id),site),ToInternal i) - then Some inj - else None - | ((Existing id,site), ToNode (Existing id',site')), e -> - if Renaming.mem id inj && Renaming.mem id' inj && - (e = - ((Existing (Renaming.apply ~debugMode inj id),site), - ToNode (Existing (Renaming.apply ~debugMode inj id'),site')) - || e = - ((Existing (Renaming.apply ~debugMode inj id'),site'), - ToNode (Existing (Renaming.apply ~debugMode inj id),site))) - then Some inj - else None - | (((Existing id,site),ToNode (Fresh (id',ty),site')), - ((Existing sid,ssite), ToNode (Fresh(sid',ty'),ssite')) - | ((Fresh (id',ty),site),ToNode (Existing id,site')), - ((Existing sid,ssite), ToNode (Fresh(sid',ty'),ssite')) - | ((Existing id,site),ToNode (Fresh (id',ty),site')), - ((Fresh(sid',ty'),ssite), ToNode (Existing sid,ssite')) - | ((Fresh (id',ty),site),ToNode (Existing id,site')), - ((Fresh(sid',ty'),ssite), ToNode (Existing sid,ssite'))) -> - if ty' = ty && not (Renaming.mem id' inj) && - ((ssite = site && ssite' = site') || - (id = id' && ssite = site' && ssite' = site)) then - match Renaming.add ~debugMode id' sid' inj with - | Some inj' when Renaming.mem id inj' && - sid = Renaming.apply ~debugMode inj' id -> +let compatible_point ~debug_mode inj e e' = + match e, e' with + | ((Existing id, site), ToNothing), e -> + if + Renaming.mem id inj + && e = ((Existing (Renaming.apply ~debug_mode inj id), site), ToNothing) + then + Some inj + else + None + | ((Existing id, site), ToInternal i), e -> + if + Renaming.mem id inj + && e = ((Existing (Renaming.apply ~debug_mode inj id), site), ToInternal i) + then + Some inj + else + None + | ((Existing id, site), ToNode (Existing id', site')), e -> + if + Renaming.mem id inj && Renaming.mem id' inj + && (e + = ( (Existing (Renaming.apply ~debug_mode inj id), site), + ToNode (Existing (Renaming.apply ~debug_mode inj id'), site') ) + || e + = ( (Existing (Renaming.apply ~debug_mode inj id'), site'), + ToNode (Existing (Renaming.apply ~debug_mode inj id), site) )) + then + Some inj + else + None + | ( ((Existing id, site), ToNode (Fresh (id', ty), site')), + ((Existing sid, ssite), ToNode (Fresh (sid', ty'), ssite')) ) + | ( ((Fresh (id', ty), site), ToNode (Existing id, site')), + ((Existing sid, ssite), ToNode (Fresh (sid', ty'), ssite')) ) + | ( ((Existing id, site), ToNode (Fresh (id', ty), site')), + ((Fresh (sid', ty'), ssite), ToNode (Existing sid, ssite')) ) + | ( ((Fresh (id', ty), site), ToNode (Existing id, site')), + ((Fresh (sid', ty'), ssite), ToNode (Existing sid, ssite')) ) -> + if + ty' = ty + && (not (Renaming.mem id' inj)) + && ((ssite = site && ssite' = site') + || (id = id' && ssite = site' && ssite' = site)) + then ( + match Renaming.add ~debug_mode id' sid' inj with + | Some inj' + when Renaming.mem id inj' && sid = Renaming.apply ~debug_mode inj' id -> Some inj' | _ -> None - else None - | ((Existing _,_), ToNode (Fresh _,_)), - (((Fresh _ | Existing _), _), _) -> None - | ((Fresh (id,ty),site), ToNothing), ((Fresh (id',ty'),site'),x) -> - if ty = ty' && site = site' && x = ToNothing - && not (Renaming.mem id inj) - then Renaming.add ~debugMode id id' inj - else None - | ((Fresh (id,ty),site), ToInternal i), ((Fresh (id',ty'),site'),x) -> - if ty = ty' && site = site' && - x = ToInternal i && not (Renaming.mem id inj) - then Renaming.add ~debugMode id id' inj - else None - | ((Fresh (id,ty),site), ToNode (Fresh (id',ty'),site')), - ((Fresh (sid,sty),ssite), ToNode (Fresh (sid',sty'),ssite')) -> - if not (Renaming.mem id inj) && not (Renaming.mem id' inj) then - if ty = sty && site = ssite && ty' = sty' && site' = ssite' - then match Renaming.add ~debugMode id sid inj with + ) else + None + | ((Existing _, _), ToNode (Fresh _, _)), (((Fresh _ | Existing _), _), _) -> + None + | ((Fresh (id, ty), site), ToNothing), ((Fresh (id', ty'), site'), x) -> + if ty = ty' && site = site' && x = ToNothing && not (Renaming.mem id inj) + then + Renaming.add ~debug_mode id id' inj + else + None + | ((Fresh (id, ty), site), ToInternal i), ((Fresh (id', ty'), site'), x) -> + if ty = ty' && site = site' && x = ToInternal i && not (Renaming.mem id inj) + then + Renaming.add ~debug_mode id id' inj + else + None + | ( ((Fresh (id, ty), site), ToNode (Fresh (id', ty'), site')), + ((Fresh (sid, sty), ssite), ToNode (Fresh (sid', sty'), ssite')) ) -> + if (not (Renaming.mem id inj)) && not (Renaming.mem id' inj) then + if ty = sty && site = ssite && ty' = sty' && site' = ssite' then ( + match Renaming.add ~debug_mode id sid inj with | None -> None - | Some inj' -> match Renaming.add ~debugMode id' sid' inj' with + | Some inj' -> + (match Renaming.add ~debug_mode id' sid' inj' with | None -> None - | Some inj'' -> Some inj'' - else if ty = sty' && site = ssite' && ty' = sty && site' = ssite - then match Renaming.add ~debugMode id sid' inj with + | Some inj'' -> Some inj'') + ) else if ty = sty' && site = ssite' && ty' = sty && site' = ssite then ( + match Renaming.add ~debug_mode id sid' inj with | None -> None - | Some inj' -> match Renaming.add ~debugMode id' sid inj' with + | Some inj' -> + (match Renaming.add ~debug_mode id' sid inj' with | None -> None - | Some inj'' -> Some inj'' - else None - else None - | ((Fresh _,_), _), ((Fresh _,_),_) -> None - | ((Fresh _,_), _), ((Existing _,_),_) -> None + | Some inj'' -> Some inj'') + ) else + None + else + None + | ((Fresh _, _), _), ((Fresh _, _), _) -> None + | ((Fresh _, _), _), ((Existing _, _), _) -> None -let rec aux_sub ~debugMode inj goal acc = function +let rec aux_sub ~debug_mode inj goal acc = function | [] -> None - | h :: t -> match compatible_point ~debugMode inj h goal with - | None -> aux_sub ~debugMode inj goal (h::acc) t - | Some inj' -> Some (inj',List.rev_append acc t) -let rec is_subnavigation ~debugMode inj nav = function - | [] -> Some (inj,nav) - | h :: t -> match aux_sub ~debugMode inj h [] nav with + | h :: t -> + (match compatible_point ~debug_mode inj h goal with + | None -> aux_sub ~debug_mode inj goal (h :: acc) t + | Some inj' -> Some (inj', List.rev_append acc t)) + +let rec is_subnavigation ~debug_mode inj nav = function + | [] -> Some (inj, nav) + | h :: t -> + (match aux_sub ~debug_mode inj h [] nav with | None -> None - | Some (inj',nav') -> is_subnavigation ~debugMode inj' nav' t + | Some (inj', nav') -> is_subnavigation ~debug_mode inj' nav' t) -let rename_id ~debugMode inj2cc = function - | Existing n -> inj2cc,Existing (Renaming.apply ~debugMode inj2cc n) - | Fresh (id,ty) -> +let rename_id ~debug_mode inj2cc = function + | Existing n -> inj2cc, Existing (Renaming.apply ~debug_mode inj2cc n) + | Fresh (id, ty) -> let img = Renaming.image inj2cc in let id' = - if Mods.IntSet.mem id img then + if Mods.IntSet.mem id img then ( match Mods.IntSet.max_elt img with | None -> 1 | Some i -> succ i - else id in - match Renaming.add ~debugMode id id' inj2cc with + ) else + id + in + (match Renaming.add ~debug_mode id id' inj2cc with | None -> assert false - | Some inj' -> inj',Fresh (id',ty) + | Some inj' -> inj', Fresh (id', ty)) -let rec rename ~debugMode inj2cc = function - | [] -> inj2cc,[] - | ((x,i), (ToNothing | ToInternal _ as a)) :: t -> - let inj,x' = rename_id ~debugMode inj2cc x in - let inj',t' = rename ~debugMode inj t in - inj',((x',i),a)::t' - | ((x,i),ToNode (y,j)) :: t-> - let inj,x' = rename_id ~debugMode inj2cc x in - let inj',y' = rename_id ~debugMode inj y in - let inj'',t' = rename ~debugMode inj' t in - inj'',((x',i),ToNode (y',j))::t' +let rec rename ~debug_mode inj2cc = function + | [] -> inj2cc, [] + | ((x, i), ((ToNothing | ToInternal _) as a)) :: t -> + let inj, x' = rename_id ~debug_mode inj2cc x in + let inj', t' = rename ~debug_mode inj t in + inj', ((x', i), a) :: t' + | ((x, i), ToNode (y, j)) :: t -> + let inj, x' = rename_id ~debug_mode inj2cc x in + let inj', y' = rename_id ~debug_mode inj y in + let inj'', t' = rename ~debug_mode inj' t in + inj'', ((x', i), ToNode (y', j)) :: t' let check_edge graph = function - | ((Fresh (id,_),site),ToNothing) -> Edges.is_free id site graph - | ((Fresh (id,_),site),ToInternal i) -> Edges.is_internal i id site graph - | ((Fresh (id,_),site),ToNode (Existing id',site')) -> + | (Fresh (id, _), site), ToNothing -> Edges.is_free id site graph + | (Fresh (id, _), site), ToInternal i -> Edges.is_internal i id site graph + | (Fresh (id, _), site), ToNode (Existing id', site') -> Edges.link_exists id site id' site' graph - | ((Fresh (id,_),site),ToNode (Fresh (id',_),site')) -> + | (Fresh (id, _), site), ToNode (Fresh (id', _), site') -> Edges.link_exists id site id' site' graph - | ((Existing id,site),ToNothing) -> Edges.is_free id site graph - | ((Existing id,site),ToInternal i) -> Edges.is_internal i id site graph - | ((Existing id,site),ToNode (Existing id',site')) -> + | (Existing id, site), ToNothing -> Edges.is_free id site graph + | (Existing id, site), ToInternal i -> Edges.is_internal i id site graph + | (Existing id, site), ToNode (Existing id', site') -> Edges.link_exists id site id' site' graph - | ((Existing id,site),ToNode (Fresh (id',_),site')) -> + | (Existing id, site), ToNode (Fresh (id', _), site') -> Edges.link_exists id site id' site' graph (*inj is the partial injection built so far: inj:abs->concrete*) -let dst_is_okay ~debugMode inj' graph root site = function +let dst_is_okay ~debug_mode inj' graph root site = function | ToNothing -> - if Edges.is_free root site graph then Some inj' else None + if Edges.is_free root site graph then + Some inj' + else + None | ToInternal i -> - if Edges.is_internal i root site graph then Some inj' else None - | ToNode (Existing id',site') -> - if Edges.link_exists root site - (Renaming.apply ~debugMode inj' id') site' graph - then Some inj' else None - | ToNode (Fresh (id',ty),site') -> - match Edges.exists_fresh root site ty site' graph with + if Edges.is_internal i root site graph then + Some inj' + else + None + | ToNode (Existing id', site') -> + if + Edges.link_exists root site + (Renaming.apply ~debug_mode inj' id') + site' graph + then + Some inj' + else + None + | ToNode (Fresh (id', ty), site') -> + (match Edges.exists_fresh root site ty site' graph with | None -> None - | Some node -> Renaming.add ~debugMode id' node inj' + | Some node -> Renaming.add ~debug_mode id' node inj') -let injection_for_one_more_edge ~debugMode ?root inj graph = function - | ((Existing id,site),dst) -> - dst_is_okay ~debugMode inj graph (Renaming.apply ~debugMode inj id) site dst - | ((Fresh (id,rty),site),dst) -> - match root with - | Some (root,rty') when rty=rty' -> - (match Renaming.add ~debugMode id root inj with - | None -> None - | Some inj' -> dst_is_okay ~debugMode inj' graph root site dst) - | _ -> None +let injection_for_one_more_edge ~debug_mode ?root inj graph = function + | (Existing id, site), dst -> + dst_is_okay ~debug_mode inj graph + (Renaming.apply ~debug_mode inj id) + site dst + | (Fresh (id, rty), site), dst -> + (match root with + | Some (root, rty') when rty = rty' -> + (match Renaming.add ~debug_mode id root inj with + | None -> None + | Some inj' -> dst_is_okay ~debug_mode inj' graph root site dst) + | _ -> None) -let imperative_dst_is_okay ~debugMode inj' graph root site = function +let imperative_dst_is_okay ~debug_mode inj' graph root site = function | ToNothing -> Edges.is_free root site graph | ToInternal i -> Edges.is_internal i root site graph - | ToNode (Existing id',site') -> - Edges.link_exists root site (Renaming.apply ~debugMode inj' id') site' graph - | ToNode (Fresh (id',ty),site') -> - match Edges.exists_fresh root site ty site' graph with + | ToNode (Existing id', site') -> + Edges.link_exists root site + (Renaming.apply ~debug_mode inj' id') + site' graph + | ToNode (Fresh (id', ty), site') -> + (match Edges.exists_fresh root site ty site' graph with | None -> false - | Some node -> Renaming.imperative_add ~debugMode id' node inj' + | Some node -> Renaming.imperative_add ~debug_mode id' node inj') -let imperative_edge_is_valid ~debugMode ?root inj graph = function - | ((Existing id,site),dst) -> - imperative_dst_is_okay - ~debugMode inj graph (Renaming.apply ~debugMode inj id) site dst - | ((Fresh (id,rty),site),dst) -> - match root with - | Some (root,rty') when rty=rty' -> - Renaming.imperative_add ~debugMode id root inj && - imperative_dst_is_okay ~debugMode inj graph root site dst - | _ -> false +let imperative_edge_is_valid ~debug_mode ?root inj graph = function + | (Existing id, site), dst -> + imperative_dst_is_okay ~debug_mode inj graph + (Renaming.apply ~debug_mode inj id) + site dst + | (Fresh (id, rty), site), dst -> + (match root with + | Some (root, rty') when rty = rty' -> + Renaming.imperative_add ~debug_mode id root inj + && imperative_dst_is_okay ~debug_mode inj graph root site dst + | _ -> false) -let concretize_port ~debugMode inj = function - | (Existing id,site) -> (Renaming.apply ~debugMode inj id,site) - | (Fresh (id,_),site) -> (Renaming.apply ~debugMode inj id,site) +let concretize_port ~debug_mode inj = function + | Existing id, site -> Renaming.apply ~debug_mode inj id, site + | Fresh (id, _), site -> Renaming.apply ~debug_mode inj id, site -let concretize_arrow ~debugMode inj = function - | ToNothing | ToInternal _ as x -> x - | ToNode x -> ToNode (concretize_port ~debugMode inj x) +let concretize_arrow ~debug_mode inj = function + | (ToNothing | ToInternal _) as x -> x + | ToNode x -> ToNode (concretize_port ~debug_mode inj x) -let concretize ~debugMode root graph nav = +let concretize ~debug_mode root graph nav = let inj = Renaming.empty () in let out = List.fold_left - (fun out (p,dst as step) -> - match out with - | None -> out - | Some (root,acc) -> - if imperative_edge_is_valid ~debugMode ?root inj graph step then - let st = (concretize_port ~debugMode inj p, - concretize_arrow ~debugMode inj dst) in - Some (None,st::acc) - else None) - (Some (Some root,[])) nav in - Option_util.map (fun (_,l) -> List.rev l) out + (fun out ((p, dst) as step) -> + match out with + | None -> out + | Some (root, acc) -> + if imperative_edge_is_valid ~debug_mode ?root inj graph step then ( + let st = + ( concretize_port ~debug_mode inj p, + concretize_arrow ~debug_mode inj dst ) + in + Some (None, st :: acc) + ) else + None) + (Some (Some root, [])) + nav + in + Option_util.map (fun (_, l) -> List.rev l) out diff --git a/core/siteGraphs/navigation.mli b/core/siteGraphs/navigation.mli index c9b22616da..a5a4f38c99 100644 --- a/core/siteGraphs/navigation.mli +++ b/core/siteGraphs/navigation.mli @@ -9,13 +9,9 @@ (** Pathes to explore a mixture *) type abstract = Existing of int | Fresh of Agent.t - type 'a port = 'a * int - type 'a arrow = ToNode of 'a port | ToNothing | ToInternal of int - type 'a step = 'a port * 'a arrow - type 'a t = 'a step list val print : @@ -24,32 +20,47 @@ val print : val step_to_yojson : abstract step -> Yojson.Basic.t val step_of_yojson : Yojson.Basic.t -> abstract step - val to_yojson : abstract t -> Yojson.Basic.t val of_yojson : Yojson.Basic.t -> abstract t val rename : - debugMode:bool -> Renaming.t -> abstract t -> Renaming.t * abstract t + debug_mode:bool -> Renaming.t -> abstract t -> Renaming.t * abstract t val compatible_fresh_point : - debugMode:bool -> abstract step -> Agent.t -> int -> abstract arrow -> + debug_mode:bool -> + abstract step -> + Agent.t -> + int -> + abstract arrow -> Renaming.t option (** Retuns the extension of the given injections so that the second edge is the image of the first *) val is_subnavigation : - debugMode:bool -> Renaming.t -> abstract t -> abstract t -> + debug_mode:bool -> + Renaming.t -> + abstract t -> + abstract t -> (Renaming.t * abstract t) option (** [is_subnavigation inj_nav2sub nav subpart] *) val check_edge : Edges.t -> abstract step -> bool + val injection_for_one_more_edge : - debugMode:bool -> ?root:Agent.t -> Renaming.t -> Edges.t -> abstract step -> + debug_mode:bool -> + ?root:Agent.t -> + Renaming.t -> + Edges.t -> + abstract step -> Renaming.t option val imperative_edge_is_valid : - debugMode:bool -> ?root:Agent.t -> Renaming.t -> Edges.t -> abstract step -> + debug_mode:bool -> + ?root:Agent.t -> + Renaming.t -> + Edges.t -> + abstract step -> bool val concretize : - debugMode:bool -> Agent.t -> Edges.t -> abstract t -> int t option + debug_mode:bool -> Agent.t -> Edges.t -> abstract t -> int t option diff --git a/core/siteGraphs/signature.ml b/core/siteGraphs/signature.ml index 3d01808819..96e4ef077e 100644 --- a/core/siteGraphs/signature.ml +++ b/core/siteGraphs/signature.ml @@ -6,290 +6,313 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) +type 'links site_sig = { + internal_state: unit NamedDecls.t; + links: 'links option; + counters_info: (int * int) option; + (** If relevant: counter CEQ value * counter delta *) +} -type t = - (unit NamedDecls.t * bool array array option * (int * int) option) NamedDecls.t +type t = bool array array site_sig NamedDecls.t let fold f = NamedDecls.fold (fun i n o _ -> f i n o) -let num_of_site ?agent_name site_name sign = - let kind = match agent_name with +let num_of_site ?agent_name site_name signature = + let kind = + match agent_name with | None -> "site name" - | Some agent_name -> "site name for agent "^agent_name - in NamedDecls.elt_id ~kind sign site_name + | Some agent_name -> "site name for agent " ^ agent_name + in + NamedDecls.elt_id ~kind signature site_name -let site_of_num addr sign = - try NamedDecls.elt_name sign addr +let site_of_num addr signature = + try NamedDecls.elt_name signature addr with Invalid_argument _ -> raise Not_found -let num_of_internal_state site_id state sign = +let num_of_internal_state site_id state signature = try - let na,(nd,_,_) = sign.NamedDecls.decls.(site_id) in - NamedDecls.elt_id ~kind:("internal state for site "^na) nd state - with - | Invalid_argument _ -> raise Not_found + let site_name, site_sig = signature.NamedDecls.decls.(site_id) in + NamedDecls.elt_id + ~kind:("internal state for site " ^ site_name) + site_sig.internal_state state + with Invalid_argument _ -> raise Not_found -let internal_state_of_num site_num val_num sign = +let internal_state_of_site_id site_id val_id signature = try - let _,(nd,_,_) = sign.NamedDecls.decls.(site_num) in - fst nd.NamedDecls.decls.(val_num) - with - | Invalid_argument _ -> raise Not_found + let site_sig = NamedDecls.elt_val signature site_id in + NamedDecls.elt_name site_sig.internal_state val_id + with Invalid_argument _ -> raise Not_found -let counter_of_site site_id sign = - try - let _,(_,_,c) = sign.NamedDecls.decls.(site_id) in c - with - | Invalid_argument _ -> raise Not_found +let counter_of_site_id site_id signature = + try (NamedDecls.elt_val signature site_id).counters_info + with Invalid_argument _ -> raise Not_found -let has_counter sign = +let has_counter signature = fold (fun p_id _ ok -> try - let _,(_,_,c) = sign.NamedDecls.decls.(p_id) in - ok||(not(c = None)) - with - | Invalid_argument _ -> raise Not_found) false sign + let site_sig = NamedDecls.elt_val signature p_id in + ok || not (site_sig.counters_info = None) + with Invalid_argument _ -> raise Not_found) + false signature + +(* +let read_position p lb = + match Yojson.Basic.from_lexbuf ~stream:true p lb with + | `Assoc [ ("line", `Int line); ("chr", `Int chr) ] + | `Assoc [ ("chr", `Int chr); ("line", `Int line) ] -> + { line; chr } + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid position", x)) + +let write_position ob { line; chr } = + Yojson.write_assoc ob [ "line", `Int line; "chr", `Int chr ] +*) let one_to_json = - NamedDecls.to_json - (fun (a,b,c) -> - `List [ - (NamedDecls.to_json (fun () -> `Null) a); - (JsonUtil.of_option - (fun links -> - `List (Array.fold_right (fun a acc -> - `List (Array.fold_right (fun b c -> `Bool b :: c) a []) :: acc) - links [])) b); - JsonUtil.of_option (fun (c1,c2) -> `List [`Int c1; `Int c2]) c]) - -let one_of_json = - NamedDecls.of_json - (function - | `List [a;b;c] -> - (NamedDecls.of_json (function - | `Null -> () - | x -> raise (Yojson.Basic.Util.Type_error - ("Problematic agent signature",x))) a), - (Yojson.Basic.Util.to_option - (function - | `List l -> - Tools.array_map_of_list (function - | `List l' -> Tools.array_map_of_list (function - | `Bool b -> b - | x -> raise (Yojson.Basic.Util.Type_error - ("Problematic agent signature",x))) - l' - | x -> raise (Yojson.Basic.Util.Type_error - ("Problematic agent signature",x))) - l - | x -> raise (Yojson.Basic.Util.Type_error - ("Problematic agent signature",x))) b), - (Yojson.Basic.Util.to_option - (function - |`List [`Int c1; `Int c2] -> (c1,c2) - | x -> raise (Yojson.Basic.Util.Type_error - ("Problematic agent signature",x))) c) - | x -> raise (Yojson.Basic.Util.Type_error - ("Problematic agent signature",x))) + NamedDecls.to_json (fun signature -> + `Assoc + [ + ( "internal_state", + NamedDecls.to_json (fun () -> `Null) signature.internal_state ); + ( "links", + JsonUtil.of_option + (fun links -> + `List + (Array.fold_right + (fun a acc -> + `List (Array.fold_right (fun b c -> `Bool b :: c) a []) + :: acc) + links [])) + signature.links ); + ( "counters_info", + JsonUtil.of_option + (fun (c1, c2) -> `List [ `Int c1; `Int c2 ]) + signature.counters_info ); + ]) + +let one_of_json : Yojson.Basic.t -> bool array array site_sig NamedDecls.t = + NamedDecls.of_json (function + | `Assoc [ ("internal_state", a); ("links", b); ("counters_info", c) ] -> + { + internal_state = + NamedDecls.of_json + (function + | `Null -> () + | x -> + raise + (Yojson.Basic.Util.Type_error + ("Problematic agent signature", x))) + a; + links = + Yojson.Basic.Util.to_option + (function + | `List l -> + Tools.array_map_of_list + (function + | `List l' -> + Tools.array_map_of_list + (function + | `Bool b -> b + | x -> + raise + (Yojson.Basic.Util.Type_error + ("Problematic agent signature", x))) + l' + | x -> + raise + (Yojson.Basic.Util.Type_error + ("Problematic agent signature", x))) + l + | x -> + raise + (Yojson.Basic.Util.Type_error + ("Problematic agent signature", x))) + b; + counters_info = + Yojson.Basic.Util.to_option + (function + | `List [ `Int c1; `Int c2 ] -> c1, c2 + | x -> + raise + (Yojson.Basic.Util.Type_error + ("Problematic agent signature", x))) + c; + } + | x -> + raise (Yojson.Basic.Util.Type_error ("Problematic agent signature", x))) + +type counter_agent_info = { id: int; arity: int; ports: int * int } type s = { - t: t NamedDecls.t; - incr: int option; - incr_sites: (int*int) option; + agent_sigs: t NamedDecls.t; + counter_agent_info: counter_agent_info option; } -let size sigs = NamedDecls.size sigs.t -let get sigs agent_id = snd sigs.t.NamedDecls.decls.(agent_id) +let size sigs = NamedDecls.size sigs.agent_sigs +let get sigs agent_id = NamedDecls.elt_val sigs.agent_sigs agent_id let arity sigs agent_id = NamedDecls.size (get sigs agent_id) + let max_arity sigs = - NamedDecls.fold (fun _ _ x a -> max x (NamedDecls.size a)) 0 sigs.t + NamedDecls.fold (fun _ _ x a -> max x (NamedDecls.size a)) 0 sigs.agent_sigs + +let agent_of_num i sigs = NamedDecls.elt_name sigs.agent_sigs i -let agent_of_num i sigs = NamedDecls.elt_name sigs.t i let num_of_agent name sigs = - NamedDecls.elt_id ~kind:"agent" sigs.t name + NamedDecls.elt_id ~kind:"agent" sigs.agent_sigs name -let id_of_site (agent_name,_ as agent_ty) site_name sigs = +let id_of_site ((agent_name, _) as agent_ty) site_name sigs = let n = num_of_agent agent_ty sigs in num_of_site ~agent_name site_name (get sigs n) -let site_of_id agent_id site_id sigs = - site_of_num site_id (get sigs agent_id) +let site_of_id agent_id site_id sigs = site_of_num site_id (get sigs agent_id) -let id_of_internal_state (agent_name,_ as agent_ty) site_name state sigs = +let id_of_internal_state ((agent_name, _) as agent_ty) site_name state sigs = let n = num_of_agent agent_ty sigs in - let sign = get sigs n in - let site_id = - num_of_site ~agent_name site_name sign in - num_of_internal_state site_id state sign + let signature = get sigs n in + let site_id = num_of_site ~agent_name site_name signature in + num_of_internal_state site_id state signature let internal_state_of_id agent_id id_site id_state sigs = - internal_state_of_num id_site id_state (get sigs agent_id) + internal_state_of_site_id id_site id_state (get sigs agent_id) -let internal_states_number agent_id site_num sigs = +let internal_states_number agent_id site_id sigs = try - let _,(nd,_,_) = (get sigs agent_id).NamedDecls.decls.(site_num) in - NamedDecls.size nd - with - | Invalid_argument _ -> raise Not_found + let site_sig = NamedDecls.elt_val (get sigs agent_id) site_id in + NamedDecls.size site_sig.internal_state + with Invalid_argument _ -> raise Not_found let default_internal_state agent_id site_id sigs = try - let _,(nd,_,_) = (get sigs agent_id).NamedDecls.decls.(site_id) in - if nd.NamedDecls.decls = [||] then None else Some 0 - with - | Invalid_argument _ -> + let site_sig = NamedDecls.elt_val (get sigs agent_id) site_id in + if NamedDecls.size site_sig.internal_state = 0 then + None + else + Some 0 + with Invalid_argument _ -> invalid_arg "Signature.default_num_value: invalid site identifier" let rec allowed_link ag1 s1 ag2 s2 sigs = - if ag1 > ag2 then allowed_link ag2 s2 ag1 s1 sigs - else - try match (get sigs ag1).NamedDecls.decls.(s1) with - | _, (_,None,_) -> true - | _, (_,Some l,_) -> l.(ag2-ag1).(s2) - with - | Invalid_argument _ -> + if ag1 > ag2 then + allowed_link ag2 s2 ag1 s1 sigs + else ( + try + match (NamedDecls.elt_val (get sigs ag1) s1).links with + | None -> true + | Some l -> l.(ag2 - ag1).(s2) + with Invalid_argument _ -> invalid_arg "Signature.allowed_link: invalid site identifier" - -let add_incr counters = - let annot = Locality.dummy in - let a_port = ("a",annot) in - let b_port = ("b",annot) in - let incr = ("__incr",Locality.dummy) in - let after = (a_port,(NamedDecls.create [||],[(b_port,incr)],None)) in - let before_lnks = - List.fold_right - (fun (ag,counts) acc -> - (List.map (fun c -> (c,ag)) counts)@acc) counters [(a_port,incr)] in - let before = (b_port,(NamedDecls.create [||],before_lnks,None)) in - let lnks = NamedDecls.create [|after;before|] in - let counter_agent = (incr,lnks) in - counter_agent - -let create ~counters contact_map sigs = - let sigs' = if counters <> [] then (add_incr counters)::sigs else sigs in - let t = Array.of_list sigs' in - let raw = NamedDecls.create t in - let s = Array.length t in - let snd_of_third = fun (_,a,_) -> a in { - t = - NamedDecls.mapi - (fun ag ag_na -> NamedDecls.mapi - (fun _ si_na (ints,links,counts) -> - if not(contact_map) then (ints, None,counts) else - let out = - Array.init - (s-ag) - (fun i -> Array.make - (NamedDecls.size (snd raw.NamedDecls.decls.(i+ag))) - false) in - let () = - List.iter - (fun ((site_name,pos as site),(agent_name,_ as agent)) -> - let a = NamedDecls.elt_id ~kind:"agent" raw agent in - let s = num_of_site - ~agent_name site (snd raw.NamedDecls.decls.(a)) in - let () = if a >= ag then out.(a-ag).(s) <- true in - if List.exists - (fun ((x,_),(y,_)) -> x = si_na && y = ag_na) - (snd_of_third (snd (snd raw.NamedDecls.decls.(a)).NamedDecls.decls.(s))) - then () - else - raise (ExceptionDefn.Malformed_Decl - (Format.asprintf - "No link to %s.%s from %s.%s." - si_na ag_na site_name agent_name,pos))) - links in - (ints,Some out,counts))) - raw; - incr = if counters = [] then None else Some 0; - incr_sites = if counters = [] then None else Some (0,1); + ) + +let create ~counters_per_agent agent_sigs = + { + agent_sigs; + counter_agent_info = + (if counters_per_agent = [] then + None + else + (* If there is a counter agent, we choose 0 for its agent id and 0 and 1 as its port ids *) + Some { id = 0; arity = 2; ports = 0, 1 }); } +let is_counter_agent sigs n_id = + match sigs.counter_agent_info with + | None -> false + | Some agent_info -> n_id = agent_info.id + +let ports_if_counter_agent sigs n_id = + match sigs.counter_agent_info with + | None -> None + | Some agent_info -> + if n_id = agent_info.id then + Some agent_info.ports + else + None + +let site_is_counter sigs ag_ty id = + counter_of_site_id id (get sigs ag_ty) <> None + +let get_counter_agent_info sigs = + match sigs.counter_agent_info with + | None -> failwith "No counter agent" + | Some counter_agent_info -> counter_agent_info + let print_agent sigs f ag_ty = Format.pp_print_string f @@ agent_of_num ag_ty sigs let print_site sigs ag_ty f id = Format.pp_print_string f @@ site_of_id ag_ty id sigs + let print_internal_state sigs ag_ty site f id = Format.pp_print_string f @@ internal_state_of_id ag_ty site id sigs + let print_site_internal_state sigs ag_ty site f = function | None -> print_site sigs ag_ty f site | Some id -> - Format.fprintf f "%s{%s}" (site_of_id ag_ty site sigs) + Format.fprintf f "%s{%s}" + (site_of_id ag_ty site sigs) (internal_state_of_id ag_ty site id sigs) + let print_counter sigs ag_ty f id = - match (counter_of_site id (get sigs ag_ty)) with - None -> () - | Some (c1,c2) -> Format.fprintf f "{=%d/+=%d}" c1 c2 + match counter_of_site_id id (get sigs ag_ty) with + | None -> () + | Some (c1, c2) -> Format.fprintf f "{=%d/+=%d}" c1 c2 -let print_one ?sigs i f sign = +let print_one ?(sigs : s option) (i : int) (f : Format.formatter) + (signature : t) = let pp_int f x = if NamedDecls.size x > 0 then Format.fprintf f "{%a}" - (NamedDecls.print - ~sep:Pp.space - (fun _ na f () -> Format.fprintf f "%s" na)) - x in + (NamedDecls.print ~sep:Pp.space (fun _ na f () -> + Format.fprintf f "%s" na)) + x + in let pp_link = match sigs with | None -> fun _ _ _ -> () - | Some sigs -> fun i f -> function - | None -> () - | Some links -> - Format.fprintf f "[%a]" - (Pp.array Pp.space - (fun ag -> Pp.array Pp.space - (fun si f b -> if b then - Format.fprintf f "%a.%a" - (print_site sigs (i+ag)) si (print_agent sigs) (i+ag)))) - links in + | Some sigs -> + fun i f -> (function + | None -> () + | Some links -> + Format.fprintf f "[%a]" + (Pp.array Pp.space (fun ag -> + Pp.array Pp.space (fun si f b -> + if b then + Format.fprintf f "%a.%a" + (print_site sigs (i + ag)) + si (print_agent sigs) (i + ag)))) + links) + in let pp_counts f = function - None -> () - | Some (c1,c2) -> Format.fprintf f "{=%d/+=%d}" c1 c2 in + | None -> () + | Some (c1, c2) -> Format.fprintf f "{=%d/+=%d}" c1 c2 + in (NamedDecls.print ~sep:(fun f -> Format.fprintf f ",@,") - (fun _ name f (ints,links,counts) -> - Format.fprintf f "%s%a%a%a" name pp_int ints (pp_link i) links - pp_counts counts)) - f sign + (fun _ name f site_sig -> + Format.fprintf f "%s%a%a%a" name pp_int site_sig.internal_state + (pp_link i) site_sig.links pp_counts site_sig.counters_info)) + f signature let print f sigs = - Format.fprintf - f "@[%a@]" - (NamedDecls.print ~sep:Pp.space - (fun i n f si -> - Format.fprintf f "@[%%agent: %s(%a)@]" n (print_one ~sigs i) si)) - sigs.t - -let to_json sigs = NamedDecls.to_json one_to_json sigs.t -let of_json v = - let t = NamedDecls.of_json one_of_json v in - let (incr,incr_sites) = - match Mods.StringMap.find_option "__incr" t.NamedDecls.finder with - | Some incr_id -> - let incr = snd t.NamedDecls.decls.(incr_id) in - let after = num_of_site ("a",Locality.dummy) incr in - let before = num_of_site ("b",Locality.dummy) incr in - Some incr_id,Some (before,after) - | None -> None,None in - { t; incr; incr_sites; } - -let is_counter_agent sigs n_id = - match sigs.incr with None -> false | Some incr_id -> n_id = incr_id - -let ports_if_counter_agent sigs n_id = - if match sigs.incr with None -> false | Some incr_id -> n_id = incr_id - then sigs.incr_sites - else None + Format.fprintf f "@[%a@]" + (NamedDecls.print ~sep:Pp.space (fun i n f si -> + Format.fprintf f "@[%%agent: %s(%a)@]" n (print_one ~sigs i) si)) + sigs.agent_sigs -let site_is_counter sigs ag_ty id = - counter_of_site id (get sigs ag_ty) <> None +let to_json sigs = NamedDecls.to_json one_to_json sigs.agent_sigs -let incr_agent sigs = - match sigs.incr with - | None -> failwith "No incr agent" +let of_json v = + let agent_sigs : 'a site_sig NamedDecls.t NamedDecls.t = + NamedDecls.of_json one_of_json v + in + match + Mods.StringMap.find_option "__counter_agent" agent_sigs.NamedDecls.finder + with | Some id -> - match sigs.incr_sites with - | None -> failwith "Signature of counter inconsistent" - | Some (before,after) -> (id,2,before,after) + let agent_signature = NamedDecls.elt_val agent_sigs id in + let ports = + ( num_of_site ("a", Loc.dummy) agent_signature, + num_of_site ("b", Loc.dummy) agent_signature ) + in + { agent_sigs; counter_agent_info = Some { id; arity = 2; ports } } + | None -> { agent_sigs; counter_agent_info = None } diff --git a/core/siteGraphs/signature.mli b/core/siteGraphs/signature.mli index 05cea4c2b1..da2a872a2e 100644 --- a/core/siteGraphs/signature.mli +++ b/core/siteGraphs/signature.mli @@ -8,32 +8,45 @@ (** Store definitions of agents *) -type t (** Store of one agent *) - -val num_of_site : ?agent_name:string -> string Locality.annot -> t -> int +(* TODO: here, we talk about agents, but is it actually agent signatures/definitions ? while instances are in siteGraphs/agent.mli *) +(* TODO document what is internal state *) + +(* TODO *) +type 'links site_sig = { + internal_state: unit NamedDecls.t; + links: 'links option; + counters_info: (int * int) option; + (** If relevant: counter CEQ value * counter delta *) +} + +type t = bool array array site_sig NamedDecls.t +(** Store of one agent signature *) + +(* TODO remove Loc annotations here ? *) +val num_of_site : ?agent_name:string -> string Loc.annoted -> t -> int val site_of_num : int -> t -> string val fold : (int -> string -> 'a -> 'a) -> 'a -> t -> 'a -val num_of_internal_state : int -> string Locality.annot -> t -> int -(** [num_of_internal_state site_id state_name sign] *) +val num_of_internal_state : int -> string Loc.annoted -> t -> int +(** [num_of_internal_state site_id state_name signature] *) -val internal_state_of_num : int -> int -> t -> string +val internal_state_of_site_id : int -> int -> t -> string +(**[internal_state_of_site_id site_id value_id signature] *) -val counter_of_site : int -> t -> (int * int) option +val counter_of_site_id : int -> t -> (int * int) option val has_counter : t -> bool -type s (** Store of all the agents *) +type s +(** Store of all the agents, s as a plural *) +(* TODO See what to be kept here? *) val create : - counters:(string Locality.annot * string Locality.annot list) list -> - bool -> - (string Locality.annot * - (unit NamedDecls.t * - (string Locality.annot * string Locality.annot) list * - (int * int) option) NamedDecls.t) list -> + counters_per_agent:(string Loc.annoted * string Loc.annoted list) list -> + t NamedDecls.t -> s val size : s -> int + val get : s -> int -> t (** [get sigs agent_id] *) @@ -43,15 +56,14 @@ val arity : s -> int -> int val max_arity : s -> int (** [max_arity sigs] returns max {!arities sigs i} *) -val num_of_agent : string Locality.annot -> s -> int +val num_of_agent : string Loc.annoted -> s -> int val agent_of_num : int -> s -> string -val id_of_site : string Locality.annot -> string Locality.annot -> s -> int +val id_of_site : string Loc.annoted -> string Loc.annoted -> s -> int (** [id_of_site agent_type site_name sigs] *) val id_of_internal_state : - string Locality.annot -> string Locality.annot -> - string Locality.annot -> s -> int + string Loc.annoted -> string Loc.annoted -> string Loc.annoted -> s -> int (** [id_of_internal_state agent_type site_name state_name sigs] *) val internal_states_number : int -> int -> s -> int @@ -60,24 +72,34 @@ val internal_states_number : int -> int -> s -> int val default_internal_state : int -> int -> s -> int option val allowed_link : int -> int -> int -> int -> s -> bool -(** [allowed_link ag1 s1 ag2 s2 sigs] *) +(** [allowed_link ag1 s1 ag2 s2 sigs] evaluates to true if and only if it is allowed to create a link between site [s1] of agent [ag1] and site [s2] of agent [ag2] *) + +(** {2 Counter specific} *) + +(** If there are counters in the signature, we define a single agent as the + * _counter agent_, which will be used as _dummies_ to keep track of the counter value *) + +val is_counter_agent : s -> int -> bool +val ports_if_counter_agent : s -> int -> (int * int) option +val site_is_counter : s -> int -> int -> bool + +type counter_agent_info = { id: int; arity: int; ports: int * int } + +val get_counter_agent_info : s -> counter_agent_info +(** [counter_agent agent_sigs] *) + +(** {2 I/O} *) val print_agent : s -> Format.formatter -> int -> unit val print_site : s -> int -> Format.formatter -> int -> unit -val print_internal_state : - s -> int -> int -> Format.formatter -> int -> unit +val print_internal_state : s -> int -> int -> Format.formatter -> int -> unit + val print_site_internal_state : s -> int -> int -> Format.formatter -> int option -> unit (** [print_site_internal_state sigs agent_type site_id f state_id] prints both the site and its internal state if it is not [None]. *) val print_counter : s -> int -> Format.formatter -> int -> unit - val print : Format.formatter -> s -> unit val to_json : s -> Yojson.Basic.t val of_json : Yojson.Basic.t -> s - -val is_counter_agent : s -> int -> bool -val ports_if_counter_agent : s -> int -> (int*int) option -val site_is_counter : s -> int -> int -> bool -val incr_agent : s -> (int * int * int * int) (** id, arity, before, after *) diff --git a/core/siteGraphs/snapshot.ml b/core/siteGraphs/snapshot.ml index 52946b9da8..1a30e628d7 100644 --- a/core/siteGraphs/snapshot.ml +++ b/core/siteGraphs/snapshot.ml @@ -6,76 +6,91 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type cc_site = { - site_link: (int * int) option; - site_state: int option; -} +type cc_site = { site_link: (int * int) option; site_state: int option } + type cc_node = { node_type: int; node_id_in_witness: int; node_sites: cc_site array; } + type connected_component = cc_node array let rec agents_are_compatibles a b don = function | [] -> true - | (x,y)::q -> - let o = a.(x) in let p = b.(y) in - o.node_type = p.node_type && + | (x, y) :: q -> + let o = a.(x) in + let p = b.(y) in + o.node_type = p.node_type + && let i_ok = Tools.array_fold_left2i (fun _ b x y -> - b && match x.site_state,y.site_state with - | Some a, Some b -> (a = b) - | None, None -> true - | (Some _ | None), _ -> false) true o.node_sites p.node_sites in - i_ok && - match Tools.array_fold_left2i - (fun _ c x y -> - match c with - | None -> c - | Some todo -> - match x.site_link, y.site_link with - | (None, Some _ | Some _, None) -> None - | None, None -> c - | Some (a,s), Some (b,s') -> - if s <> s' then None else - match - List.find_all (fun (a',b') -> a = a' || b = b') don, - List.find_all (fun (a',b') -> a = a' || b = b') todo with - | _ :: _ :: _, _ | _, _ :: _ :: _ | [ _ ], [ _ ] -> None - | [a',b'], [] | [], [a',b'] -> - if a = a' && b = b' then c else None - | [],[] -> Some ((a,b)::todo) - ) - (Some q) o.node_sites p.node_sites with - | Some todo' -> agents_are_compatibles a b ((x,y)::don) todo' - | _ -> false + b + && + match x.site_state, y.site_state with + | Some a, Some b -> a = b + | None, None -> true + | (Some _ | None), _ -> false) + true o.node_sites p.node_sites + in + i_ok + && + (match + Tools.array_fold_left2i + (fun _ c x y -> + match c with + | None -> c + | Some todo -> + (match x.site_link, y.site_link with + | None, Some _ | Some _, None -> None + | None, None -> c + | Some (a, s), Some (b, s') -> + if s <> s' then + None + else ( + match + ( List.find_all (fun (a', b') -> a = a' || b = b') don, + List.find_all (fun (a', b') -> a = a' || b = b') todo ) + with + | _ :: _ :: _, _ | _, _ :: _ :: _ | [ _ ], [ _ ] -> None + | [ (a', b') ], [] | [], [ (a', b') ] -> + if a = a' && b = b' then + c + else + None + | [], [] -> Some ((a, b) :: todo) + ))) + (Some q) o.node_sites p.node_sites + with + | Some todo' -> agents_are_compatibles a b ((x, y) :: don) todo' + | _ -> false) let classify_by_type sigs mix = let len = Signature.size sigs in - let out = Array.make len (0,[]) in + let out = Array.make len (0, []) in let classify id ag = - let nb,ags = out.(ag.node_type) in - out.(ag.node_type) <- (succ nb,id::ags) in + let nb, ags = out.(ag.node_type) in + out.(ag.node_type) <- succ nb, id :: ags + in let () = Array.iteri classify mix in out let equal cbt_a a cbt_b b = match Tools.array_min_equal_not_null cbt_a cbt_b with | None -> false - | Some ([],ags) -> ags = [] - | Some (h1::_,ags) -> + | Some ([], ags) -> ags = [] + | Some (h1 :: _, ags) -> List.fold_left - (fun bool ag -> bool || agents_are_compatibles a b [] [h1,ag]) + (fun bool ag -> bool || agents_are_compatibles a b [] [ h1, ag ]) false ags let hash_prime = 29 + let coarse_hash cbt = - Array.fold_right (fun (l,_) acc -> l + hash_prime * acc) cbt 0 + Array.fold_right (fun (l, _) acc -> l + (hash_prime * acc)) cbt 0 -type t = - (int * (int * int list) array * connected_component) list Mods.IntMap.t +type t = (int * (int * int list) array * connected_component) list Mods.IntMap.t let empty = Mods.IntMap.empty @@ -84,88 +99,126 @@ let increment_in_snapshot ~raw sigs x s = let hs = coarse_hash cbt_x in let l = Mods.IntMap.find_default [] hs s in let rec aux_increment = function - | [] -> [1,cbt_x,x] - | (n,cbt_y,y as h)::t -> - if equal cbt_x x cbt_y y then (succ n,cbt_y,y)::t - else h::aux_increment t in - Mods.IntMap.add hs (if raw then (1,cbt_x,x)::l else aux_increment l) s + | [] -> [ 1, cbt_x, x ] + | ((n, cbt_y, y) as h) :: t -> + if equal cbt_x x cbt_y y then + (succ n, cbt_y, y) :: t + else + h :: aux_increment t + in + Mods.IntMap.add hs + (if raw then + (1, cbt_x, x) :: l + else + aux_increment l) + s -let rec counter_value cc (nid,sid) count = +let rec counter_value cc (nid, sid) count = let ag = cc.(nid) in Tools.array_fold_lefti (fun id acc si -> - if (id = sid) then acc - else + if id = sid then + acc + else ( match si.site_link with | None -> acc - | Some x -> counter_value cc x (acc+1)) count ag.node_sites + | Some x -> counter_value cc x (acc + 1) + )) + count ag.node_sites -let cc_to_user_cc ~debugMode ~raw sigs cc = +let cc_to_user_cc ~debug_mode ~raw sigs cc = let r = Renaming.empty () in - let (cc_list,indexes,_) = + let cc_list, indexes, _ = Tools.array_fold_lefti - (fun i (acc,indexes,pos) ag -> - match Signature.ports_if_counter_agent sigs ag.node_type with - | None -> - let indexes' = - if i = pos then indexes else - match Renaming.add ~debugMode i pos indexes with - | None -> - raise - (ExceptionDefn.Internal_Error - (Locality.dummy_annot - "Injectivity of renaming in snapshot")) - | Some r -> r in - (ag::acc,indexes',pos+1) - | Some _ -> (acc,indexes,pos)) - ([],r,0) cc in + (fun i (acc, indexes, pos) ag -> + match Signature.ports_if_counter_agent sigs ag.node_type with + | None -> + let indexes' = + if i = pos then + indexes + else ( + match Renaming.add ~debug_mode i pos indexes with + | None -> + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy "Injectivity of renaming in snapshot")) + | Some r -> r + ) + in + ag :: acc, indexes', pos + 1 + | Some _ -> acc, indexes, pos) + ([], r, 0) cc + in let cc_without_counters = Array.of_list (List.rev cc_list) in - [|Array.map - (fun ag -> Some { - User_graph.node_id = if raw then Some ag.node_id_in_witness else None; - User_graph.node_type = - Format.asprintf "%a" (Signature.print_agent sigs) ag.node_type; - User_graph.node_sites = - Array.mapi (fun id si -> { - User_graph.site_name = - Format.asprintf - "%a" (Signature.print_site sigs ag.node_type) id; - User_graph.site_type = - let port_states = - (match si.site_state with - | None -> Some [] - | Some s -> - Some [Format.asprintf - "%a" (Signature.print_internal_state - sigs ag.node_type id) - s]) in - match si.site_link with - | None -> - User_graph.Port - {User_graph.port_links = User_graph.LINKS []; - User_graph.port_states} - | Some (dn_id,s) -> - let dn_id' = - try Renaming.apply ~debugMode indexes dn_id - with Renaming.Undefined | Invalid_argument _ -> dn_id in - match Signature.ports_if_counter_agent - sigs (cc.(dn_id)).node_type with - | None -> - User_graph.Port - {User_graph.port_links = User_graph.LINKS [((0,dn_id'),s)]; - User_graph.port_states} - | Some _ -> - User_graph.Counter (counter_value cc (dn_id,s) 0) - }) - ag.node_sites; - }) - cc_without_counters|] + [| + Array.map + (fun ag -> + Some + { + User_graph.node_id = + (if raw then + Some ag.node_id_in_witness + else + None); + User_graph.node_type = + Format.asprintf "%a" (Signature.print_agent sigs) ag.node_type; + User_graph.node_sites = + Array.mapi + (fun id si -> + { + User_graph.site_name = + Format.asprintf "%a" + (Signature.print_site sigs ag.node_type) + id; + User_graph.site_type = + (let port_states = + match si.site_state with + | None -> Some [] + | Some s -> + Some + [ + Format.asprintf "%a" + (Signature.print_internal_state sigs + ag.node_type id) + s; + ] + in + match si.site_link with + | None -> + User_graph.Port + { + User_graph.port_links = User_graph.LINKS []; + User_graph.port_states; + } + | Some (dn_id, s) -> + let dn_id' = + try Renaming.apply ~debug_mode indexes dn_id + with Renaming.Undefined | Invalid_argument _ -> + dn_id + in + (match + Signature.ports_if_counter_agent sigs + cc.(dn_id).node_type + with + | None -> + User_graph.Port + { + User_graph.port_links = + User_graph.LINKS [ (0, dn_id'), s ]; + User_graph.port_states; + } + | Some _ -> + User_graph.Counter (counter_value cc (dn_id, s) 0))); + }) + ag.node_sites; + }) + cc_without_counters; + |] let fold f x s = - Mods.IntMap.fold (fun _ l acc -> - List.fold_left (fun a (nb, _, cc) -> f a nb cc) acc l) + Mods.IntMap.fold + (fun _ l acc -> List.fold_left (fun a (nb, _, cc) -> f a nb cc) acc l) s x -let export ~debugMode ~raw sigs s = - fold (fun a x y -> (x,cc_to_user_cc ~debugMode ~raw sigs y)::a) [] s - +let export ~debug_mode ~raw sigs s = + fold (fun a x y -> (x, cc_to_user_cc ~debug_mode ~raw sigs y) :: a) [] s diff --git a/core/siteGraphs/snapshot.mli b/core/siteGraphs/snapshot.mli index 056b50c40f..71f9c69cf6 100644 --- a/core/siteGraphs/snapshot.mli +++ b/core/siteGraphs/snapshot.mli @@ -7,20 +7,24 @@ (******************************************************************************) type cc_site = { - site_link: (int * int) option; (** (node_id, site_id) *) + site_link: (int * int) option; (** (node_id, site_id) *) site_state: int option; } + type cc_node = { node_type: int; - node_id_in_witness : int; + node_id_in_witness: int; node_sites: cc_site array; } -type connected_component = cc_node array +type connected_component = cc_node array type t val cc_to_user_cc : - debugMode:bool -> raw:bool -> Signature.s -> connected_component -> + debug_mode:bool -> + raw:bool -> + Signature.s -> + connected_component -> User_graph.connected_component val empty : t @@ -29,7 +33,10 @@ val increment_in_snapshot : raw:bool -> Signature.s -> connected_component -> t -> t val export : - debugMode:bool -> raw:bool -> Signature.s -> t -> + debug_mode:bool -> + raw:bool -> + Signature.s -> + t -> (int * User_graph.connected_component) list val fold : ('a -> int -> connected_component -> 'a) -> 'a -> t -> 'a diff --git a/core/siteGraphs/user_graph.ml b/core/siteGraphs/user_graph.ml index dbf6f67e63..6c838d327a 100644 --- a/core/siteGraphs/user_graph.ml +++ b/core/siteGraphs/user_graph.ml @@ -14,18 +14,11 @@ type links = type cc_port = { port_links: links; - port_states: string list option; - (** [None] means WHATEVER *) + port_states: string list option; (** [None] means WHATEVER *) } -type site = - | Port of cc_port - | Counter of int - -type cc_site = { - site_name: string; - site_type: site -} +type site = Port of cc_port | Counter of int +type cc_site = { site_name: string; site_type: site } type cc_node = { node_type: string; @@ -35,139 +28,157 @@ type cc_node = { type connected_component = cc_node option array array -module LinkSetMap = SetMap.Make(struct - type t = (int * int) * int - let print = - Pp.pair - (Pp.pair Format.pp_print_int Format.pp_print_int) - Format.pp_print_int - let compare (x,y) (x',y') = - let c = Mods.int_pair_compare x x' in - if c=0 then Mods.int_compare y y' else c - end) +module LinkSetMap = SetMap.Make (struct + type t = (int * int) * int + + let print = + Pp.pair + (Pp.pair Format.pp_print_int Format.pp_print_int) + Format.pp_print_int + + let compare (x, y) (x', y') = + let c = Mods.int_pair_compare x x' in + if c = 0 then + Mods.int_compare y y' + else + c +end) -let print_link (dangling,free_id) p f = function +let print_link (dangling, free_id) p f = function | WHATEVER -> Format.pp_print_string f "[#]" | SOME -> Format.pp_print_string f "[_]" - | TYPE (si,ty) -> Format.fprintf f "[%s.%s]" si ty + | TYPE (si, ty) -> Format.fprintf f "[%s.%s]" si ty | LINKS [] -> Format.pp_print_string f "[.]" | LINKS l -> let myself = - ref (LinkSetMap.Map.find_default LinkSetMap.Map.empty p !dangling) in + ref (LinkSetMap.Map.find_default LinkSetMap.Map.empty p !dangling) + in let () = - Format.fprintf f"[%a]" - (Pp.list - Pp.space - (fun f p' -> - let i = - if p = p' then -1 else - match Option_util.bind - (LinkSetMap.Map.find_option p) - (LinkSetMap.Map.find_option p' !dangling) with - | None -> - let () = incr free_id in - let () = myself := LinkSetMap.Map.add p' !free_id !myself in - !free_id - | Some va -> va in - Format.fprintf f "%i" i)) l in + Format.fprintf f "[%a]" + (Pp.list Pp.space (fun f p' -> + let i = + if p = p' then + -1 + else ( + match + Option_util.bind + (LinkSetMap.Map.find_option p) + (LinkSetMap.Map.find_option p' !dangling) + with + | None -> + let () = incr free_id in + let () = myself := LinkSetMap.Map.add p' !free_id !myself in + !free_id + | Some va -> va + ) + in + Format.fprintf f "%i" i)) + l + in dangling := LinkSetMap.Map.add p !myself !dangling let print_port with_link node p id f = Format.fprintf f "%a%a" (fun f -> function - | None -> Format.pp_print_string f "{#}" - | Some [] -> () - | Some l -> - Format.fprintf f "{%a}" - (Pp.list Pp.space (fun f i -> Format.fprintf f "%s" i)) l) + | None -> Format.pp_print_string f "{#}" + | Some [] -> () + | Some l -> + Format.fprintf f "{%a}" + (Pp.list Pp.space (fun f i -> Format.fprintf f "%s" i)) + l) p.port_states - (match with_link with - | Some pack -> print_link pack (node,id) - | None -> (fun _ _ -> ())) - p.port_links + (match with_link with + | Some pack -> print_link pack (node, id) + | None -> fun _ _ -> ()) + p.port_links let print_intf with_link node = - Pp.array - Pp.space - (fun id f si -> - let () = Format.fprintf f "%s" si.site_name in - (match si.site_type with - | Port p -> print_port with_link node p id f - | Counter i -> Format.fprintf f "{=%i}" i)) + Pp.array Pp.space (fun id f si -> + let () = Format.fprintf f "%s" si.site_name in + match si.site_type with + | Port p -> print_port with_link node p id f + | Counter i -> Format.fprintf f "{=%i}" i) let print_agent with_id link node f = function | None -> Format.pp_print_string f "." | Some ag -> Format.fprintf f "%a%s(@[%a@])" (Pp.option ~with_space:false (fun f i -> Format.fprintf f "x%i:" i)) - (if with_id then ag.node_id else None) - ag.node_type (print_intf link node) - ag.node_sites + (if with_id then + ag.node_id + else + None) + ag.node_type (print_intf link node) ag.node_sites let print_cc f mix = - let link = Some (ref(LinkSetMap.Map.empty),ref 0) in + let link = Some (ref LinkSetMap.Map.empty, ref 0) in Pp.array (fun f -> Format.fprintf f "\\@ ") - (fun al -> Pp.array Pp.comma (fun ar -> print_agent true link (al,ar))) f mix + (fun al -> Pp.array Pp.comma (fun ar -> print_agent true link (al, ar))) + f mix let get_color = let store = Hashtbl.create 10 in fun i -> try Hashtbl.find store i with Not_found -> - let v = Format.sprintf "#%x%x%x" (Random.int 255) - (Random.int 255) (Random.int 255) in - let () = Hashtbl.add store i v in v + let v = + Format.sprintf "#%x%x%x" (Random.int 255) (Random.int 255) + (Random.int 255) + in + let () = Hashtbl.add store i v in + v let print_dot_cc nb_cc f mix = - Pp.array - Pp.empty - (fun il -> Pp.array - Pp.empty - (fun ir f -> function + Pp.array Pp.empty + (fun il -> + Pp.array Pp.empty (fun ir f -> function + | None -> () + | Some ag -> + Format.fprintf f + "node%d_%d_%d [label = \"@[%a@]\", color = \"%s\", \ + style=filled];@," + nb_cc il ir + (print_agent false None (il, ir)) + (Some ag) (get_color ag.node_type); + Format.fprintf f "node%d_%d_%d -> counter%d [style=invis];@," nb_cc il + ir nb_cc)) + f mix; + ignore + @@ Array.iteri + (fun al -> + Array.iteri (fun ar -> function | None -> () | Some ag -> - Format.fprintf - f "node%d_%d_%d [label = \"@[%a@]\", color = \"%s\", style=filled];@," - nb_cc il ir (print_agent false None (il,ir)) (Some ag) - (get_color ag.node_type); - Format.fprintf - f "node%d_%d_%d -> counter%d [style=invis];@," nb_cc il ir nb_cc)) f mix; - ignore @@ - Array.iteri - (fun al -> - Array.iteri - (fun ar -> function - | None -> () - | Some ag -> - Array.iteri - (fun s si -> - match si.site_type with - | Counter _ -> () - | Port p -> - match p.port_links with - | WHATEVER -> assert false - | SOME -> assert false - | TYPE (_si,_ty) -> assert false - | LINKS links -> - Pp.list - Pp.empty - (fun f ((al',ar'),s') -> - if al < al' || - (al = al' && (ar < ar' || - (ar = ar' && s < s'))) then - match mix.(al').(ar') with - | None -> assert false - | Some ag' -> - Format.fprintf - f - "node%d_%d_%d -> node%d_%d_%d \ - [taillabel=\"%s\", headlabel=\"%s\", dir=none];@," - nb_cc al ar nb_cc al' ar' si.site_name - ag'.node_sites.(s').site_name) - f links) - ag.node_sites)) - mix + Array.iteri + (fun s si -> + match si.site_type with + | Counter _ -> () + | Port p -> + (match p.port_links with + | WHATEVER -> assert false + | SOME -> assert false + | TYPE (_si, _ty) -> assert false + | LINKS links -> + Pp.list Pp.empty + (fun f ((al', ar'), s') -> + if + al < al' + || (al = al' && (ar < ar' || (ar = ar' && s < s'))) + then ( + match mix.(al').(ar') with + | None -> assert false + | Some ag' -> + Format.fprintf f + "node%d_%d_%d -> node%d_%d_%d \ + [taillabel=\"%s\", headlabel=\"%s\", \ + dir=none];@," + nb_cc al ar nb_cc al' ar' si.site_name + ag'.node_sites.(s').site_name + )) + f links)) + ag.node_sites)) + mix (* type cc_node = { @@ -179,33 +190,38 @@ type connected_component = cc_node array let write_cc_port ob p = let () = Buffer.add_char ob '{' in - let () = JsonUtil.write_field - "port_links" (fun ob -> function - | WHATEVER -> Yojson.Basic.write_null ob () - | SOME -> Yojson.Basic.write_bool ob true - | TYPE (si,ty) -> - let () = Buffer.add_string ob "{\"site_name\":\"" in - let () = Buffer.add_string ob si in - let () = Buffer.add_string ob "\",\"agent_type\":\"" in - let () = Buffer.add_string ob ty in - Buffer.add_string ob "\"}" - | LINKS l -> - JsonUtil.write_list - (JsonUtil.write_compact_pair - (JsonUtil.write_compact_pair - Yojson.Basic.write_int Yojson.Basic.write_int) - Yojson.Basic.write_int) ob l) - ob p.port_links in + let () = + JsonUtil.write_field "port_links" + (fun ob -> function + | WHATEVER -> Yojson.Basic.write_null ob () + | SOME -> Yojson.Basic.write_bool ob true + | TYPE (si, ty) -> + let () = Buffer.add_string ob "{\"site_name\":\"" in + let () = Buffer.add_string ob si in + let () = Buffer.add_string ob "\",\"agent_type\":\"" in + let () = Buffer.add_string ob ty in + Buffer.add_string ob "\"}" + | LINKS l -> + JsonUtil.write_list + (JsonUtil.write_compact_pair + (JsonUtil.write_compact_pair Yojson.Basic.write_int + Yojson.Basic.write_int) + Yojson.Basic.write_int) + ob l) + ob p.port_links + in let () = JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "port_states" + let () = + JsonUtil.write_field "port_states" (JsonUtil.write_option (JsonUtil.write_list Yojson.Basic.write_string)) - ob p.port_states in + ob p.port_states + in Buffer.add_char ob '}' let write_site ob f = let () = Buffer.add_char ob '[' in - let () = match f.site_type with + let () = + match f.site_type with | Counter i -> let () = Yojson.Basic.write_string ob "counter" in let () = Buffer.add_char ob ',' in @@ -213,44 +229,55 @@ let write_site ob f = | Port p -> let () = Yojson.Basic.write_string ob "port" in let () = Buffer.add_char ob ',' in - write_cc_port ob p in + write_cc_port ob p + in Buffer.add_char ob ']' let write_cc_site ob f = let () = Buffer.add_char ob '{' in - let () = JsonUtil.write_field - "site_name" Yojson.Basic.write_string ob f.site_name in + let () = + JsonUtil.write_field "site_name" Yojson.Basic.write_string ob f.site_name + in let () = JsonUtil.write_comma ob in let () = JsonUtil.write_field "site_type" write_site ob f in Buffer.add_char ob '}' let links_of_yojson = function | `Null -> WHATEVER - | `Bool b -> let () = assert b in SOME - | `Assoc [ "site_name", `String si; "agent_type", `String ty ] - | `Assoc [ "agent_type", `String ty; "site_name", `String si ] -> - TYPE (si,ty) + | `Bool b -> + let () = assert b in + SOME + | `Assoc [ ("site_name", `String si); ("agent_type", `String ty) ] + | `Assoc [ ("agent_type", `String ty); ("site_name", `String si) ] -> + TYPE (si, ty) | `List _ as x -> let error_msg = None in LINKS (JsonUtil.to_list (JsonUtil.compact_to_pair (JsonUtil.compact_to_pair - (JsonUtil.to_int ?error_msg) (JsonUtil.to_int ?error_msg)) - (JsonUtil.to_int ?error_msg)) x) - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect cc_port",x)) + (JsonUtil.to_int ?error_msg) + (JsonUtil.to_int ?error_msg)) + (JsonUtil.to_int ?error_msg)) + x) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect cc_port", x)) let read_cc_port p lb = - let (port_links, port_states) = - Yojson.Basic.read_fields - (fun (s,i) key p lb -> - if key = "port_links" then - (links_of_yojson (Yojson.Basic.read_json p lb),i) - else let () = assert (key = "port_states") in - (s,JsonUtil.read_option - (Yojson.Basic.read_list Yojson.Basic.read_string) p lb)) - (LINKS [],Some []) p lb in - {port_links; port_states} + let port_links, port_states = + Yojson.Basic.read_fields + (fun (s, i) key p lb -> + if key = "port_links" then + links_of_yojson (Yojson.Basic.read_json p lb), i + else ( + let () = assert (key = "port_states") in + ( s, + JsonUtil.read_option + (Yojson.Basic.read_list Yojson.Basic.read_string) + p lb ) + )) + (LINKS [], Some []) p lb + in + { port_links; port_states } let read_site p lb = let () = Yojson.Basic.read_lbr p lb in @@ -259,51 +286,74 @@ let read_site p lb = let out = JsonUtil.read_between_spaces (fun p lb -> - if key = "counter" then Counter (Yojson.Basic.read_int p lb) - else let () = assert (key = "port") in Port (read_cc_port p lb)) - p lb in + if key = "counter" then + Counter (Yojson.Basic.read_int p lb) + else ( + let () = assert (key = "port") in + Port (read_cc_port p lb) + )) + p lb + in let () = Yojson.Basic.read_rbr p lb in out let read_cc_site p lb = - let (site_name,site_type) = + let site_name, site_type = Yojson.Basic.read_fields - (fun (n,s) key p lb -> - if key = "site_name" then (Yojson.Basic.read_string p lb,s) - else let () = assert (key = "site_type") in (n,read_site p lb)) - ("",Counter (-1)) p lb in + (fun (n, s) key p lb -> + if key = "site_name" then + Yojson.Basic.read_string p lb, s + else ( + let () = assert (key = "site_type") in + n, read_site p lb + )) + ("", Counter (-1)) p lb + in { site_name; site_type } let write_cc_node ob x = JsonUtil.write_option (fun ob f -> - let () = Buffer.add_char ob '{' in - let () = JsonUtil.write_field - "node_type" Yojson.Basic.write_string ob f.node_type in - let () = JsonUtil.write_comma ob in - let () = match f.node_id with - | None -> () - | Some node_id -> - let () = JsonUtil.write_field - "node_id" Yojson.Basic.write_int ob node_id in - JsonUtil.write_comma ob in - let () = JsonUtil.write_field - "node_sites" (JsonUtil.write_array write_cc_site) ob f.node_sites in - Buffer.add_char ob '}') + let () = Buffer.add_char ob '{' in + let () = + JsonUtil.write_field "node_type" Yojson.Basic.write_string ob + f.node_type + in + let () = JsonUtil.write_comma ob in + let () = + match f.node_id with + | None -> () + | Some node_id -> + let () = + JsonUtil.write_field "node_id" Yojson.Basic.write_int ob node_id + in + JsonUtil.write_comma ob + in + let () = + JsonUtil.write_field "node_sites" + (JsonUtil.write_array write_cc_site) + ob f.node_sites + in + Buffer.add_char ob '}') ob x let read_cc_node p lb = JsonUtil.read_option (fun p lb -> - let (node_id,node_type,node_sites) = - Yojson.Basic.read_fields - (fun (id,n,s) key p lb -> - if key = "node_id" then (Some (Yojson.Basic.read_int p lb),n,s) - else if key = "node_type" then (id,Yojson.Basic.read_string p lb,s) - else let () = assert (key = "node_sites") in - (id,n,Yojson.Basic.read_array read_cc_site p lb)) - (None,"",[||]) p lb in - { node_id; node_type; node_sites }) + let node_id, node_type, node_sites = + Yojson.Basic.read_fields + (fun (id, n, s) key p lb -> + if key = "node_id" then + Some (Yojson.Basic.read_int p lb), n, s + else if key = "node_type" then + id, Yojson.Basic.read_string p lb, s + else ( + let () = assert (key = "node_sites") in + id, n, Yojson.Basic.read_array read_cc_site p lb + )) + (None, "", [||]) p lb + in + { node_id; node_type; node_sites }) p lb let write_connected_component ob f = diff --git a/core/siteGraphs/user_graph.mli b/core/siteGraphs/user_graph.mli index 92792e1a69..dc6ed0cdb2 100644 --- a/core/siteGraphs/user_graph.mli +++ b/core/siteGraphs/user_graph.mli @@ -14,18 +14,11 @@ type links = type cc_port = { port_links: links; - port_states: string list option; - (** [None] means WHATEVER *) + port_states: string list option; (** [None] means WHATEVER *) } -type site = - | Port of cc_port - | Counter of int - -type cc_site = { - site_name: string; - site_type: site -} +type site = Port of cc_port | Counter of int +type cc_site = { site_name: string; site_type: site } type cc_node = { node_type: string; @@ -36,18 +29,14 @@ type cc_node = { type connected_component = cc_node option array array val print_cc : Format.formatter -> connected_component -> unit - val print_dot_cc : int -> Format.formatter -> connected_component -> unit - val links_of_yojson : Yojson.Basic.t -> links -val write_connected_component : - Buffer.t -> connected_component -> unit - (** Output a JSON value of type {!connected_component}. *) +val write_connected_component : Buffer.t -> connected_component -> unit +(** Output a JSON value of type {!connected_component}. *) -val string_of_connected_component : - ?len:int -> connected_component -> string - (** Serialize a value of type {!connected_component} +val string_of_connected_component : ?len:int -> connected_component -> string +(** Serialize a value of type {!connected_component} into a JSON string. @param len specifies the initial length of the buffer used internally. @@ -55,8 +44,7 @@ val string_of_connected_component : val read_connected_component : Yojson.Safe.lexer_state -> Lexing.lexbuf -> connected_component - (** Input JSON data of type {!connected_component}. *) +(** Input JSON data of type {!connected_component}. *) -val connected_component_of_string : - string -> connected_component - (** Deserialize JSON data of type {!connected_component}. *) +val connected_component_of_string : string -> connected_component +(** Deserialize JSON data of type {!connected_component}. *) diff --git a/core/symmetries/affine_combinations.ml b/core/symmetries/affine_combinations.ml index 5d9829d8a9..5888a22194 100644 --- a/core/symmetries/affine_combinations.ml +++ b/core/symmetries/affine_combinations.ml @@ -1,94 +1,77 @@ -type ('mix,'id) anonamised_expr = ('mix,'id) Alg_expr.e Locality.annot - -let rec anonamise (expr: ('mix,'id) Alg_expr.e Locality.annot) : ('mix,'id) anonamised_expr = - Locality.dummy_annot - begin - match - fst expr - with - | Alg_expr.BIN_ALG_OP (op, e1, e2) -> - Alg_expr.BIN_ALG_OP (op, anonamise e1, anonamise e2) - | Alg_expr.UN_ALG_OP (op, e) -> - Alg_expr.UN_ALG_OP(op, anonamise e) - | (Alg_expr.STATE_ALG_OP _ - | Alg_expr.ALG_VAR _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.CONST _) as e -> e - | Alg_expr.IF (b,e1,e2) -> - Alg_expr.IF(anonamise_bool b, anonamise e1,anonamise e2) - | Alg_expr.DIFF_TOKEN (e,id) -> Alg_expr.DIFF_TOKEN (anonamise e,id) - | Alg_expr.DIFF_KAPPA_INSTANCE (e,id) -> - Alg_expr.DIFF_KAPPA_INSTANCE (anonamise e,id) - end +type ('mix, 'id) anonamised_expr = ('mix, 'id) Alg_expr.e Loc.annoted + +let rec anonamise (expr : ('mix, 'id) Alg_expr.e Loc.annoted) : + ('mix, 'id) anonamised_expr = + Loc.annot_with_dummy + (match fst expr with + | Alg_expr.BIN_ALG_OP (op, e1, e2) -> + Alg_expr.BIN_ALG_OP (op, anonamise e1, anonamise e2) + | Alg_expr.UN_ALG_OP (op, e) -> Alg_expr.UN_ALG_OP (op, anonamise e) + | ( Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ | Alg_expr.KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ | Alg_expr.CONST _ ) as e -> + e + | Alg_expr.IF (b, e1, e2) -> + Alg_expr.IF (anonamise_bool b, anonamise e1, anonamise e2) + | Alg_expr.DIFF_TOKEN (e, id) -> Alg_expr.DIFF_TOKEN (anonamise e, id) + | Alg_expr.DIFF_KAPPA_INSTANCE (e, id) -> + Alg_expr.DIFF_KAPPA_INSTANCE (anonamise e, id)) + and anonamise_bool bool = - Locality.dummy_annot - begin - match fst bool with - | (Alg_expr.TRUE - | Alg_expr.FALSE) as e -> e - | Alg_expr.BIN_BOOL_OP (op,b1,b2) -> - Alg_expr.BIN_BOOL_OP (op, anonamise_bool b1, anonamise_bool b2) - | Alg_expr.UN_BOOL_OP (op,b1) -> - Alg_expr.UN_BOOL_OP (op, anonamise_bool b1) - | Alg_expr.COMPARE_OP (op, e1, e2) -> - Alg_expr.COMPARE_OP (op, anonamise e1, anonamise e2) - end - -module AnonamisedExprSetMap = - (SetMap.Make - (struct - type t = (Pattern.id array list, int) anonamised_expr - let compare = compare - let print _ _ = () - end)) -module AnonamisedExprMap = AnonamisedExprSetMap.Map + Loc.annot_with_dummy + (match fst bool with + | (Alg_expr.TRUE | Alg_expr.FALSE) as e -> e + | Alg_expr.BIN_BOOL_OP (op, b1, b2) -> + Alg_expr.BIN_BOOL_OP (op, anonamise_bool b1, anonamise_bool b2) + | Alg_expr.UN_BOOL_OP (op, b1) -> Alg_expr.UN_BOOL_OP (op, anonamise_bool b1) + | Alg_expr.COMPARE_OP (op, e1, e2) -> + Alg_expr.COMPARE_OP (op, anonamise e1, anonamise e2)) +module AnonamisedExprSetMap = SetMap.Make (struct + type t = (Pattern.id array list, int) anonamised_expr -type aff_combination = - { - linear: Fractions.t AnonamisedExprMap.t ; - affine: Fractions.t - } + let compare = compare + let print _ _ = () +end) -let of_int i = - { - linear = AnonamisedExprMap.empty ; - affine = Fractions.of_int i - } +module AnonamisedExprMap = AnonamisedExprSetMap.Map -let apply_1 op aff1 = -{ - linear = - AnonamisedExprMap.fold - (fun k a map -> - let result = op a in - if Fractions.is_zero result then - map - else - AnonamisedExprMap.add k (op a) map) - aff1.linear AnonamisedExprMap.empty ; - affine = op aff1.affine ; +type aff_combination = { + linear: Fractions.t AnonamisedExprMap.t; + affine: Fractions.t; } +let of_int i = { linear = AnonamisedExprMap.empty; affine = Fractions.of_int i } + +let apply_1 op aff1 = + { + linear = + AnonamisedExprMap.fold + (fun k a map -> + let result = op a in + if Fractions.is_zero result then + map + else + AnonamisedExprMap.add k (op a) map) + aff1.linear AnonamisedExprMap.empty; + affine = op aff1.affine; + } + let apply_2 op aff1 aff2 = { linear = - snd (AnonamisedExprMap.monadic_fold2 - () - () + snd + (AnonamisedExprMap.monadic_fold2 () () (fun _ err k a b map -> - let rep = op a b in - err, - if Fractions.is_zero rep then - AnonamisedExprMap.remove k map - else AnonamisedExprMap.add k rep map) - (fun _ err _ _ map -> err,map) - (fun _ err k a map -> err,AnonamisedExprMap.add k a map) - aff1.linear aff2.linear aff1.linear) - ; - affine = op aff1.affine aff2.affine - + let rep = op a b in + ( err, + if Fractions.is_zero rep then + AnonamisedExprMap.remove k map + else + AnonamisedExprMap.add k rep map )) + (fun _ err _ _ map -> err, map) + (fun _ err k a map -> err, AnonamisedExprMap.add k a map) + aff1.linear aff2.linear aff1.linear); + affine = op aff1.affine aff2.affine; } let sum aff1 aff2 = apply_2 Fractions.add aff1 aff2 @@ -106,9 +89,8 @@ let div_scal aff i = | Some f_inv -> Some (apply_1 (Fractions.mult f_inv) aff) let necessarily_equal aff1 aff2 = - Fractions.is_equal aff1.affine aff2.affine && - AnonamisedExprMap.equal - (Fractions.is_equal) aff1.linear aff2.linear + Fractions.is_equal aff1.affine aff2.affine + && AnonamisedExprMap.equal Fractions.is_equal aff1.linear aff2.linear let is_int nbr = match nbr with @@ -118,49 +100,46 @@ let is_int nbr = let atom expr = { - linear = AnonamisedExprMap.add expr Fractions.one AnonamisedExprMap.empty ; - affine = Fractions.zero + linear = AnonamisedExprMap.add expr Fractions.one AnonamisedExprMap.empty; + affine = Fractions.zero; } let linearise expr = let expr = anonamise expr in let rec aux expr = - match - fst expr - with - | Alg_expr.BIN_ALG_OP (Operator.SUM, e1, e2) -> - sum (aux e1) (aux e2) - | Alg_expr.BIN_ALG_OP (Operator.MINUS, e1, e2) -> - minus (aux e1) (aux e2) - | Alg_expr.BIN_ALG_OP (Operator.MULT, (Alg_expr.CONST nbr,_), e2) when is_int nbr -> + match fst expr with + | Alg_expr.BIN_ALG_OP (Operator.SUM, e1, e2) -> sum (aux e1) (aux e2) + | Alg_expr.BIN_ALG_OP (Operator.MINUS, e1, e2) -> minus (aux e1) (aux e2) + | Alg_expr.BIN_ALG_OP (Operator.MULT, (Alg_expr.CONST nbr, _), e2) + when is_int nbr -> mul_scal (Nbr.to_int nbr) (aux e2) - | Alg_expr.BIN_ALG_OP (Operator.MULT, e1, (Alg_expr.CONST nbr,_)) when is_int nbr -> + | Alg_expr.BIN_ALG_OP (Operator.MULT, e1, (Alg_expr.CONST nbr, _)) + when is_int nbr -> mul_scal (Nbr.to_int nbr) (aux e1) - | Alg_expr.BIN_ALG_OP (Operator.DIV, e1, (Alg_expr.CONST nbr,_)) when is_int nbr -> - begin - match - div_scal (aux e1) (Nbr.to_int nbr) - with - | None -> - atom expr - | Some a -> a - end - | Alg_expr.UN_ALG_OP (Operator.UMINUS, e) -> - mul_scal (-1) (aux e) + | Alg_expr.BIN_ALG_OP (Operator.DIV, e1, (Alg_expr.CONST nbr, _)) + when is_int nbr -> + (match div_scal (aux e1) (Nbr.to_int nbr) with + | None -> atom expr + | Some a -> a) + | Alg_expr.UN_ALG_OP (Operator.UMINUS, e) -> mul_scal (-1) (aux e) | Alg_expr.CONST nbr when is_int nbr -> - {affine = Fractions.of_int (Nbr.to_int nbr); - linear = AnonamisedExprMap.empty} - | Alg_expr.IF _ - | Alg_expr.STATE_ALG_OP _ - | Alg_expr.ALG_VAR _ - | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.UN_ALG_OP ( - (Operator.COSINUS | Operator.SINUS | Operator.LOG | Operator.SQRT | Operator.TAN | Operator.INT | Operator.EXP),_ - ) + { + affine = Fractions.of_int (Nbr.to_int nbr); + linear = AnonamisedExprMap.empty; + } + | Alg_expr.IF _ | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ + | Alg_expr.UN_ALG_OP + ( ( Operator.COSINUS | Operator.SINUS | Operator.LOG | Operator.SQRT + | Operator.TAN | Operator.INT | Operator.EXP ), + _ ) | Alg_expr.CONST _ - | Alg_expr.BIN_ALG_OP ( - (Operator.MULT | Operator.MIN | Operator.MAX | Operator.DIV | Operator.POW | Operator.MODULO),_,_) -> atom expr - in aux expr + | Alg_expr.BIN_ALG_OP + ( ( Operator.MULT | Operator.MIN | Operator.MAX | Operator.DIV + | Operator.POW | Operator.MODULO ), + _, + _ ) -> + atom expr + in + aux expr diff --git a/core/symmetries/dune b/core/symmetries/dune index 25f211256e..0df77fed14 100644 --- a/core/symmetries/dune +++ b/core/symmetries/dune @@ -1,14 +1,23 @@ (library - (name kappa_symmetries) - (libraries kappa_parameters kappa_cli) - (flags (:standard) - -open Kappa_grammar - -open Kappa_terms - -open Kappa_mixtures - -open Kappa_parameters - -open Kappa_generic_toolset - -open Kappa_logging - -open Kappa_cli - -open Kappa_runtime - -open Kappa_kasa_type_interface -)) + (name kappa_symmetries) + (libraries kappa_parameters kappa_cli) + (flags + (:standard) + -open + Kappa_grammar + -open + Kappa_terms + -open + Kappa_mixtures + -open + Kappa_parameters + -open + Kappa_generic_toolset + -open + Kappa_logging + -open + Kappa_cli + -open + Kappa_runtime + -open + Kappa_kasa_type_interface)) diff --git a/core/symmetries/kade_backend.ml b/core/symmetries/kade_backend.ml index cf6b212a80..bd549fbbb1 100644 --- a/core/symmetries/kade_backend.ml +++ b/core/symmetries/kade_backend.ml @@ -1,34 +1,25 @@ -module Utils = -struct - +module Utils = struct let print_link_to_any_symbol f symbol_table = Format.fprintf f "%s" symbol_table.Symbol_table.link_to_any - let print_free_symbol f symbol_table = - Format.fprintf f "%s" - symbol_table.Symbol_table.free + let print_free_symbol f symbol_table = + Format.fprintf f "%s" symbol_table.Symbol_table.free let print_bound_to_unknown_symbol f symbol_table = - Format.fprintf f "%s" - symbol_table.Symbol_table.link_to_some + Format.fprintf f "%s" symbol_table.Symbol_table.link_to_some - let print_bound_symbol - symbol_table pr_bound f bound = - Format.fprintf f "%s%a" - symbol_table.Symbol_table.bound - pr_bound bound + let print_bound_symbol symbol_table pr_bound f bound = + Format.fprintf f "%s%a" symbol_table.Symbol_table.bound pr_bound bound let print_binding_type_symbol symbol_table pr_port pr_type p f a = print_bound_symbol symbol_table (fun f () -> - Format.fprintf f "%a%s%a" - (pr_port a) p - symbol_table.Symbol_table.btype_sep - pr_type p) f () + Format.fprintf f "%a%s%a" (pr_port a) p + symbol_table.Symbol_table.btype_sep pr_type p) + f () let print_binding_state symbol_table pr_binding_state f binding_state = - Format.fprintf f "%s%a%s" - symbol_table.Symbol_table.open_binding_state + Format.fprintf f "%s%a%s" symbol_table.Symbol_table.open_binding_state pr_binding_state binding_state symbol_table.Symbol_table.close_binding_state @@ -37,60 +28,49 @@ struct (fun f () -> print_bound_symbol symbol_table pr_bound f bound) f () - let print_binding_state_and_switch_symbol - _symbol_table pr_binding_state binding_state pr_switch f switch = - Format.fprintf f "%a%a" - pr_binding_state binding_state - pr_switch switch + let print_binding_state_and_switch_symbol _symbol_table pr_binding_state + binding_state pr_switch f switch = + Format.fprintf f "%a%a" pr_binding_state binding_state pr_switch switch - let print_binding_state_and_switch - symbol_table pr_binding_state binding_state pr_switch f switch = + let print_binding_state_and_switch symbol_table pr_binding_state binding_state + pr_switch f switch = print_binding_state symbol_table - (fun f () -> print_binding_state_and_switch_symbol - symbol_table pr_binding_state - binding_state pr_switch f switch) f () + (fun f () -> + print_binding_state_and_switch_symbol symbol_table pr_binding_state + binding_state pr_switch f switch) + f () let print_binding_type symbol_table pr_port pr_type p f a = print_binding_state symbol_table - (fun f () -> - print_binding_type_symbol symbol_table pr_port pr_type p f a) + (fun f () -> print_binding_type_symbol symbol_table pr_port pr_type p f a) f () let print_free_site f symbol_table = - print_binding_state symbol_table - print_free_symbol f symbol_table + print_binding_state symbol_table print_free_symbol f symbol_table let print_internal_state symbol_table pr_st f st = - Format.fprintf f "%s%s%a%s" - symbol_table.Symbol_table.open_internal_state - symbol_table.Symbol_table.internal_state_symbol - pr_st st + Format.fprintf f "%s%s%a%s" symbol_table.Symbol_table.open_internal_state + symbol_table.Symbol_table.internal_state_symbol pr_st st symbol_table.Symbol_table.close_internal_state let print_internal_state_symbol_any f symbol_table = - Format.fprintf f "%s" - symbol_table.Symbol_table.internal_state_any + Format.fprintf f "%s" symbol_table.Symbol_table.internal_state_any let print_internal_state_any f symbol_table = - Format.fprintf f "%s%a%s" - symbol_table.Symbol_table.open_internal_state + Format.fprintf f "%s%a%s" symbol_table.Symbol_table.open_internal_state print_internal_state_symbol_any symbol_table symbol_table.Symbol_table.close_internal_state let print_space symbol_table f space = Format.fprintf f - begin - match space, symbol_table.Symbol_table.breakable with - | Symbol_table.Space, true -> "@ " - | Symbol_table.Space, false -> " " - | Symbol_table.No_space, true -> "@," - | Symbol_table.No_space, false -> "" - end - - let print_separator symbol_table f (string,space) = - Format.fprintf f "%s%a" - string - (print_space symbol_table) space + (match space, symbol_table.Symbol_table.breakable with + | Symbol_table.Space, true -> "@ " + | Symbol_table.Space, false -> " " + | Symbol_table.No_space, true -> "@," + | Symbol_table.No_space, false -> "") + + let print_separator symbol_table f (string, space) = + Format.fprintf f "%s%a" string (print_space symbol_table) space let print_agent_sep_comma symbol_table f = print_separator symbol_table f symbol_table.Symbol_table.agent_sep_comma @@ -103,141 +83,137 @@ struct let print_site_sep symbol_table f = print_separator symbol_table f symbol_table.Symbol_table.site_sep - end - -module Pattern = -struct - +module Pattern = struct type id = Pattern.id - let print_free_site = - Utils.print_free_site + let print_free_site = Utils.print_free_site - let print_internal ?sigs (_,agent) site f id = + let print_internal ?sigs (_, agent) site f id = match sigs with - | Some sigs -> - Signature.print_internal_state sigs agent site f id + | Some sigs -> Signature.print_internal_state sigs agent site f id | None -> Format.fprintf f "%i" id let print_internal_state symbol_table ?sigs ag p fmt st = - Utils.print_internal_state - symbol_table (print_internal ?sigs ag p) fmt st - - let print_cc - ?(full_species=false) ?sigs ?cc_id ~noCounters ~with_id - ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) f cc = - let print_intf (ag_i, _ as ag) link_ids neigh = - snd - (Tools.array_fold_lefti - (fun p (not_empty, (free, link_ids as out)) (el, st) -> - let () = - if st >= 0 - then Format.fprintf - f "%t%a%a" - (if not_empty then - Utils.print_site_sep symbol_table - else Pp.empty) - (Agent.print_site ?sigs ag) p - (print_internal_state symbol_table ?sigs ag p) - st - else if el <> Pattern.UnSpec then - Format.fprintf - f "%t%a" - (if not_empty then - Utils.print_site_sep symbol_table - else Pp.empty) - (Agent.print_site ?sigs ag) p in - match el with - | Pattern.UnSpec -> - if st >= 0 then - let () = - if full_species then - print_free_site f symbol_table - in - (true,out) - else (not_empty,out) - | Pattern.Free -> - let () = print_free_site f symbol_table in - (true,out) - | Pattern.Link (dst_a,dst_p) -> - let dst_ty = Pattern.find_ty cc dst_a in - if match sigs with - | None -> false - | Some sigs -> Signature.is_counter_agent sigs dst_ty - && not noCounters then - let counter = Pattern.counter_value_cc cc (dst_a,dst_p) 0 in - let () = Format.fprintf f "{=%d}" counter in - (* to do: add symbols in symbol table for counters *) - true,out + Utils.print_internal_state symbol_table (print_internal ?sigs ag p) fmt st + + let print_cc ?(full_species = false) ?sigs ?cc_id ~noCounters ~with_id + ?(symbol_table = Symbol_table.symbol_table_V4) f cc = + let print_intf ((ag_i, _) as ag) link_ids neigh = + snd + (Tools.array_fold_lefti + (fun p (not_empty, ((free, link_ids) as out)) (el, st) -> + let () = + if st >= 0 then + Format.fprintf f "%t%a%a" + (if not_empty then + Utils.print_site_sep symbol_table else - let i,out' = - match - Mods.Int2Map.find_option (dst_a,dst_p) link_ids - with - | Some x -> (x, out) - | None -> - (free, (succ free, - Mods.Int2Map.add (ag_i,p) free link_ids)) - in - let () = - Utils.print_bound symbol_table - Format.pp_print_int f i - in - true, out') - (false, link_ids) neigh) - in - let () = match cc_id with - | None -> () - | Some cc_id -> Format.fprintf f "/*cc%a*/@ " - Pattern.debug_print_id cc_id in - let (_, _) = - Pattern.fold - (fun x el (not_empty,link_ids) -> - let ag_x = (x,Pattern.find_ty cc x) in - if match sigs with - | None -> true + Pp.empty) + (Agent.print_site ?sigs ag) + p + (print_internal_state symbol_table ?sigs ag p) + st + else if el <> Pattern.UnSpec then + Format.fprintf f "%t%a" + (if not_empty then + Utils.print_site_sep symbol_table + else + Pp.empty) + (Agent.print_site ?sigs ag) + p + in + match el with + | Pattern.UnSpec -> + if st >= 0 then ( + let () = if full_species then print_free_site f symbol_table in + true, out + ) else + not_empty, out + | Pattern.Free -> + let () = print_free_site f symbol_table in + true, out + | Pattern.Link (dst_a, dst_p) -> + let dst_ty = Pattern.find_ty cc dst_a in + if + match sigs with + | None -> false | Some sigs -> - (not (Signature.is_counter_agent sigs (snd ag_x))) - || noCounters then - let () = - Format.fprintf - f "%t@[%a%s" - (if not_empty - then - Utils.print_agent_sep_dot symbol_table - else Pp.empty) - (Agent.print ?sigs ~with_id) ag_x - symbol_table.Symbol_table.agent_open + Signature.is_counter_agent sigs dst_ty && not noCounters + then ( + let counter = Pattern.counter_value_cc cc (dst_a, dst_p) 0 in + let () = Format.fprintf f "{=%d}" counter in + (* to do: add symbols in symbol table for counters *) + true, out + ) else ( + let i, out' = + match Mods.Int2Map.find_option (dst_a, dst_p) link_ids with + | Some x -> x, out + | None -> + free, (succ free, Mods.Int2Map.add (ag_i, p) free link_ids) in - let out = print_intf ag_x link_ids el in let () = - Format.fprintf f "%s@]" symbol_table.Symbol_table.agent_close + Utils.print_bound symbol_table Format.pp_print_int f i in - true, out - else not_empty,link_ids) - cc (false, (1, Mods.Int2Map.empty)) - in - () - + true, out' + )) + (false, link_ids) neigh) + in + let () = + match cc_id with + | None -> () + | Some cc_id -> Format.fprintf f "/*cc%a*/@ " Pattern.debug_print_id cc_id + in + let _, _ = + Pattern.fold + (fun x el (not_empty, link_ids) -> + let ag_x = x, Pattern.find_ty cc x in + if + match sigs with + | None -> true + | Some sigs -> + (not (Signature.is_counter_agent sigs (snd ag_x))) || noCounters + then ( + let () = + Format.fprintf f "%t@[%a%s" + (if not_empty then + Utils.print_agent_sep_dot symbol_table + else + Pp.empty) + (Agent.print ?sigs ~with_id) + ag_x symbol_table.Symbol_table.agent_open + in + let out = print_intf ag_x link_ids el in + let () = + Format.fprintf f "%s@]" symbol_table.Symbol_table.agent_close + in + true, out + ) else + not_empty, link_ids) + cc + (false, (1, Mods.Int2Map.empty)) + in + () - let print - ?domain ~noCounters ~with_id - ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) f id = + let print ?domain ~noCounters ~with_id + ?(symbol_table = Symbol_table.symbol_table_V4) f id = match domain with | None -> Pattern.debug_print_id f id | Some env -> - let cc_id = if with_id then Some id else None in + let cc_id = + if with_id then + Some id + else + None + in print_cc - ~sigs:(Pattern.Env.signatures env) ?cc_id ~noCounters ~with_id - ~symbol_table - f (Pattern.Env.content (Pattern.Env.get env id)) - + ~sigs:(Pattern.Env.signatures env) + ?cc_id ~noCounters ~with_id ~symbol_table f + (Pattern.Env.content (Pattern.Env.get env id)) end -module Ast = -struct +module Ast = struct include Ast let print_link pr_port pr_type pr_annot symbol_table f = function @@ -245,78 +221,78 @@ struct Utils.print_link_to_any_symbol f symbol_table | LKappa.LNK_TYPE (p, a) -> Utils.print_binding_type_symbol symbol_table pr_port pr_type p f a - | LKappa.LNK_FREE -> - Utils.print_free_symbol f symbol_table - | LKappa.LNK_SOME -> - Utils.print_bound_to_unknown_symbol f symbol_table - | LKappa.LNK_VALUE (i,a) -> + | LKappa.LNK_FREE -> Utils.print_free_symbol f symbol_table + | LKappa.LNK_SOME -> Utils.print_bound_to_unknown_symbol f symbol_table + | LKappa.LNK_VALUE (i, a) -> Utils.print_bound_symbol symbol_table - (fun fmt a -> - Format.fprintf fmt "%i%a" i pr_annot a) + (fun fmt a -> Format.fprintf fmt "%i%a" i pr_annot a) f a - end - -module Raw_mixture = -struct - +module Raw_mixture = struct include Raw_mixture - let print_link ~noCounters symbol_table incr_agents f = function - | Raw_mixture.FREE -> - Utils.print_free_site f symbol_table + + let print_link ~noCounters symbol_table counter_agents f = function + | Raw_mixture.FREE -> Utils.print_free_site f symbol_table | Raw_mixture.VAL i -> - try - let root = Raw_mixture.find incr_agents i in - let (counter,(_,is_counter)) = Mods.DynArray.get incr_agents.Raw_mixture.rank root - in - if is_counter && not noCounters then - Format.fprintf f "{=%d}" counter - (* to do: add symbols in symbol table for counters *) - else - Utils.print_bound symbol_table Format.pp_print_int f i - with Invalid_argument _ -> - Utils.print_bound symbol_table Format.pp_print_int f i + (try + let root = Raw_mixture.find counter_agents i in + let counter, (_, is_counter) = + Mods.DynArray.get counter_agents.Raw_mixture.rank root + in + if is_counter && not noCounters then + Format.fprintf f "{=%d}" counter + (* to do: add symbols in symbol table for counters *) + else + Utils.print_bound symbol_table Format.pp_print_int f i + with Invalid_argument _ -> + Utils.print_bound symbol_table Format.pp_print_int f i) let aux_pp_si sigs symbol_table a s f i = match sigs with | Some sigs -> - Format.fprintf f - "%a%a" - (Signature.print_site sigs a) s + Format.fprintf f "%a%a" + (Signature.print_site sigs a) + s (fun fmt id_opt -> - match id_opt with - | None -> () - | Some i -> - Utils.print_internal_state - symbol_table - (Signature.print_internal_state sigs a s) fmt i ) + match id_opt with + | None -> () + | Some i -> + Utils.print_internal_state symbol_table + (Signature.print_internal_state sigs a s) + fmt i) i | None -> - match i with + (match i with | Some i -> - Format.fprintf f - "%i%a" - s - (Utils.print_internal_state symbol_table Format.pp_print_int) - i - - | None -> Format.pp_print_int f s + Format.fprintf f "%i%a" s + (Utils.print_internal_state symbol_table Format.pp_print_int) + i + | None -> Format.pp_print_int f s) let print_intf ~noCounters with_link ?sigs - ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) - incr_agents (ag_ty:int) f (ports,ints) = + ?(symbol_table = Symbol_table.symbol_table_V4) counter_agents + (ag_ty : int) f (ports, ints) = let rec aux empty i = - if i < Array.length ports then - let () = Format.fprintf - f "%t%a%a" - (if empty then Pp.empty else (Utils.print_site_sep symbol_table)) - (aux_pp_si sigs symbol_table ag_ty i) ints.(i) - (if with_link - then print_link ~noCounters symbol_table incr_agents - else (fun _ _ -> ())) - ports.(i) in - aux false (succ i) in + if i < Array.length ports then ( + let () = + Format.fprintf f "%t%a%a" + (if empty then + Pp.empty + else + Utils.print_site_sep symbol_table) + (aux_pp_si sigs symbol_table ag_ty i) + ints.(i) + (if with_link then + print_link ~noCounters symbol_table counter_agents + else + fun _ _ -> + ()) + ports.(i) + in + aux false (succ i) + ) + in aux true 0 let aux_pp_ag sigs f a = @@ -324,58 +300,50 @@ struct | Some sigs -> Signature.print_agent sigs f a | None -> Format.pp_print_int f a - let print_agent ~noCounters created link - ?sigs ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) - incr_agents f ag = - Format.fprintf f "%a%s@[%a@]%s%t" - (aux_pp_ag sigs) ag.Raw_mixture.a_type + let print_agent ~noCounters created link ?sigs + ?(symbol_table = Symbol_table.symbol_table_V4) counter_agents f ag = + Format.fprintf f "%a%s@[%a@]%s%t" (aux_pp_ag sigs) ag.Raw_mixture.a_type symbol_table.Symbol_table.agent_open - (print_intf - ~noCounters - link - ?sigs - ~symbol_table - incr_agents - ag.Raw_mixture.a_type) - (ag.Raw_mixture.a_ports, ag.Raw_mixture.a_ints) - symbol_table.Symbol_table.agent_close - (fun f -> if created then Format.pp_print_string f "+") - (* to do: add symbols for agent creation/degradation *) + (print_intf ~noCounters link ?sigs ~symbol_table counter_agents + ag.Raw_mixture.a_type) (ag.Raw_mixture.a_ports, ag.Raw_mixture.a_ints) + symbol_table.Symbol_table.agent_close (fun f -> + if created then Format.pp_print_string f "+") + (* to do: add symbols for agent creation/degradation *) let print ~noCounters ~created ?sigs - ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) - f mix = - let incr_agents = Raw_mixture.union_find_counters sigs mix in + ?(symbol_table = Symbol_table.symbol_table_V4) f mix = + let counter_agents = Raw_mixture.union_find_counters sigs mix in let rec aux_print some = function | [] -> () - | h::t -> - if match sigs with + | h :: t -> + if + match sigs with | None -> false - | Some sigs -> Signature.is_counter_agent sigs h.Raw_mixture.a_type - && not noCounters - then aux_print some t - else + | Some sigs -> + Signature.is_counter_agent sigs h.Raw_mixture.a_type + && not noCounters + then + aux_print some t + else ( + let () = if some then Utils.print_agent_sep_comma symbol_table f in let () = - if some then - Utils.print_agent_sep_comma symbol_table f + print_agent ~noCounters created true ?sigs ~symbol_table + counter_agents f h in - let () = print_agent - ~noCounters created true ?sigs ~symbol_table incr_agents f h in - aux_print true t in + aux_print true t + ) + in aux_print false mix - end -module LKappa = -struct - - - let print_link_annot ~ltypes sigs symbol_table f (s,a) = +module LKappa = struct + let print_link_annot ~ltypes sigs symbol_table f (s, a) = if ltypes then Format.fprintf f "/*%a%s%a*/" - (Signature.print_site sigs a) s - symbol_table.Symbol_table.btype_sep - (Signature.print_agent sigs) a + (Signature.print_site sigs a) + s symbol_table.Symbol_table.btype_sep + (Signature.print_agent sigs) + a let print_switching ~show_erased f = function (* to do: add symbols in symbol table for counters *) @@ -384,194 +352,220 @@ struct | LKappa.Maintained -> () | LKappa.Erased -> if show_erased then Format.pp_print_string f "--" - let print_rule_link sigs symbol_table ~show_erased ~ltypes f ((e,_),s) = - Utils.print_binding_state_and_switch - symbol_table + let print_rule_link sigs symbol_table ~show_erased ~ltypes f ((e, _), s) = + Utils.print_binding_state_and_switch symbol_table (Ast.print_link (Signature.print_site sigs) (Signature.print_agent sigs) (print_link_annot ~ltypes sigs symbol_table) symbol_table) e - (print_switching ~show_erased) f s - + (print_switching ~show_erased) + f s let print_rule_internal sigs symbol_table ~show_erased ag_ty site f = function (* to do: add symbols for mods *) | LKappa.I_ANY -> () | LKappa.I_ANY_CHANGED j -> - Format.fprintf f "{#/%a}" (Signature.print_internal_state sigs ag_ty site) j - | LKappa.I_ANY_ERASED -> - if show_erased then Format.fprintf f "~--" - | LKappa.I_VAL_CHANGED (i,j) -> + Format.fprintf f "{#/%a}" + (Signature.print_internal_state sigs ag_ty site) + j + | LKappa.I_ANY_ERASED -> if show_erased then Format.fprintf f "~--" + | LKappa.I_VAL_CHANGED (i, j) -> if i <> j then - Format.fprintf - f "{%a/%a}" (Signature.print_internal_state sigs ag_ty site) i - (Signature.print_internal_state sigs ag_ty site) j + Format.fprintf f "{%a/%a}" + (Signature.print_internal_state sigs ag_ty site) + i + (Signature.print_internal_state sigs ag_ty site) + j else - Pattern.print_internal_state symbol_table ~sigs - ((),ag_ty) site f i - | LKappa.I_VAL_ERASED i -> - Format.fprintf - f "{%a%t}" (Signature.print_internal_state sigs ag_ty site) i - (fun f -> if show_erased then Format.pp_print_string f "--") + Pattern.print_internal_state symbol_table ~sigs ((), ag_ty) site f i + | LKappa.I_VAL_ERASED i -> + Format.fprintf f "{%a%t}" (Signature.print_internal_state sigs ag_ty site) + i (fun f -> if show_erased then Format.pp_print_string f "--") let print_counter_test f = function (* to do: add symbols for counters *) - | (c,true) -> Format.fprintf f "=%i" c - | (c,false) -> Format.fprintf f ">=%i" c + | c, true -> Format.fprintf f "=%i" c + | c, false -> Format.fprintf f ">=%i" c - let print_counter_delta counters j f switch = match switch with + let print_counter_delta counters j f switch = + match switch with | LKappa.Linked i -> - begin - let root = Raw_mixture.find counters i in - let (s,(_,is_counter)) = - Mods.DynArray.get counters.Raw_mixture.rank root in - let delta = if (is_counter) then s-1 else (j-i) in - (* to do: add symbols for counters *) - Format.fprintf f "/+=%d" delta - end + let root = Raw_mixture.find counters i in + let s, (_, is_counter) = + Mods.DynArray.get counters.Raw_mixture.rank root + in + let delta = + if is_counter then + s - 1 + else + j - i + in + (* to do: add symbols for counters *) + Format.fprintf f "/+=%d" delta | LKappa.Freed -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot("Cannot erase all increment agents"))) + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy "Cannot erase all increment agents")) | LKappa.Maintained -> () | LKappa.Erased -> () - - let print_rule_intf - sigs ~show_erased ~ltypes symbol_table ag_ty ?counters f (ports,ints) = + let print_rule_intf sigs ~show_erased ~ltypes symbol_table ag_ty ?counters f + (ports, ints) = let rec aux empty i = if i < Array.length ports then - if (match ports.(i) with - | (LKappa.LNK_ANY, _), LKappa.Maintained -> ints.(i) <> LKappa.I_ANY - | ((LKappa.LNK_ANY, _), (LKappa.Erased | LKappa.Freed | LKappa.Linked _) | - ((LKappa.LNK_SOME | LKappa.ANY_FREE | LKappa.LNK_FREE | - LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _),_), _) -> true) then - - let ((e,_),switch) = ports.(i) in - let is_counter = match e with + if + match ports.(i) with + | (LKappa.LNK_ANY, _), LKappa.Maintained -> ints.(i) <> LKappa.I_ANY + | (LKappa.LNK_ANY, _), (LKappa.Erased | LKappa.Freed | LKappa.Linked _) + | ( ( ( LKappa.LNK_SOME | LKappa.ANY_FREE | LKappa.LNK_FREE + | LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _ ), + _ ), + _ ) -> + true + then ( + let (e, _), switch = ports.(i) in + let is_counter = + match e with | LKappa.ANY_FREE | LKappa.LNK_FREE | LKappa.LNK_ANY - | LKappa.LNK_TYPE _ | LKappa.LNK_SOME -> false - | LKappa.LNK_VALUE (j,_) -> - match counters with + | LKappa.LNK_TYPE _ | LKappa.LNK_SOME -> + false + | LKappa.LNK_VALUE (j, _) -> + (match counters with | None -> false - | Some (counters,created_counters) -> - try - let root = Raw_mixture.find counters j in - let (c,(eq,is_counter')) = - Mods.DynArray.get counters.Raw_mixture.rank root in - if is_counter' then - (* to do: add symbols for counters *) - let () = Format.fprintf f "%t%a{%a%a}" - (if empty then Pp.empty else Pp.space) - (Signature.print_site sigs ag_ty) i - print_counter_test (c-1,eq) - (print_counter_delta created_counters j) switch - in true else false - with Invalid_argument _ -> false in - let () = if not(is_counter) then - Format.fprintf - f "%t%a%a%a" - (if empty then Pp.empty else Utils.print_site_sep symbol_table) - (Signature.print_site sigs ag_ty) i - (print_rule_internal sigs symbol_table ~show_erased ag_ty i) ints.(i) + | Some (counters, created_counters) -> + (try + let root = Raw_mixture.find counters j in + let c, (eq, is_counter') = + Mods.DynArray.get counters.Raw_mixture.rank root + in + if is_counter' then ( + (* to do: add symbols for counters *) + let () = + Format.fprintf f "%t%a{%a%a}" + (if empty then + Pp.empty + else + Pp.space) + (Signature.print_site sigs ag_ty) + i print_counter_test + (c - 1, eq) + (print_counter_delta created_counters j) + switch + in + true + ) else + false + with Invalid_argument _ -> false)) + in + let () = + if not is_counter then + Format.fprintf f "%t%a%a%a" + (if empty then + Pp.empty + else + Utils.print_site_sep symbol_table) + (Signature.print_site sigs ag_ty) + i + (print_rule_internal sigs symbol_table ~show_erased ag_ty i) + ints.(i) (print_rule_link sigs symbol_table ~show_erased ~ltypes) - ports.(i) else () in + ports.(i) + else + () + in aux false (succ i) - else aux empty (succ i) in + ) else + aux empty (succ i) + in aux true 0 + let print_rule_agent sigs ~ltypes + ?(symbol_table = Symbol_table.symbol_table_V4) ?counters f ag = + Format.fprintf f "%a%s@[%a@]%s%t" (Signature.print_agent sigs) + ag.LKappa.ra_type symbol_table.Symbol_table.agent_open + (print_rule_intf sigs symbol_table ~show_erased:false ~ltypes + ag.LKappa.ra_type ?counters) (ag.LKappa.ra_ports, ag.LKappa.ra_ints) + symbol_table.Symbol_table.agent_close (fun f -> + if ag.LKappa.ra_erased then Format.pp_print_string f "-") + + let union_find_counters sigs mix = + let t = Raw_mixture.create 1 in + let () = + match sigs with + | None -> () + | Some sigs -> + List.iter + (fun ag -> + match Signature.ports_if_counter_agent sigs ag.LKappa.ra_type with + | None -> () + | Some (before, after) -> + let (a, _), _ = ag.LKappa.ra_ports.(after) in + let (b, _), _ = ag.LKappa.ra_ports.(before) in + (match b with + | LKappa.ANY_FREE | LKappa.LNK_FREE | LKappa.LNK_ANY + | LKappa.LNK_TYPE _ | LKappa.LNK_SOME -> + () + | LKappa.LNK_VALUE (lnk_b, _) -> + (match a with + | LKappa.LNK_VALUE (lnk_a, _) -> Raw_mixture.union t lnk_b lnk_a + | LKappa.ANY_FREE | LKappa.LNK_FREE -> + let root = Raw_mixture.find t lnk_b in + let s, _ = Mods.DynArray.get t.Raw_mixture.rank root in + Mods.DynArray.set t.Raw_mixture.rank root (s, (true, true)) + | LKappa.LNK_ANY -> + let root = Raw_mixture.find t lnk_b in + let s, _ = Mods.DynArray.get t.Raw_mixture.rank root in + Mods.DynArray.set t.Raw_mixture.rank root (s, (false, true)) + | LKappa.LNK_TYPE _ | LKappa.LNK_SOME -> + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy + "Port a of __counter_agent agent not well specified"))))) + mix + in + t - let print_rule_agent - sigs ~ltypes - ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) - ?counters f ag = - Format.fprintf f "%a%s@[%a@]%s%t" - (Signature.print_agent sigs) ag.LKappa.ra_type - symbol_table.Symbol_table.agent_open - (print_rule_intf sigs symbol_table ~show_erased:false - ~ltypes ag.LKappa.ra_type ?counters) - (ag.LKappa.ra_ports,ag.LKappa.ra_ints) - symbol_table.Symbol_table.agent_close - (fun f -> if ag.LKappa.ra_erased then Format.pp_print_string f "-") - - -let union_find_counters sigs mix = - let t = Raw_mixture.create 1 in - let () = - match sigs with - | None -> () - | Some sigs -> - List.iter - (fun ag -> - match Signature.ports_if_counter_agent sigs ag.LKappa.ra_type with - | None -> () - | Some (before,after) -> - let ((a,_),_) = ag.LKappa.ra_ports.(after) in - let ((b,_),_) = ag.LKappa.ra_ports.(before) in - match b with - | LKappa.ANY_FREE | LKappa.LNK_FREE | LKappa.LNK_ANY - | LKappa.LNK_TYPE _ | LKappa.LNK_SOME -> () - | LKappa.LNK_VALUE (lnk_b,_) -> - match a with - | LKappa.LNK_VALUE (lnk_a,_) -> Raw_mixture.union t lnk_b lnk_a - | LKappa.ANY_FREE | LKappa.LNK_FREE -> - let root = Raw_mixture.find t lnk_b in - let (s,_) = Mods.DynArray.get t.Raw_mixture.rank root in - Mods.DynArray.set t.Raw_mixture.rank root (s,(true,true)) - | LKappa.LNK_ANY -> - let root = Raw_mixture.find t lnk_b in - let (s,_) = Mods.DynArray.get t.Raw_mixture.rank root in - Mods.DynArray.set t.Raw_mixture.rank root (s,(false,true)) - | LKappa.LNK_TYPE _ | LKappa.LNK_SOME -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - ("Port a of __incr agent not well specified")))) - mix in - t - -let print_rule_mixture - ~noCounters sigs ~ltypes ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) - created f mix = - let counters = - if noCounters then None - else - Some (union_find_counters (Some sigs) mix, - Raw_mixture.union_find_counters (Some sigs) created) in + let print_rule_mixture ~noCounters sigs ~ltypes + ?(symbol_table = Symbol_table.symbol_table_V4) created f mix = + let counters = + if noCounters then + None + else + Some + ( union_find_counters (Some sigs) mix, + Raw_mixture.union_find_counters (Some sigs) created ) + in let rec aux_print some = function | [] -> () - | h::t -> - if Signature.is_counter_agent sigs h.LKappa.ra_type - && not noCounters - then aux_print some t - else - let () = - if some then - Utils.print_agent_sep_comma symbol_table f - in - let () = print_rule_agent sigs ~ltypes ~symbol_table - ?counters f h in - aux_print true t in + | h :: t -> + if Signature.is_counter_agent sigs h.LKappa.ra_type && not noCounters + then + aux_print some t + else ( + let () = if some then Utils.print_agent_sep_comma symbol_table f in + let () = print_rule_agent sigs ~ltypes ~symbol_table ?counters f h in + aux_print true t + ) + in aux_print false mix -let print_internal_lhs sigs symbol_table ag_ty site f = function - | LKappa.I_ANY -> () - | (LKappa.I_ANY_CHANGED _ | LKappa.I_ANY_ERASED) -> - Utils.print_internal_state_any f symbol_table - | (LKappa.I_VAL_CHANGED (i,_) | LKappa.I_VAL_ERASED i) -> - Pattern.print_internal_state - symbol_table ~sigs ((),ag_ty) site f i - -let print_internal_rhs sigs symbol_table ag_ty site f = function - | LKappa.I_ANY -> () - | (LKappa.I_ANY_CHANGED j | LKappa.I_VAL_CHANGED (_,j)) -> - Pattern.print_internal_state - symbol_table ~sigs ((),ag_ty) site f j - | (LKappa.I_ANY_ERASED | LKappa.I_VAL_ERASED _) -> assert false - -let print_link_lhs ~ltypes sigs symbol_table f ((e,_),_) = - Utils.print_binding_state - symbol_table + let print_internal_lhs sigs symbol_table ag_ty site f = function + | LKappa.I_ANY -> () + | LKappa.I_ANY_CHANGED _ | LKappa.I_ANY_ERASED -> + Utils.print_internal_state_any f symbol_table + | LKappa.I_VAL_CHANGED (i, _) | LKappa.I_VAL_ERASED i -> + Pattern.print_internal_state symbol_table ~sigs ((), ag_ty) site f i + + let print_internal_rhs sigs symbol_table ag_ty site f = function + | LKappa.I_ANY -> () + | LKappa.I_ANY_CHANGED j | LKappa.I_VAL_CHANGED (_, j) -> + Pattern.print_internal_state symbol_table ~sigs ((), ag_ty) site f j + | LKappa.I_ANY_ERASED | LKappa.I_VAL_ERASED _ -> assert false + + let print_link_lhs ~ltypes sigs symbol_table f ((e, _), _) = + Utils.print_binding_state symbol_table (Ast.print_link (Signature.print_site sigs) (Signature.print_agent sigs) @@ -579,322 +573,373 @@ let print_link_lhs ~ltypes sigs symbol_table f ((e,_),_) = symbol_table) f e -let print_link_rhs ~ltypes sigs symbol_table f ((e,_),s) = - Utils.print_binding_state - symbol_table - begin - fun f -> function - | LKappa.Linked i -> - Ast.print_link - (Signature.print_site sigs) - (Signature.print_agent sigs) (fun _ () -> ()) - symbol_table f (LKappa.LNK_VALUE (i,())) - | LKappa.Freed -> - Ast.print_link - (Signature.print_site sigs) - (Signature.print_agent sigs) (fun _ () -> ()) - symbol_table f LKappa.LNK_FREE - | LKappa.Maintained -> - Ast.print_link - (Signature.print_site sigs) - (Signature.print_agent sigs) - (print_link_annot ~ltypes sigs symbol_table) - symbol_table - f e - | LKappa.Erased -> assert false - end - f - s - -let print_intf_lhs ~ltypes sigs symbol_table ag_ty f (ports,ints) = - let rec aux empty i = - if i < Array.length ports then - if (match ports.(i) with - | (((LKappa.LNK_SOME | LKappa.LNK_FREE | LKappa.ANY_FREE | - LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _),_), _) -> true + let print_link_rhs ~ltypes sigs symbol_table f ((e, _), s) = + Utils.print_binding_state symbol_table + (fun f -> function + | LKappa.Linked i -> + Ast.print_link + (Signature.print_site sigs) + (Signature.print_agent sigs) + (fun _ () -> ()) + symbol_table f + (LKappa.LNK_VALUE (i, ())) + | LKappa.Freed -> + Ast.print_link + (Signature.print_site sigs) + (Signature.print_agent sigs) + (fun _ () -> ()) + symbol_table f LKappa.LNK_FREE + | LKappa.Maintained -> + Ast.print_link + (Signature.print_site sigs) + (Signature.print_agent sigs) + (print_link_annot ~ltypes sigs symbol_table) + symbol_table f e + | LKappa.Erased -> assert false) + f s + + let print_intf_lhs ~ltypes sigs symbol_table ag_ty f (ports, ints) = + let rec aux empty i = + if i < Array.length ports then + if + match ports.(i) with + | ( ( ( LKappa.LNK_SOME | LKappa.LNK_FREE | LKappa.ANY_FREE + | LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _ ), + _ ), + _ ) -> + true | (LKappa.LNK_ANY, _), _ -> - match ints.(i) with - | (LKappa.I_ANY | LKappa.I_ANY_ERASED | LKappa.I_ANY_CHANGED _) -> false - | ( LKappa.I_VAL_CHANGED _ | LKappa.I_VAL_ERASED _) -> true) then - let () = Format.fprintf - f "%t%a%a%a" - (if empty then Pp.empty else - Utils.print_site_sep symbol_table) - (Signature.print_site sigs ag_ty) i - (print_internal_lhs sigs symbol_table ag_ty i) - ints.(i) (print_link_lhs ~ltypes sigs symbol_table) ports.(i) in - aux false (succ i) - else aux empty (succ i) in - aux true 0 - -let print_intf_rhs ~ltypes sigs symbol_table ag_ty f (ports,ints) = - let rec aux empty i = - if i < Array.length ports then - if (match ports.(i) with - | (((LKappa.LNK_SOME | LKappa.LNK_FREE | LKappa.ANY_FREE | - LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _),_), _) -> true - | ((LKappa.LNK_ANY, _), (LKappa.Erased | LKappa.Freed | LKappa.Linked _)) -> true - | ((LKappa.LNK_ANY, _), LKappa.Maintained) -> - match ints.(i) with + (match ints.(i) with + | LKappa.I_ANY | LKappa.I_ANY_ERASED | LKappa.I_ANY_CHANGED _ -> + false + | LKappa.I_VAL_CHANGED _ | LKappa.I_VAL_ERASED _ -> true) + then ( + let () = + Format.fprintf f "%t%a%a%a" + (if empty then + Pp.empty + else + Utils.print_site_sep symbol_table) + (Signature.print_site sigs ag_ty) + i + (print_internal_lhs sigs symbol_table ag_ty i) + ints.(i) + (print_link_lhs ~ltypes sigs symbol_table) + ports.(i) + in + aux false (succ i) + ) else + aux empty (succ i) + in + aux true 0 + + let print_intf_rhs ~ltypes sigs symbol_table ag_ty f (ports, ints) = + let rec aux empty i = + if i < Array.length ports then + if + match ports.(i) with + | ( ( ( LKappa.LNK_SOME | LKappa.LNK_FREE | LKappa.ANY_FREE + | LKappa.LNK_TYPE _ | LKappa.LNK_VALUE _ ), + _ ), + _ ) -> + true + | (LKappa.LNK_ANY, _), (LKappa.Erased | LKappa.Freed | LKappa.Linked _) + -> + true + | (LKappa.LNK_ANY, _), LKappa.Maintained -> + (match ints.(i) with | LKappa.I_ANY -> false - | LKappa.I_VAL_CHANGED (i,j) -> i <> j - | (LKappa.I_ANY_ERASED | LKappa.I_ANY_CHANGED _ | LKappa.I_VAL_ERASED _) -> true - ) then - let () = Format.fprintf - f "%t%a%a%a" - (if empty then Pp.empty else Utils.print_site_sep symbol_table) - (Signature.print_site sigs ag_ty) i - (print_internal_rhs sigs symbol_table ag_ty i) - ints.(i) (print_link_rhs ~ltypes sigs symbol_table) ports.(i) in - aux false (succ i) - else aux empty (succ i) in - aux true 0 - -let print_agent_lhs ~ltypes sigs symbol_table f ag = - Format.fprintf - f "%a%s@[%a@]%s" - (Signature.print_agent sigs) ag.LKappa.ra_type - symbol_table.Symbol_table.agent_open - (print_intf_lhs ~ltypes sigs symbol_table ag.LKappa.ra_type) (ag.LKappa.ra_ports,ag.LKappa.ra_ints) - symbol_table.Symbol_table.agent_close - -let print_agent_rhs ~ltypes sigs symbol_table f ag = - if not ag.LKappa.ra_erased then - Format.fprintf - f "%a%s@[%a@]%s" (Signature.print_agent sigs) ag.LKappa.ra_type - symbol_table.Symbol_table.agent_open - (print_intf_rhs ~ltypes sigs symbol_table ag.LKappa.ra_type) (ag.LKappa.ra_ports,ag.LKappa.ra_ints) + | LKappa.I_VAL_CHANGED (i, j) -> i <> j + | LKappa.I_ANY_ERASED | LKappa.I_ANY_CHANGED _ + | LKappa.I_VAL_ERASED _ -> + true) + then ( + let () = + Format.fprintf f "%t%a%a%a" + (if empty then + Pp.empty + else + Utils.print_site_sep symbol_table) + (Signature.print_site sigs ag_ty) + i + (print_internal_rhs sigs symbol_table ag_ty i) + ints.(i) + (print_link_rhs ~ltypes sigs symbol_table) + ports.(i) + in + aux false (succ i) + ) else + aux empty (succ i) + in + aux true 0 + + let print_agent_lhs ~ltypes sigs symbol_table f ag = + Format.fprintf f "%a%s@[%a@]%s" + (Signature.print_agent sigs) + ag.LKappa.ra_type symbol_table.Symbol_table.agent_open + (print_intf_lhs ~ltypes sigs symbol_table ag.LKappa.ra_type) + (ag.LKappa.ra_ports, ag.LKappa.ra_ints) symbol_table.Symbol_table.agent_close -let print_rhs ~noCounters ~ltypes sigs symbol_table created f mix = - let rec aux empty = function - | [] -> - Format.fprintf f "%t%a" - (if empty || created = [] - then Pp.empty - else - Utils.print_agent_sep_comma symbol_table) - (Raw_mixture.print ~noCounters ~created:false ~sigs ~symbol_table) - created - | h :: t -> - if h.LKappa.ra_erased - then - if symbol_table.Symbol_table.show_ghost then + let print_agent_rhs ~ltypes sigs symbol_table f ag = + if not ag.LKappa.ra_erased then + Format.fprintf f "%a%s@[%a@]%s" + (Signature.print_agent sigs) + ag.LKappa.ra_type symbol_table.Symbol_table.agent_open + (print_intf_rhs ~ltypes sigs symbol_table ag.LKappa.ra_type) + (ag.LKappa.ra_ports, ag.LKappa.ra_ints) + symbol_table.Symbol_table.agent_close + + let print_rhs ~noCounters ~ltypes sigs symbol_table created f mix = + let rec aux empty = function + | [] -> + Format.fprintf f "%t%a" + (if empty || created = [] then + Pp.empty + else + Utils.print_agent_sep_comma symbol_table) + (Raw_mixture.print ~noCounters ~created:false ~sigs ~symbol_table) + created + | h :: t -> + if h.LKappa.ra_erased then + if symbol_table.Symbol_table.show_ghost then ( + let () = + Format.fprintf f "%t%s" + (if empty then + Pp.empty + else + Utils.print_agent_sep_comma symbol_table) + symbol_table.Symbol_table.ghost_agent + in + aux false t + ) else + aux false t + else ( let () = - Format.fprintf f "%t%s" - (if empty - then Pp.empty + Format.fprintf f "%t%a" + (if empty then + Pp.empty else Utils.print_agent_sep_comma symbol_table) - symbol_table.Symbol_table.ghost_agent + (print_agent_rhs ~ltypes sigs symbol_table) + h in aux false t - else aux false t - else - let () = Format.fprintf f "%t%a" - (if empty - then Pp.empty - else Utils.print_agent_sep_comma symbol_table) - (print_agent_rhs ~ltypes sigs symbol_table) h in - aux false t in - aux true mix - -let print_rates ~noCounters sigs ?symbol_table pr_tok pr_var f r = - let ltypes = false in - Format.fprintf - f " @@ %a%t" - (Alg_expr.print - (fun f m -> Format.fprintf f "|%a|" - (print_rule_mixture ~noCounters sigs ?symbol_table ~ltypes []) m) - pr_tok pr_var) (fst r.LKappa.r_rate) - (fun f -> - match r.LKappa.r_un_rate with - | None -> () - | Some ((ra,_),max_dist) -> - Format.fprintf - f " {%a%a}" - (Alg_expr.print - (fun f m -> Format.fprintf f "|%a|" - (print_rule_mixture ~noCounters sigs ?symbol_table ~ltypes []) - m) - pr_tok pr_var) ra - (Pp.option - (fun f (md,_) -> + ) + in + aux true mix + + let print_rates ~noCounters sigs ?symbol_table pr_tok pr_var f r = + let ltypes = false in + Format.fprintf f " @@ %a%t" + (Alg_expr.print + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ?symbol_table ~ltypes []) + m) + pr_tok pr_var) + (fst r.LKappa.r_rate) + (fun f -> + match r.LKappa.r_un_rate with + | None -> () + | Some ((ra, _), max_dist) -> + Format.fprintf f " {%a%a}" + (Alg_expr.print + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ?symbol_table ~ltypes []) + m) + pr_tok pr_var) + ra + (Pp.option (fun f (md, _) -> Format.fprintf f ":%a" (Alg_expr.print - (fun f m -> Format.fprintf f "|%a|" - (print_rule_mixture - ~noCounters sigs ?symbol_table ~ltypes []) m) - pr_tok pr_var) md)) max_dist) - - -let print_rule ~noCounters ~full sigs - ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) - pr_tok pr_var f r = - Format.fprintf - f "@[%t%t%a%t@]" - (fun f -> - if full || r.LKappa.r_editStyle then - Format.fprintf f "%a%t%a" - (print_rule_mixture - ~noCounters sigs ~ltypes:false ~symbol_table r.LKappa.r_created) - r.LKappa.r_mix - (fun f -> if r.LKappa.r_mix <> [] && r.LKappa.r_created <> [] then + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ?symbol_table + ~ltypes []) + m) + pr_tok pr_var) + md)) + max_dist) + + let print_rule ~noCounters ~full sigs + ?(symbol_table = Symbol_table.symbol_table_V4) pr_tok pr_var f r = + Format.fprintf f "@[%t%t%a%t@]" + (fun f -> + if full || r.LKappa.r_edit_style then + Format.fprintf f "%a%t%a" + (print_rule_mixture ~noCounters sigs ~ltypes:false ~symbol_table + r.LKappa.r_created) + r.LKappa.r_mix + (fun f -> + if r.LKappa.r_mix <> [] && r.LKappa.r_created <> [] then + (Utils.print_agent_sep_comma symbol_table) f) + (Raw_mixture.print ~noCounters ~created:true ~sigs ~symbol_table) + r.LKappa.r_created + else + Format.fprintf f "%a%t%a -> %a" + (Pp.list (Utils.print_agent_sep_comma symbol_table) - f) - (Raw_mixture.print ~noCounters ~created:true ~sigs ~symbol_table) - r.LKappa.r_created - else Format.fprintf f "%a%t%a -> %a" - (Pp.list (Utils.print_agent_sep_comma symbol_table) - (print_agent_lhs ~ltypes:false sigs symbol_table)) r.LKappa.r_mix - (fun f -> if r.LKappa.r_mix <> [] && r.LKappa.r_created <> [] then (Utils.print_agent_sep_comma symbol_table) f) - (if symbol_table.Symbol_table.show_ghost - then - Pp.list (Utils.print_agent_sep_comma symbol_table) - (fun f _ -> Format.pp_print_string f symbol_table.Symbol_table.ghost_agent) - else (fun f _ -> Pp.empty f)) - r.LKappa.r_created - (print_rhs - ~noCounters ~ltypes:false sigs symbol_table r.LKappa.r_created) - r.LKappa.r_mix) - (fun f -> - match r.LKappa.r_delta_tokens with [] -> () - | _::_ -> Format.pp_print_string f " | ") - (Pp.list - Pp.comma - (fun f ((nb,_),tk) -> - Format.fprintf - f "%a %a" - (Alg_expr.print - (fun f m -> Format.fprintf - f "|%a|" - (print_rule_mixture - ~noCounters sigs ~symbol_table ~ltypes:false []) m) - pr_tok pr_var) nb - pr_tok tk)) - r.LKappa.r_delta_tokens - (fun f -> - if full then print_rates ~noCounters sigs ~symbol_table pr_tok pr_var f r) + (print_agent_lhs ~ltypes:false sigs symbol_table)) + r.LKappa.r_mix + (fun f -> + if r.LKappa.r_mix <> [] && r.LKappa.r_created <> [] then + (Utils.print_agent_sep_comma symbol_table) f) + (if symbol_table.Symbol_table.show_ghost then + Pp.list (Utils.print_agent_sep_comma symbol_table) (fun f _ -> + Format.pp_print_string f + symbol_table.Symbol_table.ghost_agent) + else + fun f _ -> + Pp.empty f) + r.LKappa.r_created + (print_rhs ~noCounters ~ltypes:false sigs symbol_table + r.LKappa.r_created) + r.LKappa.r_mix) + (fun f -> + match r.LKappa.r_delta_tokens with + | [] -> () + | _ :: _ -> Format.pp_print_string f " | ") + (Pp.list Pp.comma (fun f ((nb, _), tk) -> + Format.fprintf f "%a %a" + (Alg_expr.print + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ~symbol_table + ~ltypes:false []) + m) + pr_tok pr_var) + nb pr_tok tk)) + r.LKappa.r_delta_tokens + (fun f -> + if full then + print_rates ~noCounters sigs ~symbol_table pr_tok pr_var f r) end - module Kappa_printer = struct let cc_mix ~noCounters ?env ?symbol_table = - let domain = match env with + let domain = + match env with | None -> None - | Some e -> Some (Model.domain e) in + | Some e -> Some (Model.domain e) + in Pp.list (fun f -> Format.fprintf f " +@ ") (fun f ccs -> - Pp.array - (fun f -> Format.fprintf f "*") - (fun _ f cc -> - Format.fprintf - f "|%a|" - (Pattern.print ~noCounters ?domain ~with_id:false ?symbol_table) - cc) - f ccs) + Pp.array + (fun f -> Format.fprintf f "*") + (fun _ f cc -> + Format.fprintf f "|%a|" + (Pattern.print ~noCounters ?domain ~with_id:false ?symbol_table) + cc) + f ccs) let alg_expr ~noCounters ?env ?symbol_table = Alg_expr.print (cc_mix ~noCounters ?env ?symbol_table) - (Model.print_token ?env) - (Model.print_alg ?env) + (Model.print_token ?env) (Model.print_alg ?env) - let decompiled_rule - ~noCounters ~full ?symbol_table:(symbol_table=Symbol_table.symbol_table_V4) env f r = + let decompiled_rule ~noCounters ~full + ?(symbol_table = Symbol_table.symbol_table_V4) env f r = let sigs = Model.signatures env in - let (r_mix,r_created) = - Pattern_compiler.lkappa_of_elementary_rule sigs (Model.domain env) r in - let pr_alg f (a,_) = alg_expr ~noCounters ~env ~symbol_table f a in - let pr_tok f (va,tok) = - Format.fprintf f "%a %a" pr_alg va (Model.print_token ~env) tok in + let r_mix, r_created = + Pattern_compiler.lkappa_of_elementary_rule sigs (Model.domain env) r + in + let pr_alg f (a, _) = alg_expr ~noCounters ~env ~symbol_table f a in + let pr_tok f (va, tok) = + Format.fprintf f "%a %a" pr_alg va (Model.print_token ~env) tok + in Format.fprintf f "%a%t%a%t%a%t" - (LKappa.print_rule_mixture - ~noCounters sigs ~symbol_table ~ltypes:false r_created) r_mix + (LKappa.print_rule_mixture ~noCounters sigs ~symbol_table ~ltypes:false + r_created) + r_mix (if r_mix <> [] && r_created <> [] then - (fun fmt -> Utils.print_agent_sep_dot symbol_table fmt) - else Pp.empty) + fun fmt -> + Utils.print_agent_sep_dot symbol_table fmt + else + Pp.empty) (Raw_mixture.print ~noCounters ~created:true ~sigs ~symbol_table) r_created - - (if r.Primitives.delta_tokens <> [] - then (fun f -> Format.fprintf f "|@ ") else Pp.empty) + (if r.Primitives.delta_tokens <> [] then + fun f -> + Format.fprintf f "|@ " + else + Pp.empty) (Pp.list Pp.comma pr_tok) r.Primitives.delta_tokens - (fun f -> if full then - Format.fprintf f " @@@ %a%t" - pr_alg r.Primitives.rate - (fun f -> - match r.Primitives.unary_rate with - | None -> () - | Some (rate, dist) -> - Format.fprintf - f " {%a%a}" pr_alg rate - (Pp.option (fun f md -> - Format.fprintf - f ":%a" (alg_expr ~noCounters ~env ~symbol_table) md)) - dist)) + (fun f -> + if full then + Format.fprintf f " @@@ %a%t" pr_alg r.Primitives.rate (fun f -> + match r.Primitives.unary_rate with + | None -> () + | Some (rate, dist) -> + Format.fprintf f " {%a%a}" pr_alg rate + (Pp.option (fun f md -> + Format.fprintf f ":%a" + (alg_expr ~noCounters ~env ~symbol_table) + md)) + dist)) let elementary_rule ~noCounters ?env ?symbol_table f r = - let domain,sigs = match env with - | None -> None,None - | Some e -> Some (Model.domain e), Some (Model.signatures e) in - let pr_alg f (a,_) = alg_expr ~noCounters ?env ?symbol_table f a in - let pr_tok f (va,tok) = - Format.fprintf f "%a %a" pr_alg va (Model.print_token ?env) tok in + let domain, sigs = + match env with + | None -> None, None + | Some e -> Some (Model.domain e), Some (Model.signatures e) + in + let pr_alg f (a, _) = alg_expr ~noCounters ?env ?symbol_table f a in + let pr_tok f (va, tok) = + Format.fprintf f "%a %a" pr_alg va (Model.print_token ?env) tok + in let pr_trans f t = Primitives.Transformation.print ?sigs f t in let boxed_cc i f cc = let () = Format.pp_open_box f 2 in let () = Format.pp_print_int f i in let () = Format.pp_print_string f ": " in let () = - Pattern.print ~noCounters ?domain ~with_id:true ?symbol_table f cc in + Pattern.print ~noCounters ?domain ~with_id:true ?symbol_table f cc + in Format.pp_close_box f () in - Format.fprintf - f "(ast: %i)@ @[@[%a@]%t@[%a@]@]@ -- @[%a@]@ ++ @[%a@]@ @@%a%t" + Format.fprintf f + "(ast: %i)@ @[@[%a@]%t@[%a@]@]@ -- @[%a@]@ ++ @[%a@]@ @@%a%t" r.Primitives.syntactic_rule - - (Pp.array Pp.comma boxed_cc) r.Primitives.connected_components - (if r.Primitives.delta_tokens <> [] - then (fun f -> Format.fprintf f "|@ ") else Pp.empty) - (Pp.list Pp.comma pr_tok) - r.Primitives.delta_tokens - - (Pp.list Pp.comma pr_trans) r.Primitives.removed - (Pp.list Pp.comma pr_trans) r.Primitives.inserted - - pr_alg r.Primitives.rate + (Pp.array Pp.comma boxed_cc) + r.Primitives.connected_components + (if r.Primitives.delta_tokens <> [] then + fun f -> + Format.fprintf f "|@ " + else + Pp.empty) + (Pp.list Pp.comma pr_tok) r.Primitives.delta_tokens + (Pp.list Pp.comma pr_trans) + r.Primitives.removed + (Pp.list Pp.comma pr_trans) + r.Primitives.inserted pr_alg r.Primitives.rate (fun f -> - match r.Primitives.unary_rate with - | None -> () - | Some (rate, dist) -> - Format.fprintf - f " {%a%a}" pr_alg rate - (Pp.option (fun f md -> - Format.fprintf f ":%a" - (alg_expr ~noCounters ?env ?symbol_table) md)) - dist) - - - end + match r.Primitives.unary_rate with + | None -> () + | Some (rate, dist) -> + Format.fprintf f " {%a%a}" pr_alg rate + (Pp.option (fun f md -> + Format.fprintf f ":%a" + (alg_expr ~noCounters ?env ?symbol_table) + md)) + dist) +end -module Model = -struct +module Model = struct let print_ast_rule ~noCounters ?env ?symbol_table f i = match env with | None -> Format.fprintf f "__ast_rule_%i" i | Some env -> let sigs = Model.signatures env in - if i = 0 then Format.pp_print_string f "Interventions" - else - match - Model.get_ast_rule_with_label env i - with - | (Some (na,_),_) -> Format.pp_print_string f na - | (None,(r,_)) -> - LKappa.print_rule - ~noCounters ~full:false sigs ?symbol_table + if i = 0 then + Format.pp_print_string f "Interventions" + else ( + match Model.get_ast_rule_with_label env i with + | Some (na, _), _ -> Format.pp_print_string f na + | None, (r, _) -> + LKappa.print_rule ~noCounters ~full:false sigs ?symbol_table (Model.print_token ~env) (Model.print_alg ~env) f r - + ) end diff --git a/core/symmetries/kade_backend.mli b/core/symmetries/kade_backend.mli index a6253627a0..faf5cea3ad 100644 --- a/core/symmetries/kade_backend.mli +++ b/core/symmetries/kade_backend.mli @@ -1,56 +1,74 @@ -module Utils: -sig - - val print_binding_type: +module Utils : sig + val print_binding_type : Symbol_table.symbol_table -> (int -> Format.formatter -> int -> unit) -> (Format.formatter -> int -> unit) -> - int -> Format.formatter -> int -> unit + int -> + Format.formatter -> + int -> + unit - val print_agent_sep_plus: + val print_agent_sep_plus : Symbol_table.symbol_table -> Format.formatter -> unit - end -module Pattern: -sig +module Pattern : sig type id = Pattern.id - val print_cc: - ?full_species:bool -> ?sigs:Signature.s -> ?cc_id:Pattern.id -> - noCounters:bool -> with_id:bool -> + + val print_cc : + ?full_species:bool -> + ?sigs:Signature.s -> + ?cc_id:Pattern.id -> + noCounters:bool -> + with_id:bool -> ?symbol_table:Symbol_table.symbol_table -> - Format.formatter -> Pattern.cc -> unit + Format.formatter -> + Pattern.cc -> + unit - val print: + val print : ?domain:Pattern.Env.t -> noCounters:bool -> with_id:bool -> ?symbol_table:Symbol_table.symbol_table -> - Format.formatter -> Pattern.id -> unit + Format.formatter -> + Pattern.id -> + unit end -module Kappa_printer: -sig - val alg_expr: - noCounters:bool -> ?env:Model.t -> +module Kappa_printer : sig + val alg_expr : + noCounters:bool -> + ?env:Model.t -> ?symbol_table:Symbol_table.symbol_table -> - Format.formatter -> (Pattern.id array list, int) Alg_expr.e -> unit + Format.formatter -> + (Pattern.id array list, int) Alg_expr.e -> + unit - val decompiled_rule: - noCounters:bool -> full:bool -> + val decompiled_rule : + noCounters:bool -> + full:bool -> ?symbol_table:Symbol_table.symbol_table -> - Model.t -> Format.formatter -> Primitives.elementary_rule -> unit + Model.t -> + Format.formatter -> + Primitives.elementary_rule -> + unit - val elementary_rule: - noCounters:bool -> ?env:Model.t -> + val elementary_rule : + noCounters:bool -> + ?env:Model.t -> ?symbol_table:Symbol_table.symbol_table -> - Format.formatter -> Primitives.elementary_rule -> unit - end + Format.formatter -> + Primitives.elementary_rule -> + unit +end -module Model: -sig - val print_ast_rule: - noCounters:bool -> ?env:Model.t -> +module Model : sig + val print_ast_rule : + noCounters:bool -> + ?env:Model.t -> ?symbol_table:Symbol_table.symbol_table -> - Format.formatter -> int -> unit + Format.formatter -> + int -> + unit end diff --git a/core/symmetries/lKappa_auto.ml b/core/symmetries/lKappa_auto.ml index 48d10848bd..244a5c034c 100644 --- a/core/symmetries/lKappa_auto.ml +++ b/core/symmetries/lKappa_auto.ml @@ -8,107 +8,106 @@ type binding_id = Lhs of int | Rhs of int | Copy_lhs of int -module Binding_id = -struct +module Binding_id = struct type t = binding_id + let compare = compare - let print log = - function + + let print log = function | Lhs i -> Format.fprintf log "LHS(%i)" i | Rhs i -> Format.fprintf log "RHS(%i)" i - | Copy_lhs i -> Format.fprintf log "RHS(%i')" i + | Copy_lhs i -> Format.fprintf log "RHS(%i')" i end module Binding_idSetMap = SetMap.Make (Binding_id) - module Binding_idMap = Binding_idSetMap.Map -module Binding_states = -struct - type t = int * ((int, unit) LKappa.link) +module Binding_states = struct + type t = int * (int, unit) LKappa.link + let compare = compare - let print log (a,b) = + + let print log (a, b) = Format.fprintf log "%i:[%a]" a - (fun log -> - LKappa.print_link - (fun _ f x -> Format.pp_print_int f x) - (fun f x -> Format.pp_print_int f x) - (fun _ () -> ()) log) + (fun log -> + LKappa.print_link + (fun _ f x -> Format.pp_print_int f x) + (fun f x -> Format.pp_print_int f x) + (fun _ () -> ()) + log) b end -module BindingCache = Hashed_list.Make(Binding_states) +module BindingCache = Hashed_list.Make (Binding_states) -module Int2 = -struct +module Int2 = struct type t = int * int + let compare = compare - let print log (a,b) = Format.fprintf log "(%i,%i)" a b + let print log (a, b) = Format.fprintf log "(%i,%i)" a b end -module PropertiesCache = Hashed_list.Make(Int2) +module PropertiesCache = Hashed_list.Make (Int2) type cannonic_node = | Regular of int * PropertiesCache.hashed_list * BindingCache.hashed_list | Back_to of int -module Node = -struct +module Node = struct type t = cannonic_node + let compare = compare - let print log = - function - | Regular (i,a,b) -> Format.fprintf log "Regular (%i,%a,%a);" i - PropertiesCache.print a BindingCache.print b + + let print log = function + | Regular (i, a, b) -> + Format.fprintf log "Regular (%i,%a,%a);" i PropertiesCache.print a + BindingCache.print b | Back_to i -> Format.fprintf log "Back_to(%i);" i end -module CannonicCache = Hashed_list.Make(Node) +module CannonicCache = Hashed_list.Make (Node) + +module CannonicSet_and_map = SetMap.Make (struct + type t = CannonicCache.hashed_list -module CannonicSet_and_map = - SetMap.Make - (struct - type t = CannonicCache.hashed_list - let compare = CannonicCache.compare - let print _ _ = () - end) + let compare = CannonicCache.compare + let print _ _ = () +end) module CannonicMap = CannonicSet_and_map.Map -module PairInt = -struct - type t = (CannonicMap.elt * int) +module PairInt = struct + type t = CannonicMap.elt * int + let compare = compare - let print _ _ = () + let print _ _ = () end -module RuleCache = Hashed_list.Make(PairInt) +module RuleCache = Hashed_list.Make (PairInt) -type cache = - { - internal_state_cache: PropertiesCache.cache ; - binding_state_cache: BindingCache.cache ; - cannonic_cache: CannonicCache.cache; - rule_cache : RuleCache.cache - } +type cache = { + internal_state_cache: PropertiesCache.cache; + binding_state_cache: BindingCache.cache; + cannonic_cache: CannonicCache.cache; + rule_cache: RuleCache.cache; +} let init_cache () = { - internal_state_cache = PropertiesCache.init () ; - binding_state_cache = BindingCache.init () ; + internal_state_cache = PropertiesCache.init (); + binding_state_cache = BindingCache.init (); cannonic_cache = CannonicCache.init (); - rule_cache = RuleCache.init () + rule_cache = RuleCache.init (); } (* id gets rid of location annotation *) -let id = - function - | LKappa.LNK_VALUE (i,_) -> LKappa.LNK_VALUE (i,()) +let id = function + | LKappa.LNK_VALUE (i, _) -> LKappa.LNK_VALUE (i, ()) | LKappa.LNK_FREE -> LKappa.LNK_FREE | LKappa.ANY_FREE -> LKappa.ANY_FREE | LKappa.LNK_ANY -> LKappa.LNK_ANY | LKappa.LNK_SOME -> LKappa.LNK_SOME - | LKappa.LNK_TYPE (a,b) -> LKappa.LNK_TYPE (a,b) + | LKappa.LNK_TYPE (a, b) -> LKappa.LNK_TYPE (a, b) (* This function translate a mixture into an array of views and a function mapping each binding site to its partner *) @@ -120,30 +119,32 @@ let id = (* If the rhs is taken into account, deleted agents have a special site (-1) with internal state 0 *) (* The state of this site shall be preserved by autos *) -let translate rate_convention cache rule = +let translate rate_convention cache rule = let lkappa_mixture = rule.LKappa.r_mix in let ag_created = rule.LKappa.r_created in let add_map rate_convention i j map = - match rate_convention, i with - | Remanent_parameters_sig.Common,_ - | (Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs | - Remanent_parameters_sig.No_correction) , Lhs _ - | Remanent_parameters_sig.Biochemist, _ -> - Binding_idMap.add - i (j::(Binding_idMap.find_default [] i map)) map - | (Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs | - Remanent_parameters_sig.No_correction), - (Rhs _ | Copy_lhs _) -> map + match rate_convention, i with + | Remanent_parameters_sig.Common, _ + | ( ( Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs + | Remanent_parameters_sig.No_correction ), + Lhs _ ) + | Remanent_parameters_sig.Biochemist, _ -> + Binding_idMap.add i (j :: Binding_idMap.find_default [] i map) map + | ( ( Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs + | Remanent_parameters_sig.No_correction ), + (Rhs _ | Copy_lhs _) ) -> + map in let ag_created = match rate_convention with | Remanent_parameters_sig.No_correction - | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> [] - | Remanent_parameters_sig.Common - | Remanent_parameters_sig.Biochemist -> ag_created + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + [] + | Remanent_parameters_sig.Common | Remanent_parameters_sig.Biochemist -> + ag_created in let n_agents_wo_creation = List.length lkappa_mixture in - let n_agents = n_agents_wo_creation + (List.length ag_created) in + let n_agents = n_agents_wo_creation + List.length ag_created in let array_name = Array.make n_agents 0 in let state_of_internal x = match x with @@ -153,234 +154,221 @@ let translate rate_convention cache rule = | LKappa.I_VAL_CHANGED (state, state') -> Some state, Some state' | LKappa.I_VAL_ERASED state -> Some state, None in - let intermediary = + let intermediary = List.fold_left (fun (map, agent_id) agent -> - let () = array_name.(agent_id) <- agent.LKappa.ra_type in - let n_site = Array.length agent.LKappa.ra_ports in - let map, _ = - Array.fold_left - (fun (map, site_id) ((state,_),switch) -> - match state, switch with - | LKappa.LNK_VALUE (i,_), LKappa.Maintained -> - add_map rate_convention - (Copy_lhs i) (agent_id, site_id+n_site) + let () = array_name.(agent_id) <- agent.LKappa.ra_type in + let n_site = Array.length agent.LKappa.ra_ports in + let map, _ = + Array.fold_left + (fun (map, site_id) ((state, _), switch) -> + match state, switch with + | LKappa.LNK_VALUE (i, _), LKappa.Maintained -> + ( add_map rate_convention (Copy_lhs i) + (agent_id, site_id + n_site) + (add_map rate_convention (Lhs i) (agent_id, site_id) map), + site_id + 1 ) + | LKappa.LNK_VALUE (i, _), LKappa.Linked j -> + ( add_map rate_convention (Rhs j) + (agent_id, site_id + n_site) (add_map rate_convention (Lhs i) (agent_id, site_id) map), - site_id + 1 - | LKappa.LNK_VALUE (i,_), LKappa.Linked j -> - add_map rate_convention (Rhs j) (agent_id,site_id+n_site) - (add_map rate_convention (Lhs i) (agent_id, site_id) map), site_id + 1 - | LKappa.LNK_VALUE (i,_), _ -> - add_map rate_convention (Lhs i) (agent_id, site_id) map, site_id + 1 - | _, LKappa.Linked j -> - add_map rate_convention (Rhs j) (agent_id, site_id+n_site) map, site_id + 1 - | (LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_SOME | - LKappa.LNK_ANY | LKappa.LNK_TYPE _), - (LKappa.Maintained | LKappa.Freed | LKappa.Erased ) -> map, site_id+1 - - ) - (map, 0) - agent.LKappa.ra_ports - in - (map, agent_id + 1)) - (Binding_idMap.empty,0) - lkappa_mixture + site_id + 1 ) + | LKappa.LNK_VALUE (i, _), _ -> + ( add_map rate_convention (Lhs i) (agent_id, site_id) map, + site_id + 1 ) + | _, LKappa.Linked j -> + ( add_map rate_convention (Rhs j) + (agent_id, site_id + n_site) + map, + site_id + 1 ) + | ( ( LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_SOME + | LKappa.LNK_ANY | LKappa.LNK_TYPE _ ), + (LKappa.Maintained | LKappa.Freed | LKappa.Erased) ) -> + map, site_id + 1) + (map, 0) agent.LKappa.ra_ports + in + map, agent_id + 1) + (Binding_idMap.empty, 0) lkappa_mixture in let scan_bonds_identifier, _ = List.fold_left (fun (map, agent_id) agent -> - let () = array_name.(agent_id) <- agent.Raw_mixture.a_type in - let n_site = Array.length agent.Raw_mixture.a_ports in - let map, _ = - Array.fold_left - (fun (map, site_id) state -> - match state with - | Raw_mixture.VAL i -> - add_map rate_convention (Rhs i) (agent_id,site_id+n_site) map, - site_id + 1 - | Raw_mixture.FREE -> - map, site_id +1) - (map, 0) - agent.Raw_mixture.a_ports - in - (map, agent_id + 1)) - intermediary - ag_created + let () = array_name.(agent_id) <- agent.Raw_mixture.a_type in + let n_site = Array.length agent.Raw_mixture.a_ports in + let map, _ = + Array.fold_left + (fun (map, site_id) state -> + match state with + | Raw_mixture.VAL i -> + ( add_map rate_convention (Rhs i) + (agent_id, site_id + n_site) + map, + site_id + 1 ) + | Raw_mixture.FREE -> map, site_id + 1) + (map, 0) agent.Raw_mixture.a_ports + in + map, agent_id + 1) + intermediary ag_created in let bonds_map = Binding_idMap.fold (fun _ list map -> - match list - with - | [a,b;c,d] -> - Mods.Int2Map.add (a,b) (c,d) - (Mods.Int2Map.add (c,d) (a,b) map) - | [] | _::_ -> assert false ) - scan_bonds_identifier - Mods.Int2Map.empty + match list with + | [ (a, b); (c, d) ] -> + Mods.Int2Map.add (a, b) (c, d) (Mods.Int2Map.add (c, d) (a, b) map) + | [] | _ :: _ -> assert false) + scan_bonds_identifier Mods.Int2Map.empty in let translate_agent rate_convention cache array_name agent_id agent = let agent_name = agent.LKappa.ra_type in let n_sites = Array.length agent.LKappa.ra_ports in - let rule_internal,_ = (* regular sites *) + let rule_internal, _ = + (* regular sites *) Array.fold_left - (fun (list,site_id) state -> - let fst_opt,snd_opt = state_of_internal state in - let list = - match fst_opt with - | None -> list - | Some x -> (site_id,x)::list - in - let list = - match rate_convention, snd_opt with - | (Remanent_parameters_sig.No_correction | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs) , _ - | _ , None -> list - | (Remanent_parameters_sig.Biochemist | Remanent_parameters_sig.Common) , Some x -> (site_id + n_sites,x)::list - in - list, site_id+1) - ([],0) agent.LKappa.ra_ints + (fun (list, site_id) state -> + let fst_opt, snd_opt = state_of_internal state in + let list = + match fst_opt with + | None -> list + | Some x -> (site_id, x) :: list + in + let list = + match rate_convention, snd_opt with + | ( ( Remanent_parameters_sig.No_correction + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs ), + _ ) + | _, None -> + list + | ( ( Remanent_parameters_sig.Biochemist + | Remanent_parameters_sig.Common ), + Some x ) -> + (site_id + n_sites, x) :: list + in + list, site_id + 1) + ([], 0) agent.LKappa.ra_ints in - let rule_internal = (* Here we add the fictitious site for the agents that are degraded *) + let rule_internal = + (* Here we add the fictitious site for the agents that are degraded *) match rate_convention with | Remanent_parameters_sig.No_correction - | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> rule_internal - | Remanent_parameters_sig.Common - | Remanent_parameters_sig.Biochemist -> + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + rule_internal + | Remanent_parameters_sig.Common | Remanent_parameters_sig.Biochemist -> if agent.LKappa.ra_erased then - (-1,0)::rule_internal - else rule_internal + (-1, 0) :: rule_internal + else + rule_internal in - let rule_port,interface,_ = + let rule_port, interface, _ = Array.fold_left - (fun (list, interface, site_id) ((port,_),switch) -> - let list, interface = - match port with - | LKappa.LNK_VALUE _ -> - let ag_partner, site_partner = - match - Mods.Int2Map.find_option (agent_id, site_id) bonds_map - with - | None -> - assert false - | Some x -> x - in - let ag_partner = array_name.(ag_partner) in - (site_id, - LKappa.LNK_TYPE - (site_partner, - ag_partner)) - ::list, - Mods.IntSet.add site_id interface - | LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_ANY - | LKappa.LNK_SOME | LKappa.LNK_TYPE _ -> - (site_id,id port)::list, interface - in - let list, interface = - match rate_convention with - | Remanent_parameters_sig.No_correction | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> - list, interface - | Remanent_parameters_sig.Common | Remanent_parameters_sig.Biochemist -> - begin - match port, switch with - | _, LKappa.Linked _ -> - let site_id = site_id + n_sites in - let ag_partner, site_partner = - match - Mods.Int2Map.find_option (agent_id, site_id) bonds_map - with - | None -> assert false - | Some x -> x - in - let ag_partner = array_name.(ag_partner) in - (site_id, - LKappa.LNK_TYPE - (site_partner, - ag_partner)) - ::list, - Mods.IntSet.add site_id interface - | LKappa.LNK_VALUE _, LKappa.Maintained -> - let site_id = site_id + n_sites in - let ag_partner, site_partner = - match - Mods.Int2Map.find_option (agent_id, site_id) bonds_map - with - | None -> assert false - | Some x -> x - in - let ag_partner = array_name.(ag_partner) in - (site_id, - LKappa.LNK_TYPE - (site_partner, - ag_partner)) - ::list, - Mods.IntSet.add site_id interface - | (LKappa.LNK_VALUE _ | LKappa.LNK_FREE | LKappa.ANY_FREE - | LKappa.LNK_ANY | LKappa.LNK_SOME | LKappa.LNK_TYPE _), - (LKappa.Maintained | LKappa.Erased) -> list, interface - | _, LKappa.Freed -> - let site_id = site_id + n_sites in - (site_id,LKappa.LNK_FREE)::list, interface - end - in - list, interface, site_id + 1 - ) - ([],Mods.IntSet.empty,0) - agent.LKappa.ra_ports + (fun (list, interface, site_id) ((port, _), switch) -> + let list, interface = + match port with + | LKappa.LNK_VALUE _ -> + let ag_partner, site_partner = + match + Mods.Int2Map.find_option (agent_id, site_id) bonds_map + with + | None -> assert false + | Some x -> x + in + let ag_partner = array_name.(ag_partner) in + ( (site_id, LKappa.LNK_TYPE (site_partner, ag_partner)) :: list, + Mods.IntSet.add site_id interface ) + | LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_ANY + | LKappa.LNK_SOME | LKappa.LNK_TYPE _ -> + (site_id, id port) :: list, interface + in + let list, interface = + match rate_convention with + | Remanent_parameters_sig.No_correction + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + list, interface + | Remanent_parameters_sig.Common + | Remanent_parameters_sig.Biochemist -> + (match port, switch with + | _, LKappa.Linked _ -> + let site_id = site_id + n_sites in + let ag_partner, site_partner = + match + Mods.Int2Map.find_option (agent_id, site_id) bonds_map + with + | None -> assert false + | Some x -> x + in + let ag_partner = array_name.(ag_partner) in + ( (site_id, LKappa.LNK_TYPE (site_partner, ag_partner)) :: list, + Mods.IntSet.add site_id interface ) + | LKappa.LNK_VALUE _, LKappa.Maintained -> + let site_id = site_id + n_sites in + let ag_partner, site_partner = + match + Mods.Int2Map.find_option (agent_id, site_id) bonds_map + with + | None -> assert false + | Some x -> x + in + let ag_partner = array_name.(ag_partner) in + ( (site_id, LKappa.LNK_TYPE (site_partner, ag_partner)) :: list, + Mods.IntSet.add site_id interface ) + | ( ( LKappa.LNK_VALUE _ | LKappa.LNK_FREE | LKappa.ANY_FREE + | LKappa.LNK_ANY | LKappa.LNK_SOME | LKappa.LNK_TYPE _ ), + (LKappa.Maintained | LKappa.Erased) ) -> + list, interface + | _, LKappa.Freed -> + let site_id = site_id + n_sites in + (site_id, LKappa.LNK_FREE) :: list, interface) + in + list, interface, site_id + 1) + ([], Mods.IntSet.empty, 0) agent.LKappa.ra_ports in let cache_prop = cache.internal_state_cache in let cache_binding = cache.binding_state_cache in let cache_prop, rule_internal = PropertiesCache.hash cache_prop rule_internal in - let cache_binding, rule_port = - BindingCache.hash cache_binding rule_port - in - {cache - with internal_state_cache = cache_prop ; - binding_state_cache = cache_binding}, - (agent_name, rule_internal, rule_port, interface) + let cache_binding, rule_port = BindingCache.hash cache_binding rule_port in + ( { + cache with + internal_state_cache = cache_prop; + binding_state_cache = cache_binding; + }, + (agent_name, rule_internal, rule_port, interface) ) in let translate_created_agent cache array_name agent_id agent = let agent_name = agent.Raw_mixture.a_type in let n_sites = Array.length agent.Raw_mixture.a_ports in - let rule_internal,_ = + let rule_internal, _ = Array.fold_left - (fun (list,site_id) state -> - let list = - match state with - | None -> list - | Some x -> (site_id,x)::list - in - list, site_id+1) - ([],n_sites) agent.Raw_mixture.a_ints + (fun (list, site_id) state -> + let list = + match state with + | None -> list + | Some x -> (site_id, x) :: list + in + list, site_id + 1) + ([], n_sites) agent.Raw_mixture.a_ints in - let rule_port,interface,_ = + let rule_port, interface, _ = Array.fold_left (fun (list, interface, site_id) port -> - let list, interface = - match port with - | Raw_mixture.VAL _ -> - let ag_partner, site_partner = - match - Mods.Int2Map.find_option (agent_id, site_id) bonds_map - with - | None -> - assert false - | Some x -> x - in - let ag_partner = array_name.(ag_partner) in - (site_id, - LKappa.LNK_TYPE - (site_partner, - ag_partner)) - ::list, - Mods.IntSet.add site_id interface - | Raw_mixture.FREE -> - (site_id, LKappa.LNK_FREE)::list, interface - in - list, interface, site_id + 1 - ) - ([],Mods.IntSet.empty,n_sites) + let list, interface = + match port with + | Raw_mixture.VAL _ -> + let ag_partner, site_partner = + match + Mods.Int2Map.find_option (agent_id, site_id) bonds_map + with + | None -> assert false + | Some x -> x + in + let ag_partner = array_name.(ag_partner) in + ( (site_id, LKappa.LNK_TYPE (site_partner, ag_partner)) :: list, + Mods.IntSet.add site_id interface ) + | Raw_mixture.FREE -> (site_id, LKappa.LNK_FREE) :: list, interface + in + list, interface, site_id + 1) + ([], Mods.IntSet.empty, n_sites) agent.Raw_mixture.a_ports in let cache_prop = cache.internal_state_cache in @@ -388,35 +376,35 @@ let translate rate_convention cache rule = let cache_prop, rule_internal = PropertiesCache.hash cache_prop rule_internal in - let cache_binding, rule_port = - BindingCache.hash cache_binding rule_port - in - {cache - with internal_state_cache = cache_prop ; - binding_state_cache = cache_binding}, - (agent_name, rule_internal, rule_port, interface) + let cache_binding, rule_port = BindingCache.hash cache_binding rule_port in + ( { + cache with + internal_state_cache = cache_prop; + binding_state_cache = cache_binding; + }, + (agent_name, rule_internal, rule_port, interface) ) in let array = Array.make n_agents - (0,PropertiesCache.empty,BindingCache.empty,Mods.IntSet.empty) + (0, PropertiesCache.empty, BindingCache.empty, Mods.IntSet.empty) in let intermediary = List.fold_left (fun (cache, ag_id) agent -> - let cache, ag = translate_agent rate_convention cache array_name ag_id agent in - let () = array.(ag_id)<-ag in - cache, ag_id+1) - (cache, 0) - lkappa_mixture + let cache, ag = + translate_agent rate_convention cache array_name ag_id agent + in + let () = array.(ag_id) <- ag in + cache, ag_id + 1) + (cache, 0) lkappa_mixture in let cache, _ = List.fold_left (fun (cache, ag_id) agent -> - let cache, ag = translate_created_agent cache array_name ag_id agent in - let () = array.(ag_id)<-ag in - cache, ag_id+1) - intermediary - ag_created + let cache, ag = translate_created_agent cache array_name ag_id agent in + let () = array.(ag_id) <- ag in + cache, ag_id + 1) + intermediary ag_created in cache, array, bonds_map @@ -427,45 +415,41 @@ let extract_cc n bonds_map array ag_id = let rec aux to_visit acc = match to_visit with | [] -> acc - | head::tail when seen.(head) -> aux tail acc - | head::tail -> - let _,_,_,intf = array.(head) in + | head :: tail when seen.(head) -> aux tail acc + | head :: tail -> + let _, _, _, intf = array.(head) in let () = seen.(head) <- true in let to_visit = Mods.IntSet.fold (fun site_id to_visit -> - match - Mods.Int2Map.find_option (head,site_id) bonds_map - with - | None -> assert false - | Some (a,_) -> a::to_visit) - intf - tail + match Mods.Int2Map.find_option (head, site_id) bonds_map with + | None -> assert false + | Some (a, _) -> a :: to_visit) + intf tail in - aux to_visit (head::acc) + aux to_visit (head :: acc) in - aux [ag_id] [] + aux [ ag_id ] [] (* the following function decompose the mixture in cc *) let decompose bonds_map array = let n = Array.length array in let rec aux k set = - if k = n then set - else aux (k+1) (Mods.IntSet.add k set) + if k = n then + set + else + aux (k + 1) (Mods.IntSet.add k set) in let set = aux 0 Mods.IntSet.empty in let rec aux set acc = - match Mods.IntSet.min_elt set - with + match Mods.IntSet.min_elt set with | None -> acc | Some min_elt -> let cc = extract_cc n bonds_map array min_elt in let set = - List.fold_left - (fun set elt -> Mods.IntSet.remove elt set) - set cc + List.fold_left (fun set elt -> Mods.IntSet.remove elt set) set cc in - aux set (cc::acc) + aux set (cc :: acc) in aux set [] @@ -475,179 +459,139 @@ let decompose bonds_map array = the position of the node in the list is given *) let cannonical_of_root bonds_map array ag_id = - let rec aux node_id stack (acc: 'a list) port_seen agent_seen = - match stack - with + let rec aux node_id stack (acc : 'a list) port_seen agent_seen = + match stack with | [] -> acc - | (ag_id,intf)::tail -> - begin - (* we currently explore agent ag_id *) - (* the sites in intf not in port_seen remain to be explored *) - match - Mods.IntSet.min_elt intf - with + | (ag_id, intf) :: tail -> + (* we currently explore agent ag_id *) + (* the sites in intf not in port_seen remain to be explored *) + (match Mods.IntSet.min_elt intf with + | None -> + (* we are done with this agent *) + (* we pop up the stack *) + aux node_id tail acc port_seen agent_seen + | Some s when Mods.Int2Set.mem (ag_id, s) port_seen -> + (* next site, has been seen in a cycle *) + (* we ignore it *) + aux node_id + ((ag_id, Mods.IntSet.remove s intf) :: tail) + acc port_seen agent_seen + | Some s -> + (* s is the next unvisited site *) + (* we remove s from the stack *) + let stack = (ag_id, Mods.IntSet.remove s intf) :: tail in + (match Mods.Int2Map.find_option (ag_id, s) bonds_map with | None -> - (* we are done with this agent *) - (* we pop up the stack *) - aux node_id tail acc port_seen agent_seen - | Some s when Mods.Int2Set.mem (ag_id,s) port_seen - -> - (* next site, has been seen in a cycle *) - (* we ignore it *) - aux - node_id - ((ag_id,Mods.IntSet.remove s intf)::tail) - acc - port_seen agent_seen - | Some s -> - (* s is the next unvisited site *) - (* we remove s from the stack *) - let stack = (ag_id, Mods.IntSet.remove s intf)::tail in - begin - match - Mods.Int2Map.find_option (ag_id, s) bonds_map - with None -> - (* pointers shall not be null *) - let _ = assert false in - [] - | Some (ag_id',s') -> - begin - match - Mods.IntMap.find_option ag_id' agent_seen - with - | None -> - (* this is the first time we see ag_id'*) - let agent_name,prop,binding,intf = - array.(ag_id') - in - let intf = Mods.IntSet.remove s' intf in - let agent_seen = - Mods.IntMap.add ag_id' node_id agent_seen - in - let stack = (ag_id',intf)::stack in - let acc = - Regular (agent_name,prop,binding) - :: acc - in - let node_id = node_id + 1 in - aux node_id stack acc port_seen agent_seen - | Some fst_pos -> - (* ag_id' has been seen at position fst_pos *) - let port_seen = - Mods.Int2Set.add (ag_id',s') port_seen - in - let acc = - Back_to fst_pos :: acc - in - let node_id = node_id + 1 in - aux node_id stack acc port_seen agent_seen - end - end - end + (* pointers shall not be null *) + let _ = assert false in + [] + | Some (ag_id', s') -> + (match Mods.IntMap.find_option ag_id' agent_seen with + | None -> + (* this is the first time we see ag_id'*) + let agent_name, prop, binding, intf = array.(ag_id') in + let intf = Mods.IntSet.remove s' intf in + let agent_seen = Mods.IntMap.add ag_id' node_id agent_seen in + let stack = (ag_id', intf) :: stack in + let acc = Regular (agent_name, prop, binding) :: acc in + let node_id = node_id + 1 in + aux node_id stack acc port_seen agent_seen + | Some fst_pos -> + (* ag_id' has been seen at position fst_pos *) + let port_seen = Mods.Int2Set.add (ag_id', s') port_seen in + let acc = Back_to fst_pos :: acc in + let node_id = node_id + 1 in + aux node_id stack acc port_seen agent_seen))) in - let agent_name,prop,binding,intf = array.(ag_id) in + let agent_name, prop, binding, intf = array.(ag_id) in aux 0 - [ag_id,intf] - [Regular (agent_name, prop, binding)] + [ ag_id, intf ] + [ Regular (agent_name, prop, binding) ] Mods.Int2Set.empty Mods.IntMap.empty (* when rhs of rules are taken into account *) (* The cc that contains created agents only shall be ignored *) let keep_this_cc rate_convention n_agents cc = match rate_convention with - | Remanent_parameters_sig.Biochemist -> - List.exists (fun i -> i true + | Remanent_parameters_sig.Biochemist -> List.exists (fun i -> i < n_agents) cc + | Remanent_parameters_sig.No_correction | Remanent_parameters_sig.Common + | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> + true let mixture_to_species_map rate_convention cache rule = let map = CannonicMap.empty in - let n_agents = List.length rule.LKappa.r_mix in - let cache, array, bonds_map = - translate rate_convention cache rule in + let n_agents = List.length rule.LKappa.r_mix in + let cache, array, bonds_map = translate rate_convention cache rule in let cc_list = decompose bonds_map array in let cannonic_cache, map = List.fold_left (fun (cache, map) cc -> - if keep_this_cc rate_convention n_agents cc - then - match cc with - | [] -> cache, map - | h::t -> - let _, occs = - List.fold_left - (fun (best,occs) i -> - let cmp = compare array.(i) best in - if cmp < 0 - then (array.(i),[i]) - else if cmp = 0 - then (best,i::occs) - else (best,occs)) - (array.(h),[h]) t - in - let occs = - List.rev_map - (cannonical_of_root bonds_map array) - occs - in - let cache, cannonic, nauto = - match occs with - | [] -> assert false - | h::t -> - let cache, hash = CannonicCache.hash cache h in - List.fold_left - (fun (cache, cannonic, nauto) list -> - let cache, hash = CannonicCache.hash cache list in - let cmp = compare cannonic hash in - if cmp < 0 - then cache, cannonic, nauto - else if cmp = 0 - then cache, cannonic, nauto+1 - else cache, hash, 1) - (cache, hash, 1) - t - in - match - CannonicMap.find_option cannonic map - with - | None -> cache, CannonicMap.add cannonic (1,nauto) map - | Some (occ, nauto') when nauto = nauto' -> - cache, CannonicMap.add cannonic (occ+1,nauto) map - | Some _ -> assert false - else cache, map) + if keep_this_cc rate_convention n_agents cc then ( + match cc with + | [] -> cache, map + | h :: t -> + let _, occs = + List.fold_left + (fun (best, occs) i -> + let cmp = compare array.(i) best in + if cmp < 0 then + array.(i), [ i ] + else if cmp = 0 then + best, i :: occs + else + best, occs) + (array.(h), [ h ]) + t + in + let occs = List.rev_map (cannonical_of_root bonds_map array) occs in + let cache, cannonic, nauto = + match occs with + | [] -> assert false + | h :: t -> + let cache, hash = CannonicCache.hash cache h in + List.fold_left + (fun (cache, cannonic, nauto) list -> + let cache, hash = CannonicCache.hash cache list in + let cmp = compare cannonic hash in + if cmp < 0 then + cache, cannonic, nauto + else if cmp = 0 then + cache, cannonic, nauto + 1 + else + cache, hash, 1) + (cache, hash, 1) t + in + (match CannonicMap.find_option cannonic map with + | None -> cache, CannonicMap.add cannonic (1, nauto) map + | Some (occ, nauto') when nauto = nauto' -> + cache, CannonicMap.add cannonic (occ + 1, nauto) map + | Some _ -> assert false) + ) else + cache, map) (cache.cannonic_cache, map) cc_list in - {cache with cannonic_cache = cannonic_cache}, - map + { cache with cannonic_cache }, map let nauto_kind nauto nocc = let rec aux k acc = - if k=0 then acc + if k = 0 then + acc else - aux (k-1) acc*k*nauto + aux (k - 1) acc * k * nauto in aux nocc 1 let nauto_of_map map = CannonicMap.fold - (fun _ (nocc,nauto) acc -> - acc * (nauto_kind nauto nocc)) - map - 1 + (fun _ (nocc, nauto) acc -> acc * nauto_kind nauto nocc) + map 1 let nauto rate_convention cache rule = - let cache, map = - mixture_to_species_map rate_convention cache rule - in + let cache, map = mixture_to_species_map rate_convention cache rule in cache, nauto_of_map map -let ncc_of_map map = - CannonicMap.fold - (fun _ (nocc,_) acc -> acc+nocc) - map - 0 +let ncc_of_map map = CannonicMap.fold (fun _ (nocc, _) acc -> acc + nocc) map 0 let cannonic_form cache rule = (*compute this map only in the case of Biochemist*) @@ -657,18 +601,12 @@ let cannonic_form cache rule = let pair_list = CannonicMap.fold (fun cannonic (nocc, _nauto) current_list -> - let pair_list = - (cannonic, nocc) :: current_list - in - pair_list - ) map [] - in - let rule_cache, hash = - RuleCache.hash cache.rule_cache pair_list + let pair_list = (cannonic, nocc) :: current_list in + pair_list) + map [] in - { - cache with rule_cache = rule_cache - }, hash + let rule_cache, hash = RuleCache.hash cache.rule_cache pair_list in + { cache with rule_cache }, hash let n_cc cache rule = let cache, map = diff --git a/core/symmetries/lKappa_auto.mli b/core/symmetries/lKappa_auto.mli index ed12e260fa..5d1c3f794a 100644 --- a/core/symmetries/lKappa_auto.mli +++ b/core/symmetries/lKappa_auto.mli @@ -9,21 +9,20 @@ type cache module CannonicCache : Hashed_list.Hash - module CannonicSet_and_map : SetMap.S with type elt = CannonicCache.hashed_list - module CannonicMap : SetMap.Map with type elt = CannonicCache.hashed_list - module RuleCache : Hashed_list.Hash -val init_cache: unit -> cache - -val mixture_to_species_map : Remanent_parameters_sig.rate_convention -> cache -> - LKappa.rule -> cache * (int * int) CannonicMap.t +val init_cache : unit -> cache -val nauto: Remanent_parameters_sig.rate_convention -> cache -> - LKappa.rule -> cache * int +val mixture_to_species_map : + Remanent_parameters_sig.rate_convention -> + cache -> + LKappa.rule -> + cache * (int * int) CannonicMap.t -val n_cc: cache -> LKappa.rule -> cache * int +val nauto : + Remanent_parameters_sig.rate_convention -> cache -> LKappa.rule -> cache * int -val cannonic_form: cache -> LKappa.rule -> cache * RuleCache.hashed_list +val n_cc : cache -> LKappa.rule -> cache * int +val cannonic_form : cache -> LKappa.rule -> cache * RuleCache.hashed_list diff --git a/core/symmetries/lKappa_group_action.ml b/core/symmetries/lKappa_group_action.ml index e914c82f3b..0b616d6171 100644 --- a/core/symmetries/lKappa_group_action.ml +++ b/core/symmetries/lKappa_group_action.ml @@ -15,60 +15,40 @@ let local_trace = false -let do_print ?trace ?fmt ?(sigs:Signature.s option) f = +let do_print ?trace ?fmt ?(sigs : Signature.s option) f = match (local_trace, trace), fmt, sigs with - | ((true, _ ) | (_, Some true)), Some fmt, Some sigs -> - f sigs fmt - | (false, (Some false | None)), _, _ - | _, None, _ - | _, _, None -> () + | (true, _ | _, Some true), Some fmt, Some sigs -> f sigs fmt + | (false, (Some false | None)), _, _ | _, None, _ | _, _, None -> () -let binding_equal ((a_t,_),a_m) ((b_t,_),b_m) = - a_t = b_t && a_m = b_m +let binding_equal ((a_t, _), a_m) ((b_t, _), b_m) = a_t = b_t && a_m = b_m -let care_binding_regular ((test,_),mods) = +let care_binding_regular ((test, _), mods) = (match mods with - | LKappa.Maintained | LKappa.Erased -> false - | LKappa.Freed | LKappa.Linked _ -> true) + | LKappa.Maintained | LKappa.Erased -> false + | LKappa.Freed | LKappa.Linked _ -> true) || - (match test with - | LKappa.LNK_VALUE _ - | LKappa.LNK_FREE - | LKappa.ANY_FREE - | LKappa.LNK_SOME - | LKappa.LNK_TYPE _ -> true - | LKappa.LNK_ANY -> false - ) - -let care_internal_regular = - function - | LKappa.I_ANY - | LKappa.I_ANY_ERASED -> false - | LKappa.I_ANY_CHANGED _ - | LKappa.I_VAL_CHANGED _ - | LKappa.I_VAL_ERASED _ -> true + match test with + | LKappa.LNK_VALUE _ | LKappa.LNK_FREE | LKappa.ANY_FREE | LKappa.LNK_SOME + | LKappa.LNK_TYPE _ -> + true + | LKappa.LNK_ANY -> false + +let care_internal_regular = function + | LKappa.I_ANY | LKappa.I_ANY_ERASED -> false + | LKappa.I_ANY_CHANGED _ | LKappa.I_VAL_CHANGED _ | LKappa.I_VAL_ERASED _ -> + true let may_swap_internal_state_regular ag_type site1 site2 ag = ag_type = ag.LKappa.ra_type - && - ( - care_internal_regular ag.LKappa.ra_ints.(site1) - || - care_internal_regular ag.LKappa.ra_ints.(site2) - ) - && - (ag.LKappa.ra_ints.(site1) <> ag.LKappa.ra_ints.(site2)) + && (care_internal_regular ag.LKappa.ra_ints.(site1) + || care_internal_regular ag.LKappa.ra_ints.(site2)) + && ag.LKappa.ra_ints.(site1) <> ag.LKappa.ra_ints.(site2) let may_swap_binding_state_regular ag_type site1 site2 ag = ag_type = ag.LKappa.ra_type - && - ( - care_binding_regular ag.LKappa.ra_ports.(site1) - || - care_binding_regular ag.LKappa.ra_ports.(site2) - ) - && - (not (binding_equal ag.LKappa.ra_ports.(site1) ag.LKappa.ra_ports.(site2))) + && (care_binding_regular ag.LKappa.ra_ports.(site1) + || care_binding_regular ag.LKappa.ra_ports.(site2)) + && not (binding_equal ag.LKappa.ra_ports.(site1) ag.LKappa.ra_ports.(site2)) let may_swap_full_regular ag_type site1 site2 ag = may_swap_binding_state_regular ag_type site1 site2 ag @@ -76,71 +56,63 @@ let may_swap_full_regular ag_type site1 site2 ag = let may_swap_internal_state_created ag_type site1 site2 ag = ag_type = ag.Raw_mixture.a_type - && - (ag.Raw_mixture.a_ints.(site1) <> ag.Raw_mixture.a_ints.(site2)) + && ag.Raw_mixture.a_ints.(site1) <> ag.Raw_mixture.a_ints.(site2) let may_swap_binding_state_created ag_type site1 site2 ag = ag_type = ag.Raw_mixture.a_type - && - (ag.Raw_mixture.a_ports.(site1) <> ag.Raw_mixture.a_ports.(site2)) + && ag.Raw_mixture.a_ports.(site1) <> ag.Raw_mixture.a_ports.(site2) let may_swap_full_created ag_type site1 site2 ag = may_swap_internal_state_created ag_type site1 site2 ag || may_swap_binding_state_created ag_type site1 site2 ag -let of_rule rule = (rule.LKappa.r_mix, rule.LKappa.r_created) - -let is_empty (rule_tail,created_tail) = - rule_tail = [] && created_tail = [] +let of_rule rule = rule.LKappa.r_mix, rule.LKappa.r_created +let is_empty (rule_tail, created_tail) = rule_tail = [] && created_tail = [] -let p_head ~fmt_err ~sigs p p_raw (rule_tail,created_tail) = +let p_head ~fmt_err ~sigs p p_raw (rule_tail, created_tail) = match rule_tail, created_tail with | h :: t, _ -> p h, (t, created_tail) | _, h :: t -> p_raw h, (rule_tail, t) | [], [] -> - let s1,i1,i2,i3 = __POS__ in + let s1, i1, i2, i3 = __POS__ in let s = Format.sprintf "%s %i %i %i" s1 i1 i2 i3 in let fmt = fmt_err in let trace = Some true in let () = - do_print ?trace ?fmt ?sigs - (fun _ fmt -> Format.fprintf fmt "%s@" s) + do_print ?trace ?fmt ?sigs (fun _ fmt -> Format.fprintf fmt "%s@" s) in raise (invalid_arg s) -let apply_head ~fmt_err ~sigs sigma sigma_raw (rule_tail,created_tail) = +let apply_head ~fmt_err ~sigs sigma sigma_raw (rule_tail, created_tail) = match rule_tail, created_tail with - | h::t, _ -> + | h :: t, _ -> let () = sigma h in t, created_tail - | _, h::t -> + | _, h :: t -> let () = sigma_raw h in rule_tail, t | [], [] -> - let s1,i1,i2,i3 = __POS__ in + let s1, i1, i2, i3 = __POS__ in let s = Format.sprintf "%s %i %i %i" s1 i1 i2 i3 in let fmt = fmt_err in let trace = Some true in let () = - do_print ?trace ?fmt ?sigs - (fun _ fmt -> Format.fprintf fmt "%s@" s) + do_print ?trace ?fmt ?sigs (fun _ fmt -> Format.fprintf fmt "%s@" s) in raise (invalid_arg s) -let apply_head_predicate ~fmt_err ~sigs f f_raw cache (rule_tail,created_tail) rule = +let apply_head_predicate ~fmt_err ~sigs f f_raw cache (rule_tail, created_tail) + rule = match rule_tail, created_tail with - | h::_, _ -> - f h rule cache - | _, h::_ -> - f_raw h rule cache + | h :: _, _ -> f h rule cache + | _, h :: _ -> f_raw h rule cache | [], [] -> - let s1,i1,i2,i3 = __POS__ in + let s1, i1, i2, i3 = __POS__ in let s = Format.sprintf "%s %i %i %i" s1 i1 i2 i3 in let fmt = fmt_err in let trace = Some true in let () = - do_print ?trace ?fmt ?sigs - (fun _ fmt -> Format.fprintf fmt "%s@" s) + do_print ?trace ?fmt ?sigs (fun _ fmt -> Format.fprintf fmt "%s@" s) in raise (invalid_arg s) @@ -150,33 +122,34 @@ let shift ~fmt_err ~sigs tail = apply_head ~fmt_err ~sigs ignore ignore tail let filter_positions ~fmt_err ~sigs p p_raw rule = let rec aux pos_id rule_tail accu = - if is_empty rule_tail - then List.rev accu - else + if is_empty rule_tail then + List.rev accu + else ( let b, rule_tail = p_head ~fmt_err ~sigs p p_raw rule_tail in if b then aux (pos_id + 1) rule_tail (pos_id :: accu) else aux (pos_id + 1) rule_tail accu + ) in aux 0 (of_rule rule) [] -let potential_positions_for_swapping_internal_states - ~fmt_err ~sigs agent_type site1 site2 rule : int list = +let potential_positions_for_swapping_internal_states ~fmt_err ~sigs agent_type + site1 site2 rule : int list = filter_positions ~fmt_err ~sigs (may_swap_internal_state_regular agent_type site1 site2) (may_swap_internal_state_created agent_type site1 site2) rule -let potential_positions_for_swapping_binding_states - ~fmt_err ~sigs agent_type site1 site2 rule = +let potential_positions_for_swapping_binding_states ~fmt_err ~sigs agent_type + site1 site2 rule = filter_positions ~fmt_err ~sigs (may_swap_binding_state_regular agent_type site1 site2) (may_swap_binding_state_created agent_type site1 site2) rule -let potential_positions_for_swapping_full - ~fmt_err ~sigs agent_type site1 site2 rule = +let potential_positions_for_swapping_full ~fmt_err ~sigs agent_type site1 site2 + rule = filter_positions ~fmt_err ~sigs (may_swap_full_regular agent_type site1 site2) (may_swap_full_created agent_type site1 site2) @@ -188,23 +161,17 @@ let backtrack ~fmt_err ~sigs sigma_inv sigma_raw_inv counter positions rule = let rec aux ~fmt_err ~sigs agent_id rule_tail pos_id positions_tail = match positions_tail with | [] -> () - | pos_head :: _ - when agent_id < pos_head -> + | pos_head :: _ when agent_id < pos_head -> let rule_tail = shift ~fmt_err ~sigs rule_tail in aux ~fmt_err ~sigs (agent_id + 1) rule_tail pos_id positions_tail - | pos_head :: pos_tail - when agent_id = pos_head -> - begin - let rule_tail = - if - counter.(pos_id) - then - apply_head ~fmt_err ~sigs sigma_inv sigma_raw_inv rule_tail - else + | pos_head :: pos_tail when agent_id = pos_head -> + let rule_tail = + if counter.(pos_id) then + apply_head ~fmt_err ~sigs sigma_inv sigma_raw_inv rule_tail + else shift ~fmt_err ~sigs rule_tail - in - aux ~fmt_err ~sigs (agent_id + 1) rule_tail (pos_id + 1) pos_tail - end + in + aux ~fmt_err ~sigs (agent_id + 1) rule_tail (pos_id + 1) pos_tail | _ :: pos_tail -> aux ~fmt_err ~sigs agent_id rule_tail (pos_id + 1) pos_tail in @@ -214,122 +181,100 @@ let backtrack ~fmt_err ~sigs sigma_inv sigma_raw_inv counter positions rule = (*SYMMETRIES*) (***************************************************************) -let for_all_elt_permutation - ~fmt_err ~sigs - (positions:int list) - (f:LKappa.rule_agent -> LKappa.rule -> 'a -> 'a * bool ) - (f_raw:Raw_mixture.agent -> LKappa.rule -> 'a -> 'a * bool) - (rule:LKappa.rule) - (init:'a) = +let for_all_elt_permutation ~fmt_err ~sigs (positions : int list) + (f : LKappa.rule_agent -> LKappa.rule -> 'a -> 'a * bool) + (f_raw : Raw_mixture.agent -> LKappa.rule -> 'a -> 'a * bool) + (rule : LKappa.rule) (init : 'a) = let rec next ~fmt_err ~sigs agent_id rule_tail pos_id positions_tail accu = match positions_tail with | [] -> accu, true - | pos_head :: _ - when agent_id < pos_head -> + | pos_head :: _ when agent_id < pos_head -> let rule_tail = shift ~fmt_err ~sigs rule_tail in next ~fmt_err ~sigs (agent_id + 1) rule_tail pos_id positions_tail accu - | pos_head :: pos_tail - when agent_id = pos_head -> - begin - match apply_head_predicate - ~fmt_err ~sigs - f f_raw - accu - rule_tail rule - with - | accu, false -> accu, false - | accu, true -> - let rule_tail = shift ~fmt_err ~sigs rule_tail in - next ~fmt_err ~sigs (agent_id + 1) rule_tail (pos_id + 1) pos_tail accu - end - | _::_ - (*when agent_id > pos_head*) -> - let s1,i1,i2,i3 = __POS__ in + | pos_head :: pos_tail when agent_id = pos_head -> + (match + apply_head_predicate ~fmt_err ~sigs f f_raw accu rule_tail rule + with + | accu, false -> accu, false + | accu, true -> + let rule_tail = shift ~fmt_err ~sigs rule_tail in + next ~fmt_err ~sigs (agent_id + 1) rule_tail (pos_id + 1) pos_tail accu) + | _ :: _ (*when agent_id > pos_head*) -> + let s1, i1, i2, i3 = __POS__ in let string = Format.sprintf "Internal bug: %s %i %i %i" s1 i1 i2 i3 in let fmt = fmt_err in let trace = Some true in let () = - do_print ?trace ?fmt ?sigs - (fun _ fmt -> - Format.fprintf fmt "%s@ " string - ) + do_print ?trace ?fmt ?sigs (fun _ fmt -> + Format.fprintf fmt "%s@ " string) in accu, false in next ~fmt_err ~sigs 0 (of_rule rule) 0 positions init -let for_all_over_orbit - ~trace ~fmt ~fmt_err ~sigs - (positions:int list) - (sigma:LKappa.rule_agent -> unit) - (sigma_inv:LKappa.rule_agent -> unit) - (sigma_raw:Raw_mixture.agent -> unit) - (sigma_raw_inv:Raw_mixture.agent -> unit) - (f: trace: bool option -> fmt:Format.formatter option -> - fmt_err:Format.formatter option -> sigs:Signature.s option -> - LKappa.rule -> 'a -> 'a * bool) - (rule:LKappa.rule) - (init:'a) : 'a * bool = - let n = List.length positions in - let counter = Array.make n false in - let rec next ~trace ~fmt ~fmt_err ~sigs agent_id rule_tail pos_id positions_tail accu = - match positions_tail with - | [] -> f ~trace ~fmt ~fmt_err ~sigs rule accu - | pos_head :: _ - when agent_id < pos_head -> - let rule_tail = shift ~fmt_err ~sigs rule_tail in - next ~trace ~fmt ~fmt_err ~sigs - (agent_id + 1) rule_tail pos_id positions_tail accu - | pos_head :: pos_tail - when agent_id = pos_head -> - begin - if - counter.(pos_id) - then - let () = counter.(pos_id) <- false in - let rule_tail = - apply_head ~fmt_err ~sigs sigma_inv sigma_raw_inv rule_tail - in - next ~trace ~fmt ~fmt_err ~sigs (agent_id + 1) rule_tail (pos_id + 1) pos_tail accu - else - let () = counter.(pos_id) <- true in - let _ = apply_head ~fmt_err ~sigs sigma sigma_raw rule_tail in - let accu, b = f ~trace ~fmt ~fmt_err ~sigs rule accu in - if b - then - next ~trace ~fmt ~fmt_err ~sigs 0 (rule.LKappa.r_mix,rule.LKappa.r_created) 0 - positions accu - else - let () = - backtrack ~fmt_err ~sigs sigma_inv sigma_raw_inv counter - positions rule - in - accu, false - end - | _::_ - (*when agent_id > pos_head*) -> - let s1,i1,i2,i3 = __POS__ in - let s = - Format.sprintf - "Internal bug: %s %i %i %i" s1 i1 i2 i3 - in - let fmt = fmt_err in - let trace = Some true in - let () = - do_print ?trace ?fmt ?sigs - (fun _ fmt -> Format.fprintf fmt "%s@" s) - in - let () = - backtrack ~fmt_err ~sigs sigma_inv sigma_raw_inv counter positions rule +let for_all_over_orbit ~trace ~fmt ~fmt_err ~sigs (positions : int list) + (sigma : LKappa.rule_agent -> unit) (sigma_inv : LKappa.rule_agent -> unit) + (sigma_raw : Raw_mixture.agent -> unit) + (sigma_raw_inv : Raw_mixture.agent -> unit) + (f : + trace:bool option -> + fmt:Format.formatter option -> + fmt_err:Format.formatter option -> + sigs:Signature.s option -> + LKappa.rule -> + 'a -> + 'a * bool) (rule : LKappa.rule) (init : 'a) : 'a * bool = + let n = List.length positions in + let counter = Array.make n false in + let rec next ~trace ~fmt ~fmt_err ~sigs agent_id rule_tail pos_id + positions_tail accu = + match positions_tail with + | [] -> f ~trace ~fmt ~fmt_err ~sigs rule accu + | pos_head :: _ when agent_id < pos_head -> + let rule_tail = shift ~fmt_err ~sigs rule_tail in + next ~trace ~fmt ~fmt_err ~sigs (agent_id + 1) rule_tail pos_id + positions_tail accu + | pos_head :: pos_tail when agent_id = pos_head -> + if counter.(pos_id) then ( + let () = counter.(pos_id) <- false in + let rule_tail = + apply_head ~fmt_err ~sigs sigma_inv sigma_raw_inv rule_tail in - accu, false - in - next ~trace ~fmt ~fmt_err ~sigs 0 (of_rule rule) 0 positions init + next ~trace ~fmt ~fmt_err ~sigs (agent_id + 1) rule_tail (pos_id + 1) + pos_tail accu + ) else ( + let () = counter.(pos_id) <- true in + let _ = apply_head ~fmt_err ~sigs sigma sigma_raw rule_tail in + let accu, b = f ~trace ~fmt ~fmt_err ~sigs rule accu in + if b then + next ~trace ~fmt ~fmt_err ~sigs 0 + (rule.LKappa.r_mix, rule.LKappa.r_created) + 0 positions accu + else ( + let () = + backtrack ~fmt_err ~sigs sigma_inv sigma_raw_inv counter positions + rule + in + accu, false + ) + ) + | _ :: _ (*when agent_id > pos_head*) -> + let s1, i1, i2, i3 = __POS__ in + let s = Format.sprintf "Internal bug: %s %i %i %i" s1 i1 i2 i3 in + let fmt = fmt_err in + let trace = Some true in + let () = + do_print ?trace ?fmt ?sigs (fun _ fmt -> Format.fprintf fmt "%s@" s) + in + let () = + backtrack ~fmt_err ~sigs sigma_inv sigma_raw_inv counter positions rule + in + accu, false + in + next ~trace ~fmt ~fmt_err ~sigs 0 (of_rule rule) 0 positions init exception False - - (****************************************************************) (*cannonic form for symmetries*) (****************************************************************) @@ -338,12 +283,11 @@ exception False let swap_binding_state_regular _ag_type site1 site2 ag = let tmp = ag.LKappa.ra_ports.(site1) in - let () = - ag.LKappa.ra_ports.(site1) <- ag.LKappa.ra_ports.(site2) in + let () = ag.LKappa.ra_ports.(site1) <- ag.LKappa.ra_ports.(site2) in let () = ag.LKappa.ra_ports.(site2) <- tmp in () -let swap_internal_state_regular _ag_type site1 site2 (ag:LKappa.rule_agent) = +let swap_internal_state_regular _ag_type site1 site2 (ag : LKappa.rule_agent) = let tmp = ag.LKappa.ra_ints.(site1) in let () = ag.LKappa.ra_ints.(site1) <- ag.LKappa.ra_ints.(site2) in let () = ag.LKappa.ra_ints.(site2) <- tmp in @@ -357,16 +301,13 @@ let swap_full_regular ag_type site1 site2 ag = let swap_binding_state_created _ag_type site1 site2 ag = let tmp = ag.Raw_mixture.a_ports.(site1) in - let () = - ag.Raw_mixture.a_ports.(site1) <- ag.Raw_mixture.a_ports.(site2) - in + let () = ag.Raw_mixture.a_ports.(site1) <- ag.Raw_mixture.a_ports.(site2) in let () = ag.Raw_mixture.a_ports.(site2) <- tmp in () let swap_internal_state_created _ag_type site1 site2 ag = let tmp = ag.Raw_mixture.a_ints.(site1) in - let () = - ag.Raw_mixture.a_ints.(site1) <- ag.Raw_mixture.a_ints.(site2) in + let () = ag.Raw_mixture.a_ints.(site1) <- ag.Raw_mixture.a_ints.(site2) in let () = ag.Raw_mixture.a_ints.(site2) <- tmp in () @@ -380,187 +321,128 @@ let swap_full_created ag_type site1 site2 ag = let fold_elt_pair f l accu = match l with | [] -> accu - | h::t -> - List.fold_left - (fun accu s2 -> f h s2 accu) - accu - t + | h :: t -> List.fold_left (fun accu s2 -> f h s2 accu) accu t -let fold_one_kind_of_sym_over_an_agent - sigma sigma_inv partition f agent_type agent rule accu = +let fold_one_kind_of_sym_over_an_agent sigma sigma_inv partition f agent_type + agent rule accu = List.fold_left (fun accu equ_class -> - fold_elt_pair - (fun s1 s2 accu -> - let () = sigma agent_type s1 s2 agent in - let accu = f rule accu in - let () = sigma_inv agent_type s1 s2 agent in - accu) - equ_class - accu) - accu - partition - -let fold_over_elt_transformation - get_sym_internal_states - get_sym_binding_states - get_sym_full_states - (rule:LKappa.rule) - (f:LKappa.rule -> 'a -> 'a) + fold_elt_pair + (fun s1 s2 accu -> + let () = sigma agent_type s1 s2 agent in + let accu = f rule accu in + let () = sigma_inv agent_type s1 s2 agent in + accu) + equ_class accu) + accu partition + +let fold_over_elt_transformation get_sym_internal_states get_sym_binding_states + get_sym_full_states (rule : LKappa.rule) (f : LKappa.rule -> 'a -> 'a) (*acc*) - (accu: 'a) : 'a = + (accu : 'a) : 'a = (*position is a list of agent*) let accu = List.fold_left (fun accu agent -> - let agent_type = agent.LKappa.ra_type in - let accu = - fold_one_kind_of_sym_over_an_agent - swap_internal_state_regular - swap_internal_state_regular - (get_sym_internal_states agent_type) - f - agent_type - agent - rule - accu - in - let accu = - fold_one_kind_of_sym_over_an_agent - swap_binding_state_regular - swap_binding_state_regular - (get_sym_binding_states agent_type) - f - agent_type - agent - rule - accu - in - let accu = - fold_one_kind_of_sym_over_an_agent - swap_full_regular - swap_full_regular - (get_sym_full_states agent_type) - f - agent_type - agent - rule - accu - in - accu - ) - accu - rule.LKappa.r_mix + let agent_type = agent.LKappa.ra_type in + let accu = + fold_one_kind_of_sym_over_an_agent swap_internal_state_regular + swap_internal_state_regular + (get_sym_internal_states agent_type) + f agent_type agent rule accu + in + let accu = + fold_one_kind_of_sym_over_an_agent swap_binding_state_regular + swap_binding_state_regular + (get_sym_binding_states agent_type) + f agent_type agent rule accu + in + let accu = + fold_one_kind_of_sym_over_an_agent swap_full_regular swap_full_regular + (get_sym_full_states agent_type) + f agent_type agent rule accu + in + accu) + accu rule.LKappa.r_mix in let accu = List.fold_left - (fun accu (agent:Raw_mixture.agent) -> - let agent_type = agent.Raw_mixture.a_type in - let accu = - fold_one_kind_of_sym_over_an_agent - swap_internal_state_created - swap_internal_state_created - (get_sym_internal_states agent_type) - f - agent_type - agent - rule - accu - in - let accu = - fold_one_kind_of_sym_over_an_agent - swap_binding_state_created - swap_binding_state_created - (get_sym_binding_states agent_type) - f - agent_type - agent - rule - accu - in - let accu = - fold_one_kind_of_sym_over_an_agent - swap_full_created - swap_full_created - (get_sym_full_states agent_type) - f - agent_type - agent - rule - accu - in - accu - ) - accu - rule.LKappa.r_created + (fun accu (agent : Raw_mixture.agent) -> + let agent_type = agent.Raw_mixture.a_type in + let accu = + fold_one_kind_of_sym_over_an_agent swap_internal_state_created + swap_internal_state_created + (get_sym_internal_states agent_type) + f agent_type agent rule accu + in + let accu = + fold_one_kind_of_sym_over_an_agent swap_binding_state_created + swap_binding_state_created + (get_sym_binding_states agent_type) + f agent_type agent rule accu + in + let accu = + fold_one_kind_of_sym_over_an_agent swap_full_created swap_full_created + (get_sym_full_states agent_type) + f agent_type agent rule accu + in + accu) + accu rule.LKappa.r_created in accu let copy_lkappa_rule rule = - {rule with - LKappa.r_mix = - List.rev_map LKappa.copy_rule_agent (List.rev rule.LKappa.r_mix); - r_created = - List.rev_map Raw_mixture.copy_agent (List.rev rule.LKappa.r_created); + { + rule with + LKappa.r_mix = + List.rev_map LKappa.copy_rule_agent (List.rev rule.LKappa.r_mix); + r_created = + List.rev_map Raw_mixture.copy_agent (List.rev rule.LKappa.r_created); } -let equiv_class - cache - seen - rule - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states - ~convention - = - let to_visit = [rule] in - let rec aux cache to_visit seen visited = - match - to_visit - with - | [] -> cache, seen, visited - | h::q -> - let cache, hashed_list = LKappa_auto.cannonic_form cache h in - let hash = LKappa_auto.RuleCache.int_of_hashed_list hashed_list in - if Mods.DynArray.get seen hash - then aux cache q seen visited - else - let visited = h::visited in +let equiv_class cache seen rule ~partitions_internal_states + ~partitions_binding_states ~partitions_full_states ~convention = + let to_visit = [ rule ] in + let rec aux cache to_visit seen visited = + match to_visit with + | [] -> cache, seen, visited + | h :: q -> + let cache, hashed_list = LKappa_auto.cannonic_form cache h in + let hash = LKappa_auto.RuleCache.int_of_hashed_list hashed_list in + if Mods.DynArray.get seen hash then + aux cache q seen visited + else ( + let visited = h :: visited in let () = Mods.DynArray.set seen hash true in let to_visit = - fold_over_elt_transformation - partitions_internal_states - partitions_binding_states - partitions_full_states - h - (fun rule list -> (copy_lkappa_rule rule::list)) + fold_over_elt_transformation partitions_internal_states + partitions_binding_states partitions_full_states h + (fun rule list -> copy_lkappa_rule rule :: list) q in aux cache to_visit seen visited - in - let cache,seen,equ_class = aux cache to_visit seen [] in - let cache, equ_class = - List.fold_left - (fun (cache, list) elt -> - let cache, nauto = - LKappa_auto.nauto - convention - cache - elt - in - (cache, (elt,nauto)::list)) - (cache,[]) equ_class - in - cache, seen, equ_class + ) + in + let cache, seen, equ_class = aux cache to_visit seen [] in + let cache, equ_class = + List.fold_left + (fun (cache, list) elt -> + let cache, nauto = LKappa_auto.nauto convention cache elt in + cache, (elt, nauto) :: list) + (cache, []) equ_class + in + cache, seen, equ_class type bwd_bisim_info = - int Symmetries_sig.site_partition array * bool Mods.DynArray.t * (LKappa_auto.cache ref) + int Symmetries_sig.site_partition array + * bool Mods.DynArray.t + * LKappa_auto.cache ref -let saturate_domain_with_symmetric_patterns - ~debugMode ~compileModeOn env bwd_bisim_info ccs domain = +let saturate_domain_with_symmetric_patterns ~debug_mode ~compile_mode_on env + bwd_bisim_info ccs domain = let sigs = Model.signatures env in let contact_map = Model.contact_map env in - let equivalence_relations,bool_array,cache_ref = bwd_bisim_info in + let equivalence_relations, bool_array, cache_ref = bwd_bisim_info in let cache = !cache_ref in let partitions_internal_states i = equivalence_relations.(i).Symmetries_sig.over_internal_states @@ -571,120 +453,107 @@ let saturate_domain_with_symmetric_patterns let partitions_full_states i = equivalence_relations.(i).Symmetries_sig.over_full_states in - let domain,cache = + let domain, cache = List.fold_left - (fun (domain,cache) cc_array -> - Array.fold_left - (fun (domain,cache) cc_id -> - let cc = - Pattern.Env.content (Pattern.Env.get (Model.domain env) cc_id) in - let cache,_,equiv_class = - equiv_class - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states - ~convention:Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs - cache - bool_array - (Patterns_extra.pattern_to_lkappa_rule ~sigs cc) - in - let domain = - List.fold_left - (fun domain (lkappa_rule,_) -> - let rule_mixture = lkappa_rule.LKappa.r_mix in - let domain,_ = - Pattern_compiler.connected_components_sum_of_ambiguous_mixture - ~debugMode ~compileModeOn contact_map domain ?origin:None - rule_mixture - in - domain) - domain equiv_class in - domain,cache) - (domain, cache) - cc_array) - (domain, cache) - ccs + (fun (domain, cache) cc_array -> + Array.fold_left + (fun (domain, cache) cc_id -> + let cc = + Pattern.Env.content (Pattern.Env.get (Model.domain env) cc_id) + in + let cache, _, equiv_class = + equiv_class ~partitions_internal_states ~partitions_binding_states + ~partitions_full_states + ~convention: + Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs cache + bool_array + (Patterns_extra.pattern_to_lkappa_rule ~sigs cc) + in + let domain = + List.fold_left + (fun domain (lkappa_rule, _) -> + let rule_mixture = lkappa_rule.LKappa.r_mix in + let domain, _ = + Pattern_compiler + .connected_components_sum_of_ambiguous_mixture ~debug_mode + ~compile_mode_on contact_map domain ?origin:None + rule_mixture + in + domain) + domain equiv_class + in + domain, cache) + (domain, cache) cc_array) + (domain, cache) ccs in let () = cache_ref := cache in domain -let check_orbit - ~trace ~fmt ~fmt_err ~sigs - (get_positions, sigma, sigma_inv, sigma_raw, sigma_raw_inv) - weight agent site1 site2 rule correct rates cache counter - to_be_checked : (LKappa_auto.cache * int array * bool array) * bool = +let check_orbit ~trace ~fmt ~fmt_err ~sigs + (get_positions, sigma, sigma_inv, sigma_raw, sigma_raw_inv) weight agent + site1 site2 rule correct rates cache counter to_be_checked : + (LKappa_auto.cache * int array * bool array) * bool = let () = - do_print ?trace ?fmt ?sigs - (fun sigs fmt -> - let () = Format.fprintf fmt "Check an orbit@." in - let () = Format.fprintf fmt "Permutation of the sites " in - let () = Signature.print_site sigs agent fmt site1 in - let () = Format.fprintf fmt " and " in - let () = Signature.print_site sigs agent fmt site2 in - let () = Format.fprintf fmt " in agent of type " in - let () = Signature.print_agent sigs fmt agent in - let () = Format.pp_print_newline fmt () in - let () = Format.fprintf fmt " rule: " in - let () = - LKappa.print_rule - ~noCounters:true ~full:true - sigs - (fun _ _ -> ()) (fun _ _ -> ()) - fmt rule - in - let () = Format.pp_print_newline fmt () in - () - ) + do_print ?trace ?fmt ?sigs (fun sigs fmt -> + let () = Format.fprintf fmt "Check an orbit@." in + let () = Format.fprintf fmt "Permutation of the sites " in + let () = Signature.print_site sigs agent fmt site1 in + let () = Format.fprintf fmt " and " in + let () = Signature.print_site sigs agent fmt site2 in + let () = Format.fprintf fmt " in agent of type " in + let () = Signature.print_agent sigs fmt agent in + let () = Format.pp_print_newline fmt () in + let () = Format.fprintf fmt " rule: " in + let () = + LKappa.print_rule ~noCounters:true ~full:true sigs + (fun _ _ -> ()) + (fun _ _ -> ()) + fmt rule + in + let () = Format.pp_print_newline fmt () in + ()) in let size = Array.length to_be_checked in let accu = cache, [], counter, to_be_checked in let f ~trace ~fmt ~fmt_err ~sigs rule (cache, l, counter, to_be_checked) = let _ = fmt_err in let () = - do_print ?trace ?fmt ?sigs - (fun sigs fmt -> - let () = Format.fprintf fmt " rule: " in - let () = - LKappa.print_rule - ~noCounters:true ~full:true - sigs - (fun _ _ -> ()) (fun _ _ -> ()) - fmt rule - in - let () = Format.pp_print_newline fmt () in - ()) + do_print ?trace ?fmt ?sigs (fun sigs fmt -> + let () = Format.fprintf fmt " rule: " in + let () = + LKappa.print_rule ~noCounters:true ~full:true sigs + (fun _ _ -> ()) + (fun _ _ -> ()) + fmt rule + in + let () = Format.pp_print_newline fmt () in + ()) in let cache, hash = LKappa_auto.cannonic_form cache rule in let i = LKappa_auto.RuleCache.int_of_hashed_list hash in - if i < size && to_be_checked.(i) - then - begin - let () = - do_print ?fmt ?trace ?sigs - (fun _ fmt -> - let () = Format.fprintf fmt "Existing rule" in - Format.pp_print_newline fmt ()) - in - let n = counter.(i) in - let () = counter.(i) <- n+1 in - if n = 0 - then - (cache, hash::l, counter, to_be_checked), true - else - (cache, l, counter, to_be_checked), true - end - else - let () = - do_print ?fmt ?trace ?sigs - (fun _ fmt -> - let () = Format.fprintf fmt "Unknown rule" in - Format.pp_print_newline fmt ()) - in + if i < size && to_be_checked.(i) then ( + let () = + do_print ?fmt ?trace ?sigs (fun _ fmt -> + let () = Format.fprintf fmt "Existing rule" in + Format.pp_print_newline fmt ()) + in + let n = counter.(i) in + let () = counter.(i) <- n + 1 in + if n = 0 then + (cache, hash :: l, counter, to_be_checked), true + else + (cache, l, counter, to_be_checked), true + ) else ( + let () = + do_print ?fmt ?trace ?sigs (fun _ fmt -> + let () = Format.fprintf fmt "Unknown rule" in + Format.pp_print_newline fmt ()) + in (cache, l, counter, to_be_checked), false + ) in let (cache, l, counter, to_be_checked), b = - for_all_over_orbit - ~trace ~fmt ~fmt_err ~sigs + for_all_over_orbit ~trace ~fmt ~fmt_err ~sigs (get_positions ~fmt_err ~sigs agent site1 site2 rule) (sigma agent site1 site2) (sigma_inv agent site1 site2) @@ -696,56 +565,50 @@ let check_orbit let i = LKappa_auto.RuleCache.int_of_hashed_list hash in Rule_modes.RuleModeMap.map (fun rate -> - weight - ~correct:(correct.(i)) - ~card_stabilizer:(counter.(i)) - ~rate) - (rates.(i)) + weight ~correct:correct.(i) ~card_stabilizer:counter.(i) ~rate) + rates.(i) in let rec aux w_ref l = match l with | [] -> true | h :: t -> if - begin - try - let (), () = - Rule_modes.RuleModeMap.monadic_fold2 - () () - (fun () () _ w_ref w () -> - match w_ref, w with - Some w_ref,Some w -> - if Affine_combinations.necessarily_equal w_ref w - then (),() - else raise False - | None,_ | _,None -> raise False) - (fun () () _ _ () -> raise False) - (fun () () _ _ () -> raise False) - w_ref - (get_weight h) - () - in true - with - | False -> false - end + try + let (), () = + Rule_modes.RuleModeMap.monadic_fold2 () () + (fun () () _ w_ref w () -> + match w_ref, w with + | Some w_ref, Some w -> + if Affine_combinations.necessarily_equal w_ref w then + (), () + else + raise False + | None, _ | _, None -> raise False) + (fun () () _ _ () -> raise False) + (fun () () _ _ () -> raise False) + w_ref (get_weight h) () + in + true + with False -> false then aux w_ref t else false in let good_rates = - b && - begin - match l with - | [] -> true - | h :: t -> aux (get_weight h) t - end + b + && + match l with + | [] -> true + | h :: t -> aux (get_weight h) t in let () = List.iter (fun h -> - let i = LKappa_auto.RuleCache.int_of_hashed_list h in - counter.(i) <- 0; to_be_checked.(i) <- true) l + let i = LKappa_auto.RuleCache.int_of_hashed_list h in + counter.(i) <- 0; + to_be_checked.(i) <- true) + l in if good_rates then (cache, counter, to_be_checked), true @@ -753,113 +616,82 @@ let check_orbit (cache, counter, to_be_checked), false let weight ~correct ~card_stabilizer ~rate = - Affine_combinations.div_scal - rate (correct * card_stabilizer) - -let check_orbit_internal_state_permutation - ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 rule ~correct rates cache - ~counter to_be_checked = - check_orbit - ~trace ~fmt ~fmt_err ~sigs - (potential_positions_for_swapping_internal_states, - swap_internal_state_regular, - swap_internal_state_regular, - swap_internal_state_created, - swap_internal_state_created) + Affine_combinations.div_scal rate (correct * card_stabilizer) + +let check_orbit_internal_state_permutation ?trace ?fmt ?fmt_err ?sigs + ~agent_type ~site1 ~site2 rule ~correct rates cache ~counter to_be_checked = + check_orbit ~trace ~fmt ~fmt_err ~sigs + ( potential_positions_for_swapping_internal_states, + swap_internal_state_regular, + swap_internal_state_regular, + swap_internal_state_created, + swap_internal_state_created ) weight agent_type site1 site2 rule correct rates cache counter to_be_checked -let check_orbit_binding_state_permutation - ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 rule ~correct rates cache - ~counter to_be_checked = - check_orbit - ~trace ~fmt ~fmt_err ~sigs - (potential_positions_for_swapping_binding_states, - swap_binding_state_regular, - swap_binding_state_regular, - swap_binding_state_created, - swap_binding_state_created) +let check_orbit_binding_state_permutation ?trace ?fmt ?fmt_err ?sigs ~agent_type + ~site1 ~site2 rule ~correct rates cache ~counter to_be_checked = + check_orbit ~trace ~fmt ~fmt_err ~sigs + ( potential_positions_for_swapping_binding_states, + swap_binding_state_regular, + swap_binding_state_regular, + swap_binding_state_created, + swap_binding_state_created ) weight agent_type site1 site2 rule correct rates cache counter to_be_checked -let check_orbit_full_permutation - ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 rule ~correct rates cache - ~counter to_be_checked = - check_orbit - ~trace ~fmt ~fmt_err ~sigs - (potential_positions_for_swapping_full, - swap_full_regular, - swap_full_regular, - swap_full_created, - swap_full_created) +let check_orbit_full_permutation ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 + ~site2 rule ~correct rates cache ~counter to_be_checked = + check_orbit ~trace ~fmt ~fmt_err ~sigs + ( potential_positions_for_swapping_full, + swap_full_regular, + swap_full_regular, + swap_full_created, + swap_full_created ) weight agent_type site1 site2 rule correct rates cache counter to_be_checked -let check_invariance - ~trace ~fmt ~fmt_err ~sigs - (get_positions, is_equal, is_equal_raw) - agent_type site1 site2 rule cache - = +let check_invariance ~trace ~fmt ~fmt_err ~sigs + (get_positions, is_equal, is_equal_raw) agent_type site1 site2 rule cache = let _ = trace, fmt, sigs in for_all_elt_permutation ~fmt_err ~sigs (get_positions ~fmt_err ~sigs agent_type site1 site2 rule) - is_equal - is_equal_raw - rule - cache + is_equal is_equal_raw rule cache -let is_invariant_internal_states_permutation - ?trace ?fmt ?fmt_err - ?sigs +let is_invariant_internal_states_permutation ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 rule cache = let _ = trace, fmt, sigs in let positions = - potential_positions_for_swapping_internal_states - ~fmt_err ~sigs agent_type site1 site2 rule + potential_positions_for_swapping_internal_states ~fmt_err ~sigs agent_type + site1 site2 rule in match positions with | [] -> cache, true - | _::_ -> cache, false + | _ :: _ -> cache, false let check_gen swap agent_type site1 site2 agent rule cache = let cache, hash = LKappa_auto.cannonic_form cache rule in let i = LKappa_auto.RuleCache.int_of_hashed_list hash in - let () = - swap - agent_type site1 site2 - agent - in + let () = swap agent_type site1 site2 agent in let cache, hash' = LKappa_auto.cannonic_form cache rule in let i' = LKappa_auto.RuleCache.int_of_hashed_list hash' in - let () = - swap - agent_type site1 site2 - agent - in - cache, i=i' - -let is_invariant_binding_states_permutation - ?(trace:bool option) ?(fmt:Format.formatter option) ?fmt_err ?(sigs:Signature.s option) ~agent_type ~site1 ~site2 - rule cache = - check_invariance - ~trace ~fmt ~fmt_err ~sigs - (potential_positions_for_swapping_binding_states, - (check_gen - swap_binding_state_regular - agent_type - site1 - site2), - (check_gen swap_binding_state_created agent_type site1 site2)) + let () = swap agent_type site1 site2 agent in + cache, i = i' + +let is_invariant_binding_states_permutation ?(trace : bool option) + ?(fmt : Format.formatter option) ?fmt_err ?(sigs : Signature.s option) + ~agent_type ~site1 ~site2 rule cache = + check_invariance ~trace ~fmt ~fmt_err ~sigs + ( potential_positions_for_swapping_binding_states, + check_gen swap_binding_state_regular agent_type site1 site2, + check_gen swap_binding_state_created agent_type site1 site2 ) agent_type site1 site2 rule cache -let is_invariant_full_states_permutation - ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 - rule cache = +let is_invariant_full_states_permutation ?trace ?fmt ?fmt_err ?sigs ~agent_type + ~site1 ~site2 rule cache = let cache, b1 = - is_invariant_internal_states_permutation - ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 - rule cache + is_invariant_internal_states_permutation ?trace ?fmt ?fmt_err ?sigs + ~agent_type ~site1 ~site2 rule cache in if b1 then - is_invariant_binding_states_permutation - ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 - rule cache + is_invariant_binding_states_permutation ?trace ?fmt ?fmt_err ?sigs + ~agent_type ~site1 ~site2 rule cache else cache, false diff --git a/core/symmetries/lKappa_group_action.mli b/core/symmetries/lKappa_group_action.mli index 7c2a5dd01a..c918231fb3 100644 --- a/core/symmetries/lKappa_group_action.mli +++ b/core/symmetries/lKappa_group_action.mli @@ -22,7 +22,7 @@ to_be_checked is an array of boolean: false means that there is no rule corresponding to this hash, or that this rule is already in an orbit; true, means that there is a rule corresponding to this hash, and it does not belong to a visited orbit *) -val check_orbit_internal_state_permutation: +val check_orbit_internal_state_permutation : ?trace:bool -> ?fmt:Format.formatter -> ?fmt_err:Format.formatter -> @@ -31,11 +31,14 @@ val check_orbit_internal_state_permutation: site1:int -> site2:int -> LKappa.rule -> - correct:(int array) -> (*what i have to divide to get gamma *) + correct:int array -> + (*what i have to divide to get gamma *) Affine_combinations.aff_combination Rule_modes.RuleModeMap.t array -> LKappa_auto.cache -> - counter:(int array) -> (*counter the number of array of orbit*) - bool array -> (LKappa_auto.cache * int array * bool array) * bool + counter:int array -> + (*counter the number of array of orbit*) + bool array -> + (LKappa_auto.cache * int array * bool array) * bool (** check_orbit_binding_state_permutation ~agent_type ~site1 ~site2 rule @@ -47,7 +50,7 @@ val check_orbit_internal_state_permutation: to_be_checked is an array of boolean: false means that there is no rule corresponding to this hash, or that this rule is already in an orbit; true, means that there is a rule corresponding to this hash, and it does not belong to a visited orbit *) -val check_orbit_binding_state_permutation: +val check_orbit_binding_state_permutation : ?trace:bool -> ?fmt:Format.formatter -> ?fmt_err:Format.formatter -> @@ -56,11 +59,12 @@ val check_orbit_binding_state_permutation: site1:int -> site2:int -> LKappa.rule -> - correct:(int array) -> + correct:int array -> Affine_combinations.aff_combination Rule_modes.RuleModeMap.t array -> LKappa_auto.cache -> - counter:(int array) -> - bool array -> (LKappa_auto.cache * int array * bool array) * bool + counter:int array -> + bool array -> + (LKappa_auto.cache * int array * bool array) * bool (** check_orbit_full_permutation ~agent_type ~site1 ~site2 rule @@ -72,7 +76,7 @@ val check_orbit_binding_state_permutation: to_be_checked is an array of boolean: false means that there is no rule corresponding to this hash, or that this rule is already in an orbit; true, means that there is a rule corresponding to this hash, and it does not belong to a visited orbit *) -val check_orbit_full_permutation: +val check_orbit_full_permutation : ?trace:bool -> ?fmt:Format.formatter -> ?fmt_err:Format.formatter -> @@ -81,13 +85,14 @@ val check_orbit_full_permutation: site1:int -> site2:int -> LKappa.rule -> - correct:(int array) -> + correct:int array -> Affine_combinations.aff_combination Rule_modes.RuleModeMap.t array -> LKappa_auto.cache -> - counter:(int array) -> - bool array -> (LKappa_auto.cache * int array * bool array) * bool + counter:int array -> + bool array -> + (LKappa_auto.cache * int array * bool array) * bool -val is_invariant_internal_states_permutation: +val is_invariant_internal_states_permutation : ?trace:bool -> ?fmt:Format.formatter -> ?fmt_err:Format.formatter -> @@ -99,7 +104,7 @@ val is_invariant_internal_states_permutation: LKappa_auto.cache -> LKappa_auto.cache * bool -val is_invariant_binding_states_permutation: +val is_invariant_binding_states_permutation : ?trace:bool -> ?fmt:Format.formatter -> ?fmt_err:Format.formatter -> @@ -111,7 +116,7 @@ val is_invariant_binding_states_permutation: LKappa_auto.cache -> LKappa_auto.cache * bool -val is_invariant_full_states_permutation: +val is_invariant_full_states_permutation : ?trace:bool -> ?fmt:Format.formatter -> ?fmt_err:Format.formatter -> @@ -123,9 +128,10 @@ val is_invariant_full_states_permutation: LKappa_auto.cache -> LKappa_auto.cache * bool - type bwd_bisim_info = - int Symmetries_sig.site_partition array * bool Mods.DynArray.t * (LKappa_auto.cache ref) + int Symmetries_sig.site_partition array + * bool Mods.DynArray.t + * LKappa_auto.cache ref val swap_binding_state_regular : int -> int -> int -> LKappa.rule_agent -> unit val swap_internal_state_regular : int -> int -> int -> LKappa.rule_agent -> unit @@ -134,7 +140,7 @@ val swap_binding_state_created : int -> int -> int -> Raw_mixture.agent -> unit val swap_internal_state_created : int -> int -> int -> Raw_mixture.agent -> unit val swap_full_created : int -> int -> int -> Raw_mixture.agent -> unit -val equiv_class: +val equiv_class : LKappa_auto.cache -> bool Mods.DynArray.t -> LKappa.rule -> @@ -144,6 +150,11 @@ val equiv_class: convention:Remanent_parameters_sig.rate_convention -> LKappa_auto.cache * bool Mods.DynArray.t * (LKappa.rule * int) list -val saturate_domain_with_symmetric_patterns: - debugMode:bool -> compileModeOn:bool -> Model.t -> bwd_bisim_info -> - Pattern.id array list -> Pattern.PreEnv.t -> Pattern.PreEnv.t +val saturate_domain_with_symmetric_patterns : + debug_mode:bool -> + compile_mode_on:bool -> + Model.t -> + bwd_bisim_info -> + Pattern.id array list -> + Pattern.PreEnv.t -> + Pattern.PreEnv.t diff --git a/core/symmetries/pattern_group_action.ml b/core/symmetries/pattern_group_action.ml index b73f66e175..a82de6cc2a 100644 --- a/core/symmetries/pattern_group_action.ml +++ b/core/symmetries/pattern_group_action.ml @@ -14,9 +14,7 @@ * under the terms of the GNU Library General Public License *) let get_internal_state_partition a = a.Symmetries_sig.over_internal_states - let get_binding_state_partition a = a.Symmetries_sig.over_binding_states - let get_full_partition a = a.Symmetries_sig.over_full_states (* @@ -24,14 +22,11 @@ let get_full_partition a = a.Symmetries_sig.over_full_states (int -> 'b -> 'a -> unit) -> ('b -> 'b -> int) -> int list -> 'a -> 'a *) -let normalize_in_agent_gen - (get:int -> 'a -> 'b) - (set:int -> 'b -> 'a -> unit) - (cmp: 'b -> 'b -> int) - equiv_class agent = +let normalize_in_agent_gen (get : int -> 'a -> 'b) + (set : int -> 'b -> 'a -> unit) (cmp : 'b -> 'b -> int) equiv_class agent = let asso = List.rev_map (fun x -> x, get x agent) equiv_class in let asso = List.sort (fun (_, x) (_, y) -> cmp x y) asso in - let asso' = List.rev_map2 (fun k (_, value) -> (k, value)) equiv_class asso in + let asso' = List.rev_map2 (fun k (_, value) -> k, value) equiv_class asso in let () = List.iter (fun (k, value) -> set k value agent) asso' in agent @@ -46,20 +41,16 @@ let normalize_gen get_type get set cmp which symmetries raw_mixture = let raw_mixture = List.rev_map (fun agent -> - let agent_type = get_type agent in - let partition = - try - which (symmetries.(agent_type)) - with - _ -> [] - in - let agent = - List.fold_left (fun agent equiv_class -> - normalize_in_agent_gen get set cmp equiv_class agent - ) agent partition - in - agent - ) (List.rev raw_mixture) + let agent_type = get_type agent in + let partition = try which symmetries.(agent_type) with _ -> [] in + let agent = + List.fold_left + (fun agent equiv_class -> + normalize_in_agent_gen get set cmp equiv_class agent) + agent partition + in + agent) + (List.rev raw_mixture) in raw_mixture @@ -71,27 +62,18 @@ let normalize_internal_states equiv_class raw_mixture = (fun agent -> agent.Raw_mixture.a_type) (fun i agent -> agent.Raw_mixture.a_ints.(i)) (fun i data agent -> agent.Raw_mixture.a_ints.(i) <- data) - compare - get_internal_state_partition - equiv_class - raw_mixture + compare get_internal_state_partition equiv_class raw_mixture let add i j map = - let old = - Mods.IntMap.find_default [] i map - in - Mods.IntMap.add i (j::old) map + let old = Mods.IntMap.find_default [] i map in + Mods.IntMap.add i (j :: old) map let pop i map = match Mods.IntMap.find_option i map with - | None -> - raise - (ExceptionDefn.Internal_Error ("Illegal map", Locality.dummy)) - | Some [a; b] -> Mods.IntMap.add i [b] map, a - | Some [a] -> Mods.IntMap.remove i map,a - | Some _ -> - raise - (ExceptionDefn.Internal_Error ("Illegal map", Locality.dummy)) + | None -> raise (ExceptionDefn.Internal_Error ("Illegal map", Loc.dummy)) + | Some [ a; b ] -> Mods.IntMap.add i [ b ] map, a + | Some [ a ] -> Mods.IntMap.remove i map, a + | Some _ -> raise (ExceptionDefn.Internal_Error ("Illegal map", Loc.dummy)) (* Raw_mixture.agent list -> @@ -101,38 +83,37 @@ let enrich_binding_state raw_mixture = let map = List.fold_left (fun map agent -> - let agent_type = agent.Raw_mixture.a_type in - let bonds = agent.Raw_mixture.a_ports in - Tools.array_fold_lefti - (fun site map port -> - match port with - | Raw_mixture.FREE -> map - | Raw_mixture.VAL i -> add i (agent_type, site) map) - map bonds - ) Mods.IntMap.empty raw_mixture + let agent_type = agent.Raw_mixture.a_type in + let bonds = agent.Raw_mixture.a_ports in + Tools.array_fold_lefti + (fun site map port -> + match port with + | Raw_mixture.FREE -> map + | Raw_mixture.VAL i -> add i (agent_type, site) map) + map bonds) + Mods.IntMap.empty raw_mixture in let refined_raw_mixture_rev, map = List.fold_left (fun (list, map) agent -> - let array = Array.make (Array.length agent.Raw_mixture.a_ports) None in - let map = - Tools.array_fold_lefti - (fun site map port -> - match port with - | Raw_mixture.FREE -> map - | Raw_mixture.VAL i -> - let map, binding_type = pop i map in - let () = array.(site) <- Some binding_type in - map) map agent.Raw_mixture.a_ports - in - ((agent, array) :: list, map)) + let array = Array.make (Array.length agent.Raw_mixture.a_ports) None in + let map = + Tools.array_fold_lefti + (fun site map port -> + match port with + | Raw_mixture.FREE -> map + | Raw_mixture.VAL i -> + let map, binding_type = pop i map in + let () = array.(site) <- Some binding_type in + map) + map agent.Raw_mixture.a_ports + in + (agent, array) :: list, map) ([], map) raw_mixture in let () = - if not (Mods.IntMap.is_empty map) - then - raise - (ExceptionDefn.Internal_Error ("Illegal map", Locality.dummy)) + if not (Mods.IntMap.is_empty map) then + raise (ExceptionDefn.Internal_Error ("Illegal map", Loc.dummy)) in List.rev refined_raw_mixture_rev @@ -146,26 +127,22 @@ let refine_class equiv_class agent output = match equiv_class with | [] -> output | h :: t -> - begin - let rec aux ref_value to_do current_class output = - match to_do with - | [] -> - begin - match ref_value with - | None -> output - | Some _ -> current_class :: output - end - | h :: t -> - if agent.(h) = ref_value - then - aux ref_value t (h :: current_class) output - else - match ref_value with - | None -> aux (agent.(h)) t [h] output - | Some _ -> aux (agent.(h)) t [h] (current_class :: output) - in - aux (agent.(h)) t [h] output - end + let rec aux ref_value to_do current_class output = + match to_do with + | [] -> + (match ref_value with + | None -> output + | Some _ -> current_class :: output) + | h :: t -> + if agent.(h) = ref_value then + aux ref_value t (h :: current_class) output + else ( + match ref_value with + | None -> aux agent.(h) t [ h ] output + | Some _ -> aux agent.(h) t [ h ] (current_class :: output) + ) + in + aux agent.(h) t [ h ] output (* ('a -> int list list) -> @@ -173,12 +150,14 @@ let refine_class equiv_class agent output = (Raw_mixture.agent * 'b option array) list -> int list list list *) let refine_partition which symmetries refined_raw_mixture = - List.rev_map (fun (agent, agent') -> + List.rev_map + (fun (agent, agent') -> let ag_type = agent.Raw_mixture.a_type in - List.fold_left (fun output equiv_class -> - refine_class equiv_class agent' output) - [] (which symmetries.(ag_type)) - ) (List.rev refined_raw_mixture) + List.fold_left + (fun output equiv_class -> refine_class equiv_class agent' output) + [] + (which symmetries.(ag_type))) + (List.rev refined_raw_mixture) (* ('a -> 'b -> 'c) -> @@ -186,7 +165,7 @@ let refine_partition which symmetries refined_raw_mixture = *) let apply_permutation get set perm agent = - let assign = List.rev_map (fun (i, j) -> (j, get i agent)) perm in + let assign = List.rev_map (fun (i, j) -> j, get i agent) perm in let () = List.iter (fun (j, data) -> set j data agent) assign in agent @@ -195,7 +174,7 @@ let apply_permutation get set perm agent = ('d -> 'c -> 'b -> unit) -> ('d * 'a) list -> 'b -> 'b *) let apply_permutation_inv get set perm agent = - let perm_inv = List.rev_map (fun (a, b) -> (b, a)) perm in + let perm_inv = List.rev_map (fun (a, b) -> b, a) perm in apply_permutation get set perm_inv agent (* @@ -206,8 +185,9 @@ let apply_permutation_inv get set perm agent = let rec fold_symmetries_over_agent get set f covering agent accu = match covering with | h :: t -> - Tools.fold_over_permutations (fun perm accu -> - let perm = List.rev_map2 (fun a b -> (a,b)) h perm in + Tools.fold_over_permutations + (fun perm accu -> + let perm = List.rev_map2 (fun a b -> a, b) h perm in let agent = apply_permutation get set perm agent in let accu = fold_symmetries_over_agent get set f t agent accu in let _ = apply_permutation_inv get set perm agent in @@ -225,45 +205,39 @@ let fold_symmetries_over_raw_mixture get set f raw_mixture covering_list accu = let rec aux get set f raw_mixture covering_list accu = match raw_mixture, covering_list with | [], [] -> f raw_mixture0 accu - | _::_, [] | [], _::_ -> + | _ :: _, [] | [], _ :: _ -> raise (ExceptionDefn.Internal_Error - ("Arguments of fold_symmetries_over_rw_mixture shall have the same length", - Locality.dummy)) + ( "Arguments of fold_symmetries_over_rw_mixture shall have the same \ + length", + Loc.dummy )) | h :: t, h' :: t' -> - fold_symmetries_over_agent - get set + fold_symmetries_over_agent get set (fun _agent accu -> aux get set f t t' accu) h' h accu - in aux get set f raw_mixture covering_list accu + in + aux get set f raw_mixture covering_list accu let copy raw_mixture = List.rev_map (fun agents -> - { - agents with - Raw_mixture.a_ints = Array.copy agents.Raw_mixture.a_ints; - Raw_mixture.a_ports = Array.copy agents.Raw_mixture.a_ports - }) + { + agents with + Raw_mixture.a_ints = Array.copy agents.Raw_mixture.a_ints; + Raw_mixture.a_ports = Array.copy agents.Raw_mixture.a_ports; + }) (List.rev raw_mixture) - let normalize_with_binding_states get1 set1 cmp get2 set2 get_partition rule_cache symmetries raw_mixture = let refined_raw_mixture = enrich_binding_state raw_mixture in let refined_raw_mixture = normalize_gen (fun (agent, _) -> agent.Raw_mixture.a_type) - get1 set1 cmp - get_partition - symmetries - refined_raw_mixture + get1 set1 cmp get_partition symmetries refined_raw_mixture in let covering_list = - refine_partition - get_partition - symmetries - refined_raw_mixture + refine_partition get_partition symmetries refined_raw_mixture in let raw_mixture = remove_binding_state refined_raw_mixture in let rule_cache, hash = @@ -271,58 +245,46 @@ let normalize_with_binding_states get1 set1 cmp get2 set2 get_partition (Patterns_extra.raw_mixture_to_lkappa_rule raw_mixture) in let rule_cache, (_, raw_mixture) = - fold_symmetries_over_raw_mixture - get2 set2 + fold_symmetries_over_raw_mixture get2 set2 (fun raw_mixture (rule_cache, (best_hash, best_raw_mixture)) -> - let rule_cache, hash = - LKappa_auto.cannonic_form - rule_cache - (Patterns_extra.raw_mixture_to_lkappa_rule raw_mixture) - in - if compare hash best_hash < 0 - then - (rule_cache, (hash, copy raw_mixture)) - else - (rule_cache, (best_hash, best_raw_mixture))) - raw_mixture - covering_list + let rule_cache, hash = + LKappa_auto.cannonic_form rule_cache + (Patterns_extra.raw_mixture_to_lkappa_rule raw_mixture) + in + if compare hash best_hash < 0 then + rule_cache, (hash, copy raw_mixture) + else + rule_cache, (best_hash, best_raw_mixture)) + raw_mixture covering_list (rule_cache, (hash, copy raw_mixture)) in rule_cache, raw_mixture let normalize_binding_states rule_cache symmetries raw_mixture = normalize_with_binding_states - (fun i (agent, agent') -> - agent.Raw_mixture.a_ports.(i), - agent'.(i)) + (fun i (agent, agent') -> agent.Raw_mixture.a_ports.(i), agent'.(i)) (fun i (data, data') (agent, agent') -> - agent.Raw_mixture.a_ports.(i) <- data; - agent'.(i) <- data') + agent.Raw_mixture.a_ports.(i) <- data; + agent'.(i) <- data') (fun (_, a) (_, b) -> compare a b) (fun i agent -> agent.Raw_mixture.a_ports.(i)) (fun i data agent -> agent.Raw_mixture.a_ports.(i) <- data) - get_binding_state_partition - rule_cache symmetries raw_mixture + get_binding_state_partition rule_cache symmetries raw_mixture let normalize_full rule_cache symmetries raw_mixture = normalize_with_binding_states (fun i (agent, agent') -> - (agent.Raw_mixture.a_ints.(i), - agent.Raw_mixture.a_ports.(i)), - agent'.(i)) + (agent.Raw_mixture.a_ints.(i), agent.Raw_mixture.a_ports.(i)), agent'.(i)) (fun i ((data_int, data_port), data') (agent, agent') -> - agent.Raw_mixture.a_ints.(i) <- data_int; - agent.Raw_mixture.a_ports.(i) <- data_port; - agent'.(i) <- data') + agent.Raw_mixture.a_ints.(i) <- data_int; + agent.Raw_mixture.a_ports.(i) <- data_port; + agent'.(i) <- data') (fun ((a, _), a') ((b, _), b') -> compare (a, a') (b, b')) - (fun i agent -> - agent.Raw_mixture.a_ints.(i), - agent.Raw_mixture.a_ports.(i)) + (fun i agent -> agent.Raw_mixture.a_ints.(i), agent.Raw_mixture.a_ports.(i)) (fun i (data_int, data_port) agent -> - agent.Raw_mixture.a_ints.(i) <- data_int; - agent.Raw_mixture.a_ports.(i) <- data_port) - get_full_partition - rule_cache symmetries raw_mixture + agent.Raw_mixture.a_ints.(i) <- data_int; + agent.Raw_mixture.a_ports.(i) <- data_port) + get_full_partition rule_cache symmetries raw_mixture let normalize_raw_mixture rule_cache symmetries raw_mixture = let rule_cache, raw_mixture = @@ -332,17 +294,14 @@ let normalize_raw_mixture rule_cache symmetries raw_mixture = normalize_binding_states rule_cache symmetries raw_mixture let normalize_species ?parameters ~sigs rule_cache cache symmetries cc = - match - Patterns_extra.species_to_raw_mixture ?parameters ~sigs cc - with + match Patterns_extra.species_to_raw_mixture ?parameters ~sigs cc with | Some (raw_mixture, unspec) -> let rule_cache, raw_mixture = - normalize_raw_mixture rule_cache symmetries - raw_mixture + normalize_raw_mixture rule_cache symmetries raw_mixture in let a, b, _ = - Patterns_extra.raw_mixture_to_species - ?parameters ~sigs cache raw_mixture unspec + Patterns_extra.raw_mixture_to_species ?parameters ~sigs cache raw_mixture + unspec in rule_cache, a, b | None -> rule_cache, cache, cc @@ -352,97 +311,55 @@ let get_trace_opt_fmt_opt parameters_opt = match parameters_opt with | None -> None, None | Some p -> - Some (Remanent_parameters.get_trace p), - Loggers.formatter_of_logger - (Remanent_parameters.get_logger p) - -let is_pattern_invariant_internal_states_permutation - ?parameters ~env - ~agent_type ~site1 ~site2 - id cache = + ( Some (Remanent_parameters.get_trace p), + Loggers.formatter_of_logger (Remanent_parameters.get_logger p) ) + +let is_pattern_invariant_internal_states_permutation ?parameters ~env + ~agent_type ~site1 ~site2 id cache = let lkappa_rule = Patterns_extra.pattern_id_to_lkappa_rule ?parameters env id in let sigs = Model.signatures env in let trace, fmt = get_trace_opt_fmt_opt parameters in - LKappa_group_action.is_invariant_internal_states_permutation - ?trace ?fmt - ~sigs - ~agent_type - ~site1 - ~site2 - lkappa_rule - cache + LKappa_group_action.is_invariant_internal_states_permutation ?trace ?fmt ~sigs + ~agent_type ~site1 ~site2 lkappa_rule cache -let is_pattern_invariant_binding_states_permutation - ?parameters ~env - ~agent_type ~site1 ~site2 - id cache = +let is_pattern_invariant_binding_states_permutation ?parameters ~env ~agent_type + ~site1 ~site2 id cache = let sigs = Model.signatures env in let lkappa_rule = Patterns_extra.pattern_id_to_lkappa_rule ?parameters env id in let trace, fmt = get_trace_opt_fmt_opt parameters in - LKappa_group_action.is_invariant_binding_states_permutation - ?trace ?fmt - ~sigs - ~agent_type - ~site1 - ~site2 - lkappa_rule - cache + LKappa_group_action.is_invariant_binding_states_permutation ?trace ?fmt ~sigs + ~agent_type ~site1 ~site2 lkappa_rule cache -let is_pattern_invariant_full_states_permutation - ?parameters ~env - ~agent_type ~site1 ~site2 - id cache = +let is_pattern_invariant_full_states_permutation ?parameters ~env ~agent_type + ~site1 ~site2 id cache = let sigs = Model.signatures env in let lkappa_rule = Patterns_extra.pattern_id_to_lkappa_rule ?parameters env id in let trace, fmt = get_trace_opt_fmt_opt parameters in - LKappa_group_action.is_invariant_full_states_permutation - ?trace ?fmt - ~sigs - ~agent_type - ~site1 - ~site2 - lkappa_rule - cache + LKappa_group_action.is_invariant_full_states_permutation ?trace ?fmt ~sigs + ~agent_type ~site1 ~site2 lkappa_rule cache -let equiv_class_gen - ?parameters - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states - to_rule - from_rule - sigma - cache - preenv - seen - species = - let _ = parameters in +let equiv_class_gen ?parameters ~partitions_internal_states + ~partitions_binding_states ~partitions_full_states to_rule from_rule sigma + cache preenv seen species = + let _ = parameters in let convention = Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs in - let rule, unspec = to_rule species in + let rule, unspec = to_rule species in let cache, seen, rule_class = - LKappa_group_action.equiv_class - cache seen rule - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states - ~convention + LKappa_group_action.equiv_class cache seen rule ~partitions_internal_states + ~partitions_binding_states ~partitions_full_states ~convention in let preenv, l = List.fold_left - (fun (preenv,l) (rule,w) -> - let preenv, species, id = - from_rule - preenv rule unspec - in - preenv,(sigma (species,id,w))::l) - (preenv, []) - (List.rev rule_class) + (fun (preenv, l) (rule, w) -> + let preenv, species, id = from_rule preenv rule unspec in + preenv, sigma (species, id, w) :: l) + (preenv, []) (List.rev rule_class) in cache, preenv, seen, l @@ -483,28 +400,15 @@ let equiv_class_of_a_species cache, preenv, seen, l *) -let equiv_class_of_a_species - ?parameters ~sigs - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states - cache - preenv - seen - species = - equiv_class_gen - ?parameters - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states +let equiv_class_of_a_species ?parameters ~sigs ~partitions_internal_states + ~partitions_binding_states ~partitions_full_states cache preenv seen species + = + equiv_class_gen ?parameters ~partitions_internal_states + ~partitions_binding_states ~partitions_full_states (Patterns_extra.species_to_lkappa_rule_and_unspec ?parameters ~sigs) - (fun a b c -> - Patterns_extra.raw_mixture_to_species a b.LKappa.r_created c) - (fun (a,_,_) -> a) - cache - preenv - seen - species + (fun a b c -> Patterns_extra.raw_mixture_to_species a b.LKappa.r_created c) + (fun (a, _, _) -> a) + cache preenv seen species (* let equiv_class_of_a_pattern @@ -534,30 +438,16 @@ let equiv_class_of_a_pattern seen cc*) - -let equiv_class_of_a_pattern - ?parameters - ~env - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states - cache - preenv - seen - species = +let equiv_class_of_a_pattern ?parameters ~env ~partitions_internal_states + ~partitions_binding_states ~partitions_full_states cache preenv seen species + = let sigs = Some (Model.signatures env) in - equiv_class_gen - ?parameters - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states + equiv_class_gen ?parameters ~partitions_internal_states + ~partitions_binding_states ~partitions_full_states (fun pattern -> - Patterns_extra.pattern_id_to_lkappa_rule_and_unspec - ?parameters env pattern) + Patterns_extra.pattern_id_to_lkappa_rule_and_unspec ?parameters env + pattern) (fun a b c -> - Patterns_extra.mixture_to_pattern ?parameters ?sigs a b.LKappa.r_mix c) - (fun (_,a,b) -> (a,b)) - cache - preenv - seen - species + Patterns_extra.mixture_to_pattern ?parameters ?sigs a b.LKappa.r_mix c) + (fun (_, a, b) -> a, b) + cache preenv seen species diff --git a/core/symmetries/pattern_group_action.mli b/core/symmetries/pattern_group_action.mli index cfd1edb233..893fa9b7f7 100644 --- a/core/symmetries/pattern_group_action.mli +++ b/core/symmetries/pattern_group_action.mli @@ -13,7 +13,7 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) -val normalize_species: +val normalize_species : ?parameters:Remanent_parameters_sig.parameters -> sigs:Signature.s -> LKappa_auto.cache -> @@ -22,7 +22,7 @@ val normalize_species: Pattern.cc -> LKappa_auto.cache * Pattern.PreEnv.t * Pattern.cc -val is_pattern_invariant_internal_states_permutation: +val is_pattern_invariant_internal_states_permutation : ?parameters:Remanent_parameters_sig.parameters -> env:Model.t -> agent_type:int -> @@ -32,7 +32,7 @@ val is_pattern_invariant_internal_states_permutation: LKappa_auto.cache -> LKappa_auto.cache * bool -val is_pattern_invariant_binding_states_permutation: +val is_pattern_invariant_binding_states_permutation : ?parameters:Remanent_parameters_sig.parameters -> env:Model.t -> agent_type:int -> @@ -42,7 +42,7 @@ val is_pattern_invariant_binding_states_permutation: LKappa_auto.cache -> LKappa_auto.cache * bool -val is_pattern_invariant_full_states_permutation: +val is_pattern_invariant_full_states_permutation : ?parameters:Remanent_parameters_sig.parameters -> env:Model.t -> agent_type:int -> @@ -52,7 +52,7 @@ val is_pattern_invariant_full_states_permutation: LKappa_auto.cache -> LKappa_auto.cache * bool -val equiv_class_of_a_pattern: +val equiv_class_of_a_pattern : ?parameters:Remanent_parameters_sig.parameters -> env:Model.t -> partitions_internal_states:(int -> int list list) -> @@ -62,11 +62,12 @@ val equiv_class_of_a_pattern: Pattern.PreEnv.t -> bool Mods.DynArray.t -> Pattern.id -> - LKappa_auto.cache * Pattern.PreEnv.t * bool Mods.DynArray.t * - (Pattern.id*int) list + LKappa_auto.cache + * Pattern.PreEnv.t + * bool Mods.DynArray.t + * (Pattern.id * int) list - -val equiv_class_of_a_species: +val equiv_class_of_a_species : ?parameters:Remanent_parameters_sig.parameters -> sigs:Signature.s -> partitions_internal_states:(int -> int list list) -> diff --git a/core/symmetries/patterns_extra.ml b/core/symmetries/patterns_extra.ml index 692447c648..e0aca73a38 100644 --- a/core/symmetries/patterns_extra.ml +++ b/core/symmetries/patterns_extra.ml @@ -1,40 +1,40 @@ let local_trace = false let do_trace parameters = - local_trace || - (match parameters with - | None -> false - | Some p -> Remanent_parameters.get_trace p) + local_trace + || + match parameters with + | None -> false + | Some p -> Remanent_parameters.get_trace p let trace_print ?parameters x = let get_trace, fmt_opt = match parameters with | None -> false, Some Format.err_formatter | Some parameters -> - Remanent_parameters.get_trace parameters, - Loggers.formatter_of_logger (Remanent_parameters.get_logger parameters) + ( Remanent_parameters.get_trace parameters, + Loggers.formatter_of_logger (Remanent_parameters.get_logger parameters) + ) in - if local_trace || get_trace - then - match fmt_opt with - | Some fmt -> - Format.fprintf fmt "%s\n" x - | None -> () + if local_trace || get_trace then ( + match fmt_opt with + | Some fmt -> Format.fprintf fmt "%s\n" x + | None -> () + ) -let safe_print_str (i,j,k,l) ?parameters print print2 = - if do_trace parameters - then +let safe_print_str (i, j, k, l) ?parameters print print2 = + if do_trace parameters then ( try let () = print Format.str_formatter in let s = Format.flush_str_formatter () in let () = trace_print ?parameters s in () - with - | _ -> + with _ -> let () = - Format.fprintf - Format.str_formatter - "An error has been encountered (%s,%i,%i,%i)\n Dumping while ignoring the signature\n" i j k l + Format.fprintf Format.str_formatter + "An error has been encountered (%s,%i,%i,%i)\n\ + \ Dumping while ignoring the signature\n" + i j k l in let s = Format.flush_str_formatter () in let () = trace_print ?parameters s in @@ -42,20 +42,18 @@ let safe_print_str (i,j,k,l) ?parameters print print2 = let s = Format.flush_str_formatter () in let () = trace_print ?parameters s in () + ) let declare_bond work ag_pos site bond_id map = match Mods.IntMap.find_option bond_id map with - | None -> - work, Mods.IntMap.add bond_id [ag_pos,site] map + | None -> work, Mods.IntMap.add bond_id [ ag_pos, site ] map | Some old -> let site1 = ag_pos, site in - begin - match old with - [site2] -> - Pattern.new_link work site1 site2, - Mods.IntMap.add bond_id ((ag_pos,site)::old) map - | [] | _ :: _ :: _ -> assert false - end + (match old with + | [ site2 ] -> + ( Pattern.new_link work site1 site2, + Mods.IntMap.add bond_id ((ag_pos, site) :: old) map ) + | [] | _ :: _ :: _ -> assert false) let raw_mixture_to_species ?parameters ?sigs preenv mix unspec = let noCounters = do_trace parameters in @@ -65,65 +63,56 @@ let raw_mixture_to_species ?parameters ?sigs preenv mix unspec = match sigs with | None -> () | Some sigs -> - safe_print_str - __POS__ - ?parameters + safe_print_str __POS__ ?parameters (fun fmt -> - Raw_mixture.print - ~noCounters ~created:false ~initial_comma:false ~sigs fmt mix) + Raw_mixture.print ~noCounters ~created:false ~initial_comma:false + ~sigs fmt mix) (fun fmt -> - Raw_mixture.print - ~noCounters ~created:false ~initial_comma:false fmt mix) + Raw_mixture.print ~noCounters ~created:false ~initial_comma:false fmt + mix) in let unspec = List.fold_left (fun map k -> Mods.Int2Set.add k map) - Mods.Int2Set.empty - unspec + Mods.Int2Set.empty unspec in let work = Pattern.begin_new preenv in - let rec aux ag_id tail (work,bond_map) = + let rec aux ag_id tail (work, bond_map) = match tail with - | [] -> work,bond_map - | mixture_agent::tail -> - let () = trace_print - (string_of_int mixture_agent.Raw_mixture.a_type) in - let pattern_agent,work = + | [] -> work, bond_map + | mixture_agent :: tail -> + let () = trace_print (string_of_int mixture_agent.Raw_mixture.a_type) in + let pattern_agent, work = Pattern.new_node work mixture_agent.Raw_mixture.a_type in let work = Tools.array_fold_lefti (fun site work state -> - match state with - | None -> work - | Some state -> - Pattern.new_internal_state work - (pattern_agent, site) state) - work - mixture_agent.Raw_mixture.a_ints + match state with + | None -> work + | Some state -> + Pattern.new_internal_state work (pattern_agent, site) state) + work mixture_agent.Raw_mixture.a_ints in - let work,bond_map = + let work, bond_map = Tools.array_fold_lefti - (fun site (work,bond_map) state -> - match state with - | Raw_mixture.FREE -> - if - Mods.Int2Set.mem - (mixture_agent.Raw_mixture.a_type, site) - unspec - then - work, bond_map - else - Pattern.new_free work (pattern_agent,site), bond_map - | Raw_mixture.VAL i -> - declare_bond work pattern_agent site i bond_map) - (work, bond_map) - mixture_agent.Raw_mixture.a_ports + (fun site (work, bond_map) state -> + match state with + | Raw_mixture.FREE -> + if + Mods.Int2Set.mem (mixture_agent.Raw_mixture.a_type, site) unspec + then + work, bond_map + else + Pattern.new_free work (pattern_agent, site), bond_map + | Raw_mixture.VAL i -> + declare_bond work pattern_agent site i bond_map) + (work, bond_map) mixture_agent.Raw_mixture.a_ports in aux (ag_id + 1) tail (work, bond_map) in let work, _bond_map = aux 0 mix (work, Mods.IntMap.empty) in - let (a, _, b, c) = Pattern.finish_new ~debugMode:noCounters work in + let a, _, b, c = Pattern.finish_new ~debug_mode:noCounters work in let () = match sigs with | None -> () @@ -133,8 +122,10 @@ let raw_mixture_to_species ?parameters ?sigs preenv mix unspec = safe_print_str __POS__ ?parameters (fun fmt -> Pattern.print_cc ~noCounters ~sigs ~with_id:false fmt b) (fun fmt -> Pattern.print_cc ~noCounters ~with_id:false fmt b) - in () - in (a, b, c) + in + () + in + a, b, c let mixture_to_pattern ?parameters ?sigs preenv mix unspec = let noCounters = do_trace parameters in @@ -144,141 +135,124 @@ let mixture_to_pattern ?parameters ?sigs preenv mix unspec = match sigs with | None -> Format.fprintf Format.std_formatter "No sigs @." | Some sigs -> - safe_print_str - __POS__ - ?parameters + safe_print_str __POS__ ?parameters (fun fmt -> - LKappa.print_rule_mixture ~noCounters ~ltypes:true sigs [] fmt mix) + LKappa.print_rule_mixture ~noCounters ~ltypes:true sigs [] fmt mix) (fun fmt -> - LKappa.print_rule_mixture ~noCounters ~ltypes:true sigs [] fmt mix) + LKappa.print_rule_mixture ~noCounters ~ltypes:true sigs [] fmt mix) in let unspec = List.fold_left (fun map k -> Mods.Int2Set.add k map) - Mods.Int2Set.empty - unspec + Mods.Int2Set.empty unspec in let work = Pattern.begin_new preenv in - let rec aux ag_id tail (work,bond_map) = + let rec aux ag_id tail (work, bond_map) = match tail with - | [] -> work,bond_map - | mixture_agent::tail -> - let () = - trace_print - (string_of_int mixture_agent.LKappa.ra_type) - in - let pattern_agent,work = + | [] -> work, bond_map + | mixture_agent :: tail -> + let () = trace_print (string_of_int mixture_agent.LKappa.ra_type) in + let pattern_agent, work = Pattern.new_node work mixture_agent.LKappa.ra_type in let work = Tools.array_fold_lefti (fun site work state -> - match state with - | LKappa.I_ANY -> work - | LKappa.I_VAL_CHANGED (i,j) when i=j -> - Pattern.new_internal_state work (pattern_agent, site) i - | LKappa.I_ANY_CHANGED _ - | LKappa.I_ANY_ERASED - | LKappa.I_VAL_CHANGED _ - | LKappa.I_VAL_ERASED _ -> assert false) - work - mixture_agent.LKappa.ra_ints + match state with + | LKappa.I_ANY -> work + | LKappa.I_VAL_CHANGED (i, j) when i = j -> + Pattern.new_internal_state work (pattern_agent, site) i + | LKappa.I_ANY_CHANGED _ | LKappa.I_ANY_ERASED + | LKappa.I_VAL_CHANGED _ | LKappa.I_VAL_ERASED _ -> + assert false) + work mixture_agent.LKappa.ra_ints in - let work,bond_map = + let work, bond_map = Tools.array_fold_lefti - (fun site (work,bond_map) state -> - match state with - | (LKappa.ANY_FREE,_), LKappa.Maintained -> work,bond_map - | (LKappa.LNK_VALUE (i,_),_) , LKappa.Maintained -> - declare_bond work pattern_agent site i bond_map - | (LKappa.LNK_FREE,_), LKappa.Maintained -> - if Mods.Int2Set.mem - (mixture_agent.LKappa.ra_type,site) - unspec - then - work, bond_map - else - Pattern.new_free work (pattern_agent,site), bond_map - | - ((LKappa.LNK_ANY - | LKappa.LNK_SOME - | LKappa.LNK_TYPE _),_),_ - | _,(LKappa.Linked _ | LKappa.Freed | LKappa.Erased) - -> assert false) - (work, bond_map) - mixture_agent.LKappa.ra_ports + (fun site (work, bond_map) state -> + match state with + | (LKappa.ANY_FREE, _), LKappa.Maintained -> work, bond_map + | (LKappa.LNK_VALUE (i, _), _), LKappa.Maintained -> + declare_bond work pattern_agent site i bond_map + | (LKappa.LNK_FREE, _), LKappa.Maintained -> + if Mods.Int2Set.mem (mixture_agent.LKappa.ra_type, site) unspec + then + work, bond_map + else + Pattern.new_free work (pattern_agent, site), bond_map + | ((LKappa.LNK_ANY | LKappa.LNK_SOME | LKappa.LNK_TYPE _), _), _ + | _, (LKappa.Linked _ | LKappa.Freed | LKappa.Erased) -> + assert false) + (work, bond_map) mixture_agent.LKappa.ra_ports in aux (ag_id + 1) tail (work, bond_map) in let work, _bond_map = aux 0 mix (work, Mods.IntMap.empty) in - let (a, _, b, c) = Pattern.finish_new ~debugMode:noCounters work in + let a, _, b, c = Pattern.finish_new ~debug_mode:noCounters work in let () = match sigs with | None -> () | Some sigs -> let () = trace_print ?parameters "OUTPUT:" in let () = - if noCounters then let _ = Pattern.id_to_yojson c in () in + if noCounters then ( + let _ = Pattern.id_to_yojson c in + () + ) + in let () = safe_print_str __POS__ ?parameters (fun fmt -> Pattern.print_cc ~noCounters ~sigs ~with_id:true fmt b) (fun fmt -> Pattern.print_cc ~noCounters ~with_id:true fmt b) - in () - in (a, b, c) + in + () + in + a, b, c let add_map i j map = -let old = - Mods.IntMap.find_default [] i map -in -Mods.IntMap.add i (j::old) map + let old = Mods.IntMap.find_default [] i map in + Mods.IntMap.add i (j :: old) map let top_sort_gen get_val get_ports list = let array = Array.of_list list in - let (map1,map2,set,empty) = + let map1, map2, set, empty = Tools.array_fold_lefti - (fun pos (map1,map2,set,empty) agent -> - let intf = get_ports agent in - if Array.length intf = 0 - then - map1,map2,set,agent::empty - else - Tools.array_fold_lefti - (fun _ (map1, map2, set,empty) value -> - match get_val value with - | Some i -> - add_map i pos map1, - add_map pos i map2, - pos :: set, - empty - | None - -> map1, map2, pos::set,empty) - (map1, map2, set, empty) - (get_ports agent)) - (Mods.IntMap.empty,Mods.IntMap.empty,[],[]) + (fun pos (map1, map2, set, empty) agent -> + let intf = get_ports agent in + if Array.length intf = 0 then + map1, map2, set, agent :: empty + else + Tools.array_fold_lefti + (fun _ (map1, map2, set, empty) value -> + match get_val value with + | Some i -> + add_map i pos map1, add_map pos i map2, pos :: set, empty + | None -> map1, map2, pos :: set, empty) + (map1, map2, set, empty) (get_ports agent)) + (Mods.IntMap.empty, Mods.IntMap.empty, [], []) array in let rec aux to_do black_listed list = match to_do with | [] -> List.rev list - | h::t when Mods.IntSet.mem h black_listed -> - aux t black_listed list - | h::t -> - let link_list = - Mods.IntMap.find_default [] h map2 - in + | h :: t when Mods.IntSet.mem h black_listed -> aux t black_listed list + | h :: t -> + let link_list = Mods.IntMap.find_default [] h map2 in let t = List.fold_left (fun list link -> - List.fold_left (fun list pos -> pos :: list) list - (Mods.IntMap.find_default [] link map1) - ) t link_list + List.fold_left + (fun list pos -> pos :: list) + list + (Mods.IntMap.find_default [] link map1)) + t link_list in let black_listed = Mods.IntSet.add h black_listed in - aux t black_listed (array.(h)::list) + aux t black_listed (array.(h) :: list) in match set with | [] -> empty - | head :: _ -> aux [head] Mods.IntSet.empty empty + | head :: _ -> aux [ head ] Mods.IntSet.empty empty let top_sort_raw_mixture list = top_sort_gen @@ -291,337 +265,282 @@ let top_sort_raw_mixture list = let top_sort_mixture list = top_sort_gen (function - | (LKappa.LNK_VALUE (i,_),_),_ -> Some i - | ((LKappa.ANY_FREE | LKappa.LNK_FREE | LKappa.LNK_ANY - | LKappa.LNK_SOME | LKappa.LNK_TYPE (_, _)),_),_ -> None) + | (LKappa.LNK_VALUE (i, _), _), _ -> Some i + | ( ( ( LKappa.ANY_FREE | LKappa.LNK_FREE | LKappa.LNK_ANY + | LKappa.LNK_SOME + | LKappa.LNK_TYPE (_, _) ), + _ ), + _ ) -> + None) (fun x -> x.LKappa.ra_ports) list let parse pattern = let agent_list, site_list = - Pattern.fold_by_type + Pattern.fold_by_type (fun ~pos ~agent_type intf (agent_list, site_list) -> - ((pos, agent_type) :: agent_list, + ( (pos, agent_type) :: agent_list, Tools.array_fold_lefti - (fun site site_list state -> - (pos, site, state) :: site_list) - site_list - intf)) + (fun site site_list state -> (pos, site, state) :: site_list) + site_list intf )) pattern ([], []) in let bond_map = let rec aux tail fresh_bond_id bond_map = match tail with | [] -> bond_map - | (_, _, ((Pattern.Free | Pattern.UnSpec), _)) :: tail - -> aux tail fresh_bond_id bond_map + | (_, _, ((Pattern.Free | Pattern.UnSpec), _)) :: tail -> + aux tail fresh_bond_id bond_map | (pos, site, (Pattern.Link (ag_pos', site'), _)) :: tail -> - match - Mods.Int2Map.find_option (ag_pos', site') bond_map - with + (match Mods.Int2Map.find_option (ag_pos', site') bond_map with | None -> aux tail (succ fresh_bond_id) (Mods.Int2Map.add (pos, site) fresh_bond_id bond_map) | Some i -> let () = trace_print (string_of_int i) in - aux - tail - fresh_bond_id - (Mods.Int2Map.add (pos, site) i bond_map) + aux tail fresh_bond_id (Mods.Int2Map.add (pos, site) i bond_map)) in aux site_list 0 Mods.Int2Map.empty in let agent_type_map = Mods.IntMap.empty in let agent_type_map = List.fold_left - (fun map (pos, agent_type) -> - Mods.IntMap.add pos agent_type map) - agent_type_map - agent_list + (fun map (pos, agent_type) -> Mods.IntMap.add pos agent_type map) + agent_type_map agent_list in agent_list, site_list, agent_type_map, bond_map let species_to_raw_mixture ?parameters ~sigs pattern = let noCounters = do_trace parameters in - let () = trace_print ?parameters - "Translation from patten to raw_mixture" in + let () = trace_print ?parameters "Translation from patten to raw_mixture" in let () = let () = trace_print ?parameters "INPUT:" in let () = - safe_print_str - __POS__ ?parameters - (fun fmt -> - Pattern.print_cc ~noCounters ~sigs ~with_id:false fmt pattern) + safe_print_str __POS__ ?parameters (fun fmt -> - Pattern.print_cc ~noCounters ~with_id:false fmt pattern) - in () - in - let _agent_list, site_list, agent_type_map, bond_map = - parse pattern + Pattern.print_cc ~noCounters ~sigs ~with_id:false fmt pattern) + (fun fmt -> Pattern.print_cc ~noCounters ~with_id:false fmt pattern) + in + () in + let _agent_list, site_list, agent_type_map, bond_map = parse pattern in let agent_map = Mods.IntMap.map (fun ag_type -> - let () = trace_print (string_of_int ag_type) in - let n_site = - if ag_type = -1 - then - 0 - else - Signature.arity sigs ag_type - in - Array.make n_site (Raw_mixture.FREE, None) - ) agent_type_map + let () = trace_print (string_of_int ag_type) in + let n_site = + if ag_type = -1 then + 0 + else + Signature.arity sigs ag_type + in + Array.make n_site (Raw_mixture.FREE, None)) + agent_type_map in let rec aux tail unspec = match tail with | [] -> Some (agent_map, unspec) | (pos, site, (binding_state, int_state)) :: tail -> let int_state = - if int_state = -1 - then None - else Some int_state + if int_state = -1 then + None + else + Some int_state in - match binding_state with + (match binding_state with | Pattern.UnSpec -> let () = trace_print (string_of_int pos) in let () = trace_print (string_of_int site) in let () = - match - Mods.IntMap.find_option pos agent_map - with + match Mods.IntMap.find_option pos agent_map with | None -> raise Exit - | Some array -> - array.(site) <- (Raw_mixture.FREE, int_state) - in - let agent_type = - Mods.IntMap.find_default (-1) pos agent_type_map + | Some array -> array.(site) <- Raw_mixture.FREE, int_state in + let agent_type = Mods.IntMap.find_default (-1) pos agent_type_map in aux tail ((agent_type, site) :: unspec) - | Pattern.Free -> + | Pattern.Free -> let () = trace_print (string_of_int pos) in let () = trace_print (string_of_int site) in let () = - match - Mods.IntMap.find_option pos agent_map - with + match Mods.IntMap.find_option pos agent_map with | None -> raise Exit - | Some array -> - array.(site) <- (Raw_mixture.FREE, int_state) + | Some array -> array.(site) <- Raw_mixture.FREE, int_state in aux tail unspec | Pattern.Link _ -> - begin - match - Mods.Int2Map.find_option (pos,site) bond_map - with - | None -> assert false - | Some i -> - let () = - match - Mods.IntMap.find_option pos agent_map - with - | None -> raise Exit - | Some array -> - array.(site) <- (Raw_mixture.VAL i, int_state) - in - aux tail unspec - end + (match Mods.Int2Map.find_option (pos, site) bond_map with + | None -> assert false + | Some i -> + let () = + match Mods.IntMap.find_option pos agent_map with + | None -> raise Exit + | Some array -> array.(site) <- Raw_mixture.VAL i, int_state + in + aux tail unspec)) in match aux site_list [] with | None -> None | Some (agent_map, unspec) -> - begin - let (), list = - Mods.IntMap.monadic_fold2 - () () - (fun () () _ agent_type intf agent_list -> - let internal = Array.map snd intf in - let binding = Array.map fst intf in - (), - ({ - Raw_mixture.a_type = agent_type ; - a_ports = binding ; - a_ints = internal ; - } :: agent_list)) - (fun () () _ _ agent_list -> - let () = - safe_print_str - __POS__ ?parameters (fun _fmt -> raise Exit) - (fun _fmt -> ()) - in - (), agent_list) - (fun () () _ _ agent_list -> - let () = - safe_print_str - __POS__ ?parameters (fun _fmt -> raise Exit) - (fun _fmt -> ()) - in - (), agent_list) - agent_type_map agent_map [] - in - let output = top_sort_raw_mixture list in - let () = trace_print ?parameters "OUTPUT:" in - let () = - safe_print_str - __POS__ ?parameters - (fun fmt -> - Raw_mixture.print - ~noCounters ~created:false ~initial_comma:false ~sigs fmt output) - (fun fmt -> Raw_mixture.print - ~noCounters ~created:false ~initial_comma:false fmt output) - in - Some (output, unspec) - end + let (), list = + Mods.IntMap.monadic_fold2 () () + (fun () () _ agent_type intf agent_list -> + let internal = Array.map snd intf in + let binding = Array.map fst intf in + ( (), + { + Raw_mixture.a_type = agent_type; + a_ports = binding; + a_ints = internal; + } + :: agent_list )) + (fun () () _ _ agent_list -> + let () = + safe_print_str __POS__ ?parameters + (fun _fmt -> raise Exit) + (fun _fmt -> ()) + in + (), agent_list) + (fun () () _ _ agent_list -> + let () = + safe_print_str __POS__ ?parameters + (fun _fmt -> raise Exit) + (fun _fmt -> ()) + in + (), agent_list) + agent_type_map agent_map [] + in + let output = top_sort_raw_mixture list in + let () = trace_print ?parameters "OUTPUT:" in + let () = + safe_print_str __POS__ ?parameters + (fun fmt -> + Raw_mixture.print ~noCounters ~created:false ~initial_comma:false + ~sigs fmt output) + (fun fmt -> + Raw_mixture.print ~noCounters ~created:false ~initial_comma:false fmt + output) + in + Some (output, unspec) let pattern_to_mixture ?parameters ~sigs pattern = let noCounters = do_trace parameters in let () = trace_print ?parameters "Translation from pattern to mixture" in let () = trace_print ?parameters "INPUT:" in let () = - safe_print_str - __POS__ ?parameters - (fun fmt -> - Pattern.print_cc ~noCounters ~sigs ~with_id:false fmt pattern) - (fun fmt -> Pattern.print_cc ~noCounters ~with_id:false fmt pattern) - in - let _agent_list, site_list, agent_type_map, bond_map = - parse pattern + safe_print_str __POS__ ?parameters + (fun fmt -> Pattern.print_cc ~noCounters ~sigs ~with_id:false fmt pattern) + (fun fmt -> Pattern.print_cc ~noCounters ~with_id:false fmt pattern) in + let _agent_list, site_list, agent_type_map, bond_map = parse pattern in let agent_map = Mods.IntMap.map (fun ag_type -> - let () = trace_print (string_of_int ag_type) in - let n_site = - if ag_type = -1 - then - 0 - else - Signature.arity sigs ag_type - in - Array.make n_site (LKappa.ANY_FREE, None) - ) agent_type_map - in - let rec aux tail unspec= + let () = trace_print (string_of_int ag_type) in + let n_site = + if ag_type = -1 then + 0 + else + Signature.arity sigs ag_type + in + Array.make n_site (LKappa.ANY_FREE, None)) + agent_type_map + in + let rec aux tail unspec = match tail with | [] -> Some (agent_map, unspec) | (pos, site, (binding_state, int_state)) :: tail -> let int_state = - if int_state = -1 - then None - else Some int_state + if int_state = -1 then + None + else + Some int_state in - match binding_state with + (match binding_state with | Pattern.UnSpec -> let () = trace_print (string_of_int pos) in let () = trace_print (string_of_int site) in let () = - match - Mods.IntMap.find_option pos agent_map - with + match Mods.IntMap.find_option pos agent_map with | None -> raise Exit - | Some array -> - array.(site) <- (LKappa.ANY_FREE, int_state) - in - let agent_type = - Mods.IntMap.find_default (-1) pos agent_type_map + | Some array -> array.(site) <- LKappa.ANY_FREE, int_state in - aux tail ((agent_type,site) :: unspec) - | Pattern.Free -> + let agent_type = Mods.IntMap.find_default (-1) pos agent_type_map in + aux tail ((agent_type, site) :: unspec) + | Pattern.Free -> let () = trace_print (string_of_int pos) in let () = trace_print (string_of_int site) in let () = - match - Mods.IntMap.find_option pos agent_map - with + match Mods.IntMap.find_option pos agent_map with | None -> raise Exit - | Some array -> - array.(site) <- (LKappa.LNK_FREE, int_state) + | Some array -> array.(site) <- LKappa.LNK_FREE, int_state in aux tail unspec | Pattern.Link _ -> - begin - match - Mods.Int2Map.find_option (pos,site) bond_map - with - | None -> assert false - | Some i -> - let () = - match - Mods.IntMap.find_option pos agent_map - with - | None -> raise Exit - | Some array -> - array.(site) <- (LKappa.LNK_VALUE (i,(0,0)), int_state) - in - aux tail unspec - end + (match Mods.Int2Map.find_option (pos, site) bond_map with + | None -> assert false + | Some i -> + let () = + match Mods.IntMap.find_option pos agent_map with + | None -> raise Exit + | Some array -> + array.(site) <- LKappa.LNK_VALUE (i, (0, 0)), int_state + in + aux tail unspec)) in - match - aux site_list [] - with + match aux site_list [] with | None -> None - | Some (agent_map, unspec)-> - begin - let (), list = - Mods.IntMap.monadic_fold2 - () () - (fun () () _ agent_type intf agent_list -> - let fst (a,_) = ((a,Locality.dummy),LKappa.Maintained) in - let snd (_,b) = - match b with - | None -> LKappa.I_ANY - | Some b -> LKappa.I_VAL_CHANGED (b,b) in - let binding = Array.map fst intf in - let internal = Array.map snd intf in - (), - ({ - LKappa.ra_erased = false ; - LKappa.ra_syntax = None ; - LKappa.ra_type = agent_type ; - LKappa.ra_ports = binding ; - LKappa.ra_ints = internal ; - } :: agent_list)) - (fun () () _ _ agent_list -> - let () = - safe_print_str - __POS__ ?parameters (fun _fmt -> raise Exit) - (fun _fmt -> ()) - in - (), agent_list) - (fun () () _ _ agent_list -> - let () = - safe_print_str - __POS__ ?parameters (fun _fmt -> raise Exit) - (fun _fmt -> ()) - in - (), agent_list) - agent_type_map - agent_map - [] - in - let output = top_sort_mixture list in - let () = trace_print ?parameters "OUTPUT:" in - let () = - safe_print_str - __POS__ ?parameters - (fun fmt -> - LKappa.print_rule_mixture - ~noCounters sigs ~ltypes:false [] fmt output) - (fun fmt -> - LKappa.print_rule_mixture - ~noCounters sigs ~ltypes:false [] fmt output) - in - Some (output, unspec) - end + | Some (agent_map, unspec) -> + let (), list = + Mods.IntMap.monadic_fold2 () () + (fun () () _ agent_type intf agent_list -> + let fst (a, _) = (a, Loc.dummy), LKappa.Maintained in + let snd (_, b) = + match b with + | None -> LKappa.I_ANY + | Some b -> LKappa.I_VAL_CHANGED (b, b) + in + let binding = Array.map fst intf in + let internal = Array.map snd intf in + ( (), + { + LKappa.ra_erased = false; + LKappa.ra_syntax = None; + LKappa.ra_type = agent_type; + LKappa.ra_ports = binding; + LKappa.ra_ints = internal; + } + :: agent_list )) + (fun () () _ _ agent_list -> + let () = + safe_print_str __POS__ ?parameters + (fun _fmt -> raise Exit) + (fun _fmt -> ()) + in + (), agent_list) + (fun () () _ _ agent_list -> + let () = + safe_print_str __POS__ ?parameters + (fun _fmt -> raise Exit) + (fun _fmt -> ()) + in + (), agent_list) + agent_type_map agent_map [] + in + let output = top_sort_mixture list in + let () = trace_print ?parameters "OUTPUT:" in + let () = + safe_print_str __POS__ ?parameters + (fun fmt -> + LKappa.print_rule_mixture ~noCounters sigs ~ltypes:false [] fmt output) + (fun fmt -> + LKappa.print_rule_mixture ~noCounters sigs ~ltypes:false [] fmt output) + in + Some (output, unspec) let pattern_id_to_mixture ?parameters env id = let sigs = Model.signatures env in - let point_opt = - try - Some (Pattern.Env.get (Model.domain env) id) - with - | _ -> None + let point_opt = + try Some (Pattern.Env.get (Model.domain env) id) with _ -> None in match point_opt with | None -> None @@ -629,80 +548,63 @@ let pattern_id_to_mixture ?parameters env id = pattern_to_mixture ?parameters ~sigs (Pattern.Env.content point) let pattern_id_to_cc env id = - let point_opt = - try - Some (Pattern.Env.get (Model.domain env) id) - with - | _ -> None + let point_opt = + try Some (Pattern.Env.get (Model.domain env) id) with _ -> None in match point_opt with | None -> None | Some point -> Some (Pattern.Env.content point) -let lkappa_init = { - LKappa.r_mix = []; - LKappa.r_created = []; - LKappa.r_delta_tokens = [] ; - LKappa.r_rate = Alg_expr.int 0 ; - LKappa.r_un_rate = None ; - LKappa.r_editStyle = true ; -} +let lkappa_init = + { + LKappa.r_mix = []; + LKappa.r_created = []; + LKappa.r_delta_tokens = []; + LKappa.r_rate = Alg_expr.int 0; + LKappa.r_un_rate = None; + LKappa.r_edit_style = true; + } let raw_mixture_to_lkappa_rule raw_mixture = { - LKappa.r_mix = []; - LKappa.r_created = raw_mixture ; - LKappa.r_delta_tokens = [] ; - LKappa.r_rate = Alg_expr.int 0 ; - LKappa.r_un_rate = None ; - LKappa.r_editStyle = true ; + LKappa.r_mix = []; + LKappa.r_created = raw_mixture; + LKappa.r_delta_tokens = []; + LKappa.r_rate = Alg_expr.int 0; + LKappa.r_un_rate = None; + LKappa.r_edit_style = true; } let rule_mixture_to_lkappa_rule rule_mixture = { - LKappa.r_mix = rule_mixture; - LKappa.r_created = [] ; - LKappa.r_delta_tokens = [] ; - LKappa.r_rate = Alg_expr.int 0 ; - LKappa.r_un_rate = None ; - LKappa.r_editStyle = true ; + LKappa.r_mix = rule_mixture; + LKappa.r_created = []; + LKappa.r_delta_tokens = []; + LKappa.r_rate = Alg_expr.int 0; + LKappa.r_un_rate = None; + LKappa.r_edit_style = true; } (*convert a species into lkappa rule signature*) - let species_to_lkappa_rule_and_unspec ?parameters ~sigs species = - let some_pair = - species_to_raw_mixture - ?parameters - ~sigs - species - in - match some_pair with - | None -> lkappa_init, [] - | Some (raw_mixture, unspec) -> - let lkappa_rule = - raw_mixture_to_lkappa_rule raw_mixture - in - lkappa_rule, unspec + let some_pair = species_to_raw_mixture ?parameters ~sigs species in + match some_pair with + | None -> lkappa_init, [] + | Some (raw_mixture, unspec) -> + let lkappa_rule = raw_mixture_to_lkappa_rule raw_mixture in + lkappa_rule, unspec let species_to_lkappa_rule ?parameters ~sigs species = fst (species_to_lkappa_rule_and_unspec ?parameters ~sigs species) let pattern_to_lkappa_rule_and_unspec ?parameters ~sigs cc = - let some_pair = - pattern_to_mixture - ?parameters - ~sigs - cc - in + let some_pair = pattern_to_mixture ?parameters ~sigs cc in match some_pair with - | None -> lkappa_init,[] + | None -> lkappa_init, [] | Some (rule_mixture, unspec) -> - let lkappa_rule = - rule_mixture_to_lkappa_rule rule_mixture - in - lkappa_rule,unspec + let lkappa_rule = rule_mixture_to_lkappa_rule rule_mixture in + lkappa_rule, unspec let pattern_to_lkappa_rule ?parameters ~sigs cc = fst (pattern_to_lkappa_rule_and_unspec ?parameters ~sigs cc) @@ -718,5 +620,5 @@ let pattern_id_to_lkappa_rule ?parameters env id = let pattern_id_to_lkappa_rule_and_unspec ?parameters env id = let sigs = Model.signatures env in match pattern_id_to_cc env id with - | None -> lkappa_init,[] + | None -> lkappa_init, [] | Some cc -> pattern_to_lkappa_rule_and_unspec ?parameters ~sigs cc diff --git a/core/symmetries/patterns_extra.mli b/core/symmetries/patterns_extra.mli index 50ad62fe7e..ba4eaa6368 100644 --- a/core/symmetries/patterns_extra.mli +++ b/core/symmetries/patterns_extra.mli @@ -1,4 +1,4 @@ -val raw_mixture_to_species: +val raw_mixture_to_species : ?parameters:Remanent_parameters_sig.parameters -> ?sigs:Signature.s -> Pattern.PreEnv.t -> @@ -6,7 +6,7 @@ val raw_mixture_to_species: (int * int) list -> Pattern.PreEnv.t * Pattern.cc * Pattern.id -val mixture_to_pattern: +val mixture_to_pattern : ?parameters:Remanent_parameters_sig.parameters -> ?sigs:Signature.s -> Pattern.PreEnv.t -> @@ -14,45 +14,53 @@ val mixture_to_pattern: (int * int) list -> Pattern.PreEnv.t * Pattern.cc * Pattern.id -val species_to_raw_mixture: +val species_to_raw_mixture : ?parameters:Remanent_parameters_sig.parameters -> sigs:Signature.s -> - Pattern.cc -> (Raw_mixture.t * (int * int) list) option + Pattern.cc -> + (Raw_mixture.t * (int * int) list) option -val pattern_to_mixture: +val pattern_to_mixture : ?parameters:Remanent_parameters_sig.parameters -> sigs:Signature.s -> - Pattern.cc -> (LKappa.rule_mixture * (int * int) list) option + Pattern.cc -> + (LKappa.rule_mixture * (int * int) list) option -val pattern_id_to_mixture: +val pattern_id_to_mixture : ?parameters:Remanent_parameters_sig.parameters -> Model.t -> Pattern.id -> (LKappa.rule_mixture * (int * int) list) option -val pattern_id_to_cc: - Model.t -> - Pattern.id -> - Pattern.cc option - -val raw_mixture_to_lkappa_rule: Raw_mixture.t -> LKappa.rule +val pattern_id_to_cc : Model.t -> Pattern.id -> Pattern.cc option +val raw_mixture_to_lkappa_rule : Raw_mixture.t -> LKappa.rule -val species_to_lkappa_rule: - ?parameters:Remanent_parameters_sig.parameters -> sigs:Signature.s -> - Pattern.t -> LKappa.rule +val species_to_lkappa_rule : + ?parameters:Remanent_parameters_sig.parameters -> + sigs:Signature.s -> + Pattern.t -> + LKappa.rule -val species_to_lkappa_rule_and_unspec: - ?parameters:Remanent_parameters_sig.parameters -> sigs:Signature.s -> - Pattern.t -> LKappa.rule * (int * int) list +val species_to_lkappa_rule_and_unspec : + ?parameters:Remanent_parameters_sig.parameters -> + sigs:Signature.s -> + Pattern.t -> + LKappa.rule * (int * int) list val pattern_to_lkappa_rule : - ?parameters:Remanent_parameters_sig.parameters -> sigs:Signature.s -> - Pattern.cc -> LKappa.rule + ?parameters:Remanent_parameters_sig.parameters -> + sigs:Signature.s -> + Pattern.cc -> + LKappa.rule val pattern_id_to_lkappa_rule : ?parameters:Remanent_parameters_sig.parameters -> - Model.t -> Pattern.id -> LKappa.rule + Model.t -> + Pattern.id -> + LKappa.rule val pattern_id_to_lkappa_rule_and_unspec : ?parameters:Remanent_parameters_sig.parameters -> - Model.t -> Pattern.id -> LKappa.rule * (int * int) list + Model.t -> + Pattern.id -> + LKappa.rule * (int * int) list diff --git a/core/symmetries/rule_modes.ml b/core/symmetries/rule_modes.ml index 6fc56b7ddb..51d4d9997e 100644 --- a/core/symmetries/rule_modes.ml +++ b/core/symmetries/rule_modes.ml @@ -1,39 +1,30 @@ type arity = Usual | Unary | Unary_refinement type direction = Direct | Op -module RuleModeIdS: - SetMap.S with type elt = int * arity * direction - = - SetMap.Make - (struct - type t = int * arity * direction - let compare = compare - let print _ _ = () - end) +module RuleModeIdS : SetMap.S with type elt = int * arity * direction = +SetMap.Make (struct + type t = int * arity * direction + + let compare = compare + let print _ _ = () +end) module RuleModeIdSet = RuleModeIdS.Set -module RuleModeS: - SetMap.S with type elt = arity * direction - = - SetMap.Make - (struct - type t = arity * direction - let compare = compare - let print _ _ = () - end) +module RuleModeS : SetMap.S with type elt = arity * direction = +SetMap.Make (struct + type t = arity * direction + + let compare = compare + let print _ _ = () +end) module RuleModeMap = RuleModeS.Map let sum_map add map1 map2 = snd (RuleModeMap.monadic_fold2 () () - (fun () () key a1 a2 map -> - (),RuleModeMap.add - key (add a1 a2) map) - (fun () () key a1 map -> - (),RuleModeMap.add key a1 map) - (fun () () _ _ map -> (),map) - map1 - map2 - map2) + (fun () () key a1 a2 map -> (), RuleModeMap.add key (add a1 a2) map) + (fun () () key a1 map -> (), RuleModeMap.add key a1 map) + (fun () () _ _ map -> (), map) + map1 map2 map2) diff --git a/core/symmetries/rule_modes.mli b/core/symmetries/rule_modes.mli index c9280c57e9..b6076535ad 100644 --- a/core/symmetries/rule_modes.mli +++ b/core/symmetries/rule_modes.mli @@ -1,13 +1,8 @@ type arity = Usual | Unary | Unary_refinement type direction = Direct | Op -module RuleModeIdSet: - SetMap.Set with type elt = int * arity * direction +module RuleModeIdSet : SetMap.Set with type elt = int * arity * direction +module RuleModeMap : SetMap.Map with type elt = arity * direction -module RuleModeMap: - SetMap.Map with type elt = arity * direction - -val sum_map: - ('a -> 'a -> 'a) -> 'a RuleModeMap.t -> - 'a RuleModeMap.t -> - 'a RuleModeMap.t +val sum_map : + ('a -> 'a -> 'a) -> 'a RuleModeMap.t -> 'a RuleModeMap.t -> 'a RuleModeMap.t diff --git a/core/symmetries/symmetries.ml b/core/symmetries/symmetries.ml index 26e200488f..d49920464e 100644 --- a/core/symmetries/symmetries.ml +++ b/core/symmetries/symmetries.ml @@ -20,15 +20,13 @@ let local_trace = false (*internal states * binding states*) -type equivalence_classes = - int Symmetries_sig.site_partition array +type equivalence_classes = int Symmetries_sig.site_partition array -type symmetries = - { - rules: equivalence_classes; - rules_and_initial_states: equivalence_classes option; - rules_and_alg_expr: equivalence_classes option - } +type symmetries = { + rules: equivalence_classes; + rules_and_initial_states: equivalence_classes option; + rules_and_alg_expr: equivalence_classes option; +} type reduction = | Ground @@ -41,208 +39,185 @@ type reduction = let add_gen add find_option k data map = let old = - match - find_option k map - with + match find_option k map with | None -> [] | Some l -> l in - add k (data::old) map + add k (data :: old) map -let partition_gen - empty add find_option fold sort empty_range cache hash int_of_hash f list = +let partition_gen empty add find_option fold sort empty_range cache hash + int_of_hash f list = let map = fst (Array.fold_left - (fun (inverse,cache) site -> - let key = site.User_graph.site_name in - let data = - match site.User_graph.site_type with - | User_graph.Counter _ -> - failwith "KaSa does not deal with counters yet" - | User_graph.Port p -> - p.User_graph.port_states, p.User_graph.port_links - in - let range = f data in - if range = empty_range - then inverse, cache - else - let sorted_range = sort range in - let cache, hash = hash cache sorted_range in - let inverse = - add_gen - add find_option (int_of_hash hash) key inverse - in - inverse, cache - ) (empty, cache) list) + (fun (inverse, cache) site -> + let key = site.User_graph.site_name in + let data = + match site.User_graph.site_type with + | User_graph.Counter _ -> + failwith "KaSa does not deal with counters yet" + | User_graph.Port p -> + p.User_graph.port_states, p.User_graph.port_links + in + let range = f data in + if range = empty_range then + inverse, cache + else ( + let sorted_range = sort range in + let cache, hash = hash cache sorted_range in + let inverse = + add_gen add find_option (int_of_hash hash) key inverse + in + inverse, cache + )) + (empty, cache) list) in - List.rev (fold (fun _ l sol -> (List.rev l)::sol) map []) + List.rev (fold (fun _ l sol -> List.rev l :: sol) map []) let partition cache hash int_of_hash f map = - partition_gen - Mods.IntMap.empty - Mods.IntMap.add - Mods.IntMap.find_option - Mods.IntMap.fold - (List.sort compare) - [] - cache hash int_of_hash f map + partition_gen Mods.IntMap.empty Mods.IntMap.add Mods.IntMap.find_option + Mods.IntMap.fold (List.sort compare) [] cache hash int_of_hash f map let partition_pair cache hash int_of_hash f map = - partition_gen - Mods.Int2Map.empty - Mods.Int2Map.add - Mods.Int2Map.find_option + partition_gen Mods.Int2Map.empty Mods.Int2Map.add Mods.Int2Map.find_option Mods.Int2Map.fold - (fun (a,b) -> - List.sort compare a, - List.sort compare b) - ([],[]) - cache hash int_of_hash f map - -module State: SetMap.OrderedType - with type t = string - = -struct + (fun (a, b) -> List.sort compare a, List.sort compare b) + ([], []) cache hash int_of_hash f map + +module State : SetMap.OrderedType with type t = string = struct type t = string + let compare = compare let print f s = Format.fprintf f "%s" s end module StateList = Hashed_list.Make (State) -module BindingType: SetMap.OrderedType - with type t = (int * int) * int - = -struct - type t = (int*int)*int +module BindingType : SetMap.OrderedType with type t = (int * int) * int = struct + type t = (int * int) * int + let compare = compare - let print f ((ag_line,ag_row),s2) = Format.fprintf f "%i.%i.%i" ag_line ag_row s2 + + let print f ((ag_line, ag_row), s2) = + Format.fprintf f "%i.%i.%i" ag_line ag_row s2 end module BindingTypeList = Hashed_list.Make (BindingType) let collect_partitioned_contact_map contact_map = Array.fold_left - (Array.fold_left - (fun map -> function - | None -> map - | Some site_node -> - let ag = site_node.User_graph.node_type in - let site_list = site_node.User_graph.node_sites in - let cache1 = StateList.init () in - let cache2 = BindingTypeList.init () in - let (internal_state_partition: string list list) = - partition - cache1 - StateList.hash - StateList.int_of_hashed_list - (fun (x,_) -> Option_util.unsome [] x) - site_list - in - let (binding_state_partition: string list list) = - partition - cache2 - BindingTypeList.hash - BindingTypeList.int_of_hashed_list - (function - | (_, User_graph.LINKS l) -> l - | (_, (WHATEVER | SOME | TYPE _)) -> assert false) - site_list - in - let full_state_partition = - partition_pair - (cache1,cache2) - (fun - (cache1,cache2) - (l1,l2) -> - let cache1,a1 = StateList.hash cache1 l1 in - let cache2,a2 = BindingTypeList.hash cache2 l2 in - (cache1,cache2),(a1,a2)) - (fun (a,b) -> - StateList.int_of_hashed_list a, - BindingTypeList.int_of_hashed_list b) - (function - | (x,User_graph.LINKS y) -> (Option_util.unsome [] x, y) - | (_, (SOME | WHATEVER | TYPE _)) -> assert false) - site_list - in - Mods.StringMap.add ag - { - Symmetries_sig.over_internal_states = internal_state_partition ; - Symmetries_sig.over_binding_states = binding_state_partition ; - Symmetries_sig.over_full_states = full_state_partition ; - } map - )) Mods.StringMap.empty contact_map + (Array.fold_left (fun map -> function + | None -> map + | Some site_node -> + let ag = site_node.User_graph.node_type in + let site_list = site_node.User_graph.node_sites in + let cache1 = StateList.init () in + let cache2 = BindingTypeList.init () in + let (internal_state_partition : string list list) = + partition cache1 StateList.hash StateList.int_of_hashed_list + (fun (x, _) -> Option_util.unsome [] x) + site_list + in + let (binding_state_partition : string list list) = + partition cache2 BindingTypeList.hash + BindingTypeList.int_of_hashed_list + (function + | _, User_graph.LINKS l -> l + | _, (WHATEVER | SOME | TYPE _) -> assert false) + site_list + in + let full_state_partition = + partition_pair (cache1, cache2) + (fun (cache1, cache2) (l1, l2) -> + let cache1, a1 = StateList.hash cache1 l1 in + let cache2, a2 = BindingTypeList.hash cache2 l2 in + (cache1, cache2), (a1, a2)) + (fun (a, b) -> + ( StateList.int_of_hashed_list a, + BindingTypeList.int_of_hashed_list b )) + (function + | x, User_graph.LINKS y -> Option_util.unsome [] x, y + | _, (SOME | WHATEVER | TYPE _) -> assert false) + site_list + in + Mods.StringMap.add ag + { + Symmetries_sig.over_internal_states = internal_state_partition; + Symmetries_sig.over_binding_states = binding_state_partition; + Symmetries_sig.over_full_states = full_state_partition; + } + map)) + Mods.StringMap.empty contact_map (*****************************************************************) (*PRINT*) (*****************************************************************) - let print_partitioned_contact_map parameters partitioned_contact_map = - let log = Remanent_parameters.get_logger parameters in - Mods.StringMap.iter - (fun agent partition -> - Symmetries_sig.print - log - (fun _agent _fmt site -> - Loggers.fprintf log "%s" site) - (fun _fmt agent -> - Loggers.fprintf log "%s" agent) - agent - partition - ) partitioned_contact_map +let print_partitioned_contact_map parameters partitioned_contact_map = + let log = Remanent_parameters.get_logger parameters in + Mods.StringMap.iter + (fun agent partition -> + Symmetries_sig.print log + (fun _agent _fmt site -> Loggers.fprintf log "%s" site) + (fun _fmt agent -> Loggers.fprintf log "%s" agent) + agent partition) + partitioned_contact_map let print_partitioned_contact_map_in_lkappa logger env partitioned_contact_map = let signature = Model.signatures env in Array.iteri (fun agent_id partition -> - Symmetries_sig.print - logger - (Signature.print_site signature) - (Signature.print_agent signature) - agent_id - partition - ) partitioned_contact_map + Symmetries_sig.print logger + (Signature.print_site signature) + (Signature.print_agent signature) + agent_id partition) + partitioned_contact_map let print_contact_map parameters contact_map = let log = Remanent_parameters.get_logger parameters in Array.iter - (Array.iter - (function - | None -> () - | Some site_node -> - let agent = site_node.User_graph.node_type in - let interface = site_node.User_graph.node_sites in - let () = Loggers.fprintf log "agent:%s\n" agent in - Array.iter - (fun site -> - let site_name = site.User_graph.site_name in - let () = Loggers.fprintf log " site:%s\n" site_name in - match site.User_graph.site_type with - | User_graph.Counter i -> - let () = Loggers.fprintf log "counter: %i" i in - let () = Loggers.print_newline log in () - | User_graph.Port p -> + (Array.iter (function + | None -> () + | Some site_node -> + let agent = site_node.User_graph.node_type in + let interface = site_node.User_graph.node_sites in + let () = Loggers.fprintf log "agent:%s\n" agent in + Array.iter + (fun site -> + let site_name = site.User_graph.site_name in + let () = Loggers.fprintf log " site:%s\n" site_name in + match site.User_graph.site_type with + | User_graph.Counter i -> + let () = Loggers.fprintf log "counter: %i" i in + let () = Loggers.print_newline log in + () + | User_graph.Port p -> + let () = + match p.User_graph.port_states with + | None | Some [] -> () + | Some l1 -> + let () = Loggers.fprintf log "internal_states:" in + let () = List.iter (Loggers.fprintf log "%s;") l1 in + let () = Loggers.print_newline log in + () + in + let () = + match p.User_graph.port_links with + | WHATEVER | SOME | TYPE _ | LINKS [] -> () + | User_graph.LINKS l2 -> + let () = Loggers.fprintf log "binding_states:" in let () = - match p.User_graph.port_states with - | None | Some [] -> () - | Some l1 -> - let () = Loggers.fprintf log "internal_states:" in - let () = List.iter (Loggers.fprintf log "%s;") l1 in - let () = Loggers.print_newline log in () + List.iter + (fun ((ag_line, ag_row), s2) -> + Loggers.fprintf log "%i.%i.%i;" ag_line ag_row s2) + l2 in - let () = - match p.User_graph.port_links with - | WHATEVER | SOME | TYPE _ | LINKS [] -> () - | User_graph.LINKS l2 -> - let () = Loggers.fprintf log "binding_states:" in - let () = - List.iter (fun ((ag_line,ag_row),s2) -> - Loggers.fprintf log "%i.%i.%i;" ag_line ag_row s2) l2 - in - let () = Loggers.print_newline log in () - in ()) interface)) contact_map + let () = Loggers.print_newline log in + () + in + ()) + interface)) + contact_map (****************************************************************) @@ -253,50 +228,42 @@ let translate_to_lkappa_representation env partitioned_contact_map = let () = Mods.StringMap.iter (fun agent_string partition -> - let ag_id = - Signature.num_of_agent - (Locality.dummy_annot agent_string) - signature - in - let interface = Signature.get signature ag_id in - let partition = - Symmetries_sig.map - (fun site_string -> - Signature.num_of_site - (Locality.dummy_annot site_string) - interface) + let ag_id = + Signature.num_of_agent (Loc.annot_with_dummy agent_string) signature + in + let interface = Signature.get signature ag_id in + let partition = + Symmetries_sig.map + (fun site_string -> + Signature.num_of_site (Loc.annot_with_dummy site_string) interface) partition - in - array.(ag_id) <- partition) + in + array.(ag_id) <- partition) partitioned_contact_map in array - - let partition_pair cache p l = let rec part cache yes no = function | [] -> cache, (List.rev yes, List.rev no) | x :: l -> let cache, b = p cache x in - if b - then part - cache - (x :: yes) - no - l - else part cache yes (x :: no) l in + if b then + part cache (x :: yes) no l + else + part cache yes (x :: no) l + in part cache [] [] l let refine_class cache p l result = let rec aux cache to_do classes = match to_do with | [] -> cache, classes - | h::tail -> + | h :: tail -> let cache, (newclass, others) = partition_pair cache (fun cache -> p cache h) tail in - aux cache others ((h::newclass) :: classes) + aux cache others ((h :: newclass) :: classes) in aux cache l result @@ -304,89 +271,84 @@ let refine_class cache p l = if l <> [] then List.fold_left (fun (cache, result) l -> - let cache, result = - refine_class cache p l result - in - cache, result - ) (cache, []) l - else (cache, []) - -let refine_partitioned_contact_map_in_lkappa_representation - cache - p_internal_state - p_binding_state - p_both - partitioned_contact_map = - Tools.array_fold_lefti - (fun agent_type cache partition -> - let over_binding_states = partition.Symmetries_sig.over_binding_states in - let over_internal_states = partition.Symmetries_sig.over_internal_states - in - let over_full_states = partition.Symmetries_sig.over_full_states in - let cache, a = - refine_class - cache - (fun cache -> p_internal_state cache agent_type) - over_internal_states - in - let cache, b = - refine_class - cache - (fun cache -> p_binding_state cache agent_type) - over_binding_states - in - let cache, c = - refine_class - cache - (fun cache -> p_both cache agent_type) - over_full_states - in - let () = - partitioned_contact_map.(agent_type) <- - { - Symmetries_sig.over_internal_states = a ; - Symmetries_sig.over_binding_states = b ; - Symmetries_sig.over_full_states = c - } - in - cache - ) cache partitioned_contact_map, partitioned_contact_map + let cache, result = refine_class cache p l result in + cache, result) + (cache, []) l + else + cache, [] + +let refine_partitioned_contact_map_in_lkappa_representation cache + p_internal_state p_binding_state p_both partitioned_contact_map = + ( Tools.array_fold_lefti + (fun agent_type cache partition -> + let over_binding_states = + partition.Symmetries_sig.over_binding_states + in + let over_internal_states = + partition.Symmetries_sig.over_internal_states + in + let over_full_states = partition.Symmetries_sig.over_full_states in + let cache, a = + refine_class cache + (fun cache -> p_internal_state cache agent_type) + over_internal_states + in + let cache, b = + refine_class cache + (fun cache -> p_binding_state cache agent_type) + over_binding_states + in + let cache, c = + refine_class cache + (fun cache -> p_both cache agent_type) + over_full_states + in + let () = + partitioned_contact_map.(agent_type) <- + { + Symmetries_sig.over_internal_states = a; + Symmetries_sig.over_binding_states = b; + Symmetries_sig.over_full_states = c; + } + in + cache) + cache partitioned_contact_map, + partitioned_contact_map ) (*****************************************************************) (*DETECT SYMMETRIES*) (*****************************************************************) let max_hash h1 h2 = - if compare h1 h2 >= 0 - then h1 - else h2 + if compare h1 h2 >= 0 then + h1 + else + h2 let max_hashes hash_list = let rec aux tail best = match tail with | [] -> best | head :: tail -> aux tail (max_hash best head) - in aux hash_list LKappa_auto.RuleCache.empty + in + aux hash_list LKappa_auto.RuleCache.empty let build_array_for_symmetries hashed_list = let max_hash = max_hashes hashed_list in let size_hash_plus_1 = - (LKappa_auto.RuleCache.int_of_hashed_list max_hash) + 1 + LKappa_auto.RuleCache.int_of_hashed_list max_hash + 1 in let to_be_checked = Array.make size_hash_plus_1 false in let counter = Array.make size_hash_plus_1 0 in let correct = Array.make size_hash_plus_1 1 in - let rate = - Array.make size_hash_plus_1 Rule_modes.RuleModeMap.empty - in + let rate = Array.make size_hash_plus_1 Rule_modes.RuleModeMap.empty in to_be_checked, counter, rate, correct (******************************************************************) (*from syntactic_rule to cannonic form *) (******************************************************************) -let divide_rule_rate_by rule_cache env rate_convention rule - lkappa_rule_init = +let divide_rule_rate_by rule_cache env rate_convention rule lkappa_rule_init = match rate_convention with | Remanent_parameters_sig.Common -> assert false (* this is not a valid parameterization *) @@ -397,8 +359,7 @@ let divide_rule_rate_by rule_cache env rate_convention rule let rule_id = rule.Primitives.syntactic_rule in let lkappa_rule = Model.get_ast_rule env rule_id in let rule_cache, output1 = - LKappa_auto.nauto rate_convention rule_cache - lkappa_rule + LKappa_auto.nauto rate_convention rule_cache lkappa_rule in let rule_cache, output2 = LKappa_auto.nauto rate_convention rule_cache lkappa_rule_init @@ -409,29 +370,23 @@ let divide_rule_rate_by rule_cache env rate_convention rule let rate rule (_, arity, _) = match arity with | Rule_modes.Usual -> Some rule.Primitives.rate - | Rule_modes.Unary_refinement - | Rule_modes.Unary -> + | Rule_modes.Unary_refinement | Rule_modes.Unary -> Option_util.map fst rule.Primitives.unary_rate let valid_modes rule id = - let add x y list = + let add x y list = match y with | None -> list - | Some _ -> x::list + | Some _ -> x :: list in let mode = Rule_modes.Direct in List.rev_map - (fun x -> id,x,mode) + (fun x -> id, x, mode) (List.rev - (Rule_modes.Usual:: - (add Rule_modes.Unary rule.Primitives.unary_rate []))) + (Rule_modes.Usual :: add Rule_modes.Unary rule.Primitives.unary_rate [])) (*cannonic form from syntactic rule*) -let cannonic_form_from_syntactic_rule - rule_cache - env - rule - lkappa_rule_init = +let cannonic_form_from_syntactic_rule rule_cache env rule lkappa_rule_init = (*over each rule*) let rule_id = rule.Primitives.syntactic_rule in let lkappa_rule = Model.get_ast_rule env rule_id in @@ -443,105 +398,89 @@ let cannonic_form_from_syntactic_rule let rule_cache, hashed_list_init = LKappa_auto.cannonic_form rule_cache lkappa_rule_init in - let i' = - LKappa_auto.RuleCache.int_of_hashed_list hashed_list_init in + let i' = LKappa_auto.RuleCache.int_of_hashed_list hashed_list_init in (*get the rate information at each rule*) let rule_id_with_mode_list = valid_modes rule rule_id in let rate_map = - List.fold_left (fun rate_map rule_id_with_mode -> + List.fold_left + (fun rate_map rule_id_with_mode -> let rate_opt = rate rule rule_id_with_mode in - let _,a,b = rule_id_with_mode in + let _, a, b = rule_id_with_mode in let rate_map = match rate_opt with | None -> rate_map | Some rate -> - Rule_modes.RuleModeMap.add (a,b) + Rule_modes.RuleModeMap.add (a, b) (Affine_combinations.linearise rate) rate_map in - rate_map - ) Rule_modes.RuleModeMap.empty rule_id_with_mode_list + rate_map) + Rule_modes.RuleModeMap.empty rule_id_with_mode_list in - rule_cache, - (lkappa_rule, i, rate_map, hashed_list), - (hashed_list_init, i') + rule_cache, (lkappa_rule, i, rate_map, hashed_list), (hashed_list_init, i') (*cannonic_form_from_syntactic_rules and initial states*) -let cannonic_form_from_syntactic_rules - rule_cache - env - rate_convention - lkappa_rule_list - get_rules = +let cannonic_form_from_syntactic_rules rule_cache env rate_convention + lkappa_rule_list get_rules = (*cannonic form from syntactic rule*) let rule_cache, cannonic_list, hashed_lists = List.fold_left (*fold over a list of rules*) - (fun (rule_cache, current_list, hashed_lists) rule -> - (*lkappa rule in the initial states*) - List.fold_left - (fun (rule_cache, current_list, hashed_lists) - lkappa_rule_init -> - (*****************************************************) - (* identifiers of rule up to isomorphism*) - let rule_cache, - (lkappa_rule, i, rate_map, hashed_list), - (hashed_list_init, i') = - cannonic_form_from_syntactic_rule - rule_cache - env - rule - lkappa_rule_init - in - (*****************************************************) - (* convention of r: - the number of automorphisms in the lhs of the rule r. - - convention_rule1 : the result of convention for each - rule. - - convention_rule2: the result of convention in the - initial states - *) - let rule_cache, convention_rule1, convention_rule2 = - divide_rule_rate_by - rule_cache - env - rate_convention - rule - lkappa_rule_init - in - (*****************************************************) - (*store result*) - let current_list = - ((i, rate_map, convention_rule1), - (i', rate_map, convention_rule2)) :: current_list - in - let hashed_lists = - ((hashed_list, lkappa_rule), - (hashed_list_init, lkappa_rule_init)) :: - hashed_lists - in - rule_cache, current_list, hashed_lists - ) (rule_cache, current_list, hashed_lists) - lkappa_rule_list - ) (rule_cache, [], []) get_rules + (fun (rule_cache, current_list, hashed_lists) rule -> + (*lkappa rule in the initial states*) + List.fold_left + (fun (rule_cache, current_list, hashed_lists) lkappa_rule_init -> + (*****************************************************) + (* identifiers of rule up to isomorphism*) + let ( rule_cache, + (lkappa_rule, i, rate_map, hashed_list), + (hashed_list_init, i') ) = + cannonic_form_from_syntactic_rule rule_cache env rule + lkappa_rule_init + in + (*****************************************************) + (* convention of r: + the number of automorphisms in the lhs of the rule r. + - convention_rule1 : the result of convention for each + rule. + - convention_rule2: the result of convention in the + initial states + *) + let rule_cache, convention_rule1, convention_rule2 = + divide_rule_rate_by rule_cache env rate_convention rule + lkappa_rule_init + in + (*****************************************************) + (*store result*) + let current_list = + ((i, rate_map, convention_rule1), (i', rate_map, convention_rule2)) + :: current_list + in + let hashed_lists = + ((hashed_list, lkappa_rule), (hashed_list_init, lkappa_rule_init)) + :: hashed_lists + in + rule_cache, current_list, hashed_lists) + (rule_cache, current_list, hashed_lists) + lkappa_rule_list) + (rule_cache, [], []) get_rules in rule_cache, cannonic_list, hashed_lists (******************************************************************) (*detect_symmetries*) -let check_invariance_gen - p ?trace ?fmt ?fmt_err ?sigs ~to_be_checked ~counter ~correct ~rates - (hash_and_rule_list: (LKappa_auto.RuleCache.hashed_list * LKappa.rule) list) - cache agent_type site1 site2 = +let check_invariance_gen p ?trace ?fmt ?fmt_err ?sigs ~to_be_checked ~counter + ~correct ~rates + (hash_and_rule_list : + (LKappa_auto.RuleCache.hashed_list * LKappa.rule) list) cache agent_type + site1 site2 = let rec aux hash_and_rule_list (cache, to_be_checked, counter) = match hash_and_rule_list with | [] -> (cache, to_be_checked, counter), true | (hash, rule) :: tail -> let id = LKappa_auto.RuleCache.int_of_hashed_list hash in - if - to_be_checked.(id) - then + if to_be_checked.(id) then ( let (cache, counter, to_be_checked), b = p ?trace ?fmt ?fmt_err ?sigs ~agent_type ~site1 ~site2 rule ~correct rates cache ~counter to_be_checked @@ -550,53 +489,38 @@ let check_invariance_gen aux tail (cache, to_be_checked, counter) else (cache, to_be_checked, counter), false - else + ) else aux tail (cache, to_be_checked, counter) in aux hash_and_rule_list (cache, to_be_checked, counter) -let check_invariance_internal_states - ~correct ~rates ?trace ?fmt ?fmt_err ?sigs - (hash_and_rule_list: (LKappa_auto.RuleCache.hashed_list * LKappa.rule) list) - (cache, to_be_checked, counter) - agent_type site1 site2 = +let check_invariance_internal_states ~correct ~rates ?trace ?fmt ?fmt_err ?sigs + (hash_and_rule_list : + (LKappa_auto.RuleCache.hashed_list * LKappa.rule) list) + (cache, to_be_checked, counter) agent_type site1 site2 = check_invariance_gen - LKappa_group_action.check_orbit_internal_state_permutation - ?trace ?fmt ?fmt_err ?sigs - ~to_be_checked ~counter ~correct ~rates + LKappa_group_action.check_orbit_internal_state_permutation ?trace ?fmt + ?fmt_err ?sigs ~to_be_checked ~counter ~correct ~rates hash_and_rule_list + cache agent_type site1 site2 + +let check_invariance_binding_states ~correct ~rates ?trace ?fmt ?fmt_err ?sigs + hash_and_rule_list (cache, to_be_checked, counter) agent_type site1 site2 = + check_invariance_gen LKappa_group_action.check_orbit_binding_state_permutation + ?trace ?fmt ?fmt_err ?sigs ~to_be_checked ~counter ~correct ~rates hash_and_rule_list cache agent_type site1 site2 -let check_invariance_binding_states - ~correct ~rates ?trace ?fmt ?fmt_err ?sigs - hash_and_rule_list - (cache, to_be_checked, counter) - agent_type site1 site2 = - check_invariance_gen - LKappa_group_action.check_orbit_binding_state_permutation - ?trace ?fmt ?fmt_err ?sigs - ~to_be_checked ~counter ~correct ~rates - hash_and_rule_list cache agent_type site1 site2 - -let check_invariance_both - ~correct ~rates ?trace ?fmt ?fmt_err ?sigs - hash_and_rule_list - (cache, to_be_checked, counter) - agent_type site1 site2 = - check_invariance_gen - LKappa_group_action.check_orbit_full_permutation - ?trace ?fmt ?fmt_err ?sigs - ~to_be_checked ~counter ~correct ~rates +let check_invariance_both ~correct ~rates ?trace ?fmt ?fmt_err ?sigs + hash_and_rule_list (cache, to_be_checked, counter) agent_type site1 site2 = + check_invariance_gen LKappa_group_action.check_orbit_full_permutation ?trace + ?fmt ?fmt_err ?sigs ~to_be_checked ~counter ~correct ~rates hash_and_rule_list cache agent_type site1 site2 -let print_symmetries_gen parameters env contact_map - partitioned_contact_map partitioned_contact_map_in_lkappa - refined_partitioned_contact_map +let print_symmetries_gen parameters env contact_map partitioned_contact_map + partitioned_contact_map_in_lkappa refined_partitioned_contact_map refined_partitioned_contact_map_init - refined_partitioned_contact_map_alg_expr - = + refined_partitioned_contact_map_alg_expr = let () = - if Remanent_parameters.get_trace parameters - then + if Remanent_parameters.get_trace parameters then ( let logger = Remanent_parameters.get_logger parameters in let () = Loggers.fprintf logger "Contact map" in let () = Loggers.print_newline logger in @@ -604,10 +528,9 @@ let print_symmetries_gen parameters env contact_map let () = Loggers.fprintf logger "Partitioned contact map" in let () = Loggers.print_newline logger in let () = - print_partitioned_contact_map parameters partitioned_contact_map in - let () = Loggers.fprintf logger - "Partitioned contact map (LKAPPA)" + print_partitioned_contact_map parameters partitioned_contact_map in + let () = Loggers.fprintf logger "Partitioned contact map (LKAPPA)" in let () = Loggers.print_newline logger in let () = print_partitioned_contact_map_in_lkappa logger env @@ -616,89 +539,69 @@ let print_symmetries_gen parameters env contact_map let () = Loggers.fprintf logger "With predicate (LKAPPA)" in let () = Loggers.print_newline logger in let () = - print_partitioned_contact_map_in_lkappa - logger env + print_partitioned_contact_map_in_lkappa logger env refined_partitioned_contact_map in let () = Loggers.fprintf logger "With predicate (LKAPPA) init" in let () = Loggers.print_newline logger in let () = - print_partitioned_contact_map_in_lkappa - logger env + print_partitioned_contact_map_in_lkappa logger env refined_partitioned_contact_map_init in - let () = Loggers.fprintf logger "With predicate (LKAPPA) algebra expression" in + let () = + Loggers.fprintf logger "With predicate (LKAPPA) algebra expression" + in let () = Loggers.print_newline logger in let () = - print_partitioned_contact_map_in_lkappa - logger env + print_partitioned_contact_map_in_lkappa logger env refined_partitioned_contact_map_alg_expr in () - else + ) else () in () - let initial_value_of_arrays cannonic_list arrays = - let to_be_checked, rates, correct = arrays in - List.iter - (fun (i, rate_map, convention_rule) -> - let () = - correct.(i) <- convention_rule - in - let () = - rates.(i) <- - (Rule_modes.sum_map (Affine_combinations.sum) (rates.(i)) rate_map) - in - let () = - to_be_checked.(i) <- true - in - () - ) cannonic_list - -let detect_symmetries - (parameters:Remanent_parameters_sig.parameters) - env cache - rate_convention - chemical_species - get_rules - contact_map - = +let initial_value_of_arrays cannonic_list arrays = + let to_be_checked, rates, correct = arrays in + List.iter + (fun (i, rate_map, convention_rule) -> + let () = correct.(i) <- convention_rule in + let () = + rates.(i) <- + Rule_modes.sum_map Affine_combinations.sum rates.(i) rate_map + in + let () = to_be_checked.(i) <- true in + ()) + cannonic_list + +let detect_symmetries (parameters : Remanent_parameters_sig.parameters) env + cache rate_convention chemical_species get_rules contact_map = (*-------------------------------------------------------------*) let trace = Some (Remanent_parameters.get_trace parameters) in let fmt = - Loggers.formatter_of_logger - (Remanent_parameters.get_logger parameters) + Loggers.formatter_of_logger (Remanent_parameters.get_logger parameters) in let fmt_err = - Loggers.formatter_of_logger - (Remanent_parameters.get_logger_err parameters) + Loggers.formatter_of_logger (Remanent_parameters.get_logger_err parameters) in let sigs = Model.signatures env in let lkappa_rule_list = - List.fold_left (fun current_list species -> + List.fold_left + (fun current_list species -> let lkappa = - Patterns_extra.species_to_lkappa_rule ~parameters ~sigs - species + Patterns_extra.species_to_lkappa_rule ~parameters ~sigs species in - lkappa :: current_list - ) [] chemical_species + lkappa :: current_list) + [] chemical_species in (*-------------------------------------------------------------*) let cache, pair_cannonic_list, pair_list = - cannonic_form_from_syntactic_rules - cache - env - rate_convention - lkappa_rule_list - get_rules - in - let hash_and_rule_list, hash_and_rule_list_init = - List.split pair_list in - let cannonic_list, init_cannonic_list = - List.split pair_cannonic_list + cannonic_form_from_syntactic_rules cache env rate_convention + lkappa_rule_list get_rules in + let hash_and_rule_list, hash_and_rule_list_init = List.split pair_list in + let cannonic_list, init_cannonic_list = List.split pair_cannonic_list in let to_be_checked_init, counter_init, rates_init, correct_init = build_array_for_symmetries (List.rev_map fst (List.rev hash_and_rule_list_init)) @@ -710,18 +613,14 @@ let detect_symmetries (********************************************************) (*detect symmetries for rules*) let to_be_checked, counter, rates, correct = - build_array_for_symmetries - (List.rev_map fst (List.rev hash_and_rule_list)) + build_array_for_symmetries (List.rev_map fst (List.rev hash_and_rule_list)) in let () = - initial_value_of_arrays cannonic_list - (to_be_checked, rates, correct) + initial_value_of_arrays cannonic_list (to_be_checked, rates, correct) in (*-------------------------------------------------------------*) (*PARTITION A CONTACT MAP RETURN A LIST OF LIST OF SITES*) - let partitioned_contact_map = - collect_partitioned_contact_map contact_map - in + let partitioned_contact_map = collect_partitioned_contact_map contact_map in (*-------------------------------------------------------------*) (*PARTITION A CONTACT MAP RETURN A LIST OF LIST OF SITES WITH A PREDICATE*) @@ -734,15 +633,12 @@ let detect_symmetries let (cache, _, _), refined_partitioned_contact_map = refine_partitioned_contact_map_in_lkappa_representation (cache, to_be_checked, counter) - (check_invariance_internal_states - ?trace ?fmt ?fmt_err - ~sigs ~correct ~rates hash_and_rule_list) - (check_invariance_binding_states - ?trace ?fmt ?fmt_err - ~sigs ~correct ~rates hash_and_rule_list) - (check_invariance_both - ?trace ?fmt ?fmt_err - ~sigs ~correct ~rates hash_and_rule_list) + (check_invariance_internal_states ?trace ?fmt ?fmt_err ~sigs ~correct + ~rates hash_and_rule_list) + (check_invariance_binding_states ?trace ?fmt ?fmt_err ~sigs ~correct + ~rates hash_and_rule_list) + (check_invariance_both ?trace ?fmt ?fmt_err ~sigs ~correct ~rates + hash_and_rule_list) p' in let refined_partitioned_contact_map = @@ -759,20 +655,16 @@ let detect_symmetries let rates = rates_init in refine_partitioned_contact_map_in_lkappa_representation (cache, to_be_checked_init, counter_init) - (check_invariance_internal_states - ?trace ?fmt ?fmt_err - ~sigs ~correct ~rates hash_and_rule_list_init) - (check_invariance_binding_states - ?trace ?fmt ?fmt_err - ~sigs ~correct ~rates hash_and_rule_list_init) - (check_invariance_both - ?trace ?fmt ?fmt_err - ~sigs ~correct ~rates hash_and_rule_list_init) + (check_invariance_internal_states ?trace ?fmt ?fmt_err ~sigs ~correct + ~rates hash_and_rule_list_init) + (check_invariance_binding_states ?trace ?fmt ?fmt_err ~sigs ~correct + ~rates hash_and_rule_list_init) + (check_invariance_both ?trace ?fmt ?fmt_err ~sigs ~correct ~rates + hash_and_rule_list_init) refined_partitioned_contact_map_copy in let refined_partitioned_contact_map_init = - Array.map Symmetries_sig.clean - refined_partitioned_contact_map_init + Array.map Symmetries_sig.clean refined_partitioned_contact_map_init in (*-------------------------------------------------------------*) (*rule and alg exprs*) @@ -780,144 +672,101 @@ let detect_symmetries let refined_partitioned_contact_map_copy = Array.copy refined_partitioned_contact_map in - let (cache, refined_partitioned_contact_map_alg_expr) = + let cache, refined_partitioned_contact_map_alg_expr = (* ford over all the alg_expr of the model *) (* for each such expression refine the partitioned contact map*) Alg_expr_extra.fold_over_mixtures_in_alg_exprs (fun pid (cache, algs) -> - let cache, refined_partitioned_contact_map_alg_expr = - refine_partitioned_contact_map_in_lkappa_representation - cache - (fun cache agent_type site1 site2 -> - Pattern_group_action.is_pattern_invariant_internal_states_permutation - ~parameters - ~env - ~agent_type - ~site1 - ~site2 - pid - cache - ) - (fun cache agent_type site1 site2 -> - Pattern_group_action.is_pattern_invariant_binding_states_permutation - ~parameters - ~env - ~agent_type - ~site1 - ~site2 - pid - cache - ) - (fun cache agent_type site1 site2 -> - Pattern_group_action.is_pattern_invariant_full_states_permutation - ~parameters - ~env - ~agent_type - ~site1 - ~site2 - pid - cache - ) - algs - in - cache, refined_partitioned_contact_map_alg_expr - ) + let cache, refined_partitioned_contact_map_alg_expr = + refine_partitioned_contact_map_in_lkappa_representation cache + (fun cache agent_type site1 site2 -> + Pattern_group_action + .is_pattern_invariant_internal_states_permutation ~parameters ~env + ~agent_type ~site1 ~site2 pid cache) + (fun cache agent_type site1 site2 -> + Pattern_group_action + .is_pattern_invariant_binding_states_permutation ~parameters ~env + ~agent_type ~site1 ~site2 pid cache) + (fun cache agent_type site1 site2 -> + Pattern_group_action.is_pattern_invariant_full_states_permutation + ~parameters ~env ~agent_type ~site1 ~site2 pid cache) + algs + in + cache, refined_partitioned_contact_map_alg_expr) env (cache, refined_partitioned_contact_map_copy) in let refined_partitioned_contact_map_alg_expr = - Array.map Symmetries_sig.clean - refined_partitioned_contact_map_alg_expr + Array.map Symmetries_sig.clean refined_partitioned_contact_map_alg_expr in (*-------------------------------------------------------------*) (*print*) let () = - print_symmetries_gen parameters env contact_map - partitioned_contact_map - partitioned_contact_map_in_lkappa - refined_partitioned_contact_map + print_symmetries_gen parameters env contact_map partitioned_contact_map + partitioned_contact_map_in_lkappa refined_partitioned_contact_map refined_partitioned_contact_map_init refined_partitioned_contact_map_alg_expr in - cache, - { - rules = refined_partitioned_contact_map; - rules_and_initial_states = - Some refined_partitioned_contact_map_init; - rules_and_alg_expr = - Some refined_partitioned_contact_map_alg_expr ; - } + ( cache, + { + rules = refined_partitioned_contact_map; + rules_and_initial_states = Some refined_partitioned_contact_map_init; + rules_and_alg_expr = Some refined_partitioned_contact_map_alg_expr; + } ) (******************************************************) (*pattern*) -module Cc = -struct +module Cc = struct type t = Pattern.cc + let compare = compare let print _ _ = () end -module CcSetMap = SetMap.Make(Cc) - +module CcSetMap = SetMap.Make (Cc) module CcMap = CcSetMap.Map -module CcId = -struct +module CcId = struct type t = Pattern.id + let compare = compare let print _ _ = () end -module CcIdSetMap = SetMap.Make(CcId) - +module CcIdSetMap = SetMap.Make (CcId) module CcIdMap = CcIdSetMap.Map -type cache = - { - rep: Pattern.cc CcMap.t ; - equiv_class: (int * (Pattern.id * int) list) CcIdMap.t ; +type cache = { + rep: Pattern.cc CcMap.t; + equiv_class: (int * (Pattern.id * int) list) CcIdMap.t; } -let empty_cache () = - { - rep = CcMap.empty ; - equiv_class = CcIdMap.empty - } +let empty_cache () = { rep = CcMap.empty; equiv_class = CcIdMap.empty } -let representative ?parameters ~sigs cache rule_cache preenv_cache - symmetries species = +let representative ?parameters ~sigs cache rule_cache preenv_cache symmetries + species = match symmetries with | Ground -> cache, rule_cache, preenv_cache, species | Forward sym | Backward sym -> - begin - match CcMap.find_option species cache.rep with - | Some species -> cache, rule_cache, preenv_cache, species - | None -> - let rule_cache, preenv_cache, species' = - Pattern_group_action.normalize_species - ?parameters - ~sigs - rule_cache - preenv_cache - sym - species - in - let cache = - {cache with rep = CcMap.add species species' cache.rep} - in - cache, rule_cache, preenv_cache, species' - end + (match CcMap.find_option species cache.rep with + | Some species -> cache, rule_cache, preenv_cache, species + | None -> + let rule_cache, preenv_cache, species' = + Pattern_group_action.normalize_species ?parameters ~sigs rule_cache + preenv_cache sym species + in + let cache = { cache with rep = CcMap.add species species' cache.rep } in + cache, rule_cache, preenv_cache, species') -let equiv_class ?parameters env array cache rule_cache preenv_cache - symmetries pattern = +let equiv_class ?parameters env array cache rule_cache preenv_cache symmetries + pattern = match symmetries with - | Ground -> cache, rule_cache, preenv_cache, array, (1, [pattern,1]) + | Ground -> cache, rule_cache, preenv_cache, array, (1, [ pattern, 1 ]) | Forward partitions | Backward partitions -> - begin - match CcIdMap.find_option pattern cache.equiv_class with - | Some equiv_class -> cache, rule_cache, preenv_cache, array, equiv_class - | None -> + (match CcIdMap.find_option pattern cache.equiv_class with + | Some equiv_class -> cache, rule_cache, preenv_cache, array, equiv_class + | None -> let partitions_internal_states a = partitions.(a).Symmetries_sig.over_internal_states in @@ -928,85 +777,62 @@ let equiv_class ?parameters env array cache rule_cache preenv_cache partitions.(a).Symmetries_sig.over_full_states in let rule_cache, preenv_cache, array, equiv_class = - Pattern_group_action.equiv_class_of_a_pattern - ?parameters - ~env - ~partitions_internal_states - ~partitions_binding_states - ~partitions_full_states - rule_cache - preenv_cache - array - pattern - in - let w_list = - List.rev_map snd equiv_class + Pattern_group_action.equiv_class_of_a_pattern ?parameters ~env + ~partitions_internal_states ~partitions_binding_states + ~partitions_full_states rule_cache preenv_cache array pattern in + let w_list = List.rev_map snd equiv_class in let lcm = Tools.lcm w_list in - let equiv_class = - List.rev_map - (fun (a,b) -> a,lcm/b) - equiv_class - in - let w = - List.fold_left - (fun w' (_,w) -> w' + w) - 0 - equiv_class - in - let equiv_class_w = w,equiv_class in + let equiv_class = List.rev_map (fun (a, b) -> a, lcm / b) equiv_class in + let w = List.fold_left (fun w' (_, w) -> w' + w) 0 equiv_class in + let equiv_class_w = w, equiv_class in let equiv_class_map = List.fold_left - (fun equiv_class_map (id,_) -> - let () = - if local_trace || (match parameters with - | None -> false - | Some p -> Remanent_parameters.get_trace p) - then - let _ = Pattern.id_to_yojson id in () - in - CcIdMap.add id equiv_class_w equiv_class_map ) - cache.equiv_class - equiv_class + (fun equiv_class_map (id, _) -> + let () = + if + local_trace + || + match parameters with + | None -> false + | Some p -> Remanent_parameters.get_trace p + then ( + let _ = Pattern.id_to_yojson id in + () + ) + in + CcIdMap.add id equiv_class_w equiv_class_map) + cache.equiv_class equiv_class in - {cache - with - equiv_class = equiv_class_map}, - rule_cache, preenv_cache, array, (w,equiv_class) - end + ( { cache with equiv_class = equiv_class_map }, + rule_cache, + preenv_cache, + array, + (w, equiv_class) )) let print_symmetries parameters env symmetries = let log = Remanent_parameters.get_logger parameters in let () = Loggers.fprintf log "Symmetries:" in - let () = Loggers.print_newline log in + let () = Loggers.print_newline log in let () = Loggers.fprintf log "In rules:" in - let () = Loggers.print_newline log in - let () = print_partitioned_contact_map_in_lkappa log env - symmetries.rules - in + let () = Loggers.print_newline log in + let () = print_partitioned_contact_map_in_lkappa log env symmetries.rules in let () = - match - symmetries.rules_and_initial_states - with + match symmetries.rules_and_initial_states with | None -> () | Some sym -> let () = Loggers.fprintf log "In rules and initial states:" in let () = Loggers.print_newline log in - let () = - print_partitioned_contact_map_in_lkappa log env sym - in + let () = print_partitioned_contact_map_in_lkappa log env sym in () in let () = - match - symmetries.rules_and_alg_expr - with + match symmetries.rules_and_alg_expr with | None -> () | Some sym -> let () = Loggers.fprintf log "In rules and algebraic expression:" in let () = Loggers.print_newline log in - let () = - print_partitioned_contact_map_in_lkappa log env sym - in + let () = print_partitioned_contact_map_in_lkappa log env sym in () - in () + in + () diff --git a/core/symmetries/symmetries.mli b/core/symmetries/symmetries.mli index 8374798eb3..f55419407c 100644 --- a/core/symmetries/symmetries.mli +++ b/core/symmetries/symmetries.mli @@ -17,15 +17,13 @@ (*TYPE*) (*******************************************************************) -type equivalence_classes = - int Symmetries_sig.site_partition array +type equivalence_classes = int Symmetries_sig.site_partition array -type symmetries = - { - rules: equivalence_classes; - rules_and_initial_states: equivalence_classes option; - rules_and_alg_expr: equivalence_classes option - } +type symmetries = { + rules: equivalence_classes; + rules_and_initial_states: equivalence_classes option; + rules_and_alg_expr: equivalence_classes option; +} type reduction = | Ground @@ -44,30 +42,44 @@ val refine_partitioned_contact_map_in_lkappa_representation : 'b Symmetries_sig.site_partition array -> 'a * 'b Symmetries_sig.site_partition array -val detect_symmetries: +val detect_symmetries : Remanent_parameters_sig.parameters -> Model.t -> LKappa_auto.cache -> Remanent_parameters_sig.rate_convention -> Pattern.cc list -> Primitives.elementary_rule list -> - Public_data.contact_map -> + Public_data.contact_map -> LKappa_auto.cache * symmetries -val print_symmetries: +val print_symmetries : Remanent_parameters_sig.parameters -> Model.t -> symmetries -> unit type cache -val empty_cache: unit -> cache +val empty_cache : unit -> cache -val representative: +val representative : ?parameters:Remanent_parameters_sig.parameters -> - sigs:Signature.s -> cache -> LKappa_auto.cache -> Pattern.PreEnv.t -> reduction -> Pattern.cc - -> cache * LKappa_auto.cache * Pattern.PreEnv.t * Pattern.cc + sigs:Signature.s -> + cache -> + LKappa_auto.cache -> + Pattern.PreEnv.t -> + reduction -> + Pattern.cc -> + cache * LKappa_auto.cache * Pattern.PreEnv.t * Pattern.cc -val equiv_class: +val equiv_class : ?parameters:Remanent_parameters_sig.parameters -> - Model.t -> - bool Mods.DynArray.t -> cache -> LKappa_auto.cache -> Pattern.PreEnv.t -> reduction -> Pattern.id -> - cache * LKappa_auto.cache * Pattern.PreEnv.t * bool Mods.DynArray.t * (int * (Pattern.id * int) list) + Model.t -> + bool Mods.DynArray.t -> + cache -> + LKappa_auto.cache -> + Pattern.PreEnv.t -> + reduction -> + Pattern.id -> + cache + * LKappa_auto.cache + * Pattern.PreEnv.t + * bool Mods.DynArray.t + * (int * (Pattern.id * int) list) diff --git a/core/symmetries/symmetries_sig.ml b/core/symmetries/symmetries_sig.ml index d12ad4ecf3..cd2e108c36 100644 --- a/core/symmetries/symmetries_sig.ml +++ b/core/symmetries/symmetries_sig.ml @@ -13,117 +13,88 @@ * All rights reserved. This file is distributed * under the terms of the GNU Library General Public License *) - -type 'a site_partition = - { - over_binding_states: 'a list list ; - over_internal_states: 'a list list ; - over_full_states: 'a list list ; - } +type 'a site_partition = { + over_binding_states: 'a list list; + over_internal_states: 'a list list; + over_full_states: 'a list list; +} let empty = - { - over_binding_states = [] ; - over_internal_states = [] ; - over_full_states = [] ; - } + { over_binding_states = []; over_internal_states = []; over_full_states = [] } let map_list_list f list = - List.rev_map - (fun list -> - List.rev_map f (List.rev list)) - (List.rev list) + List.rev_map (fun list -> List.rev_map f (List.rev list)) (List.rev list) let map f site_partition = { - over_binding_states = map_list_list f site_partition.over_binding_states ; - over_internal_states = map_list_list f site_partition.over_internal_states ; - over_full_states = map_list_list f site_partition.over_full_states + over_binding_states = map_list_list f site_partition.over_binding_states; + over_internal_states = map_list_list f site_partition.over_internal_states; + over_full_states = map_list_list f site_partition.over_full_states; } -let at_least_two = - function - | [] | [_] -> false +let at_least_two = function + | [] | [ _ ] -> false | _ -> true let clean site_partition = { over_binding_states = - List.filter - at_least_two - site_partition.over_binding_states ; + List.filter at_least_two site_partition.over_binding_states; over_internal_states = - List.filter - at_least_two - site_partition.over_internal_states ; - over_full_states = - List.filter - at_least_two - site_partition.over_full_states ; + List.filter at_least_two site_partition.over_internal_states; + over_full_states = List.filter at_least_two site_partition.over_full_states; } let print_l print_site logger fmt agent s l = - if l = [] - then () - else - let () = - Loggers.fprintf logger "%s" s - in + if l = [] then + () + else ( + let () = Loggers.fprintf logger "%s" s in let () = Loggers.print_newline logger in List.iter (fun equ_class -> - let () = Loggers.fprintf logger " {" in - let _ = - List.fold_left - (fun b site -> - let () = if b then Loggers.fprintf logger "," in - let () = - print_site agent fmt site in - true) - false - equ_class - in - let () = Loggers.fprintf logger "}" in - Loggers.print_newline logger) + let () = Loggers.fprintf logger " {" in + let _ = + List.fold_left + (fun b site -> + let () = if b then Loggers.fprintf logger "," in + let () = print_site agent fmt site in + true) + false equ_class + in + let () = Loggers.fprintf logger "}" in + Loggers.print_newline logger) l + ) -let print - logger print_site print_agent agent partition = - if partition = empty - then () - else - begin - let fmt = Loggers.formatter_of_logger logger in - match fmt with - | None -> () - | Some fmt -> - let () = Loggers.fprintf logger "************" in - let () = Loggers.print_newline logger in - let () = Loggers.fprintf logger "Agent: " in - let () = print_agent fmt agent in - let () = Loggers.print_newline logger in - let () = - print_l - print_site logger fmt - agent - " -Equivalence classes of sites for internal states:" - partition.over_internal_states - in - let () = - print_l - print_site logger fmt - agent - " -Equivalence classes of sites for bindings states:" - partition.over_binding_states - in - let () = - print_l - print_site logger fmt - agent - " -Equivalence classes of sites (both):" - partition.over_full_states - in - let () = Loggers.fprintf logger "************" in - let () = Loggers.print_newline logger in - () - end +let print logger print_site print_agent agent partition = + if partition = empty then + () + else ( + let fmt = Loggers.formatter_of_logger logger in + match fmt with + | None -> () + | Some fmt -> + let () = Loggers.fprintf logger "************" in + let () = Loggers.print_newline logger in + let () = Loggers.fprintf logger "Agent: " in + let () = print_agent fmt agent in + let () = Loggers.print_newline logger in + let () = + print_l print_site logger fmt agent + " -Equivalence classes of sites for internal states:" + partition.over_internal_states + in + let () = + print_l print_site logger fmt agent + " -Equivalence classes of sites for bindings states:" + partition.over_binding_states + in + let () = + print_l print_site logger fmt agent + " -Equivalence classes of sites (both):" partition.over_full_states + in + let () = Loggers.fprintf logger "************" in + let () = Loggers.print_newline logger in + () + ) diff --git a/core/symmetries/symmetries_sig.mli b/core/symmetries/symmetries_sig.mli index 6715f25f83..61e76d754d 100644 --- a/core/symmetries/symmetries_sig.mli +++ b/core/symmetries/symmetries_sig.mli @@ -9,18 +9,20 @@ (** Abstract domain to record relations between pair of sites in connected agents. *) -type 'a site_partition = - { - over_binding_states: 'a list list ; - over_internal_states: 'a list list ; - over_full_states: 'a list list ; - } +type 'a site_partition = { + over_binding_states: 'a list list; + over_internal_states: 'a list list; + over_full_states: 'a list list; +} val empty : 'a site_partition -val map: ('a -> 'b) -> 'a site_partition -> 'b site_partition -val clean: 'a site_partition -> 'a site_partition -val print: +val map : ('a -> 'b) -> 'a site_partition -> 'b site_partition +val clean : 'a site_partition -> 'a site_partition + +val print : Loggers.t -> ('agent -> Format.formatter -> 'site -> unit) -> (Format.formatter -> 'agent -> unit) -> - 'agent -> 'site site_partition -> unit + 'agent -> + 'site site_partition -> + unit diff --git a/core/symmetries/symmetry_interface.ml b/core/symmetries/symmetry_interface.ml index 3097385b20..d083614bb4 100644 --- a/core/symmetries/symmetry_interface.ml +++ b/core/symmetries/symmetry_interface.ml @@ -4,159 +4,122 @@ *) type rule = Primitives.elementary_rule - type preprocessed_ast = Cli_init.preprocessed_ast type ast = Ast.parsing_compil - type init = (Primitives.alg_expr * rule) list -type compil = - { - debugMode: bool; - contact_map: Contact_map.t ; - environment: Model.t ; - init: init; - rule_rate_convention: Remanent_parameters_sig.rate_convention ; - reaction_rate_convention: Remanent_parameters_sig.rate_convention option; - show_reactions: bool ; - count: Ode_args.count ; - internal_meaning : Ode_args.count ; - compute_jacobian: bool ; - symbol_table: Symbol_table.symbol_table; - allow_empty_lhs: bool; - } - -let debug_mode compil = compil.debugMode +type compil = { + debug_mode: bool; + contact_map: Contact_map.t; + environment: Model.t; + init: init; + rule_rate_convention: Remanent_parameters_sig.rate_convention; + reaction_rate_convention: Remanent_parameters_sig.rate_convention option; + show_reactions: bool; + count: Ode_args.count; + internal_meaning: Ode_args.count; + compute_jacobian: bool; + symbol_table: Symbol_table.symbol_table; + allow_empty_lhs: bool; +} + +let debug_mode compil = compil.debug_mode let do_we_allow_empty_lhs compil = compil.allow_empty_lhs let to_dotnet compil = - {compil with symbol_table = Symbol_table.unbreakable_symbol_table_dotnet} + { compil with symbol_table = Symbol_table.unbreakable_symbol_table_dotnet } let with_dot_and_plus compil = - {compil - with - symbol_table = - Symbol_table.with_dot_and_plus compil.symbol_table + { + compil with + symbol_table = Symbol_table.with_dot_and_plus compil.symbol_table; } -let dont_allow_empty_lhs compil = - {compil with allow_empty_lhs = false} +let dont_allow_empty_lhs compil = { compil with allow_empty_lhs = false } type cc_cache = Pattern.PreEnv.t - type nauto_in_rules_cache = LKappa_auto.cache - type sym_cache = Symmetries.cache - type seen_cache = bool Mods.DynArray.t - type rule_weight = int option Mods.DynArray.t -type cache = - { - cc_cache: cc_cache ; - rule_cache: nauto_in_rules_cache; - representative_cache: sym_cache ; - seen_rule: seen_cache ; - seen_pattern: seen_cache; - seen_species: seen_cache; - correcting_coef: rule_weight; - n_cc: rule_weight; - } - -let get_cc_cache cache = cache.cc_cache -let set_cc_cache cc_cache cache = {cache with cc_cache = cc_cache} +type cache = { + cc_cache: cc_cache; + rule_cache: nauto_in_rules_cache; + representative_cache: sym_cache; + seen_rule: seen_cache; + seen_pattern: seen_cache; + seen_species: seen_cache; + correcting_coef: rule_weight; + n_cc: rule_weight; +} +let get_cc_cache cache = cache.cc_cache +let set_cc_cache cc_cache cache = { cache with cc_cache } let get_rule_cache cache = cache.rule_cache - -let set_rule_cache rule_cache cache = - {cache with rule_cache = rule_cache} - +let set_rule_cache rule_cache cache = { cache with rule_cache } let get_sym_cache cache = cache.representative_cache let set_sym_cache sym_cache cache = - {cache with representative_cache = sym_cache} + { cache with representative_cache = sym_cache } let hash_rule_weight get set f cache compil rule = match get cache rule with | Some n -> cache, n | None -> - let cache,n = f cache compil rule in + let cache, n = f cache compil rule in let cache = set cache rule n in cache, n let get_representative parameters compil cache symmetries species = let sigs = Model.signatures compil.environment in let rep_cache, rule_cache, cc_cache, species = - Symmetries.representative - ~parameters - ~sigs - (get_sym_cache cache) - (get_rule_cache cache) - (get_cc_cache cache) - symmetries species + Symmetries.representative ~parameters ~sigs (get_sym_cache cache) + (get_rule_cache cache) (get_cc_cache cache) symmetries species in let cache = set_rule_cache rule_cache - (set_cc_cache cc_cache - (set_sym_cache rep_cache cache)) + (set_cc_cache cc_cache (set_sym_cache rep_cache cache)) in cache, species let equiv_class_of_pattern parameters compil cache symmetries pattern = let env = compil.environment in - let rep_cache, rule_cache, cc_cache, seen_pattern, equiv_class = - Symmetries.equiv_class - ~parameters - env - cache.seen_pattern - (get_sym_cache cache) - (get_rule_cache cache) - (get_cc_cache cache) + let rep_cache, rule_cache, cc_cache, seen_pattern, equiv_class = + Symmetries.equiv_class ~parameters env cache.seen_pattern + (get_sym_cache cache) (get_rule_cache cache) (get_cc_cache cache) symmetries pattern in let cache = set_rule_cache rule_cache - (set_cc_cache cc_cache - (set_sym_cache rep_cache cache)) + (set_cc_cache cc_cache (set_sym_cache rep_cache cache)) in - {cache with seen_pattern}, - equiv_class + { cache with seen_pattern }, equiv_class -let get_init compil= compil.init +let get_init compil = compil.init let lift_opt f compil_opt = - match - compil_opt - with + match compil_opt with | None -> None | Some a -> Some (f a) let contact_map compil = compil.contact_map - let environment compil = compil.environment - let domain compil = Model.domain (environment compil) - let domain_opt = lift_opt domain - let environment_opt = lift_opt environment - -let symbol_table compil = - compil.symbol_table +let symbol_table compil = compil.symbol_table let symbol_table_opt a = match a with | None -> Symbol_table.symbol_table_V4 | Some compil -> symbol_table compil -type mixture = Edges.t(* not necessarily connected, fully specified *) - +type mixture = Edges.t (* not necessarily connected, fully specified *) type chemical_species = Pattern.cc (* connected, fully specified *) type canonic_species = chemical_species (* chemical species in canonic form *) - type pattern = Pattern.id array (* not necessarity connected, maybe partially specified *) @@ -167,77 +130,69 @@ let dummy_chemical_species compil = Pattern.empty_cc (Pattern.Env.signatures (domain compil)) let rule_rate_convention compil = compil.rule_rate_convention - let reaction_rate_convention compil = compil.reaction_rate_convention - let what_do_we_count compil = compil.count let do_we_count_in_embeddings compil = - match - what_do_we_count compil - with + match what_do_we_count compil with | Ode_args.Occurrences -> false | Ode_args.Embeddings -> true let internal_meaning_is_nembeddings compil = - match - compil.internal_meaning - with - | Ode_args.Occurrences -> false - | Ode_args.Embeddings -> true + match compil.internal_meaning with + | Ode_args.Occurrences -> false + | Ode_args.Embeddings -> true -let do_we_prompt_reactions compil = - compil.show_reactions +let do_we_prompt_reactions compil = compil.show_reactions let print_chemical_species ?compil f = Format.fprintf f "@[%a@]" (Kade_backend.Pattern.print_cc - ~noCounters:(match compil with None -> false | Some c -> c.debugMode) + ~noCounters: + (match compil with + | None -> false + | Some c -> c.debug_mode) ~full_species:true ?sigs:(Option_util.map Model.signatures (environment_opt compil)) - ?cc_id:None - ~symbol_table:(symbol_table_opt compil) - ~with_id:false) + ?cc_id:None ~symbol_table:(symbol_table_opt compil) ~with_id:false) let print_token ?compil fmt k = - Format.fprintf fmt - "%a" - (Model.print_token ?env:(environment_opt compil)) - k + Format.fprintf fmt "%a" (Model.print_token ?env:(environment_opt compil)) k let print_canonic_species = print_chemical_species -let nbr_automorphisms_in_chemical_species ~debugMode x = - List.length (Pattern.automorphisms ~debugMode x) +let nbr_automorphisms_in_chemical_species ~debug_mode x = + List.length (Pattern.automorphisms ~debug_mode x) let compare_connected_component = Pattern.compare_canonicals let print_connected_component ?compil = Kade_backend.Pattern.print - ~noCounters:(match compil with None -> false | Some c -> c.debugMode) - ?domain:(domain_opt compil) - ~symbol_table:(symbol_table_opt compil) + ~noCounters: + (match compil with + | None -> false + | Some c -> c.debug_mode) + ?domain:(domain_opt compil) ~symbol_table:(symbol_table_opt compil) ~with_id:false let canonic_form x = x - let connected_components_of_patterns = Array.to_list -let connected_components_of_mixture_sigs - ~debugMode sigs cache contact_map_int e = - let (cache,acc) = - Pattern_decompiler.patterns_of_mixture - ~debugMode contact_map_int sigs cache e +let connected_components_of_mixture_sigs ~debug_mode sigs cache contact_map_int + e = + let cache, acc = + Pattern_decompiler.patterns_of_mixture ~debug_mode contact_map_int sigs + cache e in - cache, acc + cache, acc let connected_components_of_mixture compil cache e = let cc_cache = get_cc_cache cache in let contact_map = contact_map compil in let sigs = Pattern.Env.signatures (domain compil) in let cc_cache, acc = - Pattern_decompiler.patterns_of_mixture - ~debugMode:compil.debugMode contact_map sigs cc_cache e + Pattern_decompiler.patterns_of_mixture ~debug_mode:compil.debug_mode + contact_map sigs cc_cache e in set_cc_cache cc_cache cache, acc @@ -246,59 +201,58 @@ type embedding_forest = Matching.t (* the domain may be not connected *) let lift_embedding x = - Option_util.unsome - Matching.empty - (Matching.add_cc Matching.empty 0 x) - + Option_util.unsome Matching.empty (Matching.add_cc Matching.empty 0 x) let find_all_embeddings compil cc = - let tr = - Primitives.fully_specified_pattern_to_positive_transformations cc in + let tr = Primitives.fully_specified_pattern_to_positive_transformations cc in let env = environment compil in - let l = - Evaluator.find_all_embeddings ~debugMode:true env tr - in + let l = Evaluator.find_all_embeddings ~debug_mode:true env tr in Tools.remove_double_elements l -let add_fully_specified_to_graph ~debugMode sigs graph cc = - let e,g = +let add_fully_specified_to_graph ~debug_mode sigs graph cc = + let e, g = Pattern.fold_by_type - (fun ~pos ~agent_type intf (emb,g) -> - let a, g' = Edges.add_agent sigs agent_type g in - let ag = (a,agent_type) in - let emb' = Mods.IntMap.add pos ag emb in - emb', - Tools.array_fold_lefti - (fun site acc (l,i) -> + (fun ~pos ~agent_type intf (emb, g) -> + let a, g' = Edges.add_agent sigs agent_type g in + let ag = a, agent_type in + let emb' = Mods.IntMap.add pos ag emb in + ( emb', + Tools.array_fold_lefti + (fun site acc (l, i) -> let acc' = - if i <> -1 then Edges.add_internal a site i acc else acc in + if i <> -1 then + Edges.add_internal a site i acc + else + acc + in match l with | Pattern.UnSpec | Pattern.Free -> Edges.add_free a site acc' - | Pattern.Link (x',s') -> - match Mods.IntMap.find_option x' emb' with + | Pattern.Link (x', s') -> + (match Mods.IntMap.find_option x' emb' with | None -> acc' - | Some ag' -> fst @@ Edges.add_link ag site ag' s' acc') - g' intf) - cc (Mods.IntMap.empty,graph) in + | Some ag' -> fst @@ Edges.add_link ag site ag' s' acc')) + g' intf )) + cc (Mods.IntMap.empty, graph) + in let r = Renaming.empty () in let out = Mods.IntMap.fold - (fun i (a,_) acc -> acc && Renaming.imperative_add ~debugMode i a r) - e true in + (fun i (a, _) acc -> acc && Renaming.imperative_add ~debug_mode i a r) + e true + in let () = assert out in - (g,r) + g, r let find_embeddings compil = - Pattern.embeddings_to_fully_specified - ~debugMode:compil.debugMode (domain compil) + Pattern.embeddings_to_fully_specified ~debug_mode:compil.debug_mode + (domain compil) -let f ~debugMode ren acc (i,_cc) em = +let f ~debug_mode ren acc (i, _cc) em = List_util.map_flatten (fun m -> - List_util.map_option - (fun r -> - Matching.add_cc m i - (Renaming.compose ~debugMode true r ren)) em) + List_util.map_option + (fun r -> Matching.add_cc m i (Renaming.compose ~debug_mode true r ren)) + em) acc (*let find_embeddings_unary_binary compil p x = @@ -316,81 +270,73 @@ let f ~debugMode ren acc (i,_cc) em = (matc,mix)*) let compose_embeddings_unary_binary compil p emb_list x = - let mix,ren = - add_fully_specified_to_graph - ~debugMode:compil.debugMode + let mix, ren = + add_fully_specified_to_graph ~debug_mode:compil.debug_mode (Model.signatures compil.environment) - (Edges.empty ~with_connected_components:false) x in - let cc_list = - Tools.array_fold_lefti - (fun i acc cc -> (i,cc)::acc) - [] p + (Edges.empty ~with_connected_components:false) + x in + let cc_list = Tools.array_fold_lefti (fun i acc cc -> (i, cc) :: acc) [] p in let matc = List.fold_left2 - (f ~debugMode:compil.debugMode ren) - [Matching.empty] - cc_list emb_list in - (matc,mix) + (f ~debug_mode:compil.debug_mode ren) + [ Matching.empty ] cc_list emb_list + in + matc, mix -let disjoint_union_sigs ~debugMode sigs l = - let pat = Tools.array_map_of_list (fun (x,_,_) -> x) l in - let _,em,mix = +let disjoint_union_sigs ~debug_mode sigs l = + let pat = Tools.array_map_of_list (fun (x, _, _) -> x) l in + let _, em, mix = List.fold_left - (fun (i,em,mix) (_,r,cc) -> - let i = pred i in - let (mix',r') = - add_fully_specified_to_graph ~debugMode sigs mix cc in - let r'' = Renaming.compose ~debugMode false r r' in - (i, - Option_util.unsome - Matching.empty - (Matching.add_cc em i r''), - mix')) - (List.length l,Matching.empty, - Edges.empty ~with_connected_components:false) - l in - (pat,em,mix) + (fun (i, em, mix) (_, r, cc) -> + let i = pred i in + let mix', r' = add_fully_specified_to_graph ~debug_mode sigs mix cc in + let r'' = Renaming.compose ~debug_mode false r r' in + i, Option_util.unsome Matching.empty (Matching.add_cc em i r''), mix') + ( List.length l, + Matching.empty, + Edges.empty ~with_connected_components:false ) + l + in + pat, em, mix let disjoint_union compil l = - let sigs = Model.signatures (compil.environment) in - disjoint_union_sigs ~debugMode:compil.debugMode sigs l + let sigs = Model.signatures compil.environment in + disjoint_union_sigs ~debug_mode:compil.debug_mode sigs l type rule_id = int - type arity = Rule_modes.arity - type direction = Rule_modes.direction - type rule_name = string - type rule_id_with_mode = rule_id * arity * direction let lhs _compil _rule_id r = r.Primitives.connected_components let is_zero expr = match expr with - | Alg_expr.CONST a,_ -> - Nbr.is_zero a - | ((Alg_expr.BIN_ALG_OP (_, _, _) |Alg_expr.UN_ALG_OP (_, _) - | Alg_expr.IF (_, _, _) | Alg_expr.DIFF_TOKEN _ - | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.ALG_VAR _| Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _), _) -> false - - -let add_not_none_not_zero x y list = + | Alg_expr.CONST a, _ -> Nbr.is_zero a + | ( ( Alg_expr.BIN_ALG_OP (_, _, _) + | Alg_expr.UN_ALG_OP (_, _) + | Alg_expr.IF (_, _, _) + | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ | Alg_expr.KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ ), + _ ) -> + false + +let add_not_none_not_zero x y list = match y with | None -> list | Some x when is_zero (fst x) -> list - | Some _ -> x::list + | Some _ -> x :: list let add_not_zero x y list = - if is_zero y then list - else x::list + if is_zero y then + list + else + x :: list -let mode_of_rule _compil _rule = - Rule_modes.Direct +let mode_of_rule _compil _rule = Rule_modes.Direct let n_cc cache compil rule = let id = rule.Primitives.syntactic_rule in @@ -403,19 +349,17 @@ let n_cc cache compil rule = let n_cc cache compil rule = hash_rule_weight (fun cache rule -> - let id = rule.Primitives.syntactic_rule in - Mods.DynArray.get cache.n_cc id - ) + let id = rule.Primitives.syntactic_rule in + Mods.DynArray.get cache.n_cc id) (fun cache rule n -> - let id = rule.Primitives.syntactic_rule in - let () = Mods.DynArray.set cache.n_cc id (Some n) in - cache) - n_cc - cache compil rule + let id = rule.Primitives.syntactic_rule in + let () = Mods.DynArray.set cache.n_cc id (Some n) in + cache) + n_cc cache compil rule let valid_modes cache compil rule = let id = rule.Primitives.syntactic_rule in - let cache, arity =n_cc cache compil rule in + let cache, arity = n_cc cache compil rule in let arity' = Array.length rule.Primitives.connected_components in let mode = mode_of_rule compil rule in let () = assert (arity' <= arity) in @@ -423,217 +367,214 @@ let valid_modes cache compil rule = if arity = arity' then add_not_zero Rule_modes.Usual rule.Primitives.rate (add_not_none_not_zero Rule_modes.Unary rule.Primitives.unary_rate []) - else if arity'=1 && arity=2 - then + else if arity' = 1 && arity = 2 then ( let lkappa_rule = Model.get_ast_rule compil.environment id in - add_not_none_not_zero - Rule_modes.Unary_refinement - lkappa_rule.LKappa.r_un_rate - [] - else + add_not_none_not_zero Rule_modes.Unary_refinement + lkappa_rule.LKappa.r_un_rate [] + ) else [] in - cache, - List.rev_map - (fun x -> id,x,mode) - (List.rev mode_list) - -let rate _compil rule (_,arity,_) = - match - arity - with + cache, List.rev_map (fun x -> id, x, mode) (List.rev mode_list) + +let rate _compil rule (_, arity, _) = + match arity with | Rule_modes.Usual -> Some rule.Primitives.rate - | (Rule_modes.Unary | Rule_modes.Unary_refinement) -> + | Rule_modes.Unary | Rule_modes.Unary_refinement -> Option_util.map fst rule.Primitives.unary_rate let token_vector a = a.Primitives.delta_tokens - let token_vector_of_init = token_vector - let print_rule_id log = Format.fprintf log "%i" let print_rule ?compil = match compil with | None -> - Kade_backend.Kappa_printer.elementary_rule - ~noCounters:true ?env:None ?symbol_table:None + Kade_backend.Kappa_printer.elementary_rule ~noCounters:true ?env:None + ?symbol_table:None | Some compil -> - Kade_backend.Kappa_printer.decompiled_rule - ~noCounters:compil.debugMode + Kade_backend.Kappa_printer.decompiled_rule ~noCounters:compil.debug_mode ~full:true (environment compil) ~symbol_table:(symbol_table compil) let print_rule_name ?compil f r = let env = environment_opt compil in let id = r.Primitives.syntactic_rule in Kade_backend.Model.print_ast_rule - ~noCounters:(match compil with None -> false | Some c -> c.debugMode) + ~noCounters: + (match compil with + | None -> false + | Some c -> c.debug_mode) ?env ~symbol_table:(symbol_table_opt compil) f id let string_of_var_id ?compil ?init_mode logger r = let f logger r = match Loggers.get_encoding_format logger with | Loggers.Mathematica | Loggers.Maple -> - "var"^(string_of_int r)^(match init_mode with Some true -> "" | Some _ | None -> "(t)") - | Loggers.Octave | Loggers.Matlab -> - "var("^(string_of_int r)^")" - | Loggers.TXT | Loggers.TXT_Tabular - | Loggers.XLS | Loggers.SBML | Loggers.DOTNET - | Loggers.DOT - | Loggers.HTML | Loggers.HTML_Graph | Loggers.Js_Graph - | Loggers.HTML_Tabular | Loggers.GEPHI - | Loggers.Json | Loggers.Matrix -> "" + "var" ^ string_of_int r + ^ + (match init_mode with + | Some true -> "" + | Some _ | None -> "(t)") + | Loggers.Octave | Loggers.Matlab -> "var(" ^ string_of_int r ^ ")" + | Loggers.TXT | Loggers.TXT_Tabular | Loggers.XLS | Loggers.SBML + | Loggers.DOTNET | Loggers.DOT | Loggers.HTML | Loggers.HTML_Graph + | Loggers.Js_Graph | Loggers.HTML_Tabular | Loggers.GEPHI | Loggers.Json + | Loggers.Matrix -> + "" in let env = environment_opt compil in match env with | None -> f logger r | Some env -> - try - let array = Model.get_algs env in - fst (array.(r-1)) - with - _ -> f logger r + (try + let array = Model.get_algs env in + fst array.(r - 1) + with _ -> f logger r) let string_of_var_id_jac ?compil r dt = let _ = compil in - "jacvar("^(string_of_int r)^","^(string_of_int dt)^")" + "jacvar(" ^ string_of_int r ^ "," ^ string_of_int dt ^ ")" let rate_name compil rule rule_id = - let (_kade_id,arity,direction) = rule_id in + let _kade_id, arity, direction = rule_id in let arity_tag = match arity with | Rule_modes.Usual -> "" - | (Rule_modes.Unary | Rule_modes.Unary_refinement) -> " (unary context)" + | Rule_modes.Unary | Rule_modes.Unary_refinement -> " (unary context)" in let direction_tag = match direction with | Rule_modes.Direct -> "" | Rule_modes.Op -> " (op)" in - Format.asprintf "%a%s%s" (print_rule_name ~compil) rule - arity_tag direction_tag + Format.asprintf "%a%s%s" (print_rule_name ~compil) rule arity_tag + direction_tag -let apply_sigs ~debugMode env rule inj_nodes mix = +let apply_sigs ~debug_mode env rule inj_nodes mix = let concrete_removed = - List.map (Primitives.Transformation.concretize - ~debugMode (inj_nodes, Mods.IntMap.empty)) + List.map + (Primitives.Transformation.concretize ~debug_mode + (inj_nodes, Mods.IntMap.empty)) rule.Primitives.removed in let dummy_instances = Instances.empty env in - let (side_effects, edges_after_neg) = + let side_effects, edges_after_neg = List.fold_left (Rule_interpreter.apply_negative_transformation ?mod_connectivity_store:None dummy_instances) - ([], mix) - concrete_removed + ([], mix) concrete_removed in let (_, remaining_side_effects, edges'), concrete_inserted = List.fold_left - (fun (x,p) h -> - let (x',h') = - Rule_interpreter.apply_positive_transformation - ~debugMode (Model.signatures env) dummy_instances x h in - (x', h' :: p)) - (((inj_nodes, Mods.IntMap.empty), - side_effects, edges_after_neg), []) + (fun (x, p) h -> + let x', h' = + Rule_interpreter.apply_positive_transformation ~debug_mode + (Model.signatures env) dummy_instances x h + in + x', h' :: p) + (((inj_nodes, Mods.IntMap.empty), side_effects, edges_after_neg), []) rule.Primitives.inserted in - let (edges'',_) = + let edges'', _ = List.fold_left - (fun (e,i) ((id,_ as nc),s) -> - Edges.add_free id s e, - Primitives.Transformation.Freed (nc, s) :: i) - (edges', concrete_inserted) remaining_side_effects + (fun (e, i) (((id, _) as nc), s) -> + Edges.add_free id s e, Primitives.Transformation.Freed (nc, s) :: i) + (edges', concrete_inserted) + remaining_side_effects in edges'' let apply compil rule inj_nodes mix = - apply_sigs - ~debugMode:compil.debugMode compil.environment rule inj_nodes mix + apply_sigs ~debug_mode:compil.debug_mode compil.environment rule inj_nodes mix let get_rules compil = - Model.fold_rules - (fun _ acc r -> r::acc) [] (environment compil) + Model.fold_rules (fun _ acc r -> r :: acc) [] (environment compil) let get_variables compil = Model.get_algs (environment compil) let get_obs compil = - Array.to_list - (Model.map_observables (fun r -> r) (environment compil)) + Array.to_list (Model.map_observables (fun r -> r) (environment compil)) let remove_escape_char = (* I do not know anything about it be single quote are not allowed in Octave, please correct this function if you are more knowledgeable *) - String.map - (function '\'' -> '|' | x -> x) + String.map (function + | '\'' -> '|' + | x -> x) let get_obs_titles compil = let env = environment compil in - Array.to_list @@ - Model.map_observables - (fun x -> remove_escape_char - (Format.asprintf "%a" - (Kade_backend.Kappa_printer.alg_expr - ~noCounters:compil.debugMode ~env - ~symbol_table:(symbol_table compil) - ) x)) - env + Array.to_list + @@ Model.map_observables + (fun x -> + remove_escape_char + (Format.asprintf "%a" + (Kade_backend.Kappa_printer.alg_expr ~noCounters:compil.debug_mode + ~env ~symbol_table:(symbol_table compil)) + x)) + env let get_preprocessed_ast cli_args = let warning ~pos msg = Data.print_warning ~pos Format.err_formatter msg in - Cli_init.get_preprocessed_ast_from_cli_args ~warning ~debugMode:false cli_args -let to_preprocessed_ast x = x + Cli_init.get_preprocessed_ast_from_cli_args ~warning ~debug_mode:false + cli_args +let to_preprocessed_ast x = x let get_ast cli_args = Cli_init.get_ast_from_cli_args cli_args let to_ast x = x let preprocess cli_args ast = let warning ~pos msg = Data.print_warning ~pos Format.err_formatter msg in - Cli_init.preprocess ~warning ~debugMode:false cli_args ast + Cli_init.preprocess_ast ~warning ~debug_mode:false cli_args ast -let saturate_domain_with_symmetric_patterns ~debugMode bwd_bisim_info env = +let saturate_domain_with_symmetric_patterns ~debug_mode bwd_bisim_info env = let contact_map = Model.contact_map env in let preenv' = Model.fold_mixture_in_expr (fun domain ccs -> - LKappa_group_action.saturate_domain_with_symmetric_patterns - ~debugMode ~compileModeOn:false env bwd_bisim_info ccs domain) + LKappa_group_action.saturate_domain_with_symmetric_patterns ~debug_mode + ~compile_mode_on:false env bwd_bisim_info ccs domain) (Pattern.PreEnv.of_env (Model.domain env)) - env in - let (domain,_) = - Pattern.finalize ~debugMode ~sharing:Pattern.No_sharing preenv' contact_map in + env + in + let domain, _ = + Pattern.finalize ~debug_mode ~sharing:Pattern.No_sharing preenv' contact_map + in Model.new_domain domain env -let get_compil - ~debugMode ~dotnet ?bwd_bisim - ~rule_rate_convention ?reaction_rate_convention - ~show_reactions ~count ~internal_meaning ~compute_jacobian cli_args preprocessed_ast = +let get_compil ~debug_mode ~dotnet ?bwd_bisim ~rule_rate_convention + ?reaction_rate_convention ~show_reactions ~count ~internal_meaning + ~compute_jacobian cli_args preprocessed_ast = let warning ~pos msg = Data.print_warning ~pos Format.err_formatter msg in - let (_, env, contact_map, _, _, _, _, init), _ = - Cli_init.get_compilation_from_preprocessed_ast - ~warning cli_args preprocessed_ast + let compilation_result : Cli_init.compilation_result = + Cli_init.get_compilation_from_preprocessed_ast ~warning cli_args + preprocessed_ast in - let env = match bwd_bisim with - | None -> env + let env = + match bwd_bisim with + | None -> compilation_result.env | Some bsi -> - saturate_domain_with_symmetric_patterns ~debugMode bsi env in - let compil = { - debugMode; - environment = env ; - contact_map ; - init = init ; - rule_rate_convention = rule_rate_convention ; - reaction_rate_convention = reaction_rate_convention ; - show_reactions = show_reactions ; - count = count ; - internal_meaning = internal_meaning ; - compute_jacobian = compute_jacobian ; - allow_empty_lhs = true ; - symbol_table = - match cli_args.Run_cli_args.syntaxVersion with - | Ast.V3 -> Symbol_table.unbreakable_symbol_table_V3 - | Ast.V4 -> Symbol_table.unbreakable_symbol_table_V4 ; - } + saturate_domain_with_symmetric_patterns ~debug_mode bsi + compilation_result.env + in + let compil = + { + debug_mode; + environment = env; + contact_map = compilation_result.contact_map; + init = compilation_result.init_l; + rule_rate_convention; + reaction_rate_convention; + show_reactions; + count; + internal_meaning; + compute_jacobian; + allow_empty_lhs = true; + symbol_table = + (match cli_args.Run_cli_args.syntaxVersion with + | Ast.V3 -> Symbol_table.unbreakable_symbol_table_V3 + | Ast.V4 -> Symbol_table.unbreakable_symbol_table_V4); + } in if dotnet then to_dotnet (dont_allow_empty_lhs compil) @@ -644,24 +585,20 @@ let empty_cc_cache compil = Pattern.PreEnv.of_env (Model.domain compil.environment) let empty_lkappa_cache () = LKappa_auto.init_cache () - let empty_sym_cache () = Symmetries.empty_cache () +let empty_seen_cache () = Mods.DynArray.create 1 false +let empty_rule_weight () = Mods.DynArray.create 1 None -let empty_seen_cache () = - Mods.DynArray.create 1 false - -let empty_rule_weight () = - Mods.DynArray.create 1 None let empty_cache compil = { - cc_cache = empty_cc_cache compil ; - rule_cache = empty_lkappa_cache () ; - representative_cache = empty_sym_cache () ; - seen_pattern = empty_seen_cache () ; - seen_rule = empty_seen_cache () ; - seen_species = empty_seen_cache () ; - n_cc = empty_rule_weight () ; - correcting_coef = empty_rule_weight () ; + cc_cache = empty_cc_cache compil; + rule_cache = empty_lkappa_cache (); + representative_cache = empty_sym_cache (); + seen_pattern = empty_seen_cache (); + seen_rule = empty_seen_cache (); + seen_species = empty_seen_cache (); + n_cc = empty_rule_weight (); + correcting_coef = empty_rule_weight (); } let mixture_of_init compil c = @@ -669,31 +606,31 @@ let mixture_of_init compil c = let m = apply compil c emb m in m -let mixture_of_init_sigs ~debugMode env c = - let _, emb, m = disjoint_union_sigs ~debugMode (Model.signatures env) [] in - let m = apply_sigs ~debugMode env c emb m in +let mixture_of_init_sigs ~debug_mode env c = + let _, emb, m = disjoint_union_sigs ~debug_mode (Model.signatures env) [] in + let m = apply_sigs ~debug_mode env c emb m in m -let species_of_initial_state_env ~debugMode env contact_map_int cache list = +let species_of_initial_state_env ~debug_mode env contact_map_int cache list = let sigs = Model.signatures env in let cache, list = List.fold_left - (fun (cache,list) (_,r) -> - let b = mixture_of_init_sigs ~debugMode env r in - let cache', acc = - connected_components_of_mixture_sigs - ~debugMode sigs cache contact_map_int b - in - cache', List.rev_append acc list) - (cache,[]) list + (fun (cache, list) (_, r) -> + let b = mixture_of_init_sigs ~debug_mode env r in + let cache', acc = + connected_components_of_mixture_sigs ~debug_mode sigs cache + contact_map_int b + in + cache', List.rev_append acc list) + (cache, []) list in cache, list let species_of_initial_state compil cache list = let cc_cache, list = - species_of_initial_state_env - ~debugMode:compil.debugMode compil.environment - (contact_map compil) (get_cc_cache cache) list in + species_of_initial_state_env ~debug_mode:compil.debug_mode + compil.environment (contact_map compil) (get_cc_cache cache) list + in set_cc_cache cc_cache cache, list let nb_tokens compil = Model.nb_tokens (environment compil) @@ -701,18 +638,15 @@ let nb_tokens compil = Model.nb_tokens (environment compil) let divide_rule_rate_by cache compil rule = match compil.rule_rate_convention with | Remanent_parameters_sig.Common -> assert false -(* this is not a valid parameterization *) -(* Common can be used only to compute normal forms *) + (* this is not a valid parameterization *) + (* Common can be used only to compute normal forms *) | Remanent_parameters_sig.No_correction -> cache, 1 | Remanent_parameters_sig.Biochemist | Remanent_parameters_sig.Divide_by_nbr_of_autos_in_lhs -> let rule_id = rule.Primitives.syntactic_rule in - let lkappa_rule = - Model.get_ast_rule compil.environment rule_id - in + let lkappa_rule = Model.get_ast_rule compil.environment rule_id in let rule_cache, output = - LKappa_auto.nauto compil.rule_rate_convention - (get_rule_cache cache) + LKappa_auto.nauto compil.rule_rate_convention (get_rule_cache cache) lkappa_rule in set_rule_cache rule_cache cache, output @@ -720,78 +654,60 @@ let divide_rule_rate_by cache compil rule = let divide_rule_rate_by cache compil rule = hash_rule_weight (fun cache rule -> - let rule_id = rule.Primitives.syntactic_rule in - Mods.DynArray.get cache.correcting_coef rule_id) + let rule_id = rule.Primitives.syntactic_rule in + Mods.DynArray.get cache.correcting_coef rule_id) (fun cache rule n -> - let rule_id = rule.Primitives.syntactic_rule in - let () = Mods.DynArray.set cache.correcting_coef rule_id (Some n) in - cache) - divide_rule_rate_by - cache compil rule + let rule_id = rule.Primitives.syntactic_rule in + let () = Mods.DynArray.set cache.correcting_coef rule_id (Some n) in + cache) + divide_rule_rate_by cache compil rule let detect_symmetries parameters compil cache chemical_species contact_map = let rule_cache = get_rule_cache cache in let rule_cache, symmetries = - Symmetries.detect_symmetries - parameters - compil.environment - rule_cache - compil.rule_rate_convention - chemical_species - (get_rules compil) + Symmetries.detect_symmetries parameters compil.environment rule_cache + compil.rule_rate_convention chemical_species (get_rules compil) contact_map in - set_rule_cache rule_cache cache, - symmetries + set_rule_cache rule_cache cache, symmetries let print_symmetries parameters compil symmetries = let env = compil.environment in Symmetries.print_symmetries parameters env symmetries -let valid_mixture compil cc_cache ?max_size mixture = - match max_size - with - | None -> cc_cache,true +let valid_mixture compil cc_cache ?max_size mixture = + match max_size with + | None -> cc_cache, true | Some n -> let cc_cache, cc_list = connected_components_of_mixture compil cc_cache mixture in - cc_cache, - List.for_all - (fun cc -> Pattern.size_of_cc cc <= n) - cc_list + cc_cache, List.for_all (fun cc -> Pattern.size_of_cc cc <= n) cc_list let init_bwd_bisim_info red = - red, - Mods.DynArray.create 1 false, - ref (LKappa_auto.init_cache ()) + red, Mods.DynArray.create 1 false, ref (LKappa_auto.init_cache ()) -module type ObsMap = -sig +module type ObsMap = sig type 'a t - val empty: 'a -> 'a t - val add: connected_component -> 'a -> 'a list t -> 'a list t - val get: connected_component -> 'a list t -> 'a list - val reset: connected_component -> 'a list t -> 'a list t + val empty : 'a -> 'a t + val add : connected_component -> 'a -> 'a list t -> 'a list t + val get : connected_component -> 'a list t -> 'a list + val reset : connected_component -> 'a list t -> 'a list t end -module ObsMap = -(struct +module ObsMap : ObsMap = struct type 'a t = 'a Pattern.ObsMap.t - let empty a = - Pattern.ObsMap.dummy a - let get cc map = - Pattern.ObsMap.get map cc + let empty a = Pattern.ObsMap.dummy a + let get cc map = Pattern.ObsMap.get map cc let add cc data map = let old = get cc map in - let () = Pattern.ObsMap.set map cc (data::old) in + let () = Pattern.ObsMap.set map cc (data :: old) in map - let reset cc map = + let reset cc map = let () = Pattern.ObsMap.set map cc [] in map - -end: ObsMap) +end diff --git a/core/symmetries/symmetry_interface_sig.ml b/core/symmetries/symmetry_interface_sig.ml index 8c527bae73..0303c4b699 100644 --- a/core/symmetries/symmetry_interface_sig.ml +++ b/core/symmetries/symmetry_interface_sig.ml @@ -3,238 +3,221 @@ * Last modification: Time-stamp: *) -module type Interface = -sig +module type Interface = sig type ast type preprocessed_ast type compil type cache - - type mixture (* not necessarily connected, fully specified *) - type chemical_species (* connected, fully specified *) - type canonic_species (* chemical species in canonic form *) - type pattern (* not necessarity connected, maybe partially specified *) - type connected_component (* connected, maybe partially specified *) - + type mixture (* not necessarily connected, fully specified *) + type chemical_species (* connected, fully specified *) + type canonic_species (* chemical species in canonic form *) + type pattern (* not necessarity connected, maybe partially specified *) + type connected_component (* connected, maybe partially specified *) type rule - - type init = - ((connected_component array list,int) Alg_expr.e * rule) list - - val debug_mode: compil -> bool - val do_we_allow_empty_lhs: compil -> bool - val to_dotnet: compil -> compil - val with_dot_and_plus: compil -> compil - val dont_allow_empty_lhs: compil -> compil - val empty_cache: compil -> cache - - val get_init: compil -> init - - val mixture_of_init: compil -> rule(*hidden_init*) -> mixture - - val dummy_chemical_species: compil -> chemical_species + type init = ((connected_component array list, int) Alg_expr.e * rule) list + + val debug_mode : compil -> bool + val do_we_allow_empty_lhs : compil -> bool + val to_dotnet : compil -> compil + val with_dot_and_plus : compil -> compil + val dont_allow_empty_lhs : compil -> compil + val empty_cache : compil -> cache + val get_init : compil -> init + val mixture_of_init : compil -> rule (*hidden_init*) -> mixture + val dummy_chemical_species : compil -> chemical_species val compare_connected_component : connected_component -> connected_component -> int val print_connected_component : - ?compil:compil -> - Format.formatter -> connected_component -> unit + ?compil:compil -> Format.formatter -> connected_component -> unit - val print_token : - ?compil:compil -> Format.formatter -> int -> unit + val print_token : ?compil:compil -> Format.formatter -> int -> unit - val print_chemical_species: + val print_chemical_species : ?compil:compil -> Format.formatter -> chemical_species -> unit - val print_canonic_species: + val print_canonic_species : ?compil:compil -> Format.formatter -> canonic_species -> unit - val rule_rate_convention: compil -> - Remanent_parameters_sig.rate_convention - val reaction_rate_convention: compil -> - Remanent_parameters_sig.rate_convention option - val what_do_we_count: compil -> Ode_args.count - val do_we_count_in_embeddings: compil -> bool - val internal_meaning_is_nembeddings: compil -> bool - val do_we_prompt_reactions: compil -> bool + val rule_rate_convention : compil -> Remanent_parameters_sig.rate_convention - val symbol_table: compil -> Symbol_table.symbol_table - val nbr_automorphisms_in_chemical_species: - debugMode:bool -> chemical_species -> int + val reaction_rate_convention : + compil -> Remanent_parameters_sig.rate_convention option - val canonic_form: chemical_species -> canonic_species + val what_do_we_count : compil -> Ode_args.count + val do_we_count_in_embeddings : compil -> bool + val internal_meaning_is_nembeddings : compil -> bool + val do_we_prompt_reactions : compil -> bool + val symbol_table : compil -> Symbol_table.symbol_table - val connected_components_of_patterns: - pattern -> connected_component list + val nbr_automorphisms_in_chemical_species : + debug_mode:bool -> chemical_species -> int - val connected_components_of_mixture: - compil -> cache -> - mixture -> cache * chemical_species list + val canonic_form : chemical_species -> canonic_species + val connected_components_of_patterns : pattern -> connected_component list - type embedding (* the domain is connected *) + val connected_components_of_mixture : + compil -> cache -> mixture -> cache * chemical_species list + type embedding (* the domain is connected *) type embedding_forest (* the domain may be not connected *) - val lift_embedding: embedding -> embedding_forest + val lift_embedding : embedding -> embedding_forest - val find_embeddings: - compil -> connected_component -> chemical_species -> - embedding list + val find_embeddings : + compil -> connected_component -> chemical_species -> embedding list - val find_all_embeddings: + val find_all_embeddings : compil -> chemical_species -> (connected_component * embedding) list (*val find_embeddings_unary_binary: compil -> pattern -> chemical_species -> embedding_forest list * mixture*) - val compose_embeddings_unary_binary: - compil -> pattern -> embedding list list -> chemical_species -> embedding_forest list * mixture + val compose_embeddings_unary_binary : + compil -> + pattern -> + embedding list list -> + chemical_species -> + embedding_forest list * mixture - module type ObsMap = - sig + module type ObsMap = sig type 'a t - val empty: 'a -> 'a t - val add: connected_component -> 'a -> 'a list t -> 'a list t - val get: connected_component -> 'a list t -> 'a list - val reset: connected_component -> 'a list t -> 'a list t + val empty : 'a -> 'a t + val add : connected_component -> 'a -> 'a list t -> 'a list t + val get : connected_component -> 'a list t -> 'a list + val reset : connected_component -> 'a list t -> 'a list t end module ObsMap : ObsMap - val disjoint_union: - compil -> + val disjoint_union : + compil -> (connected_component * embedding * chemical_species) list -> pattern * embedding_forest * mixture (*type rule*) type rule_name = string - type rule_id = int + type rule_id_with_mode = rule_id * Rule_modes.arity * Rule_modes.direction - type rule_id_with_mode = - rule_id * Rule_modes.arity * Rule_modes.direction - - val valid_modes: cache -> compil -> rule -> cache * rule_id_with_mode list - - val lhs: compil -> rule_id_with_mode -> rule -> pattern + val valid_modes : cache -> compil -> rule -> cache * rule_id_with_mode list + val lhs : compil -> rule_id_with_mode -> rule -> pattern - val token_vector: + val token_vector : rule -> - ((connected_component array list,int) Alg_expr.e Locality.annot - * int) list + ((connected_component array list, int) Alg_expr.e Loc.annoted * int) list - val token_vector_of_init: + val token_vector_of_init : rule -> - ((connected_component array list,int) Alg_expr.e Locality.annot - * int) list + ((connected_component array list, int) Alg_expr.e Loc.annoted * int) list - val print_rule_id: Format.formatter -> rule_id -> unit + val print_rule_id : Format.formatter -> rule_id -> unit + val print_rule : ?compil:compil -> Format.formatter -> rule -> unit + val print_rule_name : ?compil:compil -> Format.formatter -> rule -> unit - val print_rule: - ?compil:compil -> Format.formatter -> rule -> unit - - val print_rule_name: - ?compil:compil -> Format.formatter -> rule -> unit - - val string_of_var_id: + val string_of_var_id : ?compil:compil -> ?init_mode:bool -> Loggers.t -> rule_id -> string - val string_of_var_id_jac: - ?compil:compil -> rule_id -> rule_id -> string + val string_of_var_id_jac : ?compil:compil -> rule_id -> rule_id -> string (* module SyntacticRuleSetMap:SetMap.SetMap*) - val rate: - compil -> rule -> rule_id_with_mode -> - (connected_component array list, int) Alg_expr.e Locality.annot option - - val rate_name: - compil -> rule -> rule_id_with_mode -> rule_name - - val apply: compil -> rule -> embedding_forest -> mixture -> mixture - - val get_preprocessed_ast: Run_cli_args.t -> preprocessed_ast - val to_preprocessed_ast: preprocessed_ast -> Cli_init.preprocessed_ast - val get_ast: Run_cli_args.t -> ast - val to_ast: ast -> Ast.parsing_compil - val preprocess: Run_cli_args.t -> ast -> preprocessed_ast - - val get_compil: - debugMode:bool -> dotnet:bool -> + val rate : + compil -> + rule -> + rule_id_with_mode -> + (connected_component array list, int) Alg_expr.e Loc.annoted option + + val rate_name : compil -> rule -> rule_id_with_mode -> rule_name + val apply : compil -> rule -> embedding_forest -> mixture -> mixture + val get_preprocessed_ast : Run_cli_args.t -> preprocessed_ast + val to_preprocessed_ast : preprocessed_ast -> Cli_init.preprocessed_ast + val get_ast : Run_cli_args.t -> ast + val to_ast : ast -> Ast.parsing_compil + val preprocess : Run_cli_args.t -> ast -> preprocessed_ast + + val get_compil : + debug_mode:bool -> + dotnet:bool -> ?bwd_bisim:LKappa_group_action.bwd_bisim_info -> rule_rate_convention:Remanent_parameters_sig.rate_convention -> ?reaction_rate_convention:Remanent_parameters_sig.rate_convention -> - show_reactions:bool -> count:Ode_args.count -> internal_meaning:Ode_args.count -> - compute_jacobian:bool -> Run_cli_args.t -> preprocessed_ast -> compil + show_reactions:bool -> + count:Ode_args.count -> + internal_meaning:Ode_args.count -> + compute_jacobian:bool -> + Run_cli_args.t -> + preprocessed_ast -> + compil - val get_rules: compil -> rule list + val get_rules : compil -> rule list - val get_variables: + val get_variables : compil -> - (string * - (connected_component array list,int) Alg_expr.e Locality.annot) - array - - val get_obs: - compil -> (connected_component array list,int) Alg_expr.e list + (string * (connected_component array list, int) Alg_expr.e Loc.annoted) + array - val get_obs_titles: compil -> string list - - val nb_tokens: compil -> int + val get_obs : compil -> (connected_component array list, int) Alg_expr.e list + val get_obs_titles : compil -> string list + val nb_tokens : compil -> int (*symmetries for initial states*) - val divide_rule_rate_by: cache -> compil -> rule -> - cache * int + val divide_rule_rate_by : cache -> compil -> rule -> cache * int - val species_of_initial_state_env : - debugMode:bool -> Model.t -> Contact_map.t -> + val species_of_initial_state_env : + debug_mode:bool -> + Model.t -> + Contact_map.t -> Pattern.PreEnv.t -> ('b * Primitives.elementary_rule) list -> Pattern.PreEnv.t * Pattern.cc list - val species_of_initial_state : compil -> + val species_of_initial_state : + compil -> cache -> ('b * Primitives.elementary_rule) list -> cache * Pattern.cc list val detect_symmetries : - Remanent_parameters_sig.parameters -> - compil -> - cache -> - chemical_species list -> - Public_data.contact_map -> cache * Symmetries.symmetries - + Remanent_parameters_sig.parameters -> + compil -> + cache -> + chemical_species list -> + Public_data.contact_map -> + cache * Symmetries.symmetries - val print_symmetries: - Remanent_parameters_sig.parameters -> - compil -> Symmetries.symmetries -> unit + val print_symmetries : + Remanent_parameters_sig.parameters -> + compil -> + Symmetries.symmetries -> + unit - val get_rule_cache: cache -> LKappa_auto.cache - val set_rule_cache: LKappa_auto.cache -> cache -> cache + val get_rule_cache : cache -> LKappa_auto.cache + val set_rule_cache : LKappa_auto.cache -> cache -> cache - val get_representative: + val get_representative : Remanent_parameters_sig.parameters -> - compil -> cache -> Symmetries.reduction -> - chemical_species -> cache * chemical_species - - val equiv_class_of_pattern: - Remanent_parameters_sig.parameters -> - compil -> cache -> Symmetries.reduction -> - connected_component -> cache * (int * (connected_component * int) list) + compil -> + cache -> + Symmetries.reduction -> + chemical_species -> + cache * chemical_species - val valid_mixture: + val equiv_class_of_pattern : + Remanent_parameters_sig.parameters -> compil -> cache -> - ?max_size:int -> - mixture -> - cache * bool + Symmetries.reduction -> + connected_component -> + cache * (int * (connected_component * int) list) - val init_bwd_bisim_info: - Symmetries.equivalence_classes -> - LKappa_group_action.bwd_bisim_info + val valid_mixture : + compil -> cache -> ?max_size:int -> mixture -> cache * bool + val init_bwd_bisim_info : + Symmetries.equivalence_classes -> LKappa_group_action.bwd_bisim_info end diff --git a/core/symmetries/symmetry_interface_sig.mli b/core/symmetries/symmetry_interface_sig.mli index 31ebec5820..96b7d0bfd4 100644 --- a/core/symmetries/symmetry_interface_sig.mli +++ b/core/symmetries/symmetry_interface_sig.mli @@ -3,237 +3,220 @@ * Last modification: Time-stamp: *) -module type Interface = -sig +module type Interface = sig type ast type preprocessed_ast type compil type cache - - type mixture (* not necessarily connected, fully specified *) - type chemical_species (* connected, fully specified *) - type canonic_species (* chemical species in canonic form *) - type pattern (* not necessarity connected, maybe partially specified *) - type connected_component (* connected, maybe partially specified *) - + type mixture (* not necessarily connected, fully specified *) + type chemical_species (* connected, fully specified *) + type canonic_species (* chemical species in canonic form *) + type pattern (* not necessarity connected, maybe partially specified *) + type connected_component (* connected, maybe partially specified *) type rule - - type init = - ((connected_component array list,int) Alg_expr.e * rule) list - - val debug_mode: compil -> bool - val do_we_allow_empty_lhs: compil -> bool - val to_dotnet: compil -> compil - val with_dot_and_plus: compil -> compil - val dont_allow_empty_lhs: compil -> compil - val empty_cache: compil -> cache - - val get_init: compil -> init - - val mixture_of_init: compil -> rule(*hidden_init*) -> mixture - - val dummy_chemical_species: compil -> chemical_species + type init = ((connected_component array list, int) Alg_expr.e * rule) list + + val debug_mode : compil -> bool + val do_we_allow_empty_lhs : compil -> bool + val to_dotnet : compil -> compil + val with_dot_and_plus : compil -> compil + val dont_allow_empty_lhs : compil -> compil + val empty_cache : compil -> cache + val get_init : compil -> init + val mixture_of_init : compil -> rule (*hidden_init*) -> mixture + val dummy_chemical_species : compil -> chemical_species val compare_connected_component : connected_component -> connected_component -> int val print_connected_component : - ?compil:compil -> - Format.formatter -> connected_component -> unit + ?compil:compil -> Format.formatter -> connected_component -> unit - val print_token : - ?compil:compil -> Format.formatter -> int -> unit + val print_token : ?compil:compil -> Format.formatter -> int -> unit - val print_chemical_species: + val print_chemical_species : ?compil:compil -> Format.formatter -> chemical_species -> unit - val print_canonic_species: + val print_canonic_species : ?compil:compil -> Format.formatter -> canonic_species -> unit - val rule_rate_convention: compil -> - Remanent_parameters_sig.rate_convention - val reaction_rate_convention: compil -> - Remanent_parameters_sig.rate_convention option - val what_do_we_count: compil -> Ode_args.count - val do_we_count_in_embeddings: compil -> bool - val internal_meaning_is_nembeddings: compil -> bool - val do_we_prompt_reactions: compil -> bool + val rule_rate_convention : compil -> Remanent_parameters_sig.rate_convention - val symbol_table: compil -> Symbol_table.symbol_table - val nbr_automorphisms_in_chemical_species: - debugMode:bool -> chemical_species -> int + val reaction_rate_convention : + compil -> Remanent_parameters_sig.rate_convention option - val canonic_form: chemical_species -> canonic_species + val what_do_we_count : compil -> Ode_args.count + val do_we_count_in_embeddings : compil -> bool + val internal_meaning_is_nembeddings : compil -> bool + val do_we_prompt_reactions : compil -> bool + val symbol_table : compil -> Symbol_table.symbol_table - val connected_components_of_patterns: - pattern -> connected_component list + val nbr_automorphisms_in_chemical_species : + debug_mode:bool -> chemical_species -> int - val connected_components_of_mixture: - compil -> cache -> - mixture -> cache * chemical_species list + val canonic_form : chemical_species -> canonic_species + val connected_components_of_patterns : pattern -> connected_component list - type embedding (* the domain is connected *) + val connected_components_of_mixture : + compil -> cache -> mixture -> cache * chemical_species list + type embedding (* the domain is connected *) type embedding_forest (* the domain may be not connected *) - val lift_embedding: embedding -> embedding_forest + val lift_embedding : embedding -> embedding_forest - val find_embeddings: - compil -> connected_component -> chemical_species -> - embedding list + val find_embeddings : + compil -> connected_component -> chemical_species -> embedding list - val find_all_embeddings: + val find_all_embeddings : compil -> chemical_species -> (connected_component * embedding) list (*val find_embeddings_unary_binary: compil -> pattern -> chemical_species -> embedding_forest list * mixture*) - val compose_embeddings_unary_binary: - compil -> pattern -> embedding list list -> chemical_species -> embedding_forest list * mixture + val compose_embeddings_unary_binary : + compil -> + pattern -> + embedding list list -> + chemical_species -> + embedding_forest list * mixture - module type ObsMap = - sig + module type ObsMap = sig type 'a t - val empty: 'a -> 'a t - val add: connected_component -> 'a -> 'a list t -> 'a list t - val get: connected_component -> 'a list t -> 'a list - val reset: connected_component -> 'a list t -> 'a list t + val empty : 'a -> 'a t + val add : connected_component -> 'a -> 'a list t -> 'a list t + val get : connected_component -> 'a list t -> 'a list + val reset : connected_component -> 'a list t -> 'a list t end module ObsMap : ObsMap - val disjoint_union: - compil -> + val disjoint_union : + compil -> (connected_component * embedding * chemical_species) list -> pattern * embedding_forest * mixture (*type rule*) type rule_name = string - type rule_id = int + type rule_id_with_mode = rule_id * Rule_modes.arity * Rule_modes.direction - type rule_id_with_mode = - rule_id * Rule_modes.arity * Rule_modes.direction - - val valid_modes: cache -> compil -> rule -> cache * rule_id_with_mode list - - val lhs: compil -> rule_id_with_mode -> rule -> pattern + val valid_modes : cache -> compil -> rule -> cache * rule_id_with_mode list + val lhs : compil -> rule_id_with_mode -> rule -> pattern - val token_vector: + val token_vector : rule -> - ((connected_component array list,int) Alg_expr.e Locality.annot - * int) list + ((connected_component array list, int) Alg_expr.e Loc.annoted * int) list - val token_vector_of_init: + val token_vector_of_init : rule -> - ((connected_component array list,int) Alg_expr.e Locality.annot - * int) list + ((connected_component array list, int) Alg_expr.e Loc.annoted * int) list - val print_rule_id: Format.formatter -> rule_id -> unit + val print_rule_id : Format.formatter -> rule_id -> unit + val print_rule : ?compil:compil -> Format.formatter -> rule -> unit + val print_rule_name : ?compil:compil -> Format.formatter -> rule -> unit - val print_rule: - ?compil:compil -> Format.formatter -> rule -> unit - - val print_rule_name: - ?compil:compil -> Format.formatter -> rule -> unit - - val string_of_var_id: + val string_of_var_id : ?compil:compil -> ?init_mode:bool -> Loggers.t -> rule_id -> string - val string_of_var_id_jac: - ?compil:compil -> rule_id -> rule_id -> string + val string_of_var_id_jac : ?compil:compil -> rule_id -> rule_id -> string (* module SyntacticRuleSetMap:SetMap.SetMap*) - val rate: - compil -> rule -> rule_id_with_mode -> - (connected_component array list, int) Alg_expr.e Locality.annot option - - val rate_name: - compil -> rule -> rule_id_with_mode -> rule_name - - val apply: compil -> rule -> embedding_forest -> mixture -> mixture - - val get_preprocessed_ast: Run_cli_args.t -> preprocessed_ast - val to_preprocessed_ast: preprocessed_ast -> Cli_init.preprocessed_ast - val get_ast: Run_cli_args.t -> ast - val to_ast: ast -> Ast.parsing_compil - val preprocess: Run_cli_args.t -> ast -> preprocessed_ast - - val get_compil: - debugMode:bool -> dotnet:bool -> + val rate : + compil -> + rule -> + rule_id_with_mode -> + (connected_component array list, int) Alg_expr.e Loc.annoted option + + val rate_name : compil -> rule -> rule_id_with_mode -> rule_name + val apply : compil -> rule -> embedding_forest -> mixture -> mixture + val get_preprocessed_ast : Run_cli_args.t -> preprocessed_ast + val to_preprocessed_ast : preprocessed_ast -> Cli_init.preprocessed_ast + val get_ast : Run_cli_args.t -> ast + val to_ast : ast -> Ast.parsing_compil + val preprocess : Run_cli_args.t -> ast -> preprocessed_ast + + val get_compil : + debug_mode:bool -> + dotnet:bool -> ?bwd_bisim:LKappa_group_action.bwd_bisim_info -> rule_rate_convention:Remanent_parameters_sig.rate_convention -> ?reaction_rate_convention:Remanent_parameters_sig.rate_convention -> - show_reactions:bool -> count:Ode_args.count -> internal_meaning:Ode_args.count -> - compute_jacobian:bool -> Run_cli_args.t -> preprocessed_ast -> compil + show_reactions:bool -> + count:Ode_args.count -> + internal_meaning:Ode_args.count -> + compute_jacobian:bool -> + Run_cli_args.t -> + preprocessed_ast -> + compil - val get_rules: compil -> rule list + val get_rules : compil -> rule list - val get_variables: + val get_variables : compil -> - (string * - (connected_component array list,int) Alg_expr.e Locality.annot) - array - - val get_obs: - compil -> (connected_component array list,int) Alg_expr.e list + (string * (connected_component array list, int) Alg_expr.e Loc.annoted) + array - val get_obs_titles: compil -> string list - - val nb_tokens: compil -> int + val get_obs : compil -> (connected_component array list, int) Alg_expr.e list + val get_obs_titles : compil -> string list + val nb_tokens : compil -> int (*symmetries for initial states*) - val divide_rule_rate_by: cache -> compil -> rule -> - cache * int + val divide_rule_rate_by : cache -> compil -> rule -> cache * int - val species_of_initial_state_env : - debugMode:bool -> Model.t -> Contact_map.t -> + val species_of_initial_state_env : + debug_mode:bool -> + Model.t -> + Contact_map.t -> Pattern.PreEnv.t -> ('b * Primitives.elementary_rule) list -> Pattern.PreEnv.t * Pattern.cc list - val species_of_initial_state : compil -> + val species_of_initial_state : + compil -> cache -> ('b * Primitives.elementary_rule) list -> cache * Pattern.cc list val detect_symmetries : - Remanent_parameters_sig.parameters -> - compil -> - cache -> - chemical_species list -> - Public_data.contact_map -> cache * Symmetries.symmetries - + Remanent_parameters_sig.parameters -> + compil -> + cache -> + chemical_species list -> + Public_data.contact_map -> + cache * Symmetries.symmetries - val print_symmetries: - Remanent_parameters_sig.parameters -> - compil -> Symmetries.symmetries -> unit + val print_symmetries : + Remanent_parameters_sig.parameters -> + compil -> + Symmetries.symmetries -> + unit - val get_rule_cache: cache -> LKappa_auto.cache - val set_rule_cache: LKappa_auto.cache -> cache -> cache + val get_rule_cache : cache -> LKappa_auto.cache + val set_rule_cache : LKappa_auto.cache -> cache -> cache - val get_representative: + val get_representative : Remanent_parameters_sig.parameters -> - compil -> cache -> Symmetries.reduction -> - chemical_species -> cache * chemical_species - - val equiv_class_of_pattern: - Remanent_parameters_sig.parameters -> - compil -> cache -> Symmetries.reduction -> - connected_component -> cache * (int * (connected_component * int) list) + compil -> + cache -> + Symmetries.reduction -> + chemical_species -> + cache * chemical_species - val valid_mixture: + val equiv_class_of_pattern : + Remanent_parameters_sig.parameters -> compil -> cache -> - ?max_size:int -> - mixture -> - cache * bool + Symmetries.reduction -> + connected_component -> + cache * (int * (connected_component * int) list) - val init_bwd_bisim_info: - Symmetries.equivalence_classes -> - LKappa_group_action.bwd_bisim_info + val valid_mixture : + compil -> cache -> ?max_size:int -> mixture -> cache * bool + val init_bwd_bisim_info : + Symmetries.equivalence_classes -> LKappa_group_action.bwd_bisim_info end diff --git a/core/term/alg_expr.ml b/core/term/alg_expr.ml index 2e63bfbb9d..51bf912ef1 100644 --- a/core/term/alg_expr.ml +++ b/core/term/alg_expr.ml @@ -8,145 +8,188 @@ type pervasives_bool = bool -type ('mix,'id) e = - BIN_ALG_OP of Operator.bin_alg_op * - ('mix,'id) e Locality.annot * ('mix,'id) e Locality.annot - | UN_ALG_OP of Operator.un_alg_op * ('mix,'id) e Locality.annot +type ('mix, 'id) e = + | BIN_ALG_OP of + Operator.bin_alg_op + * ('mix, 'id) e Loc.annoted + * ('mix, 'id) e Loc.annoted + | UN_ALG_OP of Operator.un_alg_op * ('mix, 'id) e Loc.annoted | STATE_ALG_OP of Operator.state_alg_op | ALG_VAR of 'id | KAPPA_INSTANCE of 'mix | TOKEN_ID of 'id | CONST of Nbr.t - | IF of ('mix,'id) bool Locality.annot * - ('mix,'id) e Locality.annot * ('mix,'id) e Locality.annot - | DIFF_TOKEN of (('mix,'id) e Locality.annot * 'id) - | DIFF_KAPPA_INSTANCE of (('mix,'id) e Locality.annot * 'mix) -and ('mix,'id) bool = + | IF of + ('mix, 'id) bool Loc.annoted + * ('mix, 'id) e Loc.annoted + * ('mix, 'id) e Loc.annoted + | DIFF_TOKEN of (('mix, 'id) e Loc.annoted * 'id) + | DIFF_KAPPA_INSTANCE of (('mix, 'id) e Loc.annoted * 'mix) + +and ('mix, 'id) bool = | TRUE | FALSE | BIN_BOOL_OP of - Operator.bin_bool_op * - ('mix,'id) bool Locality.annot * ('mix,'id) bool Locality.annot - | UN_BOOL_OP of Operator.un_bool_op * ('mix,'id) bool Locality.annot - | COMPARE_OP of Operator.compare_op * - ('mix,'id) e Locality.annot * ('mix,'id) e Locality.annot + Operator.bin_bool_op + * ('mix, 'id) bool Loc.annoted + * ('mix, 'id) bool Loc.annoted + | UN_BOOL_OP of Operator.un_bool_op * ('mix, 'id) bool Loc.annoted + | COMPARE_OP of + Operator.compare_op + * ('mix, 'id) e Loc.annoted + * ('mix, 'id) e Loc.annoted let rec e_to_yojson ~filenames f_mix f_id = function - | BIN_ALG_OP (op,a,b) -> - `List [Operator.bin_alg_op_to_json op; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) a; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) b] - | UN_ALG_OP (op,a) -> - `List [Operator.un_alg_op_to_json op; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) a] + | BIN_ALG_OP (op, a, b) -> + `List + [ + Operator.bin_alg_op_to_json op; + Loc.yojson_of_annoted ~filenames (e_to_yojson ~filenames f_mix f_id) a; + Loc.yojson_of_annoted ~filenames (e_to_yojson ~filenames f_mix f_id) b; + ] + | UN_ALG_OP (op, a) -> + `List + [ + Operator.un_alg_op_to_json op; + Loc.yojson_of_annoted ~filenames (e_to_yojson ~filenames f_mix f_id) a; + ] | STATE_ALG_OP op -> Operator.state_alg_op_to_json op - | ALG_VAR i -> `List [`String "VAR"; f_id i] - | KAPPA_INSTANCE cc -> `List [`String "MIX"; f_mix cc] - | TOKEN_ID i -> `List [`String "TOKEN"; f_id i] + | ALG_VAR i -> `List [ `String "VAR"; f_id i ] + | KAPPA_INSTANCE cc -> `List [ `String "MIX"; f_mix cc ] + | TOKEN_ID i -> `List [ `String "TOKEN"; f_id i ] | CONST n -> Nbr.to_yojson n - | IF (cond,yes,no) -> - `List [`String "IF"; - Locality.annot_to_yojson ~filenames - (bool_to_yojson ~filenames f_mix f_id) cond; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) yes; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) no] - | DIFF_TOKEN (expr,token) -> - `List [`String "DIFF_TOKEN"; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) expr; - f_id token] - | DIFF_KAPPA_INSTANCE (expr,mixture) -> - `List [`String "DIFF_MIXTURE"; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) expr; - f_mix mixture] + | IF (cond, yes, no) -> + `List + [ + `String "IF"; + Loc.yojson_of_annoted ~filenames + (bool_to_yojson ~filenames f_mix f_id) + cond; + Loc.yojson_of_annoted ~filenames (e_to_yojson ~filenames f_mix f_id) yes; + Loc.yojson_of_annoted ~filenames (e_to_yojson ~filenames f_mix f_id) no; + ] + | DIFF_TOKEN (expr, token) -> + `List + [ + `String "DIFF_TOKEN"; + Loc.yojson_of_annoted ~filenames + (e_to_yojson ~filenames f_mix f_id) + expr; + f_id token; + ] + | DIFF_KAPPA_INSTANCE (expr, mixture) -> + `List + [ + `String "DIFF_MIXTURE"; + Loc.yojson_of_annoted ~filenames + (e_to_yojson ~filenames f_mix f_id) + expr; + f_mix mixture; + ] and bool_to_yojson ~filenames f_mix f_id = function | TRUE -> `Bool true | FALSE -> `Bool false - | UN_BOOL_OP (op,a) -> - `List [ Operator.un_bool_op_to_json op; - Locality.annot_to_yojson ~filenames - (bool_to_yojson ~filenames f_mix f_id) a ] - | BIN_BOOL_OP (op,a,b) -> - `List [ Operator.bin_bool_op_to_json op; - Locality.annot_to_yojson ~filenames - (bool_to_yojson ~filenames f_mix f_id) a; - Locality.annot_to_yojson ~filenames - (bool_to_yojson ~filenames f_mix f_id) b ] - | COMPARE_OP (op,a,b) -> - `List [ Operator.compare_op_to_json op; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) a; - Locality.annot_to_yojson ~filenames - (e_to_yojson ~filenames f_mix f_id) b ] + | UN_BOOL_OP (op, a) -> + `List + [ + Operator.un_bool_op_to_json op; + Loc.yojson_of_annoted ~filenames + (bool_to_yojson ~filenames f_mix f_id) + a; + ] + | BIN_BOOL_OP (op, a, b) -> + `List + [ + Operator.bin_bool_op_to_json op; + Loc.yojson_of_annoted ~filenames + (bool_to_yojson ~filenames f_mix f_id) + a; + Loc.yojson_of_annoted ~filenames + (bool_to_yojson ~filenames f_mix f_id) + b; + ] + | COMPARE_OP (op, a, b) -> + `List + [ + Operator.compare_op_to_json op; + Loc.yojson_of_annoted ~filenames (e_to_yojson ~filenames f_mix f_id) a; + Loc.yojson_of_annoted ~filenames (e_to_yojson ~filenames f_mix f_id) b; + ] let rec e_of_yojson ~filenames f_mix f_id = function - | `List [`String "DIFF_MIXTURE"; expr ; mixture] -> + | `List [ `String "DIFF_MIXTURE"; expr; mixture ] -> DIFF_KAPPA_INSTANCE - (Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) expr, - f_mix mixture) - | `List [`String "DIFF_TOKEN"; expr ; tok] -> + ( Loc.annoted_of_yojson ~filenames (e_of_yojson ~filenames f_mix f_id) expr, + f_mix mixture ) + | `List [ `String "DIFF_TOKEN"; expr; tok ] -> DIFF_TOKEN - (Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) expr, - f_id tok) - | `List [op;a;b] -> + ( Loc.annoted_of_yojson ~filenames (e_of_yojson ~filenames f_mix f_id) expr, + f_id tok ) + | `List [ op; a; b ] -> BIN_ALG_OP - (Operator.bin_alg_op_of_json op, - Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) a, - Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) b) - | `List [`String "VAR"; i] -> ALG_VAR (f_id i) - | `List [`String "TOKEN"; i] -> TOKEN_ID (f_id i) - | `List [`String "MIX"; cc] -> KAPPA_INSTANCE (f_mix cc) - | `List [op;a] -> - UN_ALG_OP (Operator.un_alg_op_of_json op, - Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) a) - | `List [`String "IF"; cond; yes; no] -> - IF (Locality.annot_of_yojson ~filenames - (bool_of_yojson ~filenames f_mix f_id) cond, - Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) yes, - Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) no) + ( Operator.bin_alg_op_of_json op, + Loc.annoted_of_yojson ~filenames (e_of_yojson ~filenames f_mix f_id) a, + Loc.annoted_of_yojson ~filenames (e_of_yojson ~filenames f_mix f_id) b + ) + | `List [ `String "VAR"; i ] -> ALG_VAR (f_id i) + | `List [ `String "TOKEN"; i ] -> TOKEN_ID (f_id i) + | `List [ `String "MIX"; cc ] -> KAPPA_INSTANCE (f_mix cc) + | `List [ op; a ] -> + UN_ALG_OP + ( Operator.un_alg_op_of_json op, + Loc.annoted_of_yojson ~filenames (e_of_yojson ~filenames f_mix f_id) a + ) + | `List [ `String "IF"; cond; yes; no ] -> + IF + ( Loc.annoted_of_yojson ~filenames + (bool_of_yojson ~filenames f_mix f_id) + cond, + Loc.annoted_of_yojson ~filenames (e_of_yojson ~filenames f_mix f_id) yes, + Loc.annoted_of_yojson ~filenames (e_of_yojson ~filenames f_mix f_id) no + ) | x -> - try STATE_ALG_OP (Operator.state_alg_op_of_json x) - with Yojson.Basic.Util.Type_error _ -> - try CONST (Nbr.of_yojson x) - with Yojson.Basic.Util.Type_error _ -> - raise (Yojson.Basic.Util.Type_error ("Invalid Alg_expr",x)) + (try STATE_ALG_OP (Operator.state_alg_op_of_json x) + with Yojson.Basic.Util.Type_error _ -> + (try CONST (Nbr.of_yojson x) + with Yojson.Basic.Util.Type_error _ -> + raise (Yojson.Basic.Util.Type_error ("Invalid Alg_expr", x)))) + and bool_of_yojson ~filenames f_mix f_id = function - | `Bool b -> if b then TRUE else FALSE - | `List [op; a] -> - UN_BOOL_OP (Operator.un_bool_op_of_json op, - Locality.annot_of_yojson ~filenames - (bool_of_yojson ~filenames f_mix f_id) a) - | `List [op; a; b] as x -> - begin - try BIN_BOOL_OP (Operator.bin_bool_op_of_json op, - Locality.annot_of_yojson ~filenames - (bool_of_yojson ~filenames f_mix f_id) a, - Locality.annot_of_yojson ~filenames - (bool_of_yojson ~filenames f_mix f_id) b) - with Yojson.Basic.Util.Type_error _ -> - try COMPARE_OP (Operator.compare_op_of_json op, - Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) a, - Locality.annot_of_yojson ~filenames - (e_of_yojson ~filenames f_mix f_id) b) - with Yojson.Basic.Util.Type_error _ -> - raise (Yojson.Basic.Util.Type_error ("Incorrect bool expr",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect bool_expr",x)) + | `Bool b -> + if b then + TRUE + else + FALSE + | `List [ op; a ] -> + UN_BOOL_OP + ( Operator.un_bool_op_of_json op, + Loc.annoted_of_yojson ~filenames + (bool_of_yojson ~filenames f_mix f_id) + a ) + | `List [ op; a; b ] as x -> + (try + BIN_BOOL_OP + ( Operator.bin_bool_op_of_json op, + Loc.annoted_of_yojson ~filenames + (bool_of_yojson ~filenames f_mix f_id) + a, + Loc.annoted_of_yojson ~filenames + (bool_of_yojson ~filenames f_mix f_id) + b ) + with Yojson.Basic.Util.Type_error _ -> + (try + COMPARE_OP + ( Operator.compare_op_of_json op, + Loc.annoted_of_yojson ~filenames + (e_of_yojson ~filenames f_mix f_id) + a, + Loc.annoted_of_yojson ~filenames + (e_of_yojson ~filenames f_mix f_id) + b ) + with Yojson.Basic.Util.Type_error _ -> + raise (Yojson.Basic.Util.Type_error ("Incorrect bool expr", x)))) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect bool_expr", x)) let rec print pr_mix pr_tok pr_var f = function | CONST n -> Nbr.print f n @@ -154,59 +197,76 @@ let rec print pr_mix pr_tok pr_var f = function | KAPPA_INSTANCE ast -> pr_mix f ast | TOKEN_ID tk -> Format.fprintf f "|%a|" pr_tok tk | STATE_ALG_OP op -> Operator.print_state_alg_op f op - | BIN_ALG_OP (op, (a,_), (b,_)) -> + | BIN_ALG_OP (op, (a, _), (b, _)) -> Operator.print_bin_alg_op - (print pr_mix pr_tok pr_var) a - (print pr_mix pr_tok pr_var) b - f op - | UN_ALG_OP (op, (a,_)) -> + (print pr_mix pr_tok pr_var) + a + (print pr_mix pr_tok pr_var) + b f op + | UN_ALG_OP (op, (a, _)) -> Format.fprintf f "%a(%a)" Operator.print_un_alg_op op - (print pr_mix pr_tok pr_var) a - | IF ((cond,_),(yes,_),(no,_)) -> - Format.fprintf f "%a [?] %a [:] %a" (print_bool pr_mix pr_tok pr_var) cond - (print pr_mix pr_tok pr_var) yes (print pr_mix pr_tok pr_var) no - | DIFF_TOKEN ((expr,_), tok) -> + (print pr_mix pr_tok pr_var) + a + | IF ((cond, _), (yes, _), (no, _)) -> + Format.fprintf f "%a [?] %a [:] %a" + (print_bool pr_mix pr_tok pr_var) + cond + (print pr_mix pr_tok pr_var) + yes + (print pr_mix pr_tok pr_var) + no + | DIFF_TOKEN ((expr, _), tok) -> Format.fprintf f "diff(%a,%a)" (print pr_mix pr_tok pr_var) expr pr_tok tok - | DIFF_KAPPA_INSTANCE ((expr,_), mixture) -> - Format.fprintf f "diff(%a,%a)" (print pr_mix pr_tok pr_var) expr pr_mix mixture + | DIFF_KAPPA_INSTANCE ((expr, _), mixture) -> + Format.fprintf f "diff(%a,%a)" + (print pr_mix pr_tok pr_var) + expr pr_mix mixture + and print_bool pr_mix pr_tok pr_var f = function | TRUE -> Format.fprintf f "[true]" | FALSE -> Format.fprintf f "[false]" - | UN_BOOL_OP (op,(a,_)) -> - Format.fprintf f "%a (%a)" - Operator.print_un_bool_op op (print_bool pr_mix pr_tok pr_var) a - | BIN_BOOL_OP (op,(a,_), (b,_)) -> - Format.fprintf f "(%a %a %a)" (print_bool pr_mix pr_tok pr_var) a - Operator.print_bin_bool_op op (print_bool pr_mix pr_tok pr_var) b - | COMPARE_OP (op,(a,_), (b,_)) -> + | UN_BOOL_OP (op, (a, _)) -> + Format.fprintf f "%a (%a)" Operator.print_un_bool_op op + (print_bool pr_mix pr_tok pr_var) + a + | BIN_BOOL_OP (op, (a, _), (b, _)) -> + Format.fprintf f "(%a %a %a)" + (print_bool pr_mix pr_tok pr_var) + a Operator.print_bin_bool_op op + (print_bool pr_mix pr_tok pr_var) + b + | COMPARE_OP (op, (a, _), (b, _)) -> Format.fprintf f "(%a %a %a)" - (print pr_mix pr_tok pr_var) a - Operator.print_compare_op op - (print pr_mix pr_tok pr_var) b + (print pr_mix pr_tok pr_var) + a Operator.print_compare_op op + (print pr_mix pr_tok pr_var) + b -let const n = Locality.dummy_annot (CONST n) +let const n = Loc.annot_with_dummy (CONST n) let int i = const (Nbr.I i) let float f = const (Nbr.F f) -let add e1 e2 = Locality.dummy_annot (BIN_ALG_OP (Operator.SUM,e1,e2)) -let minus e1 e2 = Locality.dummy_annot (BIN_ALG_OP (Operator.MINUS,e1,e2)) -let mult e1 e2 = Locality.dummy_annot (BIN_ALG_OP (Operator.MULT,e1,e2)) -let div e1 e2 = Locality.dummy_annot (BIN_ALG_OP (Operator.DIV,e1,e2)) -let pow e1 e2 = Locality.dummy_annot (BIN_ALG_OP (Operator.POW,e1,e2)) -let log e1 = Locality.dummy_annot (UN_ALG_OP (Operator.LOG,e1)) -let ln e1 = (* JF: If I rememnber well *) - div - (log e1) - (log (int 10)) -let sin e1 = Locality.dummy_annot (UN_ALG_OP (Operator.SINUS,e1)) -let cos e1 = Locality.dummy_annot (UN_ALG_OP (Operator.COSINUS,e1)) -let uminus e1 = Locality.dummy_annot (UN_ALG_OP (Operator.UMINUS,e1)) -let sqrt e1 = Locality.dummy_annot (UN_ALG_OP (Operator.SQRT,e1)) - -let rec add_dep (in_t,in_e,toks_d,out as x) d = function +let add e1 e2 = Loc.annot_with_dummy (BIN_ALG_OP (Operator.SUM, e1, e2)) +let minus e1 e2 = Loc.annot_with_dummy (BIN_ALG_OP (Operator.MINUS, e1, e2)) +let mult e1 e2 = Loc.annot_with_dummy (BIN_ALG_OP (Operator.MULT, e1, e2)) +let div e1 e2 = Loc.annot_with_dummy (BIN_ALG_OP (Operator.DIV, e1, e2)) +let pow e1 e2 = Loc.annot_with_dummy (BIN_ALG_OP (Operator.POW, e1, e2)) +let log e1 = Loc.annot_with_dummy (UN_ALG_OP (Operator.LOG, e1)) + +let ln e1 = + (* JF: If I rememnber well *) + div (log e1) (log (int 10)) + +let sin e1 = Loc.annot_with_dummy (UN_ALG_OP (Operator.SINUS, e1)) +let cos e1 = Loc.annot_with_dummy (UN_ALG_OP (Operator.COSINUS, e1)) +let uminus e1 = Loc.annot_with_dummy (UN_ALG_OP (Operator.UMINUS, e1)) +let sqrt e1 = Loc.annot_with_dummy (UN_ALG_OP (Operator.SQRT, e1)) + +let rec add_dep ((in_t, in_e, toks_d, out) as x) d = function | BIN_ALG_OP (_, a, b), _ -> add_dep (add_dep x d a) d b - | (UN_ALG_OP (_, a) | DIFF_TOKEN (a,_) | DIFF_KAPPA_INSTANCE (a,_)), _ -(* when we differentiate against a variable, the result may depend on this variable only if the variable occurs in the differntiated expression *) - -> add_dep x d a + | (UN_ALG_OP (_, a) | DIFF_TOKEN (a, _) | DIFF_KAPPA_INSTANCE (a, _)), _ + (* when we differentiate against a variable, the result may depend on this variable only if the variable occurs in the differntiated expression *) + -> + add_dep x d a | ALG_VAR j, _ -> let () = out.(j) <- Operator.DepSet.add d out.(j) in x @@ -214,99 +274,103 @@ let rec add_dep (in_t,in_e,toks_d,out as x) d = function | TOKEN_ID i, _ -> let () = toks_d.(i) <- Operator.DepSet.add d toks_d.(i) in x - | IF (cond,yes,no), _ -> add_dep (add_dep (add_dep_bool x d cond) d yes) d no + | IF (cond, yes, no), _ -> + add_dep (add_dep (add_dep_bool x d cond) d yes) d no | STATE_ALG_OP op, _ -> - match op with - | (Operator.EMAX_VAR | Operator.TMAX_VAR) -> x - | Operator.TIME_VAR -> (Operator.DepSet.add d in_t,in_e,toks_d,out) - | (Operator.CPUTIME | Operator.EVENT_VAR | Operator.NULL_EVENT_VAR) -> - (in_t,Operator.DepSet.add d in_e,toks_d,out) + (match op with + | Operator.EMAX_VAR | Operator.TMAX_VAR -> x + | Operator.TIME_VAR -> Operator.DepSet.add d in_t, in_e, toks_d, out + | Operator.CPUTIME | Operator.EVENT_VAR | Operator.NULL_EVENT_VAR -> + in_t, Operator.DepSet.add d in_e, toks_d, out) and add_dep_bool x d = function | (TRUE | FALSE), _ -> x - | UN_BOOL_OP (_,a), _ -> add_dep_bool x d a - | BIN_BOOL_OP (_,a, b), _ -> add_dep_bool (add_dep_bool x d a) d b - | COMPARE_OP (_,a, b), _ -> add_dep (add_dep x d a) d b + | UN_BOOL_OP (_, a), _ -> add_dep_bool x d a + | BIN_BOOL_OP (_, a, b), _ -> add_dep_bool (add_dep_bool x d a) d b + | COMPARE_OP (_, a, b), _ -> add_dep (add_dep x d a) d b let rec has_mix : - type a. ?var_decls:('b -> ('c,'b) e) -> (a,'b) e -> pervasives_bool = - fun ?var_decls -> function - | BIN_ALG_OP (_, (a,_), (b,_)) -> has_mix ?var_decls a || has_mix ?var_decls b - | UN_ALG_OP (_, (a,_)) - | DIFF_TOKEN ((a,_),_) | DIFF_KAPPA_INSTANCE ((a,_),_) -> + type a. ?var_decls:('b -> ('c, 'b) e) -> (a, 'b) e -> pervasives_bool = + fun ?var_decls -> function + | BIN_ALG_OP (_, (a, _), (b, _)) -> + has_mix ?var_decls a || has_mix ?var_decls b + | UN_ALG_OP (_, (a, _)) + | DIFF_TOKEN ((a, _), _) + | DIFF_KAPPA_INSTANCE ((a, _), _) -> (* when we differentiate against a variable, the result may depend on this variable only if the variable occurs in the differntiated expression *) has_mix ?var_decls a | STATE_ALG_OP _ | CONST _ -> false | TOKEN_ID _ | KAPPA_INSTANCE _ -> true - | IF ((cond,_),(yes,_),(no,_)) -> + | IF ((cond, _), (yes, _), (no, _)) -> has_mix ?var_decls yes || has_mix ?var_decls no || bool_has_mix ?var_decls cond | ALG_VAR i -> - match var_decls with + (match var_decls with | None -> false - | Some f -> has_mix ?var_decls (f i) + | Some f -> has_mix ?var_decls (f i)) + and bool_has_mix : - type a. ?var_decls:('b -> ('c,'b) e) -> (a,'b) bool -> pervasives_bool = - fun ?var_decls -> function + type a. ?var_decls:('b -> ('c, 'b) e) -> (a, 'b) bool -> pervasives_bool = + fun ?var_decls -> function | TRUE | FALSE -> false - | COMPARE_OP (_,(a,_),(b,_)) -> + | COMPARE_OP (_, (a, _), (b, _)) -> has_mix ?var_decls a || has_mix ?var_decls b - | BIN_BOOL_OP (_,(a,_),(b,_)) -> + | BIN_BOOL_OP (_, (a, _), (b, _)) -> bool_has_mix ?var_decls a || bool_has_mix ?var_decls b - | UN_BOOL_OP (_,(a,_)) -> - bool_has_mix ?var_decls a + | UN_BOOL_OP (_, (a, _)) -> bool_has_mix ?var_decls a let rec is_constant = function - | CONST _,_ -> true - | IF (a,b,c),_ -> bool_is_constant a && is_constant b && is_constant c - | BIN_ALG_OP (_,a,b),_ -> is_constant a && is_constant b - | (UN_ALG_OP (_,a) | DIFF_KAPPA_INSTANCE (a,_) | DIFF_TOKEN (a,_)),_ -> + | CONST _, _ -> true + | IF (a, b, c), _ -> bool_is_constant a && is_constant b && is_constant c + | BIN_ALG_OP (_, a, b), _ -> is_constant a && is_constant b + | (UN_ALG_OP (_, a) | DIFF_KAPPA_INSTANCE (a, _) | DIFF_TOKEN (a, _)), _ -> is_constant a - | (ALG_VAR _ | STATE_ALG_OP _ | TOKEN_ID _ | KAPPA_INSTANCE _),_ -> false + | (ALG_VAR _ | STATE_ALG_OP _ | TOKEN_ID _ | KAPPA_INSTANCE _), _ -> false + and bool_is_constant = function - | (TRUE | FALSE),_ -> true - | COMPARE_OP (_,a,b),_ -> is_constant a && is_constant b - | BIN_BOOL_OP (_,a,b),_ -> bool_is_constant a && bool_is_constant b - | UN_BOOL_OP (_,a),_ -> bool_is_constant a + | (TRUE | FALSE), _ -> true + | COMPARE_OP (_, a, b), _ -> is_constant a && is_constant b + | BIN_BOOL_OP (_, a, b), _ -> bool_is_constant a && bool_is_constant b + | UN_BOOL_OP (_, a), _ -> bool_is_constant a let rec is_time_homogeneous = function - | CONST _,_ -> true - | IF (a,b,c),_ -> + | CONST _, _ -> true + | IF (a, b, c), _ -> bool_is_time_homogeneous a && is_time_homogeneous b && is_time_homogeneous c - | BIN_ALG_OP (_,a,b),_ -> is_time_homogeneous a && is_time_homogeneous b - | (UN_ALG_OP (_,a) | DIFF_KAPPA_INSTANCE (a,_) | DIFF_TOKEN (a,_)), _ -> + | BIN_ALG_OP (_, a, b), _ -> is_time_homogeneous a && is_time_homogeneous b + | (UN_ALG_OP (_, a) | DIFF_KAPPA_INSTANCE (a, _) | DIFF_TOKEN (a, _)), _ -> is_time_homogeneous a - | STATE_ALG_OP - ( Operator.EVENT_VAR - | Operator.CPUTIME - | Operator.NULL_EVENT_VAR - | Operator.TMAX_VAR - | Operator.EMAX_VAR) ,_ - | ALG_VAR _,_ - | TOKEN_ID _,_ - | KAPPA_INSTANCE _,_ -> true - | STATE_ALG_OP Operator.TIME_VAR,_ -> false + | ( STATE_ALG_OP + ( Operator.EVENT_VAR | Operator.CPUTIME | Operator.NULL_EVENT_VAR + | Operator.TMAX_VAR | Operator.EMAX_VAR ), + _ ) + | ALG_VAR _, _ + | TOKEN_ID _, _ + | KAPPA_INSTANCE _, _ -> + true + | STATE_ALG_OP Operator.TIME_VAR, _ -> false + and bool_is_time_homogeneous = function - | (TRUE | FALSE),_ -> true - | COMPARE_OP (_,a,b),_ -> - is_time_homogeneous a && is_time_homogeneous b - | BIN_BOOL_OP (_,a,b),_ -> + | (TRUE | FALSE), _ -> true + | COMPARE_OP (_, a, b), _ -> is_time_homogeneous a && is_time_homogeneous b + | BIN_BOOL_OP (_, a, b), _ -> bool_is_time_homogeneous a && bool_is_time_homogeneous b - | UN_BOOL_OP (_,a),_ -> bool_is_time_homogeneous a + | UN_BOOL_OP (_, a), _ -> bool_is_time_homogeneous a let rec aux_extract_cc acc = function | BIN_ALG_OP (_, a, b), _ -> aux_extract_cc (aux_extract_cc acc a) b - | (UN_ALG_OP (_, a) | DIFF_TOKEN (a,_) | DIFF_KAPPA_INSTANCE (a,_)),_ -> + | (UN_ALG_OP (_, a) | DIFF_TOKEN (a, _) | DIFF_KAPPA_INSTANCE (a, _)), _ -> aux_extract_cc acc a | (ALG_VAR _ | CONST _ | TOKEN_ID _ | STATE_ALG_OP _), _ -> acc | KAPPA_INSTANCE i, _ -> i :: acc - | IF (cond,yes,no), _ -> + | IF (cond, yes, no), _ -> aux_extract_cc (aux_extract_cc (extract_cc_bool acc cond) yes) no + and extract_cc_bool acc = function | (TRUE | FALSE), _ -> acc - | BIN_BOOL_OP (_,a, b), _ -> extract_cc_bool (extract_cc_bool acc a) b - | UN_BOOL_OP (_,a), _ -> extract_cc_bool acc a - | COMPARE_OP (_,a, b), _ -> aux_extract_cc (aux_extract_cc acc a) b + | BIN_BOOL_OP (_, a, b), _ -> extract_cc_bool (extract_cc_bool acc a) b + | UN_BOOL_OP (_, a), _ -> extract_cc_bool acc a + | COMPARE_OP (_, a, b), _ -> aux_extract_cc (aux_extract_cc acc a) b let extract_connected_components x = aux_extract_cc [] x let extract_connected_components_bool x = extract_cc_bool [] x @@ -317,290 +381,356 @@ let setup_alg_vars_rev_dep toks vars = let toks_d = Array.make (NamedDecls.size toks) Operator.DepSet.empty in let out = Array.make (Array.length vars) Operator.DepSet.empty in Tools.array_fold_lefti - (fun i x (_,y) -> add_dep x (Operator.ALG i) y) (in_t,in_e,toks_d,out) vars - -let rec propagate_constant - ~warning ?max_time ?max_events updated_vars vars = function - | BIN_ALG_OP (op,a,b),pos as x -> - (match propagate_constant - ~warning ?max_time ?max_events updated_vars vars a, - propagate_constant - ~warning ?max_time ?max_events updated_vars vars b with - | (CONST c1,_),(CONST c2,_) -> CONST (Nbr.of_bin_alg_op op c1 c2),pos - | ((BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ | KAPPA_INSTANCE _ - | DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ - | CONST _ | IF _),_ as a'), - ((BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ | KAPPA_INSTANCE _ - | DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ - | CONST _ | IF _),_ as b') -> - if a == a' && b == b' then x else (BIN_ALG_OP (op,a',b'),pos)) - | UN_ALG_OP (op,a),pos as x -> - (match propagate_constant - ~warning ?max_time ?max_events updated_vars vars a with - | CONST c,_ -> CONST (Nbr.of_un_alg_op op c),pos - | (DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ - | BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ - | KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ | IF _),_ as a' -> - if a == a' then x else (UN_ALG_OP (op,a'),pos)) - | DIFF_TOKEN (a,t),pos as x -> - (match propagate_constant - ~warning ?max_time ?max_events updated_vars vars a with - | CONST _,_ -> - (* the derivative of a constant is zero *) - CONST (Nbr.zero),pos - | (DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | BIN_ALG_OP _ | UN_ALG_OP _ | IF _ - | STATE_ALG_OP _ | KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _),_ as a' -> - if a == a' then x else (DIFF_TOKEN (a',t),pos)) - | DIFF_KAPPA_INSTANCE (a,m),pos as x -> - (match propagate_constant - ~warning ?max_time ?max_events updated_vars vars a with - | CONST _,_ -> - (* the derivative of a constant is zero *) - CONST (Nbr.zero),pos - | (DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | BIN_ALG_OP _ | UN_ALG_OP _ - | STATE_ALG_OP _ | KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ | IF _),_ - as a' -> - if a == a' then x else (DIFF_KAPPA_INSTANCE (a',m),pos)) - | STATE_ALG_OP (Operator.EMAX_VAR),pos -> - CONST - (match max_events with - | Some n -> Nbr.I n - | None -> - let () = - warning - ~pos (fun f -> Format.pp_print_string - f "[Emax] constant is evaluated to infinity") in - Nbr.F infinity),pos - | STATE_ALG_OP (Operator.TMAX_VAR),pos -> - CONST - (match max_time with - | Some t -> Nbr.F t - | None -> - let () = - warning - ~pos (fun f -> Format.pp_print_string - f "[Tmax] constant is evaluated to infinity") in - Nbr.F infinity),pos - | STATE_ALG_OP (Operator.CPUTIME | Operator.TIME_VAR | Operator.EVENT_VAR - | Operator.NULL_EVENT_VAR),_ as x -> x - | ALG_VAR i,pos as x -> - (if List.mem i updated_vars then x - else match vars.(i) with - | _,((CONST _ | ALG_VAR _ as y),_) -> y,pos - | _,((BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ | KAPPA_INSTANCE _ - | TOKEN_ID _ | IF _ | DIFF_KAPPA_INSTANCE _ | DIFF_TOKEN _),_) -> x) - | (KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _),_ as x -> x - - | IF (cond,yes,no),pos -> - match propagate_constant_bool - ~warning ?max_time ?max_events updated_vars vars cond with + (fun i x (_, y) -> add_dep x (Operator.ALG i) y) + (in_t, in_e, toks_d, out) vars + +let rec propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars = + function + | (BIN_ALG_OP (op, a, b), pos) as x -> + (match + ( propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars a, + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars b + ) + with + | (CONST c1, _), (CONST c2, _) -> CONST (Nbr.of_bin_alg_op op c1 c2), pos + | ( (( ( BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ | KAPPA_INSTANCE _ + | DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ + | CONST _ | IF _ ), + _ ) as a'), + (( ( BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ | KAPPA_INSTANCE _ + | DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ + | CONST _ | IF _ ), + _ ) as b') ) -> + if a == a' && b == b' then + x + else + BIN_ALG_OP (op, a', b'), pos) + | (UN_ALG_OP (op, a), pos) as x -> + (match + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars a + with + | CONST c, _ -> CONST (Nbr.of_un_alg_op op c), pos + | ( ( DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | BIN_ALG_OP _ | UN_ALG_OP _ + | STATE_ALG_OP _ | KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ | IF _ ), + _ ) as a' -> + if a == a' then + x + else + UN_ALG_OP (op, a'), pos) + | (DIFF_TOKEN (a, t), pos) as x -> + (match + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars a + with + | CONST _, _ -> + (* the derivative of a constant is zero *) + CONST Nbr.zero, pos + | ( ( DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | BIN_ALG_OP _ | UN_ALG_OP _ + | IF _ | STATE_ALG_OP _ | KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ ), + _ ) as a' -> + if a == a' then + x + else + DIFF_TOKEN (a', t), pos) + | (DIFF_KAPPA_INSTANCE (a, m), pos) as x -> + (match + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars a + with + | CONST _, _ -> + (* the derivative of a constant is zero *) + CONST Nbr.zero, pos + | ( ( DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _ | BIN_ALG_OP _ | UN_ALG_OP _ + | STATE_ALG_OP _ | KAPPA_INSTANCE _ | TOKEN_ID _ | ALG_VAR _ | IF _ ), + _ ) as a' -> + if a == a' then + x + else + DIFF_KAPPA_INSTANCE (a', m), pos) + | STATE_ALG_OP Operator.EMAX_VAR, pos -> + ( CONST + (match max_events with + | Some n -> Nbr.I n + | None -> + let () = + warning ~pos (fun f -> + Format.pp_print_string f + "[Emax] constant is evaluated to infinity") + in + Nbr.F infinity), + pos ) + | STATE_ALG_OP Operator.TMAX_VAR, pos -> + ( CONST + (match max_time with + | Some t -> Nbr.F t + | None -> + let () = + warning ~pos (fun f -> + Format.pp_print_string f + "[Tmax] constant is evaluated to infinity") + in + Nbr.F infinity), + pos ) + | ( STATE_ALG_OP + ( Operator.CPUTIME | Operator.TIME_VAR | Operator.EVENT_VAR + | Operator.NULL_EVENT_VAR ), + _ ) as x -> + x + | (ALG_VAR i, pos) as x -> + if List.mem i updated_vars then + x + else ( + match vars.(i) with + | _, (((CONST _ | ALG_VAR _) as y), _) -> y, pos + | ( _, + ( ( BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ | KAPPA_INSTANCE _ + | TOKEN_ID _ | IF _ | DIFF_KAPPA_INSTANCE _ | DIFF_TOKEN _ ), + _ ) ) -> + x + ) + | ((KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _), _) as x -> x + | IF (cond, yes, no), pos -> + (match + propagate_constant_bool ~warning ?max_time ?max_events ~updated_vars + ~vars cond + with | TRUE, _ -> - propagate_constant ~warning ?max_time ?max_events updated_vars vars yes - | FALSE,_ -> - propagate_constant ~warning ?max_time ?max_events updated_vars vars no - | (BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_ as cond' -> - (IF (cond', - propagate_constant - ~warning ?max_time ?max_events updated_vars vars yes, - propagate_constant - ~warning ?max_time ?max_events updated_vars vars no),pos) -and propagate_constant_bool - ~warning ?max_time ?max_events updated_vars vars = function - | (TRUE | FALSE),_ as x -> x - | UN_BOOL_OP (op,a),pos -> - begin match propagate_constant_bool - ~warning ?max_time ?max_events updated_vars vars a, op with - | (TRUE,_), Operator.NOT -> FALSE,pos - | (FALSE,_), Operator.NOT -> TRUE,pos - | ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_ as a'),_ -> - UN_BOOL_OP (op,a'),pos - end - | BIN_BOOL_OP (op,a,b),pos -> - begin match propagate_constant_bool - ~warning ?max_time ?max_events updated_vars vars a, op with - | (TRUE,_), Operator.OR -> TRUE,pos - | (FALSE,_), Operator.AND -> FALSE,pos - | (TRUE,_), Operator.AND - | (FALSE,_), Operator.OR -> - propagate_constant_bool - ~warning ?max_time ?max_events updated_vars vars b - | ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_ as a'),_ -> - match propagate_constant_bool - ~warning ?max_time ?max_events updated_vars vars b, op with - | (TRUE,_), Operator.OR -> TRUE,pos - | (FALSE,_), Operator.AND -> FALSE,pos - | (TRUE,_), Operator.AND - | (FALSE,_), Operator.OR -> a' - | ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_ as b'),_ -> - BIN_BOOL_OP (op,a',b'),pos - end - | COMPARE_OP (op,a,b),pos -> - let a' = propagate_constant - ~warning ?max_time ?max_events updated_vars vars a in - let b' = propagate_constant - ~warning ?max_time ?max_events updated_vars vars b in - match a',b' with - | (CONST n1,_), (CONST n2,_) -> - (if Nbr.of_compare_op op n1 n2 then TRUE,pos else FALSE,pos) - | (( DIFF_KAPPA_INSTANCE _ | DIFF_TOKEN _ - | BIN_ALG_OP _ | UN_ALG_OP _ | STATE_ALG_OP _ | ALG_VAR _ - | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _),_), _ -> - COMPARE_OP (op,a',b'),pos - -let rec has_progress_dep ~only_time (in_t,_,_,deps as vars_deps) = function - | (BIN_ALG_OP (_, a, b),_) -> - has_progress_dep ~only_time vars_deps a || - has_progress_dep ~only_time vars_deps b - | ((UN_ALG_OP (_, a) | DIFF_TOKEN (a,_) | DIFF_KAPPA_INSTANCE (a,_)),_) -> + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars yes + | FALSE, _ -> + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars no + | ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _) as cond' -> + ( IF + ( cond', + propagate_constant ~warning ?max_time ?max_events ~updated_vars + ~vars yes, + propagate_constant ~warning ?max_time ?max_events ~updated_vars + ~vars no ), + pos )) + +and propagate_constant_bool ~warning ?max_time ?max_events ~updated_vars ~vars = + function + | ((TRUE | FALSE), _) as x -> x + | UN_BOOL_OP (op, a), pos -> + (match + ( propagate_constant_bool ~warning ?max_time ?max_events ~updated_vars + ~vars a, + op ) + with + | (TRUE, _), Operator.NOT -> FALSE, pos + | (FALSE, _), Operator.NOT -> TRUE, pos + | (((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _) as a'), _ -> + UN_BOOL_OP (op, a'), pos) + | BIN_BOOL_OP (op, a, b), pos -> + (match + ( propagate_constant_bool ~warning ?max_time ?max_events ~updated_vars + ~vars a, + op ) + with + | (TRUE, _), Operator.OR -> TRUE, pos + | (FALSE, _), Operator.AND -> FALSE, pos + | (TRUE, _), Operator.AND | (FALSE, _), Operator.OR -> + propagate_constant_bool ~warning ?max_time ?max_events ~updated_vars ~vars + b + | (((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _) as a'), _ -> + (match + ( propagate_constant_bool ~warning ?max_time ?max_events ~updated_vars + ~vars b, + op ) + with + | (TRUE, _), Operator.OR -> TRUE, pos + | (FALSE, _), Operator.AND -> FALSE, pos + | (TRUE, _), Operator.AND | (FALSE, _), Operator.OR -> a' + | (((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _) as b'), _ -> + BIN_BOOL_OP (op, a', b'), pos)) + | COMPARE_OP (op, a, b), pos -> + let a' = + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars a + in + let b' = + propagate_constant ~warning ?max_time ?max_events ~updated_vars ~vars b + in + (match a', b' with + | (CONST n1, _), (CONST n2, _) -> + if Nbr.of_compare_op op n1 n2 then + TRUE, pos + else + FALSE, pos + | ( ( ( DIFF_KAPPA_INSTANCE _ | DIFF_TOKEN _ | BIN_ALG_OP _ | UN_ALG_OP _ + | STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ + | IF _ ), + _ ), + _ ) -> + COMPARE_OP (op, a', b'), pos) + +let rec has_progress_dep ~only_time ((in_t, _, _, deps) as vars_deps) = function + | BIN_ALG_OP (_, a, b), _ -> has_progress_dep ~only_time vars_deps a - | ((KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _),_) -> false - | (STATE_ALG_OP Operator.TIME_VAR,_) -> true - | (STATE_ALG_OP Operator.EVENT_VAR,_) -> not only_time - | (STATE_ALG_OP (Operator.CPUTIME | Operator.NULL_EVENT_VAR | - Operator.EMAX_VAR | Operator.TMAX_VAR),_) -> false - | (ALG_VAR i,_) -> + || has_progress_dep ~only_time vars_deps b + | (UN_ALG_OP (_, a) | DIFF_TOKEN (a, _) | DIFF_KAPPA_INSTANCE (a, _)), _ -> + has_progress_dep ~only_time vars_deps a + | (KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _), _ -> false + | STATE_ALG_OP Operator.TIME_VAR, _ -> true + | STATE_ALG_OP Operator.EVENT_VAR, _ -> not only_time + | ( STATE_ALG_OP + ( Operator.CPUTIME | Operator.NULL_EVENT_VAR | Operator.EMAX_VAR + | Operator.TMAX_VAR ), + _ ) -> + false + | ALG_VAR i, _ -> let rec aux j = - Operator.DepSet.mem (Operator.ALG j) in_t || - Operator.DepSet.exists - (function Operator.ALG k -> aux k - | (Operator.RULE _ | Operator.MODIF _) -> false) deps.(j) in + Operator.DepSet.mem (Operator.ALG j) in_t + || Operator.DepSet.exists + (function + | Operator.ALG k -> aux k + | Operator.RULE _ | Operator.MODIF _ -> false) + deps.(j) + in aux i - | IF (cond,yes,no),_ -> - bool_has_progress_dep ~only_time vars_deps cond || - has_progress_dep ~only_time vars_deps yes || - has_progress_dep ~only_time vars_deps no + | IF (cond, yes, no), _ -> + bool_has_progress_dep ~only_time vars_deps cond + || has_progress_dep ~only_time vars_deps yes + || has_progress_dep ~only_time vars_deps no and bool_has_progress_dep ~only_time vars_deps = function | (TRUE | FALSE), _ -> false - | COMPARE_OP (_,a,b),_ -> - has_progress_dep ~only_time vars_deps a || - has_progress_dep ~only_time vars_deps b - | BIN_BOOL_OP (_,a,b),_ -> - bool_has_progress_dep ~only_time vars_deps a || - bool_has_progress_dep ~only_time vars_deps b - | UN_BOOL_OP (_,a),_ -> + | COMPARE_OP (_, a, b), _ -> + has_progress_dep ~only_time vars_deps a + || has_progress_dep ~only_time vars_deps b + | BIN_BOOL_OP (_, a, b), _ -> bool_has_progress_dep ~only_time vars_deps a + || bool_has_progress_dep ~only_time vars_deps b + | UN_BOOL_OP (_, a), _ -> bool_has_progress_dep ~only_time vars_deps a let rec is_equality_test_time vars_deps = function | TRUE | FALSE -> false - | UN_BOOL_OP (Operator.NOT,(a,_)) -> is_equality_test_time vars_deps a - | BIN_BOOL_OP (_,(a,_),(b,_)) -> - (is_equality_test_time vars_deps a)||(is_equality_test_time vars_deps b) - | COMPARE_OP (op,a,b) -> + | UN_BOOL_OP (Operator.NOT, (a, _)) -> is_equality_test_time vars_deps a + | BIN_BOOL_OP (_, (a, _), (b, _)) -> + is_equality_test_time vars_deps a || is_equality_test_time vars_deps b + | COMPARE_OP (op, a, b) -> let only_time = true in - match op with - | Operator.EQUAL when - has_progress_dep ~only_time vars_deps a || - has_progress_dep ~only_time vars_deps b -> - true - | (Operator.EQUAL | Operator.SMALLER | Operator.GREATER | Operator.DIFF) -> - false + (match op with + | Operator.EQUAL + when has_progress_dep ~only_time vars_deps a + || has_progress_dep ~only_time vars_deps b -> + true + | Operator.EQUAL | Operator.SMALLER | Operator.GREATER | Operator.DIFF -> + false) let rec map_on_mixture f = function - | KAPPA_INSTANCE i,p -> (f i,p) - | DIFF_KAPPA_INSTANCE _,_ -> + | KAPPA_INSTANCE i, p -> f i, p + | DIFF_KAPPA_INSTANCE _, _ -> failwith "Alg_expr.map_on_mixture doesn't know what to do of DIFF_KAPPA_INSTANCE" - | CONST _,_ as x -> x - | ALG_VAR _,_ as x -> x - | TOKEN_ID _,_ as x -> x - | DIFF_TOKEN (a,i),p -> (DIFF_TOKEN (map_on_mixture f a,i),p) - | STATE_ALG_OP _,_ as x -> x - | BIN_ALG_OP (o,x,y),p -> - (BIN_ALG_OP (o,map_on_mixture f x,map_on_mixture f y),p) - | UN_ALG_OP (o,x),p -> (UN_ALG_OP (o,map_on_mixture f x),p) - | IF (b,x,y),p -> - (IF (map_bool_on_mixture f b,map_on_mixture f x,map_on_mixture f y),p) + | (CONST _, _) as x -> x + | (ALG_VAR _, _) as x -> x + | (TOKEN_ID _, _) as x -> x + | DIFF_TOKEN (a, i), p -> DIFF_TOKEN (map_on_mixture f a, i), p + | (STATE_ALG_OP _, _) as x -> x + | BIN_ALG_OP (o, x, y), p -> + BIN_ALG_OP (o, map_on_mixture f x, map_on_mixture f y), p + | UN_ALG_OP (o, x), p -> UN_ALG_OP (o, map_on_mixture f x), p + | IF (b, x, y), p -> + IF (map_bool_on_mixture f b, map_on_mixture f x, map_on_mixture f y), p + and map_bool_on_mixture f = function - | TRUE,_ as x -> x - | FALSE,_ as x -> x - | BIN_BOOL_OP (o,x,y),p -> - (BIN_BOOL_OP (o,map_bool_on_mixture f x,map_bool_on_mixture f y),p) - | UN_BOOL_OP (o,x),p -> - (UN_BOOL_OP (o,map_bool_on_mixture f x),p) - | COMPARE_OP (o,x,y),p -> - (COMPARE_OP (o,map_on_mixture f x,map_on_mixture f y),p) + | (TRUE, _) as x -> x + | (FALSE, _) as x -> x + | BIN_BOOL_OP (o, x, y), p -> + BIN_BOOL_OP (o, map_bool_on_mixture f x, map_bool_on_mixture f y), p + | UN_BOOL_OP (o, x), p -> UN_BOOL_OP (o, map_bool_on_mixture f x), p + | COMPARE_OP (o, x, y), p -> + COMPARE_OP (o, map_on_mixture f x, map_on_mixture f y), p let rec fold_on_mixture f x = function - | KAPPA_INSTANCE i,_ -> f x i - | DIFF_KAPPA_INSTANCE _,_ -> + | KAPPA_INSTANCE i, _ -> f x i + | DIFF_KAPPA_INSTANCE _, _ -> failwith "Alg_expr.fold_on_mixture doesn't know what to do of DIFF_KAPPA_INSTANCE" - | CONST _,_ -> x - | ALG_VAR _,_ -> x - | TOKEN_ID _,_ -> x - | DIFF_TOKEN (a,_),_ -> fold_on_mixture f x a - | STATE_ALG_OP _,_ -> x - | BIN_ALG_OP (_,a,b),_ -> fold_on_mixture f (fold_on_mixture f x a) b - | UN_ALG_OP (_,a),_ -> fold_on_mixture f x a - | IF (b,u,v),_ -> + | CONST _, _ -> x + | ALG_VAR _, _ -> x + | TOKEN_ID _, _ -> x + | DIFF_TOKEN (a, _), _ -> fold_on_mixture f x a + | STATE_ALG_OP _, _ -> x + | BIN_ALG_OP (_, a, b), _ -> fold_on_mixture f (fold_on_mixture f x a) b + | UN_ALG_OP (_, a), _ -> fold_on_mixture f x a + | IF (b, u, v), _ -> fold_bool_on_mixture f (fold_on_mixture f (fold_on_mixture f x u) v) b + and fold_bool_on_mixture f x = function - | TRUE,_ -> x - | FALSE,_ -> x - | BIN_BOOL_OP (_,a,b),_ -> + | TRUE, _ -> x + | FALSE, _ -> x + | BIN_BOOL_OP (_, a, b), _ -> fold_bool_on_mixture f (fold_bool_on_mixture f x a) b - | UN_BOOL_OP (_,a),_ -> fold_bool_on_mixture f x a - | COMPARE_OP (_,a,b),_ -> - fold_on_mixture f (fold_on_mixture f x a) b + | UN_BOOL_OP (_, a), _ -> fold_bool_on_mixture f x a + | COMPARE_OP (_, a, b), _ -> fold_on_mixture f (fold_on_mixture f x a) b let rec equal a b = - match a,b with - | (BIN_ALG_OP (opa,a1,a2),_), (BIN_ALG_OP (opb,b1,b2),_) -> + match a, b with + | (BIN_ALG_OP (opa, a1, a2), _), (BIN_ALG_OP (opb, b1, b2), _) -> opa = opb && equal a1 b1 && equal a2 b2 - | (BIN_ALG_OP _,_), - ((UN_ALG_OP _ | STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ - | CONST _ | IF _),_) - | ((UN_ALG_OP _ | STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ - | CONST _ | IF _),_), - (BIN_ALG_OP _,_) -> false - | (UN_ALG_OP (opa,a1),_), (UN_ALG_OP (opb,b1),_) -> opa = opb && equal a1 b1 - | (UN_ALG_OP _,_), - ((STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ - | IF _),_) - | ((STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ - | IF _),_), - (UN_ALG_OP _,_) -> false - | (STATE_ALG_OP opa,_), (STATE_ALG_OP opb,_) -> opa = opb - | (STATE_ALG_OP _,_), - ((ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _),_) - | ((ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _),_), - (STATE_ALG_OP _,_) -> false - | (ALG_VAR id1,_), (ALG_VAR id2,_) -> id1=id2 - | (ALG_VAR _,_), ((KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _),_) - | ((KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _),_), (ALG_VAR _,_) -> + | ( (BIN_ALG_OP _, _), + ( ( UN_ALG_OP _ | STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ + | TOKEN_ID _ | CONST _ | IF _ ), + _ ) ) + | ( ( ( UN_ALG_OP _ | STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ + | TOKEN_ID _ | CONST _ | IF _ ), + _ ), + (BIN_ALG_OP _, _) ) -> + false + | (UN_ALG_OP (opa, a1), _), (UN_ALG_OP (opb, b1), _) -> + opa = opb && equal a1 b1 + | ( (UN_ALG_OP _, _), + ( ( STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ + | IF _ ), + _ ) ) + | ( ( ( STATE_ALG_OP _ | ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ + | IF _ ), + _ ), + (UN_ALG_OP _, _) ) -> + false + | (STATE_ALG_OP opa, _), (STATE_ALG_OP opb, _) -> opa = opb + | ( (STATE_ALG_OP _, _), + ((ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _), _) ) + | ( ((ALG_VAR _ | KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _), _), + (STATE_ALG_OP _, _) ) -> + false + | (ALG_VAR id1, _), (ALG_VAR id2, _) -> id1 = id2 + | (ALG_VAR _, _), ((KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _), _) + | ((KAPPA_INSTANCE _ | TOKEN_ID _ | CONST _ | IF _), _), (ALG_VAR _, _) -> false - | (KAPPA_INSTANCE mix1,_),(KAPPA_INSTANCE mix2,_) -> mix1=mix2 - | (KAPPA_INSTANCE _,_), (( TOKEN_ID _ | CONST _ | IF _),_) - | (( TOKEN_ID _ | CONST _ | IF _),_), (KAPPA_INSTANCE _,_) -> + | (KAPPA_INSTANCE mix1, _), (KAPPA_INSTANCE mix2, _) -> mix1 = mix2 + | (KAPPA_INSTANCE _, _), ((TOKEN_ID _ | CONST _ | IF _), _) + | ((TOKEN_ID _ | CONST _ | IF _), _), (KAPPA_INSTANCE _, _) -> + false + | (TOKEN_ID id1, _), (TOKEN_ID id2, _) -> id1 = id2 + | (TOKEN_ID _, _), ((CONST _ | IF _), _) + | ((CONST _ | IF _), _), (TOKEN_ID _, _) -> false - | (TOKEN_ID id1,_), (TOKEN_ID id2,_) -> id1=id2 - | (TOKEN_ID _,_), (( CONST _ | IF _),_) - | (( CONST _ | IF _),_), (TOKEN_ID _,_) -> false | (CONST c1, _), (CONST c2, _) -> Nbr.is_equal c1 c2 - | (CONST _,_), (IF _,_) - | (IF _,_),(CONST _,_) -> false - - | (IF (conda,a1,a2),_), (IF (condb,b1,b2),_) -> + | (CONST _, _), (IF _, _) | (IF _, _), (CONST _, _) -> false + | (IF (conda, a1, a2), _), (IF (condb, b1, b2), _) -> equal_bool conda condb && equal a1 b1 && equal a2 b2 - | ((DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _),_),_ - | _,((DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _),_) -> assert false -and equal_bool a b = - match a,b with - | (TRUE,_),(TRUE,_) -> true - | (TRUE,_), ((FALSE |BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_) - | ((FALSE | BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_), (TRUE,_) -> - false - | (FALSE,_),(FALSE,_) -> true - | (FALSE,_), ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_) - | ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _),_), (FALSE,_) -> false - | (UN_BOOL_OP (opa,a),_), (UN_BOOL_OP (opb,b),_) -> opa=opb && equal_bool a b - | (UN_BOOL_OP _,_),((BIN_BOOL_OP _ | COMPARE_OP _),_) - | ((BIN_BOOL_OP _ | COMPARE_OP _),_),(UN_BOOL_OP _,_) -> false - | (BIN_BOOL_OP (opa,a1,a2),_), (BIN_BOOL_OP (opb,b1,b2),_) -> - opa=opb && equal_bool a1 b1 && equal_bool a2 b2 - | (BIN_BOOL_OP _,_),(COMPARE_OP _,_) - | (COMPARE_OP _,_),(BIN_BOOL_OP _,_) -> false - | (COMPARE_OP (opa,a1,a2),_), (COMPARE_OP (opb,b1,b2),_) -> - opa=opb && equal a1 b1 && equal a2 b2 + | ((DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _), _), _ + | _, ((DIFF_TOKEN _ | DIFF_KAPPA_INSTANCE _), _) -> + assert false +and equal_bool a b = + match a, b with + | (TRUE, _), (TRUE, _) -> true + | (TRUE, _), ((FALSE | BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _) + | ((FALSE | BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _), (TRUE, _) -> + false + | (FALSE, _), (FALSE, _) -> true + | (FALSE, _), ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _) + | ((BIN_BOOL_OP _ | COMPARE_OP _ | UN_BOOL_OP _), _), (FALSE, _) -> + false + | (UN_BOOL_OP (opa, a), _), (UN_BOOL_OP (opb, b), _) -> + opa = opb && equal_bool a b + | (UN_BOOL_OP _, _), ((BIN_BOOL_OP _ | COMPARE_OP _), _) + | ((BIN_BOOL_OP _ | COMPARE_OP _), _), (UN_BOOL_OP _, _) -> + false + | (BIN_BOOL_OP (opa, a1, a2), _), (BIN_BOOL_OP (opb, b1, b2), _) -> + opa = opb && equal_bool a1 b1 && equal_bool a2 b2 + | (BIN_BOOL_OP _, _), (COMPARE_OP _, _) | (COMPARE_OP _, _), (BIN_BOOL_OP _, _) + -> + false + | (COMPARE_OP (opa, a1, a2), _), (COMPARE_OP (opb, b1, b2), _) -> + opa = opb && equal a1 b1 && equal a2 b2 diff --git a/core/term/alg_expr.mli b/core/term/alg_expr.mli index 8aa5691876..6f214f794f 100644 --- a/core/term/alg_expr.mli +++ b/core/term/alg_expr.mli @@ -8,158 +8,198 @@ type pervasives_bool = bool -type ('mix,'id) e = - BIN_ALG_OP of Operator.bin_alg_op * - ('mix,'id) e Locality.annot * ('mix,'id) e Locality.annot - | UN_ALG_OP of Operator.un_alg_op * ('mix,'id) e Locality.annot +type ('mix, 'id) e = + | BIN_ALG_OP of + Operator.bin_alg_op + * ('mix, 'id) e Loc.annoted + * ('mix, 'id) e Loc.annoted + | UN_ALG_OP of Operator.un_alg_op * ('mix, 'id) e Loc.annoted | STATE_ALG_OP of Operator.state_alg_op | ALG_VAR of 'id | KAPPA_INSTANCE of 'mix | TOKEN_ID of 'id | CONST of Nbr.t - | IF of ('mix,'id) bool Locality.annot * - ('mix,'id) e Locality.annot * ('mix,'id) e Locality.annot - | DIFF_TOKEN of (('mix,'id) e Locality.annot * 'id) - | DIFF_KAPPA_INSTANCE of (('mix,'id) e Locality.annot * 'mix) -and ('mix,'id) bool = + | IF of + ('mix, 'id) bool Loc.annoted + * ('mix, 'id) e Loc.annoted + * ('mix, 'id) e Loc.annoted + | DIFF_TOKEN of (('mix, 'id) e Loc.annoted * 'id) + | DIFF_KAPPA_INSTANCE of (('mix, 'id) e Loc.annoted * 'mix) + +and ('mix, 'id) bool = | TRUE | FALSE | BIN_BOOL_OP of - Operator.bin_bool_op * - ('mix,'id) bool Locality.annot * ('mix,'id) bool Locality.annot - | UN_BOOL_OP of Operator.un_bool_op * ('mix,'id) bool Locality.annot - | COMPARE_OP of Operator.compare_op * - ('mix,'id) e Locality.annot * ('mix,'id) e Locality.annot + Operator.bin_bool_op + * ('mix, 'id) bool Loc.annoted + * ('mix, 'id) bool Loc.annoted + | UN_BOOL_OP of Operator.un_bool_op * ('mix, 'id) bool Loc.annoted + | COMPARE_OP of + Operator.compare_op + * ('mix, 'id) e Loc.annoted + * ('mix, 'id) e Loc.annoted val e_to_yojson : - filenames : int Mods.StringMap.t -> - ('a -> Yojson.Basic.t) -> ('b -> Yojson.Basic.t) -> - ('a,'b) e -> Yojson.Basic.t + filenames:int Mods.StringMap.t -> + ('a -> Yojson.Basic.t) -> + ('b -> Yojson.Basic.t) -> + ('a, 'b) e -> + Yojson.Basic.t val e_of_yojson : - filenames : string array -> - (Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'b) -> - Yojson.Basic.t -> ('a,'b) e + filenames:string array -> + (Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t -> 'b) -> + Yojson.Basic.t -> + ('a, 'b) e val print : - (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> - (Format.formatter -> 'b -> unit) -> Format.formatter -> ('a, 'b) e -> unit + (Format.formatter -> 'a -> unit) -> + (Format.formatter -> 'b -> unit) -> + (Format.formatter -> 'b -> unit) -> + Format.formatter -> + ('a, 'b) e -> + unit val bool_to_yojson : - filenames : int Mods.StringMap.t -> - ('a -> Yojson.Basic.t) -> ('b -> Yojson.Basic.t) -> - ('a,'b) bool -> Yojson.Basic.t + filenames:int Mods.StringMap.t -> + ('a -> Yojson.Basic.t) -> + ('b -> Yojson.Basic.t) -> + ('a, 'b) bool -> + Yojson.Basic.t val bool_of_yojson : - filenames : string array -> - (Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'b) -> - Yojson.Basic.t -> ('a,'b) bool + filenames:string array -> + (Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t -> 'b) -> + Yojson.Basic.t -> + ('a, 'b) bool val print_bool : - (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> + (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> - Format.formatter -> ('a,'b) bool -> unit - + (Format.formatter -> 'b -> unit) -> + Format.formatter -> + ('a, 'b) bool -> + unit +val const : Nbr.t -> ('a, 'b) e Loc.annoted (** {2 Smart constructor } *) -val const : Nbr.t -> ('a,'b) e Locality.annot -val int : int -> ('a,'b) e Locality.annot -val float : float -> ('a,'b) e Locality.annot + +val int : int -> ('a, 'b) e Loc.annoted +val float : float -> ('a, 'b) e Loc.annoted + val add : - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -> - ('a,'b) e Locality.annot + ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted + val minus : - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -> - ('a,'b) e Locality.annot + ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted + val mult : - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -> - ('a,'b) e Locality.annot + ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted + val div : - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -> - ('a,'b) e Locality.annot + ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted + val pow : - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -> - ('a,'b) e Locality.annot -val ln : - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -val uminus: - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -val sin: - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -val cos: - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot -val sqrt: - ('a,'b) e Locality.annot -> ('a,'b) e Locality.annot + ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted + +val ln : ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted +val uminus : ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted +val sin : ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted +val cos : ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted +val sqrt : ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted -(** depend in time, depend in event number, depend in given var *) val add_dep : - (Operator.DepSet.t * Operator.DepSet.t * Operator.DepSet.t array - * Operator.DepSet.t array) -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array -> Operator.rev_dep -> - ('a,int) e Locality.annot -> - (Operator.DepSet.t * Operator.DepSet.t * Operator.DepSet.t array - * Operator.DepSet.t array) + ('a, int) e Loc.annoted -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array +(** depend in time, depend in event number, depend in given var *) val add_dep_bool : - (Operator.DepSet.t * Operator.DepSet.t * Operator.DepSet.t array - * Operator.DepSet.t array) -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array -> Operator.rev_dep -> - ('a,int) bool Locality.annot -> - (Operator.DepSet.t * Operator.DepSet.t * Operator.DepSet.t array - * Operator.DepSet.t array) + ('a, int) bool Loc.annoted -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array val setup_alg_vars_rev_dep : unit NamedDecls.t -> - (string Locality.annot * ('a,int) e Locality.annot) array -> - (Operator.DepSet.t * Operator.DepSet.t * Operator.DepSet.t array - * Operator.DepSet.t array) - -val has_mix : ?var_decls:('b -> ('c,'b) e) -> ('a,'b) e -> pervasives_bool + (string Loc.annoted * ('a, int) e Loc.annoted) array -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array -val is_constant : ('a, 'b) e Locality.annot -> pervasives_bool +val has_mix : ?var_decls:('b -> ('c, 'b) e) -> ('a, 'b) e -> pervasives_bool +val is_constant : ('a, 'b) e Loc.annoted -> pervasives_bool -val is_time_homogeneous : ('a, 'b) e Locality.annot -> pervasives_bool +val is_time_homogeneous : ('a, 'b) e Loc.annoted -> pervasives_bool (** does not take into account symbolic propagation of expression *) -val has_progress_dep : only_time:pervasives_bool -> - (Operator.DepSet.t * Operator.DepSet.t * - Operator.DepSet.t array * Operator.DepSet.t array) -> - ('a,int) e Locality.annot -> pervasives_bool +val has_progress_dep : + only_time:pervasives_bool -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array -> + ('a, int) e Loc.annoted -> + pervasives_bool -val extract_connected_components : ('a,'b) e Locality.annot -> 'a list - -val extract_connected_components_bool : ('a,'b) bool Locality.annot -> 'a list +val extract_connected_components : ('a, 'b) e Loc.annoted -> 'a list +val extract_connected_components_bool : ('a, 'b) bool Loc.annoted -> 'a list val propagate_constant : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - ?max_time:float -> ?max_events:int -> int list -> - (string Locality.annot * ('a,int) e Locality.annot) array -> - ('a,int) e Locality.annot -> ('a,int) e Locality.annot + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + ?max_time:float -> + ?max_events:int -> + updated_vars:int list -> + vars:(string Loc.annoted * ('a, int) e Loc.annoted) array -> + ('a, int) e Loc.annoted -> + ('a, int) e Loc.annoted val propagate_constant_bool : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - ?max_time:float -> ?max_events:int -> int list -> - (string Locality.annot * ('a,int) e Locality.annot) array -> - ('a,int) bool Locality.annot -> ('a,int) bool Locality.annot + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + ?max_time:float -> + ?max_events:int -> + updated_vars:int list -> + vars:(string Loc.annoted * ('a, int) e Loc.annoted) array -> + ('a, int) bool Loc.annoted -> + ('a, int) bool Loc.annoted val is_equality_test_time : - (Operator.DepSet.t * Operator.DepSet.t * - Operator.DepSet.t array * Operator.DepSet.t array) -> - ('a,int) bool -> pervasives_bool + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array -> + ('a, int) bool -> + pervasives_bool val map_on_mixture : - ('a -> ('c, 'b) e) -> ('a, 'b) e Locality.annot -> ('c, 'b) e Locality.annot + ('a -> ('c, 'b) e) -> ('a, 'b) e Loc.annoted -> ('c, 'b) e Loc.annoted + val map_bool_on_mixture : - ('a -> ('c, 'b) e) -> - ('a, 'b) bool Locality.annot -> ('c, 'b) bool Locality.annot + ('a -> ('c, 'b) e) -> ('a, 'b) bool Loc.annoted -> ('c, 'b) bool Loc.annoted + +val fold_on_mixture : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) e Loc.annoted -> 'a -val fold_on_mixture : - ('a -> 'b -> 'a) -> 'a -> ('b, 'c) e Locality.annot -> 'a val fold_bool_on_mixture : - ('a -> 'b -> 'a) -> 'a -> ('b, 'c) bool Locality.annot -> 'a + ('a -> 'b -> 'a) -> 'a -> ('b, 'c) bool Loc.annoted -> 'a +val equal : ('a, 'b) e Loc.annoted -> ('a, 'b) e Loc.annoted -> pervasives_bool (** Syntactic equality up to positions but not associativity and comutativity *) -val equal : - ('a, 'b) e Locality.annot -> ('a, 'b) e Locality.annot -> pervasives_bool + val equal_bool : - ('a, 'b) bool Locality.annot -> ('a, 'b) bool Locality.annot -> pervasives_bool + ('a, 'b) bool Loc.annoted -> ('a, 'b) bool Loc.annoted -> pervasives_bool diff --git a/core/term/alg_expr_extra.ml b/core/term/alg_expr_extra.ml index 763e573fe3..94b9e5f945 100644 --- a/core/term/alg_expr_extra.ml +++ b/core/term/alg_expr_extra.ml @@ -7,405 +7,354 @@ (******************************************************************************) let divide_expr_by_int e i = - Locality.dummy_annot - (Alg_expr.BIN_ALG_OP - (Operator.DIV, e, Locality.dummy_annot (Alg_expr.CONST (Nbr.I i)))) + Loc.annot_with_dummy + (Alg_expr.BIN_ALG_OP + (Operator.DIV, e, Loc.annot_with_dummy (Alg_expr.CONST (Nbr.I i)))) -type ('a,'b) corrected_rate_const = - { - num: Nbr.t ; - den: Nbr.t ; - var: ('a,'b) Alg_expr.e Locality.annot option - } +type ('a, 'b) corrected_rate_const = { + num: Nbr.t; + den: Nbr.t; + var: ('a, 'b) Alg_expr.e Loc.annoted option; +} -let rec simplify ?root_only:(root_only=false) expr = - match expr - with - | Alg_expr.BIN_ALG_OP (op,a,b),loc -> - begin - let a,b = - if - root_only - then a,b - else - simplify a, simplify b - in - let root_only = true in - match op with - | Operator.SUM -> - begin - match a,b with - | (Alg_expr.CONST a,_), (Alg_expr.CONST b,_) -> - Alg_expr.CONST (Nbr.add a b),loc - | (Alg_expr.CONST a,_),_ when Nbr.is_zero a -> b - | _,(Alg_expr.CONST b,_) when Nbr.is_zero b -> a - | ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ ),_), - ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_) - -> Alg_expr.BIN_ALG_OP(op,a,b),loc - end - | Operator.MINUS -> - begin - match a,b with - | (Alg_expr.CONST a,_), (Alg_expr.CONST b,_) -> - Alg_expr.CONST (Nbr.sub a b),loc - | _,(Alg_expr.CONST b,_) when Nbr.is_zero b -> a - | ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_TOKEN _ - | Alg_expr.DIFF_KAPPA_INSTANCE _),_), - ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_) -> - Alg_expr.BIN_ALG_OP(op,a,b),loc - end - | Operator.MULT -> - begin - match a,b with - | (Alg_expr.CONST a,_), (Alg_expr.CONST b,_) -> - Alg_expr.CONST (Nbr.mult a b),loc - | (Alg_expr.CONST a',_),_ when Nbr.is_equal a' Nbr.zero -> a - | _,(Alg_expr.CONST b',_) when Nbr.is_equal b' Nbr.zero -> b - | (Alg_expr.CONST a,_),_ when Nbr.is_equal a Nbr.one -> b - | _,(Alg_expr.CONST b,_) when Nbr.is_equal b Nbr.one -> a - | (Alg_expr.CONST a,loc_cst), - ( Alg_expr.BIN_ALG_OP (Operator.MULT,(Alg_expr.CONST b,_),c),_ - | Alg_expr.BIN_ALG_OP (Operator.MULT,c,(Alg_expr.CONST b,_)),_) - | - ( Alg_expr.BIN_ALG_OP (Operator.MULT,(Alg_expr.CONST b,_),c),_ - | Alg_expr.BIN_ALG_OP (Operator.MULT,c, (Alg_expr.CONST b,_)),_), (Alg_expr.CONST a,loc_cst) - -> (* a*(b*c) -> (a*b)*c if a & b are constant *) - simplify ~root_only - (Alg_expr.BIN_ALG_OP( - Operator.MULT, - (Alg_expr.CONST (Nbr.mult a b),loc_cst), - c),loc) - | (Alg_expr.CONST a,loc_cst), - (Alg_expr.BIN_ALG_OP (Operator.DIV,(Alg_expr.CONST b,_),c),_) - | - (Alg_expr.BIN_ALG_OP (Operator.DIV,(Alg_expr.CONST b,_),c),_), - (Alg_expr.CONST a,loc_cst) - -> - (* a*(b/c) -> (a*b)/c if a & b are constant *) - simplify ~root_only - (Alg_expr.BIN_ALG_OP - (Operator.DIV,(Alg_expr.CONST (Nbr.mult a b),loc_cst) - ,c),loc) - | - (Alg_expr.BIN_ALG_OP (Operator.DIV,b,(Alg_expr.CONST c,_)),_), - (Alg_expr.CONST a,loc_cst) - |(Alg_expr.CONST a,loc_cst), - (Alg_expr.BIN_ALG_OP (Operator.DIV,b,(Alg_expr.CONST c,_)),_) - when not (Nbr.is_zero c) && Nbr.is_zero (Nbr.rem a c) - -> - (* a*(b/c) -> ((a/c)*b) if a & c are constant and c|a *) - simplify ~root_only - (Alg_expr.BIN_ALG_OP - (Operator.MULT,(Alg_expr.CONST (Nbr.internal_div a c),loc_cst) - ,b),loc) - | ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP - ((Operator.DIV | Operator.MULT | Operator.SUM | Operator.MINUS | Operator.POW | Operator.MODULO | Operator.MIN | Operator.MAX),_,_) - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_), - ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_) - -> Alg_expr.BIN_ALG_OP(op,a,b),loc - - end - | Operator.DIV -> - begin - match a,b with - | _,(Alg_expr.CONST b,_) when Nbr.is_equal b Nbr.one -> a - | (Alg_expr.CONST a,_),(Alg_expr.CONST b,_) when - not (Nbr.is_zero b) && Nbr.is_zero (Nbr.rem a b) -> - Alg_expr.CONST (Nbr.internal_div a b),loc - | (Alg_expr.BIN_ALG_OP - (Operator.MULT, - (Alg_expr.CONST a,_), - b),loc_bin), - (Alg_expr.CONST c,_) - when Nbr.is_zero (Nbr.rem a c)-> - (* (a*b/c) & c|a -> ((c/a)*b)*) - simplify ~root_only - (Alg_expr.BIN_ALG_OP - (Operator.MULT, - (Alg_expr.CONST (Nbr.internal_div c a),loc_bin), - b),loc) - | (Alg_expr.BIN_ALG_OP - (Operator.MULT,b, - (Alg_expr.CONST a,_) - ),loc_bin), - (Alg_expr.CONST c,_) - when Nbr.is_zero (Nbr.rem a c) - -> (* (b*a/c) & c|a -> ((c/a)*b)*) - simplify ~root_only - (Alg_expr.BIN_ALG_OP - (Operator.MULT, - (Alg_expr.CONST (Nbr.internal_div c a),loc_bin), - b),loc) - - | a, - (Alg_expr.BIN_ALG_OP - (Operator.DIV, - (Alg_expr.CONST b,_), - (Alg_expr.CONST c,_)),locdiv) -> - (* (a/b/c) -> a/(b*c) *) - simplify ~root_only - (Alg_expr.BIN_ALG_OP - (Operator.DIV,a,Alg_expr.(CONST (Nbr.mult b c),locdiv)), - loc) - | ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ - | Alg_expr.BIN_ALG_OP - ((Operator.DIV | Operator.MULT | Operator.SUM | Operator.MINUS | Operator.POW | Operator.MODULO | Operator.MIN | Operator.MAX),_,_) - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_), - ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _),_) -> Alg_expr.BIN_ALG_OP(op,a,b),loc - end - | Operator.POW -> - begin - match a,b with - | _,(Alg_expr.CONST b,_) when Nbr.is_equal b Nbr.one -> a - | (Alg_expr.CONST a,_),(Alg_expr.CONST b,_) - when Nbr.is_smaller a (Nbr.I 11) && - Nbr.is_greater b Nbr.zero && Nbr.is_smaller b (Nbr.I 11) -> - (Alg_expr.CONST (Nbr.pow a b),loc) - | ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_), - ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_) -> Alg_expr.BIN_ALG_OP(op,a,b),loc - end - | Operator.MODULO -> - begin - match a,b with - | _,(Alg_expr.CONST b,_) when Nbr.is_equal b Nbr.one -> a - | ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_), - ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _),_) -> Alg_expr.BIN_ALG_OP(op,a,b),loc - end - | Operator.MIN | Operator.MAX -> - begin - Alg_expr.BIN_ALG_OP(op,a,b),loc - end - end - | Alg_expr.UN_ALG_OP (op,a),loc -> - let a = simplify a in - begin - match op with - | Operator.UMINUS -> - begin - match a with - Alg_expr.CONST a,_ -> Alg_expr.CONST (Nbr.neg a),loc - | (Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ ),_ -> Alg_expr.UN_ALG_OP(op,a),loc - end - | Operator.COSINUS | Operator.EXP -> - begin - match a with - | Alg_expr.CONST a,_ when Nbr.is_zero a -> - Alg_expr.CONST Nbr.one,loc - | (Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ +let rec simplify ?(root_only = false) expr = + match expr with + | Alg_expr.BIN_ALG_OP (op, a, b), loc -> + let a, b = + if root_only then + a, b + else + simplify a, simplify b + in + let root_only = true in + (match op with + | Operator.SUM -> + (match a, b with + | (Alg_expr.CONST a, _), (Alg_expr.CONST b, _) -> + Alg_expr.CONST (Nbr.add a b), loc + | (Alg_expr.CONST a, _), _ when Nbr.is_zero a -> b + | _, (Alg_expr.CONST b, _) when Nbr.is_zero b -> a + | ( ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ), + ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) ) -> + Alg_expr.BIN_ALG_OP (op, a, b), loc) + | Operator.MINUS -> + (match a, b with + | (Alg_expr.CONST a, _), (Alg_expr.CONST b, _) -> + Alg_expr.CONST (Nbr.sub a b), loc + | _, (Alg_expr.CONST b, _) when Nbr.is_zero b -> a + | ( ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ ), + _ ), + ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) ) -> + Alg_expr.BIN_ALG_OP (op, a, b), loc) + | Operator.MULT -> + (match a, b with + | (Alg_expr.CONST a, _), (Alg_expr.CONST b, _) -> + Alg_expr.CONST (Nbr.mult a b), loc + | (Alg_expr.CONST a', _), _ when Nbr.is_equal a' Nbr.zero -> a + | _, (Alg_expr.CONST b', _) when Nbr.is_equal b' Nbr.zero -> b + | (Alg_expr.CONST a, _), _ when Nbr.is_equal a Nbr.one -> b + | _, (Alg_expr.CONST b, _) when Nbr.is_equal b Nbr.one -> a + | ( (Alg_expr.CONST a, loc_cst), + ( Alg_expr.BIN_ALG_OP (Operator.MULT, (Alg_expr.CONST b, _), c), _ + | Alg_expr.BIN_ALG_OP (Operator.MULT, c, (Alg_expr.CONST b, _)), _ ) ) + | ( ( Alg_expr.BIN_ALG_OP (Operator.MULT, (Alg_expr.CONST b, _), c), _ + | Alg_expr.BIN_ALG_OP (Operator.MULT, c, (Alg_expr.CONST b, _)), _ ), + (Alg_expr.CONST a, loc_cst) ) -> + (* a*(b*c) -> (a*b)*c if a & b are constant *) + simplify ~root_only + ( Alg_expr.BIN_ALG_OP + (Operator.MULT, (Alg_expr.CONST (Nbr.mult a b), loc_cst), c), + loc ) + | ( (Alg_expr.CONST a, loc_cst), + (Alg_expr.BIN_ALG_OP (Operator.DIV, (Alg_expr.CONST b, _), c), _) ) + | ( (Alg_expr.BIN_ALG_OP (Operator.DIV, (Alg_expr.CONST b, _), c), _), + (Alg_expr.CONST a, loc_cst) ) -> + (* a*(b/c) -> (a*b)/c if a & b are constant *) + simplify ~root_only + ( Alg_expr.BIN_ALG_OP + (Operator.DIV, (Alg_expr.CONST (Nbr.mult a b), loc_cst), c), + loc ) + | ( (Alg_expr.BIN_ALG_OP (Operator.DIV, b, (Alg_expr.CONST c, _)), _), + (Alg_expr.CONST a, loc_cst) ) + | ( (Alg_expr.CONST a, loc_cst), + (Alg_expr.BIN_ALG_OP (Operator.DIV, b, (Alg_expr.CONST c, _)), _) ) + when (not (Nbr.is_zero c)) && Nbr.is_zero (Nbr.rem a c) -> + (* a*(b/c) -> ((a/c)*b) if a & c are constant and c|a *) + simplify ~root_only + ( Alg_expr.BIN_ALG_OP + ( Operator.MULT, + (Alg_expr.CONST (Nbr.internal_div a c), loc_cst), + b ), + loc ) + | ( ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ + | Alg_expr.BIN_ALG_OP + ( ( Operator.DIV | Operator.MULT | Operator.SUM | Operator.MINUS + | Operator.POW | Operator.MODULO | Operator.MIN | Operator.MAX + ), + _, + _ ) + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ), + ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) ) -> + Alg_expr.BIN_ALG_OP (op, a, b), loc) + | Operator.DIV -> + (match a, b with + | _, (Alg_expr.CONST b, _) when Nbr.is_equal b Nbr.one -> a + | (Alg_expr.CONST a, _), (Alg_expr.CONST b, _) + when (not (Nbr.is_zero b)) && Nbr.is_zero (Nbr.rem a b) -> + Alg_expr.CONST (Nbr.internal_div a b), loc + | ( ( Alg_expr.BIN_ALG_OP (Operator.MULT, (Alg_expr.CONST a, _), b), + loc_bin ), + (Alg_expr.CONST c, _) ) + when Nbr.is_zero (Nbr.rem a c) -> + (* (a*b/c) & c|a -> ((c/a)*b)*) + simplify ~root_only + ( Alg_expr.BIN_ALG_OP + ( Operator.MULT, + (Alg_expr.CONST (Nbr.internal_div c a), loc_bin), + b ), + loc ) + | ( ( Alg_expr.BIN_ALG_OP (Operator.MULT, b, (Alg_expr.CONST a, _)), + loc_bin ), + (Alg_expr.CONST c, _) ) + when Nbr.is_zero (Nbr.rem a c) -> + (* (b*a/c) & c|a -> ((c/a)*b)*) + simplify ~root_only + ( Alg_expr.BIN_ALG_OP + ( Operator.MULT, + (Alg_expr.CONST (Nbr.internal_div c a), loc_bin), + b ), + loc ) + | ( a, + ( Alg_expr.BIN_ALG_OP + (Operator.DIV, (Alg_expr.CONST b, _), (Alg_expr.CONST c, _)), + locdiv ) ) -> + (* (a/b/c) -> a/(b*c) *) + simplify ~root_only + ( Alg_expr.BIN_ALG_OP + (Operator.DIV, a, Alg_expr.(CONST (Nbr.mult b c), locdiv)), + loc ) + | ( ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ + | Alg_expr.BIN_ALG_OP + ( ( Operator.DIV | Operator.MULT | Operator.SUM | Operator.MINUS + | Operator.POW | Operator.MODULO | Operator.MIN | Operator.MAX + ), + _, + _ ) + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ), + ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) ) -> + Alg_expr.BIN_ALG_OP (op, a, b), loc) + | Operator.POW -> + (match a, b with + | _, (Alg_expr.CONST b, _) when Nbr.is_equal b Nbr.one -> a + | (Alg_expr.CONST a, _), (Alg_expr.CONST b, _) + when Nbr.is_smaller a (Nbr.I 11) + && Nbr.is_greater b Nbr.zero + && Nbr.is_smaller b (Nbr.I 11) -> + Alg_expr.CONST (Nbr.pow a b), loc + | ( ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ), + ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ ),_ - -> - Alg_expr.UN_ALG_OP(op,a),loc - end - | Operator.SINUS | Operator.TAN -> - begin - match a with - | Alg_expr.CONST a,_ when Nbr.is_equal a Nbr.one -> - Alg_expr.CONST Nbr.zero,loc - | (Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) ) -> + Alg_expr.BIN_ALG_OP (op, a, b), loc) + | Operator.MODULO -> + (match a, b with + | _, (Alg_expr.CONST b, _) when Nbr.is_equal b Nbr.one -> a + | ( ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ ),_ - -> - Alg_expr.UN_ALG_OP(op,a),loc - end - | Operator.SQRT - | Operator.LOG | Operator.INT - -> Alg_expr.UN_ALG_OP(op,a),loc - end - | Alg_expr.DIFF_KAPPA_INSTANCE (expr,mix),loc -> - begin - let expr = simplify expr in - match expr with - | Alg_expr.CONST _,_ -> Alg_expr.CONST (Nbr.zero),loc - | (Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ), + ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) ) -> + Alg_expr.BIN_ALG_OP (op, a, b), loc) + | Operator.MIN | Operator.MAX -> Alg_expr.BIN_ALG_OP (op, a, b), loc) + | Alg_expr.UN_ALG_OP (op, a), loc -> + let a = simplify a in + (match op with + | Operator.UMINUS -> + (match a with + | Alg_expr.CONST a, _ -> Alg_expr.CONST (Nbr.neg a), loc + | ( ( Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.STATE_ALG_OP _ | Alg_expr.KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.DIFF_TOKEN _ ), + _ ) -> + Alg_expr.UN_ALG_OP (op, a), loc) + | Operator.COSINUS | Operator.EXP -> + (match a with + | Alg_expr.CONST a, _ when Nbr.is_zero a -> Alg_expr.CONST Nbr.one, loc + | ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ ),_-> - Alg_expr.DIFF_KAPPA_INSTANCE (expr,mix),loc - end - | Alg_expr.DIFF_TOKEN (expr,token),loc -> - begin - let expr = simplify expr in - match expr with - | Alg_expr.CONST _,_ -> Alg_expr.CONST (Nbr.zero),loc - | (Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) -> + Alg_expr.UN_ALG_OP (op, a), loc) + | Operator.SINUS | Operator.TAN -> + (match a with + | Alg_expr.CONST a, _ when Nbr.is_equal a Nbr.one -> + Alg_expr.CONST Nbr.zero, loc + | ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.DIFF_TOKEN _ ),_-> - Alg_expr.DIFF_TOKEN (expr,token),loc - end - | Alg_expr.STATE_ALG_OP _,_ - | Alg_expr.ALG_VAR _,_ - | Alg_expr.KAPPA_INSTANCE _,_ - | Alg_expr.TOKEN_ID _,_ - | Alg_expr.CONST _,_ -> expr - | Alg_expr.IF (cond,yes,no),loc -> - let cond,yes,no = - simplify_bool cond, simplify yes, simplify no - in - begin - match cond with - | Alg_expr.TRUE,_ -> yes - | Alg_expr.FALSE, _ -> no - | Alg_expr.UN_BOOL_OP (_,_),_ - | Alg_expr.BIN_BOOL_OP (_,_,_),_ - | Alg_expr.COMPARE_OP (_,_,_),_ -> Alg_expr.IF (cond,yes,no),loc - end + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.DIFF_TOKEN _ ), + _ ) -> + Alg_expr.UN_ALG_OP (op, a), loc) + | Operator.SQRT | Operator.LOG | Operator.INT -> + Alg_expr.UN_ALG_OP (op, a), loc) + | Alg_expr.DIFF_KAPPA_INSTANCE (expr, mix), loc -> + let expr = simplify expr in + (match expr with + | Alg_expr.CONST _, _ -> Alg_expr.CONST Nbr.zero, loc + | ( ( Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.STATE_ALG_OP _ | Alg_expr.KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.DIFF_TOKEN _ ), + _ ) -> + Alg_expr.DIFF_KAPPA_INSTANCE (expr, mix), loc) + | Alg_expr.DIFF_TOKEN (expr, token), loc -> + let expr = simplify expr in + (match expr with + | Alg_expr.CONST _, _ -> Alg_expr.CONST Nbr.zero, loc + | ( ( Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ | Alg_expr.UN_ALG_OP _ + | Alg_expr.STATE_ALG_OP _ | Alg_expr.KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + | Alg_expr.DIFF_TOKEN _ ), + _ ) -> + Alg_expr.DIFF_TOKEN (expr, token), loc) + | Alg_expr.STATE_ALG_OP _, _ + | Alg_expr.ALG_VAR _, _ + | Alg_expr.KAPPA_INSTANCE _, _ + | Alg_expr.TOKEN_ID _, _ + | Alg_expr.CONST _, _ -> + expr + | Alg_expr.IF (cond, yes, no), loc -> + let cond, yes, no = simplify_bool cond, simplify yes, simplify no in + (match cond with + | Alg_expr.TRUE, _ -> yes + | Alg_expr.FALSE, _ -> no + | Alg_expr.UN_BOOL_OP (_, _), _ + | Alg_expr.BIN_BOOL_OP (_, _, _), _ + | Alg_expr.COMPARE_OP (_, _, _), _ -> + Alg_expr.IF (cond, yes, no), loc) + and simplify_bool expr_bool = match expr_bool with | Alg_expr.TRUE, _ | Alg_expr.FALSE, _ -> expr_bool | Alg_expr.UN_BOOL_OP (op, a), loc -> - begin - match simplify_bool a with - | Alg_expr.TRUE,_ -> Alg_expr.FALSE, loc - | Alg_expr.FALSE,_ -> Alg_expr.TRUE, loc - | (Alg_expr.BIN_BOOL_OP (_,_,_), _ - | Alg_expr.COMPARE_OP (_,_,_), _ - | Alg_expr.UN_BOOL_OP (_,_), _) as a' - -> Alg_expr.UN_BOOL_OP(op,a'),loc - end - | Alg_expr.BIN_BOOL_OP (op, a ,b),loc -> - begin - let a,b = simplify_bool a, simplify_bool b in - match - op - with - | Operator.AND -> - begin - match a,b with - | (Alg_expr.TRUE,_),_ -> b - | (Alg_expr.FALSE,_),_ -> a - | _,(Alg_expr.TRUE,_) -> a - | _,(Alg_expr.FALSE,_) -> b - | ((Alg_expr.BIN_BOOL_OP (_,_,_) - | Alg_expr.COMPARE_OP (_,_,_) - | Alg_expr.UN_BOOL_OP (_,_)),_), - ((Alg_expr.BIN_BOOL_OP (_,_,_) - | Alg_expr.COMPARE_OP (_,_,_) - | Alg_expr.UN_BOOL_OP (_,_)),_) - -> Alg_expr.BIN_BOOL_OP(op,a,b),loc - end - | Operator.OR -> - begin - match a,b with - | (Alg_expr.TRUE,_),_ -> a - | (Alg_expr.FALSE,_),_ -> b - | _,(Alg_expr.TRUE,_) -> b - | _,(Alg_expr.FALSE,_) -> a - | ((Alg_expr.BIN_BOOL_OP (_,_,_) - | Alg_expr.COMPARE_OP (_,_,_) - | Alg_expr.UN_BOOL_OP (_,_)),_), - ((Alg_expr.BIN_BOOL_OP (_,_,_) - | Alg_expr.COMPARE_OP (_,_,_) - | Alg_expr.UN_BOOL_OP (_,_)),_) - -> Alg_expr.BIN_BOOL_OP(op,a,b),loc - end - end - | Alg_expr.COMPARE_OP (op,a,b),loc -> - let a,b = simplify a, simplify b in - match a,b with - | (Alg_expr.CONST a,_), (Alg_expr.CONST b,_) -> - begin - match op - with - Operator.GREATER -> - if Nbr.is_greater a b - then - Alg_expr.TRUE, loc - else - Alg_expr.FALSE, loc - | Operator.SMALLER -> - if Nbr.is_smaller a b - then + (match simplify_bool a with + | Alg_expr.TRUE, _ -> Alg_expr.FALSE, loc + | Alg_expr.FALSE, _ -> Alg_expr.TRUE, loc + | ( Alg_expr.BIN_BOOL_OP (_, _, _), _ + | Alg_expr.COMPARE_OP (_, _, _), _ + | Alg_expr.UN_BOOL_OP (_, _), _ ) as a' -> + Alg_expr.UN_BOOL_OP (op, a'), loc) + | Alg_expr.BIN_BOOL_OP (op, a, b), loc -> + let a, b = simplify_bool a, simplify_bool b in + (match op with + | Operator.AND -> + (match a, b with + | (Alg_expr.TRUE, _), _ -> b + | (Alg_expr.FALSE, _), _ -> a + | _, (Alg_expr.TRUE, _) -> a + | _, (Alg_expr.FALSE, _) -> b + | ( ( ( Alg_expr.BIN_BOOL_OP (_, _, _) + | Alg_expr.COMPARE_OP (_, _, _) + | Alg_expr.UN_BOOL_OP (_, _) ), + _ ), + ( ( Alg_expr.BIN_BOOL_OP (_, _, _) + | Alg_expr.COMPARE_OP (_, _, _) + | Alg_expr.UN_BOOL_OP (_, _) ), + _ ) ) -> + Alg_expr.BIN_BOOL_OP (op, a, b), loc) + | Operator.OR -> + (match a, b with + | (Alg_expr.TRUE, _), _ -> a + | (Alg_expr.FALSE, _), _ -> b + | _, (Alg_expr.TRUE, _) -> b + | _, (Alg_expr.FALSE, _) -> a + | ( ( ( Alg_expr.BIN_BOOL_OP (_, _, _) + | Alg_expr.COMPARE_OP (_, _, _) + | Alg_expr.UN_BOOL_OP (_, _) ), + _ ), + ( ( Alg_expr.BIN_BOOL_OP (_, _, _) + | Alg_expr.COMPARE_OP (_, _, _) + | Alg_expr.UN_BOOL_OP (_, _) ), + _ ) ) -> + Alg_expr.BIN_BOOL_OP (op, a, b), loc)) + | Alg_expr.COMPARE_OP (op, a, b), loc -> + let a, b = simplify a, simplify b in + (match a, b with + | (Alg_expr.CONST a, _), (Alg_expr.CONST b, _) -> + (match op with + | Operator.GREATER -> + if Nbr.is_greater a b then Alg_expr.TRUE, loc else Alg_expr.FALSE, loc - | Operator.EQUAL -> - if Nbr.is_equal a b - then - Alg_expr.TRUE, loc - else - Alg_expr.FALSE, loc - | Operator.DIFF -> - if Nbr.is_equal a b - then - Alg_expr.FALSE, loc + | Operator.SMALLER -> + if Nbr.is_smaller a b then + Alg_expr.TRUE, loc else + Alg_expr.FALSE, loc + | Operator.EQUAL -> + if Nbr.is_equal a b then Alg_expr.TRUE, loc - end - | ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ - | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _) ,_), - ((Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ - | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.IF _ - | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _),_) -> Alg_expr.COMPARE_OP(op,a,b),loc + else + Alg_expr.FALSE, loc + | Operator.DIFF -> + if Nbr.is_equal a b then + Alg_expr.FALSE, loc + else + Alg_expr.TRUE, loc) + | ( ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ ), + _ ), + ( ( Alg_expr.CONST _ | Alg_expr.ALG_VAR _ | Alg_expr.BIN_ALG_OP _ + | Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.IF _ + | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ ), + _ ) ) -> + Alg_expr.COMPARE_OP (op, a, b), loc) let simplify expr = let root_only = false in @@ -413,276 +362,207 @@ let simplify expr = let rec clean expr = let expr = fst expr in - match expr - with - | Alg_expr.BIN_ALG_OP (op,a,b) -> - Locality.dummy_annot - (Alg_expr.BIN_ALG_OP - (op, clean a, clean b)) - | Alg_expr.UN_ALG_OP (op,a) -> - Locality.dummy_annot - (Alg_expr.UN_ALG_OP (op, clean a)) - | Alg_expr.DIFF_TOKEN (expr,dt) -> - Locality.dummy_annot - (Alg_expr.DIFF_TOKEN (clean expr,dt)) - | Alg_expr.DIFF_KAPPA_INSTANCE(expr,dt) -> - Locality.dummy_annot - (Alg_expr.DIFF_KAPPA_INSTANCE (clean expr,dt)) - | Alg_expr.STATE_ALG_OP _ - | Alg_expr.ALG_VAR _ - | Alg_expr.KAPPA_INSTANCE _ - | Alg_expr.TOKEN_ID _ - | Alg_expr.CONST _ -> - Locality.dummy_annot expr - | Alg_expr.IF (cond,yes,no) -> - Locality.dummy_annot - (Alg_expr.IF (clean_bool cond, clean yes, clean no)) -and clean_bool expr_bool= + match expr with + | Alg_expr.BIN_ALG_OP (op, a, b) -> + Loc.annot_with_dummy (Alg_expr.BIN_ALG_OP (op, clean a, clean b)) + | Alg_expr.UN_ALG_OP (op, a) -> + Loc.annot_with_dummy (Alg_expr.UN_ALG_OP (op, clean a)) + | Alg_expr.DIFF_TOKEN (expr, dt) -> + Loc.annot_with_dummy (Alg_expr.DIFF_TOKEN (clean expr, dt)) + | Alg_expr.DIFF_KAPPA_INSTANCE (expr, dt) -> + Loc.annot_with_dummy (Alg_expr.DIFF_KAPPA_INSTANCE (clean expr, dt)) + | Alg_expr.STATE_ALG_OP _ | Alg_expr.ALG_VAR _ | Alg_expr.KAPPA_INSTANCE _ + | Alg_expr.TOKEN_ID _ | Alg_expr.CONST _ -> + Loc.annot_with_dummy expr + | Alg_expr.IF (cond, yes, no) -> + Loc.annot_with_dummy (Alg_expr.IF (clean_bool cond, clean yes, clean no)) + +and clean_bool expr_bool = let expr = fst expr_bool in match expr with - | Alg_expr.TRUE - | Alg_expr.FALSE -> - Locality.dummy_annot expr - | Alg_expr.UN_BOOL_OP (op,a) -> - Locality.dummy_annot (Alg_expr.UN_BOOL_OP (op,clean_bool a)) - | Alg_expr.BIN_BOOL_OP (op,a,b) -> - Locality.dummy_annot (Alg_expr.BIN_BOOL_OP (op,clean_bool a,clean_bool b)) - | Alg_expr.COMPARE_OP (op,a,b) -> - Locality.dummy_annot (Alg_expr.COMPARE_OP (op,clean a,clean b)) + | Alg_expr.TRUE | Alg_expr.FALSE -> Loc.annot_with_dummy expr + | Alg_expr.UN_BOOL_OP (op, a) -> + Loc.annot_with_dummy (Alg_expr.UN_BOOL_OP (op, clean_bool a)) + | Alg_expr.BIN_BOOL_OP (op, a, b) -> + Loc.annot_with_dummy (Alg_expr.BIN_BOOL_OP (op, clean_bool a, clean_bool b)) + | Alg_expr.COMPARE_OP (op, a, b) -> + Loc.annot_with_dummy (Alg_expr.COMPARE_OP (op, clean a, clean b)) let rec get_corrected_rate e = match e with - Alg_expr.BIN_ALG_OP - (Operator.MULT,(Alg_expr.CONST cst,_),e),_ - | Alg_expr.BIN_ALG_OP - (Operator.MULT,e,(Alg_expr.CONST cst,_)),_ - -> - begin - match get_corrected_rate e with - | None -> None - | Some corrected_rate -> - Some {corrected_rate with num = Nbr.mult cst corrected_rate.num} - end - | Alg_expr.BIN_ALG_OP - (Operator.DIV,e,(Alg_expr.CONST cst,_)),_ -> - begin - match get_corrected_rate e with - | None -> None - | Some corrected_rate -> - Some {corrected_rate with den = Nbr.mult cst corrected_rate.den} - end - | Alg_expr.BIN_ALG_OP - (Operator.SUM,e1,e2),_ -> - begin - match get_corrected_rate e1 with - | None -> None - | Some corrected_rate1 -> - begin - match get_corrected_rate e2 with - | Some corrected_rate2 - when compare corrected_rate1.var corrected_rate2.var = 0 - && Nbr.is_equal corrected_rate1.den corrected_rate2.den - -> - Some - { - corrected_rate1 with - num = Nbr.add corrected_rate1.num corrected_rate2.num; - } - | Some corrected_rate2 when compare corrected_rate1.var corrected_rate2.var = 0 -> - Some - { - corrected_rate1 with - num = - Nbr.add - (Nbr.mult corrected_rate2.den corrected_rate1.num) - (Nbr.mult corrected_rate1.den corrected_rate2.num); - den = Nbr.mult corrected_rate1.den corrected_rate2.den; + | Alg_expr.BIN_ALG_OP (Operator.MULT, (Alg_expr.CONST cst, _), e), _ + | Alg_expr.BIN_ALG_OP (Operator.MULT, e, (Alg_expr.CONST cst, _)), _ -> + (match get_corrected_rate e with + | None -> None + | Some corrected_rate -> + Some { corrected_rate with num = Nbr.mult cst corrected_rate.num }) + | Alg_expr.BIN_ALG_OP (Operator.DIV, e, (Alg_expr.CONST cst, _)), _ -> + (match get_corrected_rate e with + | None -> None + | Some corrected_rate -> + Some { corrected_rate with den = Nbr.mult cst corrected_rate.den }) + | Alg_expr.BIN_ALG_OP (Operator.SUM, e1, e2), _ -> + (match get_corrected_rate e1 with + | None -> None + | Some corrected_rate1 -> + (match get_corrected_rate e2 with + | Some corrected_rate2 + when compare corrected_rate1.var corrected_rate2.var = 0 + && Nbr.is_equal corrected_rate1.den corrected_rate2.den -> + Some + { + corrected_rate1 with + num = Nbr.add corrected_rate1.num corrected_rate2.num; } - | None | Some _ -> None - end - end - | Alg_expr.BIN_ALG_OP - ((Operator.MULT | Operator.DIV | Operator.MINUS | - Operator.POW | Operator.MODULO | Operator.MAX | Operator.MIN),_,_),_ - | (Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ - | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ - | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ - | Alg_expr.IF _) ,_ -> None - | Alg_expr.ALG_VAR _,_ -> - Some - { - var = Some e ; - num = Nbr.one ; - den = Nbr.one } - | Alg_expr.CONST cst,_ -> - Some - { var = None ; - num = cst ; - den = Nbr.one - } + | Some corrected_rate2 + when compare corrected_rate1.var corrected_rate2.var = 0 -> + Some + { + corrected_rate1 with + num = + Nbr.add + (Nbr.mult corrected_rate2.den corrected_rate1.num) + (Nbr.mult corrected_rate1.den corrected_rate2.num); + den = Nbr.mult corrected_rate1.den corrected_rate2.den; + } + | None | Some _ -> None)) + | ( Alg_expr.BIN_ALG_OP + ( ( Operator.MULT | Operator.DIV | Operator.MINUS | Operator.POW + | Operator.MODULO | Operator.MAX | Operator.MIN ), + _, + _ ), + _ ) + | ( ( Alg_expr.UN_ALG_OP _ | Alg_expr.STATE_ALG_OP _ + | Alg_expr.KAPPA_INSTANCE _ | Alg_expr.TOKEN_ID _ | Alg_expr.DIFF_TOKEN _ + | Alg_expr.DIFF_KAPPA_INSTANCE _ | Alg_expr.IF _ ), + _ ) -> + None + | Alg_expr.ALG_VAR _, _ -> Some { var = Some e; num = Nbr.one; den = Nbr.one } + | Alg_expr.CONST cst, _ -> Some { var = None; num = cst; den = Nbr.one } -let get_corrected_rate e = - get_corrected_rate (clean e) +let get_corrected_rate e = get_corrected_rate (clean e) let print pr_var f corrected_rate_const = match corrected_rate_const with | None -> Format.fprintf f "None" | Some a -> - begin - match a.var with - | Some _ -> - (Format.fprintf f "(%a/%a).%a" - Nbr.print a.num Nbr.print a.den pr_var a.var) - | None -> - Format.fprintf f "(%a/%a)" Nbr.print a.num Nbr.print a.den - end + (match a.var with + | Some _ -> + Format.fprintf f "(%a/%a).%a" Nbr.print a.num Nbr.print a.den pr_var a.var + | None -> Format.fprintf f "(%a/%a)" Nbr.print a.num Nbr.print a.den) let necessarily_equal a_opt b_opt = - match a_opt,b_opt - with - | None,_ | _,None -> false + match a_opt, b_opt with + | None, _ | _, None -> false | Some a, Some b -> - Option_util.equal Alg_expr.equal a.var b.var && - Nbr.is_equal (Nbr.mult a.num b.den) (Nbr.mult a.den b.num) + Option_util.equal Alg_expr.equal a.var b.var + && Nbr.is_equal (Nbr.mult a.num b.den) (Nbr.mult a.den b.num) let dep empty add_mixture add_token union dep_env ?time_var expr = let rec aux add_mixture add_token union dep_env expr accu = match fst expr with - | Alg_expr.BIN_ALG_OP (_,e1,e2) | Alg_expr.IF(_,e1,e2) -> - aux add_mixture add_token union dep_env e1 - (aux add_mixture add_token union dep_env e2 accu) - | Alg_expr.UN_ALG_OP (_,e) - | Alg_expr.DIFF_TOKEN (e,_) - | Alg_expr.DIFF_KAPPA_INSTANCE (e,_) - -> aux add_mixture add_token union dep_env e accu + | Alg_expr.BIN_ALG_OP (_, e1, e2) | Alg_expr.IF (_, e1, e2) -> + aux add_mixture add_token union dep_env e1 + (aux add_mixture add_token union dep_env e2 accu) + | Alg_expr.UN_ALG_OP (_, e) + | Alg_expr.DIFF_TOKEN (e, _) + | Alg_expr.DIFF_KAPPA_INSTANCE (e, _) -> + aux add_mixture add_token union dep_env e accu | Alg_expr.STATE_ALG_OP Operator.TIME_VAR -> - begin - match time_var with - | Some id -> add_mixture id accu - | None -> - raise - (ExceptionDefn.Internal_Error - ("A variable for time shall be provided to analyse the dependences in a time-dependent expression",snd expr)) - end + (match time_var with + | Some id -> add_mixture id accu + | None -> + raise + (ExceptionDefn.Internal_Error + ( "A variable for time shall be provided to analyse the \ + dependences in a time-dependent expression", + snd expr ))) | Alg_expr.STATE_ALG_OP - (Operator.CPUTIME | Operator.EVENT_VAR | Operator.NULL_EVENT_VAR | Operator.TMAX_VAR | Operator.EMAX_VAR) -> accu - | Alg_expr.ALG_VAR id -> - union (dep_env id) accu - | Alg_expr.KAPPA_INSTANCE mix -> - add_mixture mix accu - | Alg_expr.TOKEN_ID id -> - add_token id accu + ( Operator.CPUTIME | Operator.EVENT_VAR | Operator.NULL_EVENT_VAR + | Operator.TMAX_VAR | Operator.EMAX_VAR ) -> + accu + | Alg_expr.ALG_VAR id -> union (dep_env id) accu + | Alg_expr.KAPPA_INSTANCE mix -> add_mixture mix accu + | Alg_expr.TOKEN_ID id -> add_token id accu | Alg_expr.CONST _ -> accu in aux add_mixture add_token union dep_env expr empty let rec diff_gen f_mix f_token f_symb f_time expr = match fst expr with - | Alg_expr.IF(b,e1,e2) -> - Locality.dummy_annot + | Alg_expr.IF (b, e1, e2) -> + Loc.annot_with_dummy (Alg_expr.IF - (b, - diff_gen f_mix f_token f_symb f_time e1, - diff_gen f_mix f_token f_symb f_time e2)) - | Alg_expr.BIN_ALG_OP (op,e1,e2) -> - begin - match op with - | Operator.SUM -> - Alg_expr.add - (diff_gen f_mix f_token f_symb f_time e1) - (diff_gen f_mix f_token f_symb f_time e2) - | Operator.MULT -> - Alg_expr.add - (Alg_expr.mult - e1 - (diff_gen f_mix f_token f_symb f_time e2)) - (Alg_expr.mult - e2 - (diff_gen f_mix f_token f_symb f_time e1)) - | Operator.MINUS -> - Alg_expr.minus - (diff_gen f_mix f_token f_symb f_time e1) - (diff_gen f_mix f_token f_symb f_time e2) - | Operator.MIN | Operator.MAX -> - Alg_expr.int 0 - | Operator.MODULO -> - diff_gen f_mix f_token f_symb f_time e1 - | Operator.DIV -> - Alg_expr.div - (Alg_expr.minus - (Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e1) - e2) - (Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e2) - e1) - ) - (Alg_expr.pow - e2 - (Alg_expr.int 2) - ) - | Operator.POW -> (* (u^v)*(v'*ln(u)+v*u'/u) *) - Alg_expr.mult - (Alg_expr.pow e1 e2) - (Alg_expr.add - (Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e2) - (Alg_expr.ln e1)) - (Alg_expr.div - (Alg_expr.mult - e2 - (diff_gen f_mix f_token f_symb f_time e1)) - e1)) - end - | Alg_expr.UN_ALG_OP (op,e) -> - begin - match op with - | Operator.UMINUS -> - Alg_expr.uminus - (diff_gen f_mix f_token f_symb f_time e) - | Operator.COSINUS -> - Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e) - (Alg_expr.uminus (Alg_expr.sin e)) - | Operator.SINUS -> - Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e) - (Alg_expr.cos e) - | Operator.LOG -> - Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e) - (Alg_expr.div - (Alg_expr.int 1) - (e)) - | Operator.SQRT -> - Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e) - (Alg_expr.div - (Alg_expr.int (-1)) - (Alg_expr.sqrt e)) - | Operator.EXP -> - Alg_expr.mult - (diff_gen f_mix f_token f_symb f_time e) - e - | Operator.TAN -> + ( b, + diff_gen f_mix f_token f_symb f_time e1, + diff_gen f_mix f_token f_symb f_time e2 )) + | Alg_expr.BIN_ALG_OP (op, e1, e2) -> + (match op with + | Operator.SUM -> + Alg_expr.add + (diff_gen f_mix f_token f_symb f_time e1) + (diff_gen f_mix f_token f_symb f_time e2) + | Operator.MULT -> + Alg_expr.add + (Alg_expr.mult e1 (diff_gen f_mix f_token f_symb f_time e2)) + (Alg_expr.mult e2 (diff_gen f_mix f_token f_symb f_time e1)) + | Operator.MINUS -> + Alg_expr.minus + (diff_gen f_mix f_token f_symb f_time e1) + (diff_gen f_mix f_token f_symb f_time e2) + | Operator.MIN | Operator.MAX -> Alg_expr.int 0 + | Operator.MODULO -> diff_gen f_mix f_token f_symb f_time e1 + | Operator.DIV -> + Alg_expr.div + (Alg_expr.minus + (Alg_expr.mult (diff_gen f_mix f_token f_symb f_time e1) e2) + (Alg_expr.mult (diff_gen f_mix f_token f_symb f_time e2) e1)) + (Alg_expr.pow e2 (Alg_expr.int 2)) + | Operator.POW -> + (* (u^v)*(v'*ln(u)+v*u'/u) *) + Alg_expr.mult (Alg_expr.pow e1 e2) + (Alg_expr.add + (Alg_expr.mult + (diff_gen f_mix f_token f_symb f_time e2) + (Alg_expr.ln e1)) + (Alg_expr.div + (Alg_expr.mult e2 (diff_gen f_mix f_token f_symb f_time e1)) + e1))) + | Alg_expr.UN_ALG_OP (op, e) -> + (match op with + | Operator.UMINUS -> + Alg_expr.uminus (diff_gen f_mix f_token f_symb f_time e) + | Operator.COSINUS -> Alg_expr.mult (diff_gen f_mix f_token f_symb f_time e) - (Alg_expr.add - (Alg_expr.int 1) - (Alg_expr.pow e (Alg_expr.int 2))) - | Operator.INT -> Alg_expr.int 0 - end + (Alg_expr.uminus (Alg_expr.sin e)) + | Operator.SINUS -> + Alg_expr.mult (diff_gen f_mix f_token f_symb f_time e) (Alg_expr.cos e) + | Operator.LOG -> + Alg_expr.mult + (diff_gen f_mix f_token f_symb f_time e) + (Alg_expr.div (Alg_expr.int 1) e) + | Operator.SQRT -> + Alg_expr.mult + (diff_gen f_mix f_token f_symb f_time e) + (Alg_expr.div (Alg_expr.int (-1)) (Alg_expr.sqrt e)) + | Operator.EXP -> Alg_expr.mult (diff_gen f_mix f_token f_symb f_time e) e + | Operator.TAN -> + Alg_expr.mult + (diff_gen f_mix f_token f_symb f_time e) + (Alg_expr.add (Alg_expr.int 1) (Alg_expr.pow e (Alg_expr.int 2))) + | Operator.INT -> Alg_expr.int 0) | Alg_expr.STATE_ALG_OP Operator.TIME_VAR -> f_time () | Alg_expr.STATE_ALG_OP - (Operator.CPUTIME | Operator.EVENT_VAR | Operator.NULL_EVENT_VAR | Operator.TMAX_VAR | Operator.EMAX_VAR) -> Alg_expr.int 0 - | Alg_expr.KAPPA_INSTANCE mix -> - f_mix mix - | Alg_expr.TOKEN_ID id -> - f_token id - | Alg_expr.CONST _ -> Alg_expr.int 0 - | Alg_expr.ALG_VAR _ - | Alg_expr.DIFF_TOKEN _ - | Alg_expr.DIFF_KAPPA_INSTANCE _ -> f_symb expr + ( Operator.CPUTIME | Operator.EVENT_VAR | Operator.NULL_EVENT_VAR + | Operator.TMAX_VAR | Operator.EMAX_VAR ) -> + Alg_expr.int 0 + | Alg_expr.KAPPA_INSTANCE mix -> f_mix mix + | Alg_expr.TOKEN_ID id -> f_token id + | Alg_expr.CONST _ -> Alg_expr.int 0 + | Alg_expr.ALG_VAR _ | Alg_expr.DIFF_TOKEN _ | Alg_expr.DIFF_KAPPA_INSTANCE _ + -> + f_symb expr let diff_token expr token = let f_mix _ = Alg_expr.int 0 in @@ -692,18 +572,9 @@ let diff_token expr token = else Alg_expr.int 0 in - let f_symb expr = - Alg_expr.DIFF_TOKEN - (expr,token), - Locality.dummy - in + let f_symb expr = Alg_expr.DIFF_TOKEN (expr, token), Loc.dummy in let f_time _ = Alg_expr.int 0 in - diff_gen - f_mix - f_token - f_symb - f_time - expr + diff_gen f_mix f_token f_symb f_time expr let diff_mixture ?time_var expr mixture = let f_mix a = @@ -712,38 +583,30 @@ let diff_mixture ?time_var expr mixture = else Alg_expr.int 0 in - let f_token _ = - Alg_expr.int 0 - in - let f_symb expr = - Alg_expr.DIFF_KAPPA_INSTANCE - (expr,mixture), - Locality.dummy - in + let f_token _ = Alg_expr.int 0 in + let f_symb expr = Alg_expr.DIFF_KAPPA_INSTANCE (expr, mixture), Loc.dummy in let f_time () = match time_var with - | Some b when mixture=b -> Alg_expr.int 1 + | Some b when mixture = b -> Alg_expr.int 1 | Some _ -> Alg_expr.int 0 | None -> - raise - (ExceptionDefn.Internal_Error - ("A time-dependent expression cannot be differentiated without specifying a variable for time progress",Locality.dummy)) + raise + (ExceptionDefn.Internal_Error + ( "A time-dependent expression cannot be differentiated without \ + specifying a variable for time progress", + Loc.dummy )) in diff_gen f_mix f_token f_symb f_time expr let fold_over_mix_in_list f mix accu = - List.fold_left (fun accu array_id -> - Array.fold_left (fun accu pid -> - f pid accu - ) accu array_id - ) accu mix + List.fold_left + (fun accu array_id -> + Array.fold_left (fun accu pid -> f pid accu) accu array_id) + accu mix let fold_over_mix_in_alg_expr f expr accu = let l = Alg_expr.extract_connected_components expr in - List.fold_left - (fun accu mix -> fold_over_mix_in_list f mix accu) - accu - l + List.fold_left (fun accu mix -> fold_over_mix_in_list f mix accu) accu l let fold_over_mixtures_in_alg_exprs f model accu = let algs_expr = Model.get_algs model in @@ -751,48 +614,38 @@ let fold_over_mixtures_in_alg_exprs f model accu = (*algs*) let accu = Array.fold_left - (fun accu (_, mix) -> - fold_over_mix_in_alg_expr - f - mix - accu - ) accu algs_expr + (fun accu (_, mix) -> fold_over_mix_in_alg_expr f mix accu) + accu algs_expr in (*observations*) let accu = Array.fold_left - (fun accu mix -> - fold_over_mix_in_alg_expr - f - mix - accu - ) accu observables + (fun accu mix -> fold_over_mix_in_alg_expr f mix accu) + accu observables in (*rules*) let rules = Model.get_rules model in (*rate*) let accu = - Array.fold_left (fun accu elementary_rule -> + Array.fold_left + (fun accu elementary_rule -> let rate = elementary_rule.Primitives.rate in - let accu = - fold_over_mix_in_alg_expr f rate accu - in + let accu = fold_over_mix_in_alg_expr f rate accu in (*unary_rate*) let unary_rate = elementary_rule.Primitives.unary_rate in let accu = match unary_rate with | None -> accu - | Some (expr, _) -> - fold_over_mix_in_alg_expr f expr accu + | Some (expr, _) -> fold_over_mix_in_alg_expr f expr accu in (*delta tokens*) let delta_tokens = elementary_rule.Primitives.delta_tokens in let accu = - List.fold_left (fun accu (expr, _) -> - fold_over_mix_in_alg_expr f expr accu - ) accu delta_tokens + List.fold_left + (fun accu (expr, _) -> fold_over_mix_in_alg_expr f expr accu) + accu delta_tokens in - accu - ) accu rules + accu) + accu rules in accu diff --git a/core/term/alg_expr_extra.mli b/core/term/alg_expr_extra.mli index e7c6a41ea3..8568df06f3 100644 --- a/core/term/alg_expr_extra.mli +++ b/core/term/alg_expr_extra.mli @@ -6,63 +6,65 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) - (** Primitives for handling rule rates when detecting symmetries *) -val divide_expr_by_int: - ('mix,'id) Alg_expr.e Locality.annot -> - int -> ('mix,'id) Alg_expr.e Locality.annot +val divide_expr_by_int : + ('mix, 'id) Alg_expr.e Loc.annoted -> + int -> + ('mix, 'id) Alg_expr.e Loc.annoted (* Partial normal form for expressions *) (* We only deal with constant, single alg_var multiplied/divided by a constant, sum of two expr either both constant or dealing with the same alg_var *) (* I think this is enough to deal with symmetries *) (* We may be more complete later *) -val simplify: - ('mix,'id) Alg_expr.e Locality.annot -> ('mix,'id) Alg_expr.e Locality.annot +val simplify : + ('mix, 'id) Alg_expr.e Loc.annoted -> ('mix, 'id) Alg_expr.e Loc.annoted -type ('mix,'id) corrected_rate_const +type ('mix, 'id) corrected_rate_const (* printer *) val print : - (Format.formatter -> ('mix, 'id) Alg_expr.e Locality.annot option -> unit) - -> Format.formatter -> ('mix,'id) corrected_rate_const option -> unit + (Format.formatter -> ('mix, 'id) Alg_expr.e Loc.annoted option -> unit) -> + Format.formatter -> + ('mix, 'id) corrected_rate_const option -> + unit (* conversion *) -val get_corrected_rate: - ('mix,'id) Alg_expr.e Locality.annot -> ('mix,'id) corrected_rate_const option +val get_corrected_rate : + ('mix, 'id) Alg_expr.e Loc.annoted -> ('mix, 'id) corrected_rate_const option (* partial equality test *) (* true means "yes they are equal" *) (* false means "either equal, or not"*) -val necessarily_equal: - ('mix,'id) corrected_rate_const option -> - ('mix,'id) corrected_rate_const option -> bool +val necessarily_equal : + ('mix, 'id) corrected_rate_const option -> + ('mix, 'id) corrected_rate_const option -> + bool (** derivation *) -val dep: +val dep : 'set -> ('mix -> 'set -> 'set) -> ('id -> 'set -> 'set) -> ('set -> 'set -> 'set) -> ('id -> 'set) -> ?time_var:'mix -> - ('mix,'id) Alg_expr.e Locality.annot -> + ('mix, 'id) Alg_expr.e Loc.annoted -> 'set -val diff_token: - ('mix,'id) Alg_expr.e Locality.annot -> - 'id -> - ('mix,'id) Alg_expr.e Locality.annot +val diff_token : + ('mix, 'id) Alg_expr.e Loc.annoted -> + 'id -> + ('mix, 'id) Alg_expr.e Loc.annoted -val diff_mixture: - ?time_var:'mix -> - ('mix,'id) Alg_expr.e Locality.annot -> - 'mix -> - ('mix,'id) Alg_expr.e Locality.annot +val diff_mixture : + ?time_var:'mix -> + ('mix, 'id) Alg_expr.e Loc.annoted -> + 'mix -> + ('mix, 'id) Alg_expr.e Loc.annoted -val fold_over_mixtures_in_alg_exprs: - (Pattern.id -> 'a -> 'a) -> - Model.t -> 'a -> 'a +val fold_over_mixtures_in_alg_exprs : + (Pattern.id -> 'a -> 'a) -> Model.t -> 'a -> 'a diff --git a/core/term/configuration.ml b/core/term/configuration.ml index f5d309b43f..7628c90ae2 100644 --- a/core/term/configuration.ml +++ b/core/term/configuration.ml @@ -9,208 +9,258 @@ type period = DE of int | DT of float type t = { - progressSize : int; - progressChar : char; - dumpIfDeadlocked : bool; - initial : float option; - maxConsecutiveClash : int; - outputFileName : string option; - plotPeriod : period option; - seed : int option; - traceFileName : string option; - deltaActivitiesFileName : string option; + progressSize: int; + progressChar: char; + dumpIfDeadlocked: bool; + initial: float option; + maxConsecutiveClash: int; + outputFileName: string option; + plotPeriod: period option; + seed: int option; + traceFileName: string option; + deltaActivitiesFileName: string option; } -let empty = { - progressSize = 70; - progressChar = '#'; - dumpIfDeadlocked = true; - initial = None; - maxConsecutiveClash = 3; - seed = None; - traceFileName = None; - plotPeriod = None; - outputFileName = None; - deltaActivitiesFileName = None; -} +let empty = + { + progressSize = 70; + progressChar = '#'; + dumpIfDeadlocked = true; + initial = None; + maxConsecutiveClash = 3; + seed = None; + traceFileName = None; + plotPeriod = None; + outputFileName = None; + deltaActivitiesFileName = None; + } let parse result = let get_value pos_p param value_list f = match value_list with - | [v,pos] -> f v pos + | [ (v, pos) ] -> f v pos | _ -> raise (ExceptionDefn.Malformed_Decl - ("Wrong number of arguments for parameter "^param,pos_p)) in + ("Wrong number of arguments for parameter " ^ param, pos_p)) + in let get_bool_value pos_p param value_list = - get_value pos_p param value_list - (fun value pos_v -> - match value with - | "true" | "yes" -> true - | "false" | "no" -> false - | _ as error -> - raise - (ExceptionDefn.Malformed_Decl - ("Value "^error^" should be either \"yes\" or \"no\"", pos_v)) - ) in + get_value pos_p param value_list (fun value pos_v -> + match value with + | "true" | "yes" -> true + | "false" | "no" -> false + | _ as error -> + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ error ^ " should be either \"yes\" or \"no\"", pos_v))) + in List.fold_left - (fun (conf,story_compression,formatCflow,cflowFile) - ((param,pos_p),value_list) -> + (fun (conf, story_compression, formatCflow, cflowFile) + ((param, pos_p), value_list) -> match param with | "displayCompression" -> - let rec parse (a,b,c) l = + let rec parse (a, b, c) l = match l with - | ("strong",_)::tl -> parse (a,b,true) tl - | ("weak",_)::tl -> parse (a,true,c) tl - | ("none",_)::tl -> parse (true,b,c) tl - | [] -> (conf,(a,b,c),formatCflow,cflowFile) - | (error,pos)::_ -> - raise (ExceptionDefn.Malformed_Decl - ("Unknown value "^error^" for compression mode", pos)) + | ("strong", _) :: tl -> parse (a, b, true) tl + | ("weak", _) :: tl -> parse (a, true, c) tl + | ("none", _) :: tl -> parse (true, b, c) tl + | [] -> conf, (a, b, c), formatCflow, cflowFile + | (error, pos) :: _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Unknown value " ^ error ^ " for compression mode", pos)) in parse story_compression value_list | "cflowFileName" -> - get_value pos_p param value_list - (fun x _ -> (conf,story_compression,formatCflow,Some x)) + get_value pos_p param value_list (fun x _ -> + conf, story_compression, formatCflow, Some x) | "seed" -> - get_value pos_p param value_list - (fun s p -> - try - ({ conf with seed = Some (int_of_string s) }, - story_compression,formatCflow,cflowFile) - with Failure _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^s^" should be an integer", p))) + get_value pos_p param value_list (fun s p -> + try + ( { conf with seed = Some (int_of_string s) }, + story_compression, + formatCflow, + cflowFile ) + with Failure _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ s ^ " should be an integer", p))) | "T0" -> - get_value pos_p param value_list - (fun s p -> - try - ({ conf with initial = Some (float_of_string s) }, - story_compression,formatCflow,cflowFile) - with Failure _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^s^" should be a float", p))) + get_value pos_p param value_list (fun s p -> + try + ( { conf with initial = Some (float_of_string s) }, + story_compression, + formatCflow, + cflowFile ) + with Failure _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ s ^ " should be a float", p))) | "plotPeriod" -> - begin match value_list with - | [s,p] -> - (try - ({conf with plotPeriod = Some (DT (float_of_string s))}, - story_compression,formatCflow,cflowFile) - with Failure _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^s^" should be a float", p))) - | [s,sp;u,up] -> - if u = "e" || u = "event" || u = "events" || - u = "Event" || u = "Events" then - try - ({conf with plotPeriod = Some (DE (int_of_string s))}, - story_compression,formatCflow,cflowFile) - with Failure _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^s^" should be an integer", sp)) - else if u = "t.u." || u = "time units" || u = "Time units" || - u = "time unit" || u = "Time unit" then - try - ({conf with plotPeriod = Some (DT (float_of_string s))}, - story_compression,formatCflow,cflowFile) - with Failure _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^s^" should be a float", sp)) - else - raise (ExceptionDefn.Malformed_Decl - ("Incorrect unit "^u, up)) - | _ -> - raise - (ExceptionDefn.Malformed_Decl - ("Wrong number of arguments for parameter "^param,pos_p)) - end + (match value_list with + | [ (s, p) ] -> + (try + ( { conf with plotPeriod = Some (DT (float_of_string s)) }, + story_compression, + formatCflow, + cflowFile ) + with Failure _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ s ^ " should be a float", p))) + | [ (s, sp); (u, up) ] -> + if + u = "e" || u = "event" || u = "events" || u = "Event" + || u = "Events" + then ( + try + ( { conf with plotPeriod = Some (DE (int_of_string s)) }, + story_compression, + formatCflow, + cflowFile ) + with Failure _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ s ^ " should be an integer", sp)) + ) else if + u = "t.u." || u = "time units" || u = "Time units" + || u = "time unit" || u = "Time unit" + then ( + try + ( { conf with plotPeriod = Some (DT (float_of_string s)) }, + story_compression, + formatCflow, + cflowFile ) + with Failure _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ s ^ " should be a float", sp)) + ) else + raise (ExceptionDefn.Malformed_Decl ("Incorrect unit " ^ u, up)) + | _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Wrong number of arguments for parameter " ^ param, pos_p))) | "outputFileName" -> - get_value pos_p param value_list - (fun s _ -> - ({ conf with outputFileName = Some s }, - story_compression,formatCflow,cflowFile)) + get_value pos_p param value_list (fun s _ -> + ( { conf with outputFileName = Some s }, + story_compression, + formatCflow, + cflowFile )) | "traceFileName" -> - get_value pos_p param value_list - (fun s _ -> - ({ conf with traceFileName = Some s }, - story_compression,formatCflow,cflowFile)) + get_value pos_p param value_list (fun s _ -> + ( { conf with traceFileName = Some s }, + story_compression, + formatCflow, + cflowFile )) | "deltaActivitiesFileName" -> - get_value pos_p param value_list - (fun s _ -> - ({ conf with deltaActivitiesFileName = Some s }, - story_compression,formatCflow,cflowFile)) - + get_value pos_p param value_list (fun s _ -> + ( { conf with deltaActivitiesFileName = Some s }, + story_compression, + formatCflow, + cflowFile )) | "progressBarSize" -> - ({ conf with - progressSize = get_value pos_p param value_list - (fun v p -> + ( { + conf with + progressSize = + get_value pos_p param value_list (fun v p -> try int_of_string v with Failure _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^v^" should be an integer", p))) - },story_compression,formatCflow,cflowFile) + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ v ^ " should be an integer", p))); + }, + story_compression, + formatCflow, + cflowFile ) | "progressBarSymbol" -> - ({ conf with - progressChar = get_value pos_p param value_list - (fun v p -> - try - String.unsafe_get v 0 + ( { + conf with + progressChar = + get_value pos_p param value_list (fun v p -> + try String.unsafe_get v 0 with _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^v^" should be a character",p))) - },story_compression,formatCflow,cflowFile) - + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ v ^ " should be a character", p))); + }, + story_compression, + formatCflow, + cflowFile ) | "dumpIfDeadlocked" -> - ({ conf with dumpIfDeadlocked = get_bool_value pos_p param value_list }, - story_compression,formatCflow,cflowFile) + ( { conf with dumpIfDeadlocked = get_bool_value pos_p param value_list }, + story_compression, + formatCflow, + cflowFile ) | "maxConsecutiveClash" -> - get_value pos_p param value_list - (fun v p -> - try - ({ conf with maxConsecutiveClash = int_of_string v }, - story_compression,formatCflow,cflowFile) - with _ -> - raise (ExceptionDefn.Malformed_Decl - ("Value "^v^" should be an integer",p))) + get_value pos_p param value_list (fun v p -> + try + ( { conf with maxConsecutiveClash = int_of_string v }, + story_compression, + formatCflow, + cflowFile ) + with _ -> + raise + (ExceptionDefn.Malformed_Decl + ("Value " ^ v ^ " should be an integer", p))) | "dotCflows" -> - let formatCflow = get_value pos_p param value_list (fun v _ -> v) in - (conf,story_compression,formatCflow,cflowFile) -(* if get_bool_value pos_p param value_list then - (story_compression, Dot) else - (story_compression, Html)*) + let formatCflow = get_value pos_p param value_list (fun v _ -> v) in + conf, story_compression, formatCflow, cflowFile + (* if get_bool_value pos_p param value_list then + (story_compression, Dot) else + (story_compression, Html)*) | _ as error -> - raise (ExceptionDefn.Malformed_Decl ("Unknown parameter "^error, pos_p)) - ) (empty, (false,false,false), "dot", None) result + raise + (ExceptionDefn.Malformed_Decl ("Unknown parameter " ^ error, pos_p))) + (empty, (false, false, false), "dot", None) + result let print f conf = let () = Format.pp_open_vbox f 0 in - let () = Pp.option ~with_space:false - (fun f -> Format.fprintf f "%%def: \"seed\" \"%i\"@,") f conf.seed in - let () = Format.fprintf - f "%%def: \"dumpIfDeadlocked\" \"%b\"@," conf.dumpIfDeadlocked in - let () = Format.fprintf - f "%%def: \"maxConsecutiveClash\" \"%i\"@," conf.maxConsecutiveClash in - let () = Format.fprintf - f "%%def: \"progressBarSize\" \"%i\"@," conf.progressSize in - let () = Format.fprintf - f "%%def: \"progressBarSymbol\" \"%c\"@," conf.progressChar in - let () = Pp.option ~with_space:false + let () = + Pp.option ~with_space:false + (fun f -> Format.fprintf f "%%def: \"seed\" \"%i\"@,") + f conf.seed + in + let () = + Format.fprintf f "%%def: \"dumpIfDeadlocked\" \"%b\"@," + conf.dumpIfDeadlocked + in + let () = + Format.fprintf f "%%def: \"maxConsecutiveClash\" \"%i\"@," + conf.maxConsecutiveClash + in + let () = + Format.fprintf f "%%def: \"progressBarSize\" \"%i\"@," conf.progressSize + in + let () = + Format.fprintf f "%%def: \"progressBarSymbol\" \"%c\"@," conf.progressChar + in + let () = + Pp.option ~with_space:false (fun f -> Format.fprintf f "%%def: \"T0\" \"%g\"@,") - f conf.initial in - let () = Pp.option ~with_space:false + f conf.initial + in + let () = + Pp.option ~with_space:false (fun f -> function - | DE i -> - Format.fprintf f "%%def: \"plotPeriod\" \"%i\" \"events\"@," i - | DT t -> - Format.fprintf f "%%def: \"plotPeriod\" \"%g\" \"t.u.\"@," t) - f conf.plotPeriod in - let () = Pp.option ~with_space:false + | DE i -> Format.fprintf f "%%def: \"plotPeriod\" \"%i\" \"events\"@," i + | DT t -> Format.fprintf f "%%def: \"plotPeriod\" \"%g\" \"t.u.\"@," t) + f conf.plotPeriod + in + let () = + Pp.option ~with_space:false (fun f -> Format.fprintf f "%%def: \"outputFileName\" \"%s\"@,") - f conf.outputFileName in - let () = Pp.option ~with_space:false + f conf.outputFileName + in + let () = + Pp.option ~with_space:false (fun f -> Format.fprintf f "%%def: \"traceFileName\" \"%s\"@,") - f conf.traceFileName in - let () = Pp.option ~with_space:false + f conf.traceFileName + in + let () = + Pp.option ~with_space:false (fun f -> Format.fprintf f "%%def: \"deltaActivitiesFileName\" \"%s\"@,") - f conf.deltaActivitiesFileName in + f conf.deltaActivitiesFileName + in Format.pp_close_box f () diff --git a/core/term/configuration.mli b/core/term/configuration.mli index 1f72438d2a..e9b320d3e8 100644 --- a/core/term/configuration.mli +++ b/core/term/configuration.mli @@ -9,23 +9,25 @@ type period = DE of int | DT of float type t = { - progressSize : int; - progressChar : char; - dumpIfDeadlocked : bool; - initial : float option; - maxConsecutiveClash : int; - outputFileName : string option; - plotPeriod : period option; - seed : int option; - traceFileName : string option; - deltaActivitiesFileName : string option; + progressSize: int; + progressChar: char; + dumpIfDeadlocked: bool; + initial: float option; + maxConsecutiveClash: int; + outputFileName: string option; + plotPeriod: period option; + seed: int option; + traceFileName: string option; + deltaActivitiesFileName: string option; } val empty : t val parse : - ((string * Locality.t) * (string * Locality.t) list) list -> - t * (bool * bool * bool) * - string (*cflowFormat*) * string option (*cflowFile*) + ((string * Loc.t) * (string * Loc.t) list) list -> + t + * (bool * bool * bool) + * string (*cflowFormat*) + * string option (*cflowFile*) val print : Format.formatter -> t -> unit diff --git a/core/term/contact_map.ml b/core/term/contact_map.ml index ed05db87f4..bf6fa6db00 100644 --- a/core/term/contact_map.ml +++ b/core/term/contact_map.ml @@ -16,114 +16,147 @@ type t = (Mods.IntSet.t * Mods.Int2Set.t) array array let to_yojson a = - let intls_to_json a = `List (Mods.IntSet.fold (fun b acc -> `Int b::acc) a []) in + let intls_to_json a = + `List (Mods.IntSet.fold (fun b acc -> `Int b :: acc) a []) + in let pairls_to_json a = - `List (Mods.Int2Set.fold (fun (b,c) acc-> `List[`Int b;`Int c]::acc) a []) in + `List + (Mods.Int2Set.fold + (fun (b, c) acc -> `List [ `Int b; `Int c ] :: acc) + a []) + in let array_to_json a = - `List (Array.fold_left - (fun acc (a,b) -> - (`List [(intls_to_json a);(pairls_to_json b)])::acc) [] a) in - `List (Array.fold_left - (fun acc t ->(array_to_json t)::acc) [] a) + `List + (Array.fold_left + (fun acc (a, b) -> `List [ intls_to_json a; pairls_to_json b ] :: acc) + [] a) + in + `List (Array.fold_left (fun acc t -> array_to_json t :: acc) [] a) -let of_yojson (a:Yojson.Basic.t) = +let of_yojson (a : Yojson.Basic.t) = let intls_of_json a = - List.fold_left (fun acc -> function + List.fold_left + (fun acc -> function | `Int b -> Mods.IntSet.add b acc - | x -> raise (Yojson.Basic.Util.Type_error("bla1",x))) - Mods.IntSet.empty a in + | x -> raise (Yojson.Basic.Util.Type_error ("bla1", x))) + Mods.IntSet.empty a + in let pairls_of_json a = - List.fold_left (fun acc -> function - | `List [`Int b;`Int c] -> Mods.Int2Set.add (b,c) acc - | x -> raise (Yojson.Basic.Util.Type_error("bla2",x))) - Mods.Int2Set.empty a in - let array_of_json = - function `List ls -> - (match ls with - | [`List a;`List b] -> ((intls_of_json a),(pairls_of_json b)) - | _ -> raise Not_found) - |x -> raise (Yojson.Basic.Util.Type_error("bla3",x)) in + List.fold_left + (fun acc -> function + | `List [ `Int b; `Int c ] -> Mods.Int2Set.add (b, c) acc + | x -> raise (Yojson.Basic.Util.Type_error ("bla2", x))) + Mods.Int2Set.empty a + in + let array_of_json = function + | `List ls -> + (match ls with + | [ `List a; `List b ] -> intls_of_json a, pairls_of_json b + | _ -> raise Not_found) + | x -> raise (Yojson.Basic.Util.Type_error ("bla3", x)) + in match a with - | `List array1 -> Tools.array_map_of_list - (function `List array2 -> - Tools.array_map_of_list array_of_json array2 - |x ->raise (Yojson.Basic.Util.Type_error("bla4",x))) - array1 - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct contact map",x)) - + | `List array1 -> + Tools.array_map_of_list + (function + | `List array2 -> Tools.array_map_of_list array_of_json array2 + | x -> raise (Yojson.Basic.Util.Type_error ("bla4", x))) + array1 + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct contact map", x)) let print_kappa ~noCounters sigs f c = Format.fprintf f "@[%a@]" - (Pp.array Pp.space - (fun ag f intf -> - if Signature.ports_if_counter_agent sigs ag = None - || noCounters then - Format.fprintf f "@[%%agent:@ %a(@[%a@])@]" - (Signature.print_agent sigs) ag - (Pp.array Pp.space - (fun s f (is,ls) -> - if (Signature.site_is_counter sigs ag s) - &¬ noCounters - then - Format.fprintf f "@[%a%a@]" - (Signature.print_site sigs ag) s - (Signature.print_counter sigs ag) s - else - Format.fprintf f "@[%a%t%t@]" - (Signature.print_site sigs ag) s - (fun f -> if not (Mods.IntSet.is_empty is) then - Format.fprintf f "{@[%a@]}" - (Pp.set Mods.IntSet.elements Pp.space - (Signature.print_internal_state sigs ag s)) is) - (fun f -> if not (Mods.Int2Set.is_empty ls) then - Format.fprintf f "@,[@[%a@]]" - (Pp.set Mods.Int2Set.elements Pp.space - (fun f (ad,sd) -> - Format.fprintf f "%a.%a" - (Signature.print_site sigs ad) sd - (Signature.print_agent sigs) ad)) ls) - )) - intf)) + (Pp.array Pp.space (fun ag f intf -> + if Signature.ports_if_counter_agent sigs ag = None || noCounters then + Format.fprintf f "@[%%agent:@ %a(@[%a@])@]" + (Signature.print_agent sigs) + ag + (Pp.array Pp.space (fun s f (is, ls) -> + if Signature.site_is_counter sigs ag s && not noCounters then + Format.fprintf f "@[%a%a@]" + (Signature.print_site sigs ag) + s + (Signature.print_counter sigs ag) + s + else + Format.fprintf f "@[%a%t%t@]" + (Signature.print_site sigs ag) + s + (fun f -> + if not (Mods.IntSet.is_empty is) then + Format.fprintf f "{@[%a@]}" + (Pp.set Mods.IntSet.elements Pp.space + (Signature.print_internal_state sigs ag s)) + is) + (fun f -> + if not (Mods.Int2Set.is_empty ls) then + Format.fprintf f "@,[@[%a@]]" + (Pp.set Mods.Int2Set.elements Pp.space + (fun f (ad, sd) -> + Format.fprintf f "%a.%a" + (Signature.print_site sigs ad) + sd + (Signature.print_agent sigs) + ad)) + ls))) + intf)) c let cut_at i s' l = let rec aux_cut_at o = function | [] -> None - | ((j,s),_ as h) :: t -> if i = j then - if s >= s' then None else Some (h::o) - else aux_cut_at (h::o) t - in aux_cut_at [] l + | (((j, s), _) as h) :: t -> + if i = j then + if s >= s' then + None + else + Some (h :: o) + else + aux_cut_at (h :: o) t + in + aux_cut_at [] l let get_cycles contact_map = - let rec dfs (known,out as acc) path i last_s = - if Mods.IntSet.mem i known - then match cut_at i last_s path with + let rec dfs ((known, out) as acc) path i last_s = + if Mods.IntSet.mem i known then ( + match cut_at i last_s path with | None -> acc | Some x -> known, x :: out - else + ) else ( let known' = Mods.IntSet.add i known in Tools.array_fold_lefti - (fun s acc (_,l)-> - if s = last_s then acc else - Mods.Int2Set.fold - (fun (ty,s' as x) acc -> dfs acc (((i,s),x)::path) ty s') - l acc) - (known',out) contact_map.(i) in - let rec scan (known,out as acc) i = - if i < 0 then out else + (fun s acc (_, l) -> + if s = last_s then + acc + else + Mods.Int2Set.fold + (fun ((ty, s') as x) acc -> dfs acc (((i, s), x) :: path) ty s') + l acc) + (known', out) contact_map.(i) + ) + in + let rec scan ((known, out) as acc) i = + if i < 0 then + out + else scan - (if Mods.IntSet.mem i known then acc else dfs acc [] i (-1)) - (pred i) in - scan (Mods.IntSet.empty,[]) (Array.length contact_map - 1) + (if Mods.IntSet.mem i known then + acc + else + dfs acc [] i (-1)) + (pred i) + in + scan (Mods.IntSet.empty, []) (Array.length contact_map - 1) let print_cycles sigs form contact_map = let o = get_cycles contact_map in Pp.list Pp.space - (Pp.list Pp.empty - (fun f ((ag,s),(ag',s')) -> - Format.fprintf f "%a.%a-%a." - (Signature.print_agent sigs) ag - (Signature.print_site sigs ag) s - (Signature.print_site sigs ag') s' - ) - ) form o + (Pp.list Pp.empty (fun f ((ag, s), (ag', s')) -> + Format.fprintf f "%a.%a-%a." + (Signature.print_agent sigs) + ag + (Signature.print_site sigs ag) + s + (Signature.print_site sigs ag') + s')) + form o diff --git a/core/term/contact_map.mli b/core/term/contact_map.mli index a0bfc92656..bbd8556078 100644 --- a/core/term/contact_map.mli +++ b/core/term/contact_map.mli @@ -13,6 +13,5 @@ val print_kappa : noCounters:bool -> Signature.s -> Format.formatter -> t -> unit val print_cycles : Signature.s -> Format.formatter -> t -> unit - val to_yojson : t -> Yojson.Basic.t val of_yojson : Yojson.Basic.t -> t diff --git a/core/term/dune b/core/term/dune index 3b7f5a0054..d33e95dcf8 100644 --- a/core/term/dune +++ b/core/term/dune @@ -2,6 +2,5 @@ (name kappa_terms) (libraries kappa_mixtures) (public_name kappa-library.terms) - (flags (:standard -w @a - -open Kappa_generic_toolset - -open Kappa_mixtures))) + (flags + (:standard -w @a -open Kappa_generic_toolset -open Kappa_mixtures))) diff --git a/core/term/instantiation.ml b/core/term/instantiation.ml index 5e837bd47b..895d7e3755 100644 --- a/core/term/instantiation.ml +++ b/core/term/instantiation.ml @@ -8,13 +8,10 @@ type agent_name = int type site_name = int -type internal_state = int - +type internal_state = int type binding_type = agent_name * site_name - type abstract = Matching.Agent.t type concrete = Agent.t - type 'a site = 'a * site_name type 'a test = @@ -33,6 +30,29 @@ type 'a action = | Free of 'a site | Remove of 'a +(* The semantics of concrete actions seems to be the following one. + + - When an agent is removed, no other action is stored about it (including bond releasing). + - Created agents are created without default binding/internal states. + - Bonds are inserted thanks to two symmetric actions (Bind_to ...) *) + +let weight action = + match action with + | Create _ -> 1 + | Mod_internal _ | Bind _ | Bind_to _ | Free _ -> 2 + | Remove _ -> 0 + +let weight_reverse action = + match action with + | Create _ -> 1 + | Mod_internal _ | Bind _ | Bind_to _ | Free _ -> 0 + | Remove _ -> 2 + +let sort_concrete_action_list = Tools.sort_by_priority weight 2 +let sort_concrete_action_list_reverse = Tools.sort_by_priority weight_reverse 2 +let sort_abstract_action_list = Tools.sort_by_priority weight 2 +let sort_abstract_action_list_reverse = Tools.sort_by_priority weight_reverse 2 + type 'a binding_state = | ANY | FREE @@ -41,599 +61,782 @@ type 'a binding_state = | BOUND_to of 'a site type 'a event = { - tests : 'a test list list; - actions : 'a action list; - side_effects_src : ('a site * 'a binding_state) list; - side_effects_dst : 'a site list; - connectivity_tests : 'a test list; + tests: 'a test list list; + actions: 'a action list; + side_effects_src: ('a site * 'a binding_state) list; + side_effects_dst: 'a site list; + connectivity_tests: 'a test list; } -let empty_event = { - tests = []; - actions = []; - side_effects_src = []; - side_effects_dst = []; - connectivity_tests = []; -} +let empty_event = + { + tests = []; + actions = []; + side_effects_src = []; + side_effects_dst = []; + connectivity_tests = []; + } -let concretize_binding_state ~debugMode inj2graph = function +let concretize_binding_state ~debug_mode inj2graph = function | ANY -> ANY | FREE -> FREE | BOUND -> BOUND | BOUND_TYPE bt -> BOUND_TYPE bt - | BOUND_to (pl,s) -> - BOUND_to (Matching.Agent.concretize ~debugMode inj2graph pl,s) - -let concretize_test ~debugMode inj2graph = function - | Is_Here pl -> - Is_Here (Matching.Agent.concretize ~debugMode inj2graph pl) - | Has_Internal ((pl,s),i) -> - Has_Internal((Matching.Agent.concretize ~debugMode inj2graph pl,s),i) - | Is_Free (pl,s) -> - Is_Free (Matching.Agent.concretize ~debugMode inj2graph pl,s) - | Is_Bound (pl,s) -> - Is_Bound (Matching.Agent.concretize ~debugMode inj2graph pl,s) - | Has_Binding_type ((pl,s),t) -> - Has_Binding_type ((Matching.Agent.concretize ~debugMode inj2graph pl,s),t) - | Is_Bound_to ((pl,s),(pl',s')) -> - Is_Bound_to ((Matching.Agent.concretize ~debugMode inj2graph pl,s), - (Matching.Agent.concretize ~debugMode inj2graph pl',s')) - -let concretize_action ~debugMode inj2graph = function - | Create (pl,i) -> - Create (Matching.Agent.concretize ~debugMode inj2graph pl,i) - | Mod_internal ((pl,s),i) -> - Mod_internal ((Matching.Agent.concretize ~debugMode inj2graph pl,s),i) - | Bind ((pl,s),(pl',s')) -> - Bind ((Matching.Agent.concretize ~debugMode inj2graph pl,s), - (Matching.Agent.concretize ~debugMode inj2graph pl',s')) - | Bind_to ((pl,s),(pl',s')) -> - Bind_to ((Matching.Agent.concretize ~debugMode inj2graph pl,s), - (Matching.Agent.concretize ~debugMode inj2graph pl',s')) - | Free (pl,s) -> Free (Matching.Agent.concretize ~debugMode inj2graph pl,s) - | Remove pl -> Remove (Matching.Agent.concretize ~debugMode inj2graph pl) - -let try_concretize_action ~debugMode inj2graph actions = - try Some (concretize_action ~debugMode inj2graph actions) + | BOUND_to (pl, s) -> + BOUND_to (Matching.Agent.concretize ~debug_mode inj2graph pl, s) + +let concretize_test ~debug_mode inj2graph = function + | Is_Here pl -> Is_Here (Matching.Agent.concretize ~debug_mode inj2graph pl) + | Has_Internal ((pl, s), i) -> + Has_Internal ((Matching.Agent.concretize ~debug_mode inj2graph pl, s), i) + | Is_Free (pl, s) -> + Is_Free (Matching.Agent.concretize ~debug_mode inj2graph pl, s) + | Is_Bound (pl, s) -> + Is_Bound (Matching.Agent.concretize ~debug_mode inj2graph pl, s) + | Has_Binding_type ((pl, s), t) -> + Has_Binding_type ((Matching.Agent.concretize ~debug_mode inj2graph pl, s), t) + | Is_Bound_to ((pl, s), (pl', s')) -> + Is_Bound_to + ( (Matching.Agent.concretize ~debug_mode inj2graph pl, s), + (Matching.Agent.concretize ~debug_mode inj2graph pl', s') ) + +let concretize_action ~debug_mode inj2graph = function + | Create (pl, i) -> + Create (Matching.Agent.concretize ~debug_mode inj2graph pl, i) + | Mod_internal ((pl, s), i) -> + Mod_internal ((Matching.Agent.concretize ~debug_mode inj2graph pl, s), i) + | Bind ((pl, s), (pl', s')) -> + Bind + ( (Matching.Agent.concretize ~debug_mode inj2graph pl, s), + (Matching.Agent.concretize ~debug_mode inj2graph pl', s') ) + | Bind_to ((pl, s), (pl', s')) -> + Bind_to + ( (Matching.Agent.concretize ~debug_mode inj2graph pl, s), + (Matching.Agent.concretize ~debug_mode inj2graph pl', s') ) + | Free (pl, s) -> Free (Matching.Agent.concretize ~debug_mode inj2graph pl, s) + | Remove pl -> Remove (Matching.Agent.concretize ~debug_mode inj2graph pl) + +let try_concretize_action ~debug_mode inj2graph actions = + try Some (concretize_action ~debug_mode inj2graph actions) with Not_found -> None - (* The action is dealing with a fresh agent *) +(* The action is dealing with a fresh agent *) -let concretize_event ~debugMode inj2graph e = +let concretize_event ~debug_mode inj2graph e = { tests = - List.map (List.rev_map (concretize_test ~debugMode inj2graph)) e.tests; + List.map (List.rev_map (concretize_test ~debug_mode inj2graph)) e.tests; actions = - List.rev_map (concretize_action ~debugMode inj2graph) e.actions; - side_effects_src = List.rev_map - (fun ((pl,s),b) -> - ((Matching.Agent.concretize ~debugMode inj2graph pl,s), - concretize_binding_state ~debugMode inj2graph b)) + (* actions are reordered the following way: + 1) Remove actions + 2) Creation actions + 3) Anything else.*) + sort_abstract_action_list + (List.rev_map (concretize_action ~debug_mode inj2graph) e.actions); + side_effects_src = + List.rev_map + (fun ((pl, s), b) -> + ( (Matching.Agent.concretize ~debug_mode inj2graph pl, s), + concretize_binding_state ~debug_mode inj2graph b )) e.side_effects_src; - side_effects_dst = List.rev_map - (fun (pl,s) -> (Matching.Agent.concretize ~debugMode inj2graph pl,s)) + side_effects_dst = + List.rev_map + (fun (pl, s) -> Matching.Agent.concretize ~debug_mode inj2graph pl, s) e.side_effects_dst; connectivity_tests = - List.rev_map (concretize_test ~debugMode inj2graph) e.connectivity_tests; + List.rev_map (concretize_test ~debug_mode inj2graph) e.connectivity_tests; } let map_test f = function - | Is_Here a | Has_Internal ((a,_),_) | Is_Free (a,_) | Is_Bound (a,_) - | Has_Binding_type ((a,_),_) | Is_Bound_to ((a,_),_) -> f a + | Is_Here a + | Has_Internal ((a, _), _) + | Is_Free (a, _) + | Is_Bound (a, _) + | Has_Binding_type ((a, _), _) + | Is_Bound_to ((a, _), _) -> + f a let map_action f = function - | Create (a,_) | Mod_internal ((a,_),_) | Bind ((a,_),_) - | Bind_to ((a,_),_) | Free (a,_) | Remove a -> f a + | Create (a, _) + | Mod_internal ((a, _), _) + | Bind ((a, _), _) + | Bind_to ((a, _), _) + | Free (a, _) + | Remove a -> + f a let match_tests = function (* abstract, concrete*) - | (Is_Here a,Is_Here b) -> (Matching.Agent.get_type a) = (Agent.sort b) - | (Has_Internal ((a,s),i),Has_Internal ((b,t),j)) -> - ((Matching.Agent.get_type a) = (Agent.sort b))&&(s=t)&&(i=j) - | (Has_Binding_type ((a,s),c),Has_Binding_type ((b,t),d)) -> - ((Matching.Agent.get_type a) = (Agent.sort b))&&(s=t)&&(c=d) - | (Is_Free (a,s),Is_Free (b,t)) | (Is_Bound (a,s),Is_Bound (b,t)) -> - ((Matching.Agent.get_type a) = (Agent.sort b))&&(s=t) - | (Is_Bound_to ((a,s),(c,u)),(Is_Bound_to ((b,t),(d,v)))) -> - ((Matching.Agent.get_type a) = (Agent.sort b))&&(s=t)&& - ((Matching.Agent.get_type c) = (Agent.sort d))&&(u=v) - | (Is_Here _,_) | (Has_Internal _,_) | (Is_Free _,_) | (Is_Bound _,_) - | (Is_Bound_to _,_) | (Has_Binding_type _, _) -> false + | Is_Here a, Is_Here b -> Matching.Agent.get_type a = Agent.sort b + | Has_Internal ((a, s), i), Has_Internal ((b, t), j) -> + Matching.Agent.get_type a = Agent.sort b && s = t && i = j + | Has_Binding_type ((a, s), c), Has_Binding_type ((b, t), d) -> + Matching.Agent.get_type a = Agent.sort b && s = t && c = d + | Is_Free (a, s), Is_Free (b, t) | Is_Bound (a, s), Is_Bound (b, t) -> + Matching.Agent.get_type a = Agent.sort b && s = t + | Is_Bound_to ((a, s), (c, u)), Is_Bound_to ((b, t), (d, v)) -> + Matching.Agent.get_type a = Agent.sort b + && s = t + && Matching.Agent.get_type c = Agent.sort d + && u = v + | Is_Here _, _ + | Has_Internal _, _ + | Is_Free _, _ + | Is_Bound _, _ + | Is_Bound_to _, _ + | Has_Binding_type _, _ -> + false let match_actions = function (* abstract, concrete*) - | (Create (a,als),Create (b,bls)) -> - ((Matching.Agent.get_type a)=(Agent.sort b))&& - (List.fold_left2 (fun ok (s,i) (t,j) -> ok&&(s=t)&&(i=j)) true als bls) - | (Mod_internal ((a,s),i), Mod_internal ((b,t),j)) -> - ((Matching.Agent.get_type a)=(Agent.sort b))&&(s=t)&&(i=j) - | (Bind ((a,s),(c,u)), Bind ((b,t),(d,v))) - | (Bind_to ((a,s),(c,u)), Bind_to ((b,t),(d,v))) -> - ((Matching.Agent.get_type a)=(Agent.sort b))&&(s=t)&& - ((Matching.Agent.get_type c)=(Agent.sort d))&&(u=v) - | (Free (a,s), Free (b,t)) -> - ((Matching.Agent.get_type a)=(Agent.sort b))&&(s=t) - | (Remove a,Remove b) -> ((Matching.Agent.get_type a)=(Agent.sort b)) - | (Create _,_) | (Mod_internal _,_)| (Bind _,_)| (Bind_to _,_)| (Free _,_) - | (Remove _,_) -> false + | Create (a, als), Create (b, bls) -> + Matching.Agent.get_type a = Agent.sort b + && List.fold_left2 + (fun ok (s, i) (t, j) -> ok && s = t && i = j) + true als bls + | Mod_internal ((a, s), i), Mod_internal ((b, t), j) -> + Matching.Agent.get_type a = Agent.sort b && s = t && i = j + | Bind ((a, s), (c, u)), Bind ((b, t), (d, v)) + | Bind_to ((a, s), (c, u)), Bind_to ((b, t), (d, v)) -> + Matching.Agent.get_type a = Agent.sort b + && s = t + && Matching.Agent.get_type c = Agent.sort d + && u = v + | Free (a, s), Free (b, t) -> + Matching.Agent.get_type a = Agent.sort b && s = t + | Remove a, Remove b -> Matching.Agent.get_type a = Agent.sort b + | Create _, _ + | Mod_internal _, _ + | Bind _, _ + | Bind_to _, _ + | Free _, _ + | Remove _, _ -> + false let get_ids f aux = List.fold_left (fun acc a -> let id = f a in - if (List.mem id acc) then acc else id::acc) aux + if List.mem id acc then + acc + else + id :: acc) + aux let rec match_quarks a_quarks c_quarks fmatch = match a_quarks with - | aq::aqs -> - let (cqs,rest) = - List.partition (fun cq -> fmatch (aq,cq)) c_quarks in - if (cqs = []) then false - else match_quarks aqs rest fmatch - | [] -> (c_quarks = []) + | aq :: aqs -> + let cqs, rest = List.partition (fun cq -> fmatch (aq, cq)) c_quarks in + if cqs = [] then + false + else + match_quarks aqs rest fmatch + | [] -> c_quarks = [] let rec find_match tests actions ctests cactions = function | [] -> - raise - (ExceptionDefn.Internal_Error - (Locality.dummy_annot "abstract and concret quarks don't match")) - | cid::tl -> - let ctests' = - List.filter - (fun test -> map_test (fun a -> (Agent.id a) = cid) test) ctests in - let cactions' = - List.filter - (fun act -> map_action (fun a -> (Agent.id a) = cid) act) cactions in - if ((match_quarks tests ctests' match_tests)&& - (match_quarks actions cactions' match_actions)) then cid - else find_match tests actions ctests cactions tl - -let matching_abstract_concrete ~debugMode ae ce = + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy "abstract and concret quarks don't match")) + | cid :: tl -> + let ctests' = + List.filter (fun test -> map_test (fun a -> Agent.id a = cid) test) ctests + in + let cactions' = + List.filter + (fun act -> map_action (fun a -> Agent.id a = cid) act) + cactions + in + if + match_quarks tests ctests' match_tests + && match_quarks actions cactions' match_actions + then + cid + else + find_match tests actions ctests cactions tl + +let matching_abstract_concrete ~debug_mode ae ce = let ae_tests = List.flatten ae.tests in let ce_tests = List.flatten ce.tests in let abstract_ids = - (get_ids - (map_action (Matching.Agent.get_id)) - (get_ids (map_test (Matching.Agent.get_id)) [] ae_tests) - ae.actions) in + get_ids + (map_action Matching.Agent.get_id) + (get_ids (map_test Matching.Agent.get_id) [] ae_tests) + ae.actions + in let concrete_ids = - (get_ids - (map_action (Agent.id)) - (get_ids (map_test (Agent.id)) [] ce_tests) - ce.actions) in + get_ids (map_action Agent.id) + (get_ids (map_test Agent.id) [] ce_tests) + ce.actions + in let available_ids used = List.filter - (fun i -> not(Mods.IntSet.mem i (Renaming.image used))) concrete_ids in + (fun i -> not (Mods.IntSet.mem i (Renaming.image used))) + concrete_ids + in let partition fmap i = - List.partition (fun q -> fmap (fun a -> (Matching.Agent.get_id a) = i) q) in + List.partition (fun q -> fmap (fun a -> Matching.Agent.get_id a = i) q) + in let matching = Renaming.empty () in let injective = List.fold_left (fun acc i -> - acc && - let (tests,_) = partition map_test i ae_tests in - let (actions,_) = partition map_action i ae.actions in - let j = - find_match tests actions ce_tests ce.actions (available_ids matching) in - Renaming.imperative_add ~debugMode i j matching) - true abstract_ids in - if injective then Some matching else None - -let subst_map_concrete_agent f (id,na as agent) = - try if f id == id then agent else (f id,na) + acc + && + let tests, _ = partition map_test i ae_tests in + let actions, _ = partition map_action i ae.actions in + let j = + find_match tests actions ce_tests ce.actions (available_ids matching) + in + Renaming.imperative_add ~debug_mode i j matching) + true abstract_ids + in + if injective then + Some matching + else + None + +let subst_map_concrete_agent f ((id, na) as agent) = + try + if f id == id then + agent + else + f id, na with Not_found -> agent -let subst_map_site f (ag,s as site) = +let subst_map_site f ((ag, s) as site) = let ag' = f ag in - if ag==ag' then site else (ag',s) + if ag == ag' then + site + else + ag', s let subst_map_agent_in_test f = function | Is_Here agent as x -> let agent' = f agent in - if agent == agent' then x else Is_Here agent' - | Has_Internal (site,internal_state) as x -> + if agent == agent' then + x + else + Is_Here agent' + | Has_Internal (site, internal_state) as x -> let site' = subst_map_site f site in - if site == site' then x else Has_Internal (site',internal_state) + if site == site' then + x + else + Has_Internal (site', internal_state) | Is_Free site as x -> let site' = subst_map_site f site in - if site == site' then x else Is_Free site' + if site == site' then + x + else + Is_Free site' | Is_Bound site as x -> let site' = subst_map_site f site in - if site == site' then x else Is_Bound site' - | Has_Binding_type (site,binding_type) as x -> + if site == site' then + x + else + Is_Bound site' + | Has_Binding_type (site, binding_type) as x -> let site' = subst_map_site f site in - if site == site' then x else Has_Binding_type (site',binding_type) - | Is_Bound_to (site1,site2) as x -> + if site == site' then + x + else + Has_Binding_type (site', binding_type) + | Is_Bound_to (site1, site2) as x -> let site1' = subst_map_site f site1 in let site2' = subst_map_site f site2 in - if site1 == site1' && site2 == site2' then x - else Is_Bound_to (site1',site2') + if site1 == site1' && site2 == site2' then + x + else + Is_Bound_to (site1', site2') + let subst_map_agent_in_concrete_test f x = subst_map_agent_in_test (subst_map_concrete_agent f) x + let subst_agent_in_concrete_test id id' x = subst_map_agent_in_concrete_test - (fun j -> if j = id then id' else j) x -let rename_abstract_test ~debugMode id inj x = - subst_map_agent_in_test (Matching.Agent.rename ~debugMode id inj) x + (fun j -> + if j = id then + id' + else + j) + x + +let rename_abstract_test ~debug_mode id inj x = + subst_map_agent_in_test (Matching.Agent.rename ~debug_mode id inj) x let subst_map2_agent_in_action f f' = function - | Create (agent,list) as x -> + | Create (agent, list) as x -> let agent' = f' agent in - if agent == agent' then x else Create(agent',list) - | Mod_internal (site,i) as x -> + if agent == agent' then + x + else + Create (agent', list) + | Mod_internal (site, i) as x -> let site' = subst_map_site f' site in - if site == site' then x else Mod_internal(site',i) - | Bind (s1,s2) as x -> + if site == site' then + x + else + Mod_internal (site', i) + | Bind (s1, s2) as x -> let s1' = subst_map_site f' s1 in let s2' = subst_map_site f' s2 in - if s1==s1' && s2==s2' then x else Bind(s1',s2') - | Bind_to (s1,s2) as x -> + if s1 == s1' && s2 == s2' then + x + else + Bind (s1', s2') + | Bind_to (s1, s2) as x -> let s1' = subst_map_site f' s1 in let s2' = subst_map_site f' s2 in - if s1==s1' && s2==s2' then x else Bind_to(s1',s2') + if s1 == s1' && s2 == s2' then + x + else + Bind_to (s1', s2') | Free site as x -> let site' = subst_map_site f' site in - if site == site' then x else Free site' + if site == site' then + x + else + Free site' | Remove agent as x -> let agent' = f agent in - if agent==agent' then x else Remove agent' + if agent == agent' then + x + else + Remove agent' let subst_map_agent_in_action f x = subst_map2_agent_in_action f f x let subst_map_agent_in_concrete_action f x = subst_map_agent_in_action (subst_map_concrete_agent f) x + let subst_agent_in_concrete_action id id' x = subst_map_agent_in_concrete_action - (fun j -> if j = id then id' else j) x -let rename_abstract_action ~debugMode id inj x = - subst_map_agent_in_action (Matching.Agent.rename ~debugMode id inj) x + (fun j -> + if j = id then + id' + else + j) + x + +let rename_abstract_action ~debug_mode id inj x = + subst_map_agent_in_action (Matching.Agent.rename ~debug_mode id inj) x let subst_map_binding_state f = function - | (ANY | FREE | BOUND | BOUND_TYPE _ as x) -> x - | BOUND_to (ag,s) as x -> - let ag' = f ag in if ag == ag' then x else BOUND_to (ag',s) -let subst_map_agent_in_side_effect f (site,bstate as x) = + | (ANY | FREE | BOUND | BOUND_TYPE _) as x -> x + | BOUND_to (ag, s) as x -> + let ag' = f ag in + if ag == ag' then + x + else + BOUND_to (ag', s) + +let subst_map_agent_in_side_effect f ((site, bstate) as x) = let site' = subst_map_site f site in let bstate' = subst_map_binding_state f bstate in - if site == site' && bstate == bstate' then x else (site',bstate') + if site == site' && bstate == bstate' then + x + else + site', bstate' + let subst_map_agent_in_concrete_side_effect f x = subst_map_agent_in_side_effect (subst_map_concrete_agent f) x + let subst_agent_in_concrete_side_effect id id' x = subst_map_agent_in_concrete_side_effect - (fun j -> if j = id then id' else j) x -let rename_abstract_side_effect ~debugMode id inj x = - subst_map_agent_in_side_effect (Matching.Agent.rename ~debugMode id inj) x + (fun j -> + if j = id then + id' + else + j) + x + +let rename_abstract_side_effect ~debug_mode id inj x = + subst_map_agent_in_side_effect (Matching.Agent.rename ~debug_mode id inj) x let subst_map_agent_in_event f e = { - tests = List_util.smart_map - (List_util.smart_map (subst_map_agent_in_test f)) e.tests; + tests = + List_util.smart_map + (List_util.smart_map (subst_map_agent_in_test f)) + e.tests; actions = List_util.smart_map (subst_map_agent_in_action f) e.actions; side_effects_src = List_util.smart_map (subst_map_agent_in_side_effect f) e.side_effects_src; - side_effects_dst = - List_util.smart_map (subst_map_site f) e.side_effects_dst; + side_effects_dst = List_util.smart_map (subst_map_site f) e.side_effects_dst; connectivity_tests = List_util.smart_map (subst_map_agent_in_test f) e.connectivity_tests; } let subst_map2_agent_in_event f f' e = { - tests = List_util.smart_map - (List_util.smart_map (subst_map_agent_in_test f)) e.tests; + tests = + List_util.smart_map + (List_util.smart_map (subst_map_agent_in_test f)) + e.tests; actions = List_util.smart_map (subst_map2_agent_in_action f f') e.actions; side_effects_src = List_util.smart_map (subst_map_agent_in_side_effect f) e.side_effects_src; - side_effects_dst = - List_util.smart_map (subst_map_site f) e.side_effects_dst; + side_effects_dst = List_util.smart_map (subst_map_site f) e.side_effects_dst; connectivity_tests = List_util.smart_map (subst_map_agent_in_test f) e.connectivity_tests; } let subst_map_agent_in_concrete_event f x = subst_map_agent_in_event (subst_map_concrete_agent f) x + let subst_map2_agent_in_concrete_event f f' x = subst_map2_agent_in_event - (subst_map_concrete_agent f) (subst_map_concrete_agent f') x + (subst_map_concrete_agent f) + (subst_map_concrete_agent f') + x let subst_agent_in_concrete_event id id' x = subst_map_agent_in_concrete_event - (fun j -> if j = id then id' else j) x -let rename_abstract_event ~debugMode id inj x = - subst_map_agent_in_event (Matching.Agent.rename ~debugMode id inj) x + (fun j -> + if j = id then + id' + else + j) + x + +let rename_abstract_event ~debug_mode id inj x = + subst_map_agent_in_event (Matching.Agent.rename ~debug_mode id inj) x + +let print_concrete_agent_site ?sigs f (agent, id) = + Format.fprintf f "%a.%a" + (Agent.print ?sigs ~with_id:true) + agent + (Agent.print_site ?sigs agent) + id -let print_concrete_agent_site ?sigs f (agent,id) = - Format.fprintf f "%a.%a" (Agent.print ?sigs ~with_id:true) agent - (Agent.print_site ?sigs agent) id let print_concrete_test ?sigs f = function | Is_Here agent -> Format.fprintf f "Is_Here(%a)" (Agent.print ?sigs ~with_id:true) agent - | Has_Internal ((ag,id),int) -> + | Has_Internal ((ag, id), int) -> Format.fprintf f "Has_Internal(%a.%a)" - (Agent.print ?sigs ~with_id:true) ag - (Agent.print_internal ?sigs ag id) int + (Agent.print ?sigs ~with_id:true) + ag + (Agent.print_internal ?sigs ag id) + int | Is_Free site -> Format.fprintf f "Is_Free(%a)" (print_concrete_agent_site ?sigs) site | Is_Bound site -> Format.fprintf f "Is_Bound(%a)" (print_concrete_agent_site ?sigs) site - | Has_Binding_type (site,(ty,sid)) -> - Format.fprintf f "Btype(%a,%t)" - (print_concrete_agent_site ?sigs) site + | Has_Binding_type (site, (ty, sid)) -> + Format.fprintf f "Btype(%a,%t)" (print_concrete_agent_site ?sigs) site (fun f -> - match sigs with - | None -> Format.fprintf f "%i.%i" ty sid - | Some sigs -> - Format.fprintf - f "%a.%a" (Signature.print_agent sigs) ty - (Signature.print_site sigs ty) sid) - | Is_Bound_to (site1,site2) -> + match sigs with + | None -> Format.fprintf f "%i.%i" ty sid + | Some sigs -> + Format.fprintf f "%a.%a" + (Signature.print_agent sigs) + ty + (Signature.print_site sigs ty) + sid) + | Is_Bound_to (site1, site2) -> Format.fprintf f "Is_Bound(%a,%a)" - (print_concrete_agent_site ?sigs) site1 - (print_concrete_agent_site ?sigs) site2 + (print_concrete_agent_site ?sigs) + site1 + (print_concrete_agent_site ?sigs) + site2 + let print_concrete_action ?sigs f = function - | Create ((_,ty as agent),list) -> - Format.fprintf - f "Create(%a[@[%a@]])" (Agent.print ?sigs ~with_id:true) agent - (Pp.list Pp.comma - (fun f (x,y) -> - match sigs with - | Some sigs -> - Signature.print_site_internal_state sigs ty x f y - | None -> - match y with - | None -> Format.pp_print_int f x - | Some y -> - Format.fprintf f "%i.%i" x y)) + | Create (((_, ty) as agent), list) -> + Format.fprintf f "Create(%a[@[%a@]])" + (Agent.print ?sigs ~with_id:true) + agent + (Pp.list Pp.comma (fun f (x, y) -> + match sigs with + | Some sigs -> Signature.print_site_internal_state sigs ty x f y + | None -> + (match y with + | None -> Format.pp_print_int f x + | Some y -> Format.fprintf f "%i.%i" x y))) list - | Mod_internal ((ag,id),int) -> - Format.fprintf f "Mod(%a.%a)" (Agent.print ?sigs ~with_id:true) ag - (Agent.print_internal ?sigs ag id) int - | Bind (site1,site2) -> - Format.fprintf f "Bind(%a,%a)" (print_concrete_agent_site ?sigs) site1 - (print_concrete_agent_site ?sigs) site2 - | Bind_to (site1,site2) -> - Format.fprintf f "Bind_to(%a,%a)" (print_concrete_agent_site ?sigs) site1 - (print_concrete_agent_site ?sigs) site2 + | Mod_internal ((ag, id), int) -> + Format.fprintf f "Mod(%a.%a)" + (Agent.print ?sigs ~with_id:true) + ag + (Agent.print_internal ?sigs ag id) + int + | Bind (site1, site2) -> + Format.fprintf f "Bind(%a,%a)" + (print_concrete_agent_site ?sigs) + site1 + (print_concrete_agent_site ?sigs) + site2 + | Bind_to (site1, site2) -> + Format.fprintf f "Bind_to(%a,%a)" + (print_concrete_agent_site ?sigs) + site1 + (print_concrete_agent_site ?sigs) + site2 | Free site -> Format.fprintf f "Free(%a)" (print_concrete_agent_site ?sigs) site | Remove agent -> Format.fprintf f "Remove(%a)" (Agent.print ?sigs ~with_id:true) agent + let print_concrete_binding_state ?sigs f = function | ANY -> Format.pp_print_string f "*" | FREE -> () | BOUND -> Format.pp_print_string f "!_" - | BOUND_TYPE (s,a) -> - Format.fprintf - f "!%a.%a" + | BOUND_TYPE (s, a) -> + Format.fprintf f "!%a.%a" (match sigs with - | Some sigs -> Signature.print_site sigs s - | None -> Format.pp_print_int) a + | Some sigs -> Signature.print_site sigs s + | None -> Format.pp_print_int) + a (match sigs with - | Some sigs -> Signature.print_agent sigs - | None -> Format.pp_print_int) s - | BOUND_to ((ag_id,ag),s) -> - Format.fprintf - f "!%a_%i.%a" + | Some sigs -> Signature.print_agent sigs + | None -> Format.pp_print_int) + s + | BOUND_to ((ag_id, ag), s) -> + Format.fprintf f "!%a_%i.%a" (match sigs with - | Some sigs -> Signature.print_agent sigs - | None -> Format.pp_print_int) ag ag_id + | Some sigs -> Signature.print_agent sigs + | None -> Format.pp_print_int) + ag ag_id (match sigs with - | Some sigs -> Signature.print_site sigs ag - | None -> Format.pp_print_int) s + | Some sigs -> Signature.print_site sigs ag + | None -> Format.pp_print_int) + s let json_dictionnary = - "\"binding_type\":{\"type\":0,\"site\":1},\ - \"quark\":{\"agent\":0,\"site\":1},\ - \"test\":[\"Is_here\",\"Has_Internal\",\"Is_Free\",\"Is_Bound\",\"Has_Binding_type\",\"Is_Bound_to\"],\ - \"actions\":[\"Create\",\"Mod_internal\",\"Bind\",\"Bind_to\",\"Free\",\"Remove\"],\ - \"binding_state\":[\"ANY\",\"FREE\",\"BOUND\",\"BOUND_TYPE\",\"BOUND_to\"],\ - \"event\":{\"tests\":0,\"actions\":1,\"side_effect_src\":2,\"side_effect_dst\":3,\"connectivity_tests\":4}" + "\"binding_type\":{\"type\":0,\"site\":1},\"quark\":{\"agent\":0,\"site\":1},\"test\":[\"Is_here\",\"Has_Internal\",\"Is_Free\",\"Is_Bound\",\"Has_Binding_type\",\"Is_Bound_to\"],\"actions\":[\"Create\",\"Mod_internal\",\"Bind\",\"Bind_to\",\"Free\",\"Remove\"],\"binding_state\":[\"ANY\",\"FREE\",\"BOUND\",\"BOUND_TYPE\",\"BOUND_to\"],\"event\":{\"tests\":0,\"actions\":1,\"side_effect_src\":2,\"side_effect_dst\":3,\"connectivity_tests\":4}" let write_binding_type ob a = JsonUtil.write_compact_pair Yojson.Basic.write_int Yojson.Basic.write_int ob a + let read_binding_type p lb = JsonUtil.read_compact_pair Yojson.Basic.read_int Yojson.Basic.read_int p lb -let binding_type_to_json (ty,s) = `List [`Int ty; `Int s] + +let binding_type_to_json (ty, s) = `List [ `Int ty; `Int s ] + let binding_type_of_json = function - | `List [`Int ty; `Int s] -> (ty,s) - | x -> raise (Yojson.Basic.Util.Type_error ("Not a binding_type",x)) + | `List [ `Int ty; `Int s ] -> ty, s + | x -> raise (Yojson.Basic.Util.Type_error ("Not a binding_type", x)) let write_quark f ob a = JsonUtil.write_compact_pair f Yojson.Basic.write_int ob a -let read_quark f p lb = - JsonUtil.read_compact_pair f Yojson.Basic.read_int p lb -let quark_to_json f (ag,s) = `List [f ag; `Int s] + +let read_quark f p lb = JsonUtil.read_compact_pair f Yojson.Basic.read_int p lb +let quark_to_json f (ag, s) = `List [ f ag; `Int s ] + let quark_of_json f = function - | `List [ag; `Int s] -> (f ag,s) - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect quark",x)) + | `List [ ag; `Int s ] -> f ag, s + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect quark", x)) let write_test f ob t = JsonUtil.write_sequence ob (match t with - | Is_Here a -> - [ (fun o -> Yojson.Basic.write_int o 0); (fun o -> f o a) ] - | Has_Internal (s,i) -> - [ (fun o -> Yojson.Basic.write_int o 1); - (fun o -> write_quark f o s); - (fun o -> Yojson.Basic.write_int o i) ] - | Is_Free s -> - [ (fun o -> Yojson.Basic.write_int o 2); (fun o -> write_quark f o s) ] - | Is_Bound s -> - [ (fun o -> Yojson.Basic.write_int o 3); (fun o -> write_quark f o s) ] - | Has_Binding_type (s,b) -> - [ (fun ob -> Yojson.Basic.write_int ob 4); - (fun ob -> write_quark f ob s); - (fun ob -> write_binding_type ob b) ] - | Is_Bound_to (s1,s2) -> - [ (fun ob -> Yojson.Basic.write_int ob 5); - (fun ob -> write_quark f ob s1); - (fun ob -> write_quark f ob s2) ]) + | Is_Here a -> [ (fun o -> Yojson.Basic.write_int o 0); (fun o -> f o a) ] + | Has_Internal (s, i) -> + [ + (fun o -> Yojson.Basic.write_int o 1); + (fun o -> write_quark f o s); + (fun o -> Yojson.Basic.write_int o i); + ] + | Is_Free s -> + [ (fun o -> Yojson.Basic.write_int o 2); (fun o -> write_quark f o s) ] + | Is_Bound s -> + [ (fun o -> Yojson.Basic.write_int o 3); (fun o -> write_quark f o s) ] + | Has_Binding_type (s, b) -> + [ + (fun ob -> Yojson.Basic.write_int ob 4); + (fun ob -> write_quark f ob s); + (fun ob -> write_binding_type ob b); + ] + | Is_Bound_to (s1, s2) -> + [ + (fun ob -> Yojson.Basic.write_int ob 5); + (fun ob -> write_quark f ob s1); + (fun ob -> write_quark f ob s2); + ]) let read_test f st b = JsonUtil.read_variant Yojson.Basic.read_int (fun st b -> function - | 0 -> - let y = JsonUtil.read_next_item f st b in - Is_Here y - | 1 -> - let s = JsonUtil.read_next_item (read_quark f) st b in - let i = JsonUtil.read_next_item Yojson.Basic.read_int st b in - Has_Internal (s,i) - | 2 -> - let s = JsonUtil.read_next_item (read_quark f) st b in - Is_Free s - | 3 -> - let s = JsonUtil.read_next_item (read_quark f) st b in - Is_Bound s - | 4 -> - let s = JsonUtil.read_next_item (read_quark f) st b in - let bi = JsonUtil.read_next_item read_binding_type st b in - Has_Binding_type (s, bi) - | 5 -> - let s1 = JsonUtil.read_next_item (read_quark f) st b in - let s2 = JsonUtil.read_next_item (read_quark f) st b in - Is_Bound_to (s1, s2) - | _ -> Yojson.json_error "Wrong test" (*st b*)) + | 0 -> + let y = JsonUtil.read_next_item f st b in + Is_Here y + | 1 -> + let s = JsonUtil.read_next_item (read_quark f) st b in + let i = JsonUtil.read_next_item Yojson.Basic.read_int st b in + Has_Internal (s, i) + | 2 -> + let s = JsonUtil.read_next_item (read_quark f) st b in + Is_Free s + | 3 -> + let s = JsonUtil.read_next_item (read_quark f) st b in + Is_Bound s + | 4 -> + let s = JsonUtil.read_next_item (read_quark f) st b in + let bi = JsonUtil.read_next_item read_binding_type st b in + Has_Binding_type (s, bi) + | 5 -> + let s1 = JsonUtil.read_next_item (read_quark f) st b in + let s2 = JsonUtil.read_next_item (read_quark f) st b in + Is_Bound_to (s1, s2) + | _ -> Yojson.json_error "Wrong test" (*st b*)) st b let test_to_json f = function - | Is_Here a -> `List [`Int 0; f a] - | Has_Internal (s,i) -> - `List [`Int 1; quark_to_json f s; `Int i] - | Is_Free s -> `List [`Int 2; quark_to_json f s] - | Is_Bound s -> `List [`Int 3; quark_to_json f s] - | Has_Binding_type (s,b) -> - `List [`Int 4;quark_to_json f s;binding_type_to_json b] - | Is_Bound_to (s1,s2) -> - `List [`Int 5; quark_to_json f s1; quark_to_json f s2] + | Is_Here a -> `List [ `Int 0; f a ] + | Has_Internal (s, i) -> `List [ `Int 1; quark_to_json f s; `Int i ] + | Is_Free s -> `List [ `Int 2; quark_to_json f s ] + | Is_Bound s -> `List [ `Int 3; quark_to_json f s ] + | Has_Binding_type (s, b) -> + `List [ `Int 4; quark_to_json f s; binding_type_to_json b ] + | Is_Bound_to (s1, s2) -> + `List [ `Int 5; quark_to_json f s1; quark_to_json f s2 ] + let test_of_json f = function - | `List [`Int 0; a] -> Is_Here (f a) - | `List [`Int 1; s; `Int i] -> - Has_Internal (quark_of_json f s,i) - | `List [`Int 2; s] -> Is_Free (quark_of_json f s) - | `List [`Int 3; s] -> Is_Bound (quark_of_json f s) - | `List [`Int 4; s; b] -> + | `List [ `Int 0; a ] -> Is_Here (f a) + | `List [ `Int 1; s; `Int i ] -> Has_Internal (quark_of_json f s, i) + | `List [ `Int 2; s ] -> Is_Free (quark_of_json f s) + | `List [ `Int 3; s ] -> Is_Bound (quark_of_json f s) + | `List [ `Int 4; s; b ] -> Has_Binding_type (quark_of_json f s, binding_type_of_json b) - | `List [`Int 5; s1; s2] -> + | `List [ `Int 5; s1; s2 ] -> Is_Bound_to (quark_of_json f s1, quark_of_json f s2) - | x -> raise (Yojson.Basic.Util.Type_error ("Wrong test",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Wrong test", x)) let write_action f ob a = JsonUtil.write_sequence ob (match a with - | Create (ag,info) -> - [ (fun o -> Yojson.Basic.write_int o 0); - (fun o -> f o ag); - (fun o -> JsonUtil.write_list - (JsonUtil.write_compact_pair - Yojson.Basic.write_int - (JsonUtil.write_option Yojson.Basic.write_int)) o info) ] - | Mod_internal (s,i) -> - [ (fun o -> Yojson.Basic.write_int o 1); - (fun o -> write_quark f o s); - (fun o -> Yojson.Basic.write_int o i) ] - | Bind (s1,s2) -> - [ (fun o -> Yojson.Basic.write_int o 2); - (fun o -> write_quark f o s1); - (fun o -> write_quark f o s2) ] - | Bind_to (s1,s2) -> - [ (fun o -> Yojson.Basic.write_int o 3); - (fun o -> write_quark f o s1); - (fun o -> write_quark f o s2) ] - | Free s -> - [ (fun o -> Yojson.Basic.write_int o 4); (fun o -> write_quark f o s) ] - | Remove a -> - [ (fun o -> Yojson.Basic.write_int o 5); (fun o -> f o a) ]) + | Create (ag, info) -> + [ + (fun o -> Yojson.Basic.write_int o 0); + (fun o -> f o ag); + (fun o -> + JsonUtil.write_list + (JsonUtil.write_compact_pair Yojson.Basic.write_int + (JsonUtil.write_option Yojson.Basic.write_int)) + o info); + ] + | Mod_internal (s, i) -> + [ + (fun o -> Yojson.Basic.write_int o 1); + (fun o -> write_quark f o s); + (fun o -> Yojson.Basic.write_int o i); + ] + | Bind (s1, s2) -> + [ + (fun o -> Yojson.Basic.write_int o 2); + (fun o -> write_quark f o s1); + (fun o -> write_quark f o s2); + ] + | Bind_to (s1, s2) -> + [ + (fun o -> Yojson.Basic.write_int o 3); + (fun o -> write_quark f o s1); + (fun o -> write_quark f o s2); + ] + | Free s -> + [ (fun o -> Yojson.Basic.write_int o 4); (fun o -> write_quark f o s) ] + | Remove a -> [ (fun o -> Yojson.Basic.write_int o 5); (fun o -> f o a) ]) let read_action f st b = JsonUtil.read_variant Yojson.Basic.read_int (fun st b -> function - | 0 -> - let ag = JsonUtil.read_next_item f st b in - let info = - JsonUtil.read_next_item - (Yojson.Basic.read_list - (JsonUtil.read_compact_pair - Yojson.Basic.read_int - (JsonUtil.read_option Yojson.Basic.read_int))) st b in - Create (ag,info) - | 1 -> - let s = JsonUtil.read_next_item (read_quark f) st b in - let i = JsonUtil.read_next_item Yojson.Basic.read_int st b in - Mod_internal (s,i) - | 2 -> - let s1 = JsonUtil.read_next_item (read_quark f) st b in - let s2 = JsonUtil.read_next_item (read_quark f) st b in - Bind (s1,s2) - | 3 -> - let s1 = JsonUtil.read_next_item (read_quark f) st b in - let s2 = JsonUtil.read_next_item (read_quark f) st b in - Bind_to (s1,s2) - | 4 -> - let s = JsonUtil.read_next_item (read_quark f) st b in Free s - | 5 -> - let a = JsonUtil.read_next_item f st b in Remove a - | _ -> Yojson.json_error "Wrong action" (*st b*)) + | 0 -> + let ag = JsonUtil.read_next_item f st b in + let info = + JsonUtil.read_next_item + (Yojson.Basic.read_list + (JsonUtil.read_compact_pair Yojson.Basic.read_int + (JsonUtil.read_option Yojson.Basic.read_int))) + st b + in + Create (ag, info) + | 1 -> + let s = JsonUtil.read_next_item (read_quark f) st b in + let i = JsonUtil.read_next_item Yojson.Basic.read_int st b in + Mod_internal (s, i) + | 2 -> + let s1 = JsonUtil.read_next_item (read_quark f) st b in + let s2 = JsonUtil.read_next_item (read_quark f) st b in + Bind (s1, s2) + | 3 -> + let s1 = JsonUtil.read_next_item (read_quark f) st b in + let s2 = JsonUtil.read_next_item (read_quark f) st b in + Bind_to (s1, s2) + | 4 -> + let s = JsonUtil.read_next_item (read_quark f) st b in + Free s + | 5 -> + let a = JsonUtil.read_next_item f st b in + Remove a + | _ -> Yojson.json_error "Wrong action" (*st b*)) st b let action_to_json f = function - | Create (ag,info) -> - `List [`Int 0; f ag; - `List (List.map (fun (s,i) -> - `List (`Int s :: - (match i with None -> [] | Some i -> [`Int i]))) info)] - | Mod_internal (s,i) -> - `List [`Int 1; quark_to_json f s; `Int i] - | Bind (s1,s2) -> - `List [`Int 2; quark_to_json f s1; quark_to_json f s2] - | Bind_to (s1,s2) -> - `List [`Int 3; quark_to_json f s1; quark_to_json f s2] - | Free s -> `List [`Int 4; quark_to_json f s] - | Remove a -> `List [`Int 5; f a] + | Create (ag, info) -> + `List + [ + `Int 0; + f ag; + `List + (List.map + (fun (s, i) -> + `List + (`Int s + :: + (match i with + | None -> [] + | Some i -> [ `Int i ]))) + info); + ] + | Mod_internal (s, i) -> `List [ `Int 1; quark_to_json f s; `Int i ] + | Bind (s1, s2) -> `List [ `Int 2; quark_to_json f s1; quark_to_json f s2 ] + | Bind_to (s1, s2) -> `List [ `Int 3; quark_to_json f s1; quark_to_json f s2 ] + | Free s -> `List [ `Int 4; quark_to_json f s ] + | Remove a -> `List [ `Int 5; f a ] + let action_of_json f = function - | `List [`Int 0; ag; `List info] -> - Create (f ag, - List.map (function - | `List [ `Int s ] -> (s,None) - | `List [ `Int s; `Int i ] -> (s, Some i) - | x -> raise (Yojson.Basic.Util.Type_error - ("Invalid action info",x)) - ) info) - | `List [`Int 1; s; `Int i] -> - Mod_internal (quark_of_json f s, i) - | `List [`Int 2; s1; s2] -> - Bind (quark_of_json f s1, quark_of_json f s2) - | `List [`Int 3; s1; s2] -> - Bind_to (quark_of_json f s1, quark_of_json f s2) - | `List [`Int 4; s] -> Free (quark_of_json f s) - | `List [`Int 5; a] -> Remove (f a) - | x -> raise (Yojson.Basic.Util.Type_error ("Wrong action",x)) + | `List [ `Int 0; ag; `List info ] -> + Create + ( f ag, + List.map + (function + | `List [ `Int s ] -> s, None + | `List [ `Int s; `Int i ] -> s, Some i + | x -> + raise (Yojson.Basic.Util.Type_error ("Invalid action info", x))) + info ) + | `List [ `Int 1; s; `Int i ] -> Mod_internal (quark_of_json f s, i) + | `List [ `Int 2; s1; s2 ] -> Bind (quark_of_json f s1, quark_of_json f s2) + | `List [ `Int 3; s1; s2 ] -> Bind_to (quark_of_json f s1, quark_of_json f s2) + | `List [ `Int 4; s ] -> Free (quark_of_json f s) + | `List [ `Int 5; a ] -> Remove (f a) + | x -> raise (Yojson.Basic.Util.Type_error ("Wrong action", x)) let write_binding_state f ob bf = JsonUtil.write_sequence ob (match bf with - | ANY -> [ (fun o -> Yojson.Basic.write_int o 0) ] - | FREE -> [ (fun o -> Yojson.Basic.write_int o 1) ] - | BOUND -> [ (fun o -> Yojson.Basic.write_int o 2) ] - | BOUND_TYPE b -> - [ (fun o -> Yojson.Basic.write_int o 3); - (fun o -> write_binding_type o b) ] - | BOUND_to s -> - [ (fun o -> Yojson.Basic.write_int o 4); - (fun o -> write_quark f o s) ]) + | ANY -> [ (fun o -> Yojson.Basic.write_int o 0) ] + | FREE -> [ (fun o -> Yojson.Basic.write_int o 1) ] + | BOUND -> [ (fun o -> Yojson.Basic.write_int o 2) ] + | BOUND_TYPE b -> + [ + (fun o -> Yojson.Basic.write_int o 3); (fun o -> write_binding_type o b); + ] + | BOUND_to s -> + [ (fun o -> Yojson.Basic.write_int o 4); (fun o -> write_quark f o s) ]) let read_binding_state f st b = JsonUtil.read_variant Yojson.Basic.read_int (fun st b -> function - | 0 -> ANY - | 1 -> FREE - | 2 -> BOUND - | 3 -> - let b = JsonUtil.read_next_item read_binding_type st b in - BOUND_TYPE b - | 4 -> - let s = JsonUtil.read_next_item (read_quark f) st b in - BOUND_to s - | _ -> Yojson.json_error "Wrong binding state" (*st b*)) + | 0 -> ANY + | 1 -> FREE + | 2 -> BOUND + | 3 -> + let b = JsonUtil.read_next_item read_binding_type st b in + BOUND_TYPE b + | 4 -> + let s = JsonUtil.read_next_item (read_quark f) st b in + BOUND_to s + | _ -> Yojson.json_error "Wrong binding state" (*st b*)) st b let binding_state_to_json f = function @@ -641,72 +844,87 @@ let binding_state_to_json f = function | FREE -> `List [ `Int 1 ] | BOUND -> `List [ `Int 2 ] | BOUND_TYPE b -> `List [ `Int 3; binding_type_to_json b ] - | BOUND_to s -> `List [`Int 4; quark_to_json f s ] + | BOUND_to s -> `List [ `Int 4; quark_to_json f s ] + let binding_state_of_json f = function - | `List [`Int 0] -> ANY - | `List [`Int 1] -> FREE - | `List [`Int 2] -> BOUND - | `List [`Int 3; `List [`Int ty; `Int s]] -> BOUND_TYPE (ty,s) - | `List [`Int 4; `List [ag; `Int s]] -> BOUND_to (f ag,s) - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect binding_state",x)) + | `List [ `Int 0 ] -> ANY + | `List [ `Int 1 ] -> FREE + | `List [ `Int 2 ] -> BOUND + | `List [ `Int 3; `List [ `Int ty; `Int s ] ] -> BOUND_TYPE (ty, s) + | `List [ `Int 4; `List [ ag; `Int s ] ] -> BOUND_to (f ag, s) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect binding_state", x)) let write_event f ob e = JsonUtil.write_sequence ob - [ (fun o -> - JsonUtil.write_list (JsonUtil.write_list (write_test f)) o e.tests); + [ + (fun o -> + JsonUtil.write_list (JsonUtil.write_list (write_test f)) o e.tests); (fun o -> JsonUtil.write_list (write_action f) o e.actions); (fun o -> - JsonUtil.write_list - (JsonUtil.write_compact_pair (write_quark f) (write_binding_state f)) - o e.side_effects_src); + JsonUtil.write_list + (JsonUtil.write_compact_pair (write_quark f) (write_binding_state f)) + o e.side_effects_src); (fun o -> JsonUtil.write_list (write_quark f) o e.side_effects_dst); - (fun o -> JsonUtil.write_list (write_test f) o e.connectivity_tests) ] + (fun o -> JsonUtil.write_list (write_test f) o e.connectivity_tests); + ] let read_event f st b = JsonUtil.read_variant (Yojson.Basic.read_list (Yojson.Basic.read_list (read_test f))) (fun st b tests -> - let actions = - JsonUtil.read_next_item - (Yojson.Basic.read_list (read_action f)) st b in - let side_effects_src = - JsonUtil.read_next_item - (Yojson.Basic.read_list - (JsonUtil.read_compact_pair (read_quark f) (read_binding_state f))) - st b in - let side_effects_dst = - JsonUtil.read_next_item (Yojson.Basic.read_list (read_quark f)) st b in - let connectivity_tests = - JsonUtil.read_next_item (Yojson.Basic.read_list (read_test f)) st b in - {tests; actions; side_effects_src; side_effects_dst; connectivity_tests}) + let actions = + JsonUtil.read_next_item (Yojson.Basic.read_list (read_action f)) st b + in + let side_effects_src = + JsonUtil.read_next_item + (Yojson.Basic.read_list + (JsonUtil.read_compact_pair (read_quark f) (read_binding_state f))) + st b + in + let side_effects_dst = + JsonUtil.read_next_item (Yojson.Basic.read_list (read_quark f)) st b + in + let connectivity_tests = + JsonUtil.read_next_item (Yojson.Basic.read_list (read_test f)) st b + in + { tests; actions; side_effects_src; side_effects_dst; connectivity_tests }) st b let event_to_json f e = - `List [ - `List - (List.map (fun cct -> `List (List.map (test_to_json f) cct)) e.tests); - `List (List.map (action_to_json f) e.actions); - `List (List.map - (fun (s,b) -> `List [quark_to_json f s; binding_state_to_json f b]) - e.side_effects_src); - `List (List.map (quark_to_json f) e.side_effects_dst); - `List (List.map (test_to_json f) e.connectivity_tests); - ] + `List + [ + `List + (List.map (fun cct -> `List (List.map (test_to_json f) cct)) e.tests); + `List (List.map (action_to_json f) e.actions); + `List + (List.map + (fun (s, b) -> + `List [ quark_to_json f s; binding_state_to_json f b ]) + e.side_effects_src); + `List (List.map (quark_to_json f) e.side_effects_dst); + `List (List.map (test_to_json f) e.connectivity_tests); + ] + let event_of_json f = function | `List [ `List t; `List a; `List s_e_src; `List s_e_dst; `List c_t ] as x -> - begin try { - tests = - List.map (function `List ccl -> List.map (test_of_json f) ccl - | _ -> raise Not_found) t; - actions = List.map (action_of_json f) a; - side_effects_src = - List.map (function - | `List [s;b] -> (quark_of_json f s, binding_state_of_json f b) - | _ -> raise Not_found) s_e_src; - side_effects_dst = List.map (quark_of_json f) s_e_dst; - connectivity_tests = List.map (test_of_json f) c_t; - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Incorrect event",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect event",x)) + (try + { + tests = + List.map + (function + | `List ccl -> List.map (test_of_json f) ccl + | _ -> raise Not_found) + t; + actions = List.map (action_of_json f) a; + side_effects_src = + List.map + (function + | `List [ s; b ] -> quark_of_json f s, binding_state_of_json f b + | _ -> raise Not_found) + s_e_src; + side_effects_dst = List.map (quark_of_json f) s_e_dst; + connectivity_tests = List.map (test_of_json f) c_t; + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Incorrect event", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect event", x)) diff --git a/core/term/instantiation.mli b/core/term/instantiation.mli index 6c3d65eae3..70dbdc72b1 100644 --- a/core/term/instantiation.mli +++ b/core/term/instantiation.mli @@ -12,13 +12,14 @@ type agent_name = int type site_name = int -type internal_state = int - +type internal_state = int type binding_type = agent_name * site_name -type abstract = Matching.Agent.t (** in a rule *) +type abstract = Matching.Agent.t +(** in a rule *) -type concrete = Agent.t (** in a simulation state *) +type concrete = Agent.t +(** in a simulation state *) type 'a site = 'a * site_name @@ -38,6 +39,16 @@ type 'a action = | Free of 'a site | Remove of 'a +val sort_concrete_action_list : concrete action list -> concrete action list + +val sort_concrete_action_list_reverse : + concrete action list -> concrete action list + +val sort_abstract_action_list : concrete action list -> concrete action list + +val sort_abstract_action_list_reverse : + concrete action list -> concrete action list + type 'a binding_state = | ANY | FREE @@ -46,98 +57,138 @@ type 'a binding_state = | BOUND_to of 'a site type 'a event = { - tests : 'a test list list; - (** The tests written in the rule (pattern by pattern) *) - actions : 'a action list; (** The modifications written in the rule *) - side_effects_src : ('a site * 'a binding_state) list -(** the site of the agents mentioned in the rule where there is a side - effects *); - side_effects_dst : 'a site list -(** the site of agents not mentionned in the rule that have been freed - by side effect *); - connectivity_tests : 'a test list; - (** witness that patterns where connected (unary instances only of course) *) + tests: 'a test list list; + (** The tests written in the rule (pattern by pattern) *) + actions: 'a action list; (** The modifications written in the rule *) + side_effects_src: ('a site * 'a binding_state) list; + (** the site of the agents mentioned in the rule where there is a side + effects *) + side_effects_dst: 'a site list; + (** the site of agents not mentionned in the rule that have been freed + by side effect *) + connectivity_tests: 'a test list; + (** witness that patterns where connected (unary instances only of course) *) } val empty_event : 'a event val rename_abstract_test : - debugMode:bool -> int -> Renaming.t -> abstract test -> abstract test + debug_mode:bool -> int -> Renaming.t -> abstract test -> abstract test + val rename_abstract_action : - debugMode:bool -> int -> Renaming.t -> abstract action -> abstract action + debug_mode:bool -> int -> Renaming.t -> abstract action -> abstract action + val rename_abstract_event : - debugMode:bool -> int -> Renaming.t -> abstract event -> abstract event -val rename_abstract_side_effect: - debugMode:bool -> int -> Renaming.t -> + debug_mode:bool -> int -> Renaming.t -> abstract event -> abstract event + +val rename_abstract_side_effect : + debug_mode:bool -> + int -> + Renaming.t -> (Matching.Agent.t * 'a) * Matching.Agent.t binding_state -> (Matching.Agent.t * 'a) * Matching.Agent.t binding_state + val concretize_test : - debugMode:bool -> (Matching.t * int Mods.IntMap.t) -> - abstract test -> concrete test + debug_mode:bool -> + Matching.t * int Mods.IntMap.t -> + abstract test -> + concrete test + val concretize_action : - debugMode:bool -> (Matching.t * int Mods.IntMap.t) -> - abstract action -> concrete action + debug_mode:bool -> + Matching.t * int Mods.IntMap.t -> + abstract action -> + concrete action val try_concretize_action : - debugMode:bool -> (Matching.t * int Mods.IntMap.t) -> - abstract action -> (concrete action) option + debug_mode:bool -> + Matching.t * int Mods.IntMap.t -> + abstract action -> + concrete action option (** Same than [concretize_action], except that it returns [None] if the provided injection's domain does not contain a fresh agent that is involved in the action that is being concretized. *) val concretize_event : - debugMode:bool -> (Matching.t * int Mods.IntMap.t) -> - abstract event -> concrete event + debug_mode:bool -> + Matching.t * int Mods.IntMap.t -> + abstract event -> + concrete event + val matching_abstract_concrete : - debugMode:bool -> abstract event -> concrete event -> Renaming.t option + debug_mode:bool -> abstract event -> concrete event -> Renaming.t option val subst_map_agent_in_concrete_test : (int -> int) -> concrete test -> concrete test -val subst_agent_in_concrete_test : - int -> int -> concrete test -> concrete test + +val subst_agent_in_concrete_test : int -> int -> concrete test -> concrete test + val subst_map_agent_in_concrete_action : (int -> int) -> concrete action -> concrete action + val subst_agent_in_concrete_action : int -> int -> concrete action -> concrete action -val subst_map_agent_in_concrete_side_effect: - (int -> int) -> (concrete site * concrete binding_state) -> - (concrete site * concrete binding_state) -val subst_agent_in_concrete_side_effect: - int -> int -> (concrete site * concrete binding_state) -> - (concrete site * concrete binding_state) -val subst_map_agent_in_concrete_event: + +val subst_map_agent_in_concrete_side_effect : + (int -> int) -> + concrete site * concrete binding_state -> + concrete site * concrete binding_state + +val subst_agent_in_concrete_side_effect : + int -> + int -> + concrete site * concrete binding_state -> + concrete site * concrete binding_state + +val subst_map_agent_in_concrete_event : (int -> int) -> concrete event -> concrete event -val subst_map2_agent_in_concrete_event: + +(* In subst_map2_agent_in_concrete_event, the first renaming concerns the ids of the agent before the event, the second renaming the ones after the event. + In the case when a removed agent and a created one have the same id, then + the first renaming will be applied to anything related to the removed agent, + the second one will be applied to anything related to the second one *) +val subst_map2_agent_in_concrete_event : (int -> int) -> (int -> int) -> concrete event -> concrete event -val subst_agent_in_concrete_event: + +val subst_agent_in_concrete_event : int -> int -> concrete event -> concrete event val print_concrete_test : ?sigs:Signature.s -> Format.formatter -> concrete test -> unit + val print_concrete_action : ?sigs:Signature.s -> Format.formatter -> concrete action -> unit + val print_concrete_binding_state : ?sigs:Signature.s -> Format.formatter -> concrete binding_state -> unit val json_dictionnary : string - val test_to_json : ('a -> Yojson.Basic.t) -> 'a test -> Yojson.Basic.t val test_of_json : (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a test val write_test : (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a test -> unit + val read_test : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> - Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a test + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'a test val action_to_json : ('a -> Yojson.Basic.t) -> 'a action -> Yojson.Basic.t val action_of_json : (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a action -val write_action : - (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a action -> unit +val write_action : (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a action -> unit + val read_action : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> - Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a action + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'a action + val event_to_json : ('a -> Yojson.Basic.t) -> 'a event -> Yojson.Basic.t val event_of_json : (Yojson.Basic.t -> 'a) -> Yojson.Basic.t -> 'a event val write_event : (Buffer.t -> 'a -> unit) -> Buffer.t -> 'a event -> unit + val read_event : (Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a) -> - Yojson.Basic.lexer_state -> Lexing.lexbuf -> 'a event + Yojson.Basic.lexer_state -> + Lexing.lexbuf -> + 'a event diff --git a/core/term/kappa_printer.ml b/core/term/kappa_printer.ml index 38e671895c..c45ff92360 100644 --- a/core/term/kappa_printer.ml +++ b/core/term/kappa_printer.ml @@ -7,85 +7,95 @@ (******************************************************************************) let cc_mix ~noCounters ?env f mix = - let domain = match env with + let domain = + match env with | None -> None - | Some e -> Some (Model.domain e) in + | Some e -> Some (Model.domain e) + in match mix with | [] -> Format.fprintf f "0" | _ -> Pp.list (fun f -> Format.fprintf f " +@ ") (fun f ccs -> - Pp.array - (fun f -> Format.fprintf f "*") - (fun _ f cc -> - Format.fprintf - f "|%a|" - (Pattern.print ~noCounters ?domain ~with_id:false) cc) f ccs) + Pp.array + (fun f -> Format.fprintf f "*") + (fun _ f cc -> + Format.fprintf f "|%a|" + (Pattern.print ~noCounters ?domain ~with_id:false) + cc) + f ccs) f mix let alg_expr ~noCounters ?env = - Alg_expr.print - (cc_mix ~noCounters ?env) (Model.print_token ?env) (Model.print_alg ?env) + Alg_expr.print (cc_mix ~noCounters ?env) (Model.print_token ?env) + (Model.print_alg ?env) let bool_expr ~noCounters ?env = - Alg_expr.print_bool - (cc_mix ~noCounters ?env) + Alg_expr.print_bool (cc_mix ~noCounters ?env) (fun f i -> Format.fprintf f "|%a|" (Model.print_token ?env) i) (Model.print_alg ?env) let print_expr ~noCounters ?env f = let aux f = function - | Primitives.Str_pexpr (str,_) -> Format.fprintf f "\"%s\"" str - | Primitives.Alg_pexpr (alg,_) -> alg_expr ~noCounters ?env f alg - in function - | [] -> () - | [ Primitives.Str_pexpr (str,_) ] -> Format.fprintf f "\"%s\"" str - | ([ Primitives.Alg_pexpr _ ] | _::_::_) as e -> - Format.fprintf f "(%a)" (Pp.list (fun f -> Format.fprintf f ".") aux) e + | Primitives.Str_pexpr (str, _) -> Format.fprintf f "\"%s\"" str + | Primitives.Alg_pexpr (alg, _) -> alg_expr ~noCounters ?env f alg + in + function + | [] -> () + | [ Primitives.Str_pexpr (str, _) ] -> Format.fprintf f "\"%s\"" str + | ([ Primitives.Alg_pexpr _ ] | _ :: _ :: _) as e -> + Format.fprintf f "(%a)" (Pp.list (fun f -> Format.fprintf f ".") aux) e let print_expr_val alg_val f e = let aux f = function - | Primitives.Str_pexpr (str,_) -> Format.pp_print_string f str - | Primitives.Alg_pexpr (alg,_) -> - Nbr.print f (alg_val alg) - in Pp.list (fun f -> Format.pp_print_cut f ()) aux f e + | Primitives.Str_pexpr (str, _) -> Format.pp_print_string f str + | Primitives.Alg_pexpr (alg, _) -> Nbr.print f (alg_val alg) + in + Pp.list (fun f -> Format.pp_print_cut f ()) aux f e let decompiled_rule ~noCounters ~full env f r = let sigs = Model.signatures env in - let (r_mix,r_created) = - Pattern_compiler.lkappa_of_elementary_rule sigs (Model.domain env) r in - let pr_alg f (a,_) = alg_expr ~noCounters ~env f a in - let pr_tok f (va,tok) = - Format.fprintf f "%a %a" pr_alg va (Model.print_token ~env) tok in + let r_mix, r_created = + Pattern_compiler.lkappa_of_elementary_rule sigs (Model.domain env) r + in + let pr_alg f (a, _) = alg_expr ~noCounters ~env f a in + let pr_tok f (va, tok) = + Format.fprintf f "%a %a" pr_alg va (Model.print_token ~env) tok + in Format.fprintf f "%a%a%t%a%t" - (LKappa.print_rule_mixture ~noCounters sigs ~ltypes:false r_created) r_mix - (Raw_mixture.print ~noCounters ~created:true ~initial_comma:(r_mix <> []) ~sigs) r_created - - (if r.Primitives.delta_tokens <> [] - then (fun f -> Format.fprintf f "|@ ") else Pp.empty) + (LKappa.print_rule_mixture ~noCounters sigs ~ltypes:false r_created) + r_mix + (Raw_mixture.print ~noCounters ~created:true ~initial_comma:(r_mix <> []) + ~sigs) + r_created + (if r.Primitives.delta_tokens <> [] then + fun f -> + Format.fprintf f "|@ " + else + Pp.empty) (Pp.list Pp.comma pr_tok) r.Primitives.delta_tokens - - (fun f -> if full then - Format.fprintf f "@ @@ %a%t" - pr_alg r.Primitives.rate - (fun f -> - match r.Primitives.unary_rate with - | None -> () - | Some (rate, dist) -> - Format.fprintf - f " {%a%a}" pr_alg rate - (Pp.option (fun f md -> - Format.fprintf f ":%a" (alg_expr ~noCounters ~env) md)) - dist)) + (fun f -> + if full then + Format.fprintf f "@ @@ %a%t" pr_alg r.Primitives.rate (fun f -> + match r.Primitives.unary_rate with + | None -> () + | Some (rate, dist) -> + Format.fprintf f " {%a%a}" pr_alg rate + (Pp.option (fun f md -> + Format.fprintf f ":%a" (alg_expr ~noCounters ~env) md)) + dist)) let elementary_rule ~noCounters ?env f r = - let domain,sigs = match env with - | None -> None,None - | Some e -> Some (Model.domain e), Some (Model.signatures e) in - let pr_alg f (a,_) = alg_expr ~noCounters ?env f a in - let pr_tok f (va,tok) = - Format.fprintf f "%a %a" pr_alg va (Model.print_token ?env) tok in + let domain, sigs = + match env with + | None -> None, None + | Some e -> Some (Model.domain e), Some (Model.signatures e) + in + let pr_alg f (a, _) = alg_expr ~noCounters ?env f a in + let pr_tok f (va, tok) = + Format.fprintf f "%a %a" pr_alg va (Model.print_token ?env) tok + in let pr_trans f t = Primitives.Transformation.print ?sigs f t in let boxed_cc i f cc = let () = Format.pp_open_box f 2 in @@ -94,89 +104,91 @@ let elementary_rule ~noCounters ?env f r = let () = Pattern.print ~noCounters ?domain ~with_id:true f cc in Format.pp_close_box f () in - Format.fprintf - f "(ast: %i)@ @[@[%a@]%t@[%a@]@]@ -- @[%a@]@ ++ @[%a@]@ @@%a%t" + Format.fprintf f "(ast: %i)@ @[@[%a@]%t@[%a@]@]@ -- @[%a@]@ ++ @[%a@]@ @@%a%t" r.Primitives.syntactic_rule - - (Pp.array Pp.comma boxed_cc) r.Primitives.connected_components - (if r.Primitives.delta_tokens <> [] - then (fun f -> Format.fprintf f "|@ ") else Pp.empty) - (Pp.list Pp.comma pr_tok) - r.Primitives.delta_tokens - - (Pp.list Pp.comma pr_trans) r.Primitives.removed - (Pp.list Pp.comma pr_trans) r.Primitives.inserted - - pr_alg r.Primitives.rate + (Pp.array Pp.comma boxed_cc) + r.Primitives.connected_components + (if r.Primitives.delta_tokens <> [] then + fun f -> + Format.fprintf f "|@ " + else + Pp.empty) + (Pp.list Pp.comma pr_tok) r.Primitives.delta_tokens + (Pp.list Pp.comma pr_trans) + r.Primitives.removed + (Pp.list Pp.comma pr_trans) + r.Primitives.inserted pr_alg r.Primitives.rate (fun f -> - match r.Primitives.unary_rate with - | None -> () - | Some (rate, dist) -> - Format.fprintf - f " {%a%a}" pr_alg rate - (Pp.option (fun f md -> - Format.fprintf f ":%a" (alg_expr ~noCounters ?env) md)) - dist) + match r.Primitives.unary_rate with + | None -> () + | Some (rate, dist) -> + Format.fprintf f " {%a%a}" pr_alg rate + (Pp.option (fun f md -> + Format.fprintf f ":%a" (alg_expr ~noCounters ?env) md)) + dist) let modification ~noCounters ?env f m = - let domain = match env with + let domain = + match env with | None -> None - | Some e -> Some (Model.domain e) in + | Some e -> Some (Model.domain e) + in match m with - | Primitives.PRINT (nme,va) -> + | Primitives.PRINT (nme, va) -> if nme <> [] then Format.fprintf f "$PRINTF %a > %a" - (print_expr ~noCounters ?env) va (print_expr ~noCounters ?env) nme + (print_expr ~noCounters ?env) + va + (print_expr ~noCounters ?env) + nme else Format.fprintf f "$PRINTF %a" (print_expr ~noCounters ?env) va | Primitives.PLOTENTRY -> Format.pp_print_string f "$PLOTENTRY" - | Primitives.ITER_RULE ((n,_),rule) -> - Format.fprintf f "$APPLY %a %a" (alg_expr ~noCounters ?env) n + | Primitives.ITER_RULE ((n, _), rule) -> + Format.fprintf f "$APPLY %a %a" + (alg_expr ~noCounters ?env) + n (match env with - | None -> elementary_rule ~noCounters ?env - | Some env -> decompiled_rule ~noCounters ~full:false env) + | None -> elementary_rule ~noCounters ?env + | Some env -> decompiled_rule ~noCounters ~full:false env) rule - | Primitives.UPDATE (id,(va,_)) -> - Format.fprintf f "$UPDATE %a %a" - (Model.print_alg ?env) id (alg_expr ~noCounters ?env) va - | Primitives.SNAPSHOT (raw,fn) -> - Format.fprintf - f "$SNAPSHOT %a%t" (print_expr ~noCounters ?env) fn - (fun f -> if raw then Format.pp_print_string f " [true]") + | Primitives.UPDATE (id, (va, _)) -> + Format.fprintf f "$UPDATE %a %a" (Model.print_alg ?env) id + (alg_expr ~noCounters ?env) + va + | Primitives.SNAPSHOT (raw, fn) -> + Format.fprintf f "$SNAPSHOT %a%t" (print_expr ~noCounters ?env) fn (fun f -> + if raw then Format.pp_print_string f " [true]") | Primitives.STOP fn -> Format.fprintf f "$STOP %a" (print_expr ~noCounters ?env) fn - | Primitives.DIN (kind,fn) -> - Format.fprintf - f "$DIN %a %t[true]" (print_expr ~noCounters ?env) fn - (fun f -> match kind with - | Primitives.ABSOLUTE -> Format.fprintf f "\"absolute\" " - | Primitives.RELATIVE -> () - | Primitives.PROBABILITY -> Format.fprintf f "\"probability\" ") + | Primitives.DIN (kind, fn) -> + Format.fprintf f "$DIN %a %t[true]" (print_expr ~noCounters ?env) fn + (fun f -> + match kind with + | Primitives.ABSOLUTE -> Format.fprintf f "\"absolute\" " + | Primitives.RELATIVE -> () + | Primitives.PROBABILITY -> Format.fprintf f "\"probability\" ") | Primitives.DINOFF fn -> Format.fprintf f "$DIN %a [false]" (print_expr ~noCounters ?env) fn - | Primitives.CFLOW (_name,cc,_) -> - Format.fprintf - f "$TRACK @[%a@] [true]" - (Pp.array - Pp.comma - (fun _ -> Pattern.print ~noCounters ?domain ~with_id:false)) cc - | Primitives.CFLOWOFF (_,cc) -> - Format.fprintf - f "$TRACK %a [false]" - (Pp.array - Pp.comma - (fun _ -> Pattern.print ~noCounters ?domain ~with_id:false)) cc - | Primitives.SPECIES (fn,cc,_) -> - Format.fprintf - f "$SPECIES_OF @[%a@] [true] > %a" - (Pp.array - Pp.comma - (fun _ -> Pattern.print ~noCounters ?domain ~with_id:false)) cc - (print_expr ~noCounters ?env) fn + | Primitives.CFLOW (_name, cc, _) -> + Format.fprintf f "$TRACK @[%a@] [true]" + (Pp.array Pp.comma (fun _ -> + Pattern.print ~noCounters ?domain ~with_id:false)) + cc + | Primitives.CFLOWOFF (_, cc) -> + Format.fprintf f "$TRACK %a [false]" + (Pp.array Pp.comma (fun _ -> + Pattern.print ~noCounters ?domain ~with_id:false)) + cc + | Primitives.SPECIES (fn, cc, _) -> + Format.fprintf f "$SPECIES_OF @[%a@] [true] > %a" + (Pp.array Pp.comma (fun _ -> + Pattern.print ~noCounters ?domain ~with_id:false)) + cc + (print_expr ~noCounters ?env) + fn | Primitives.SPECIES_OFF fn -> - Format.fprintf - f "$SPECIES_OF [false] > %a" - (print_expr ~noCounters ?env) fn + Format.fprintf f "$SPECIES_OF [false] > %a" (print_expr ~noCounters ?env) fn let perturbation ~noCounters ?env f pert = let aux_alarm f = @@ -184,28 +196,30 @@ let perturbation ~noCounters ?env f pert = | None -> () | Some n -> Format.fprintf f "alarm %a " Nbr.print n in - Format.fprintf f "%%mod: %t%a do %arepeat %a" - aux_alarm - (bool_expr ~noCounters ?env) (fst pert.Primitives.precondition) + Format.fprintf f "%%mod: %t%a do %arepeat %a" aux_alarm + (bool_expr ~noCounters ?env) + (fst pert.Primitives.precondition) (Pp.list ~trailing:Pp.colon Pp.colon (modification ~noCounters ?env)) pert.Primitives.effect - (bool_expr ~noCounters ?env) (fst pert.Primitives.repeat) + (bool_expr ~noCounters ?env) + (fst pert.Primitives.repeat) let env ~noCounters f env = - Model.print - ~noCounters (fun env -> alg_expr ~noCounters ~env) + Model.print ~noCounters + (fun env -> alg_expr ~noCounters ~env) (fun env -> elementary_rule ~noCounters ~env) - (fun env -> perturbation ~noCounters ~env) f env + (fun env -> perturbation ~noCounters ~env) + f env let env_kappa ~noCounters f env = - Model.print_kappa - ~noCounters + Model.print_kappa ~noCounters (fun env -> alg_expr ~noCounters ~env) - (fun env -> perturbation ~noCounters ~env) f env + (fun env -> perturbation ~noCounters ~env) + f env let decompiled_env ~noCounters f env = - Model.print_kappa - ~noCounters + Model.print_kappa ~noCounters (fun env -> alg_expr ~noCounters ~env) ~pr_rule:(decompiled_rule ~noCounters ~full:true) - (fun env -> perturbation ~noCounters ~env) f env + (fun env -> perturbation ~noCounters ~env) + f env diff --git a/core/term/kappa_printer.mli b/core/term/kappa_printer.mli index 8e3eac139e..592e389261 100644 --- a/core/term/kappa_printer.mli +++ b/core/term/kappa_printer.mli @@ -9,35 +9,51 @@ (** Printers (user readable) of Kappa compiled units *) val alg_expr : - noCounters:bool -> ?env:Model.t -> - Format.formatter -> Primitives.alg_expr -> unit + noCounters:bool -> + ?env:Model.t -> + Format.formatter -> + Primitives.alg_expr -> + unit val bool_expr : - noCounters:bool -> ?env:Model.t -> Format.formatter -> - (Pattern.id array list,int) Alg_expr.bool -> unit + noCounters:bool -> + ?env:Model.t -> + Format.formatter -> + (Pattern.id array list, int) Alg_expr.bool -> + unit val print_expr_val : ('a -> Nbr.t) -> Format.formatter -> 'a Primitives.print_expr list -> unit val elementary_rule : - noCounters:bool -> ?env:Model.t -> - Format.formatter -> Primitives.elementary_rule -> unit + noCounters:bool -> + ?env:Model.t -> + Format.formatter -> + Primitives.elementary_rule -> + unit val decompiled_rule : - noCounters:bool -> full:bool -> Model.t -> - Format.formatter -> Primitives.elementary_rule -> unit + noCounters:bool -> + full:bool -> + Model.t -> + Format.formatter -> + Primitives.elementary_rule -> + unit val modification : - noCounters:bool -> ?env:Model.t -> - Format.formatter -> Primitives.modification -> unit + noCounters:bool -> + ?env:Model.t -> + Format.formatter -> + Primitives.modification -> + unit val perturbation : - noCounters:bool -> ?env:Model.t -> - Format.formatter -> Primitives.perturbation -> unit + noCounters:bool -> + ?env:Model.t -> + Format.formatter -> + Primitives.perturbation -> + unit val env : noCounters:bool -> Format.formatter -> Model.t -> unit - val env_kappa : noCounters:bool -> Format.formatter -> Model.t -> unit - -val decompiled_env : - noCounters:bool -> Format.formatter -> Model.t -> unit +val decompiled_env : noCounters:bool -> Format.formatter -> Model.t -> unit diff --git a/core/term/lKappa.ml b/core/term/lKappa.ml index c6ce7438c9..ab2fab47a9 100644 --- a/core/term/lKappa.ml +++ b/core/term/lKappa.ml @@ -6,13 +6,13 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -type ('a,'annot) link = +type ('a, 'annot) link = | ANY_FREE | LNK_VALUE of int * 'annot | LNK_FREE | LNK_ANY | LNK_SOME - | LNK_TYPE of 'a * 'a (** port * agent_type *) + | LNK_TYPE of 'a * 'a (** port * agent_type *) type switching = Linked of int | Freed | Maintained | Erased @@ -23,31 +23,30 @@ type rule_internal = | I_VAL_CHANGED of int * int | I_VAL_ERASED of int -type rule_agent = - { - ra_type: int; - ra_erased: bool; - ra_ports: - ((int,int*int) link Locality.annot * switching) array; - ra_ints: rule_internal array; - ra_syntax: - (((int,int*int) link Locality.annot * switching) array * - rule_internal array) option; - } +type rule_agent = { + ra_type: int; + ra_erased: bool; + ra_ports: ((int, int * int) link Loc.annoted * switching) array; + ra_ints: rule_internal array; + ra_syntax: + (((int, int * int) link Loc.annoted * switching) array + * rule_internal array) + option; +} type rule_mixture = rule_agent list -type rule = - { - r_mix: rule_mixture; - r_created: Raw_mixture.t; - r_delta_tokens : - ((rule_mixture,int) Alg_expr.e Locality.annot * int) list; - r_rate : (rule_mixture,int) Alg_expr.e Locality.annot; - r_un_rate : ((rule_mixture,int) Alg_expr.e Locality.annot - * (rule_mixture,int) Alg_expr.e Locality.annot option) option; - r_editStyle: bool; - } +type rule = { + r_mix: rule_mixture; + r_created: Raw_mixture.t; + r_delta_tokens: ((rule_mixture, int) Alg_expr.e Loc.annoted * int) list; + r_rate: (rule_mixture, int) Alg_expr.e Loc.annoted; + r_un_rate: + ((rule_mixture, int) Alg_expr.e Loc.annoted + * (rule_mixture, int) Alg_expr.e Loc.annoted option) + option; + r_edit_style: bool; +} let print_link pr_port pr_type pr_annot f = function | ANY_FREE -> Format.pp_print_string f "#" @@ -55,64 +54,70 @@ let print_link pr_port pr_type pr_annot f = function | LNK_ANY -> Format.pp_print_string f "#" | LNK_FREE -> Format.pp_print_string f "." | LNK_SOME -> Format.pp_print_string f "_" - | LNK_VALUE (i,a) -> Format.fprintf f "%i%a" i pr_annot a + | LNK_VALUE (i, a) -> Format.fprintf f "%i%a" i pr_annot a let link_to_json port_to_json type_to_json annot_to_json = function | ANY_FREE -> `String "ANY_FREE" | LNK_FREE -> `String "FREE" - | LNK_TYPE (p, a) -> `List [port_to_json a p; type_to_json a] + | LNK_TYPE (p, a) -> `List [ port_to_json a p; type_to_json a ] | LNK_ANY -> `Null | LNK_SOME -> `String "SOME" - | LNK_VALUE (i,a) -> `List (`Int i :: annot_to_json a) + | LNK_VALUE (i, a) -> `List (`Int i :: annot_to_json a) -let link_of_json port_of_json type_of_json annot_of_json = function +let link_of_json port_of_json type_of_json annoted_of_json = function | `String "ANY_FREE" -> ANY_FREE | `String "FREE" -> LNK_FREE - | `List [p; a] -> let x = type_of_json a in LNK_TYPE (port_of_json x p, x) + | `List [ p; a ] -> + let x = type_of_json a in + LNK_TYPE (port_of_json x p, x) | `Null -> LNK_ANY | `String "SOME" -> LNK_SOME - | `List (`Int i :: ( [] | _::_::_ as a)) -> LNK_VALUE (i,annot_of_json a) - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect link",x)) + | `List (`Int i :: (([] | _ :: _ :: _) as a)) -> + LNK_VALUE (i, annoted_of_json a) + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect link", x)) -let print_link_annot ~ltypes sigs f (s,a) = +let print_link_annot ~ltypes sigs f (s, a) = if ltypes then Format.fprintf f "/*%a.%a*/" - (Signature.print_site sigs a) s - (Signature.print_agent sigs) a + (Signature.print_site sigs a) + s + (Signature.print_agent sigs) + a let print_rule_internal sigs ~show_erased ag_ty site f = function | I_ANY -> () | I_ANY_CHANGED j -> Format.fprintf f "{#/%a}" (Signature.print_internal_state sigs ag_ty site) j | I_ANY_ERASED -> - Format.fprintf f - "{#%t}" (fun f -> if show_erased then Format.pp_print_string f "--") - | I_VAL_CHANGED (i,j) -> + Format.fprintf f "{#%t}" (fun f -> + if show_erased then Format.pp_print_string f "--") + | I_VAL_CHANGED (i, j) -> if i <> j then - Format.fprintf - f "{%a/%a}" (Signature.print_internal_state sigs ag_ty site) i - (Signature.print_internal_state sigs ag_ty site) j + Format.fprintf f "{%a/%a}" + (Signature.print_internal_state sigs ag_ty site) + i + (Signature.print_internal_state sigs ag_ty site) + j else Format.fprintf f "{%a}" (Signature.print_internal_state sigs ag_ty site) i | I_VAL_ERASED i -> - Format.fprintf - f "{%a%t}" (Signature.print_internal_state sigs ag_ty site) i + Format.fprintf f "{%a%t}" (Signature.print_internal_state sigs ag_ty site) i (fun f -> if show_erased then Format.pp_print_string f "--") let rule_internal_to_json = function | I_ANY -> `Null - | I_ANY_CHANGED j -> `List [`String "ANY"; `Int j] + | I_ANY_CHANGED j -> `List [ `String "ANY"; `Int j ] | I_ANY_ERASED -> `String "ERASED" - | I_VAL_CHANGED (i,j) -> `List [`Int i; `Int j] - | I_VAL_ERASED i -> `List [ `Int i; `String "ERASED"] + | I_VAL_CHANGED (i, j) -> `List [ `Int i; `Int j ] + | I_VAL_ERASED i -> `List [ `Int i; `String "ERASED" ] let rule_internal_of_json = function | `Null -> I_ANY - | `List [`String "ANY"; `Int j] -> I_ANY_CHANGED j + | `List [ `String "ANY"; `Int j ] -> I_ANY_CHANGED j | `String "ERASED" -> I_ANY_ERASED - | `List [`Int i; `Int j] -> I_VAL_CHANGED (i,j) - | `List [ `Int i; `String "ERASED"] -> I_VAL_ERASED i - | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect rule_internal",x)) + | `List [ `Int i; `Int j ] -> I_VAL_CHANGED (i, j) + | `List [ `Int i; `String "ERASED" ] -> I_VAL_ERASED i + | x -> raise (Yojson.Basic.Util.Type_error ("Uncorrect rule_internal", x)) let print_switching ~show_erased f = function | Linked i -> Format.fprintf f "/%i" i @@ -129,74 +134,99 @@ let switching_to_json = function let switching_of_json = function | `String "Freed" -> Freed | `String "Maintained" -> Maintained - | `String "Erased"-> Erased + | `String "Erased" -> Erased | x -> Linked (JsonUtil.to_int ~error_msg:"Invalid Switching" x) -let print_rule_link sigs ~show_erased ~ltypes f ((e,_),s) = - Format.fprintf - f "[%a%a]" +let print_rule_link sigs ~show_erased ~ltypes f ((e, _), s) = + Format.fprintf f "[%a%a]" (print_link (Signature.print_site sigs) - (Signature.print_agent sigs) (print_link_annot ~ltypes sigs)) + (Signature.print_agent sigs) + (print_link_annot ~ltypes sigs)) e - (print_switching ~show_erased) s + (print_switching ~show_erased) + s let print_counter_test f = function - | (c,true) -> Format.fprintf f "=%i" c - | (c,false) -> Format.fprintf f ">=%i" c + | c, true -> Format.fprintf f "=%i" c + | c, false -> Format.fprintf f ">=%i" c -let print_counter_delta counters j f switch = match switch with +let print_counter_delta counters j f switch = + match switch with | Linked i -> - begin - let root = Raw_mixture.find counters i in - let (s,(_,is_counter)) = - Mods.DynArray.get counters.Raw_mixture.rank root in - let delta = if (is_counter) then s-1 else (j-i) in - Format.fprintf f "/+=%d" delta - end + let root = Raw_mixture.find counters i in + let s, (_, is_counter) = Mods.DynArray.get counters.Raw_mixture.rank root in + let delta = + if is_counter then + s - 1 + else + j - i + in + Format.fprintf f "/+=%d" delta | Freed -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot("Cannot erase all increment agents"))) + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy "Cannot erase all increment agents")) | Maintained -> () | Erased -> () -let print_rule_intf - ~noCounters sigs ~show_erased ~ltypes ag_ty - f (ports,ints,counters,created_counters) = +let print_rule_intf ~noCounters sigs ~show_erased ~ltypes ag_ty f + (ports, ints, counters, created_counters) = let rec aux empty i = if i < Array.length ports then - if (match ports.(i) with - | (LNK_ANY, _), Maintained -> ints.(i) <> I_ANY - | ((LNK_ANY, _), (Erased | Freed | Linked _) | - ((LNK_SOME | ANY_FREE | LNK_FREE | - LNK_TYPE _ | LNK_VALUE _),_), _) -> true) then - - let ((e,_),switch) = ports.(i) in - let is_counter = match e with + if + match ports.(i) with + | (LNK_ANY, _), Maintained -> ints.(i) <> I_ANY + | (LNK_ANY, _), (Erased | Freed | Linked _) + | ((LNK_SOME | ANY_FREE | LNK_FREE | LNK_TYPE _ | LNK_VALUE _), _), _ -> + true + then ( + let (e, _), switch = ports.(i) in + let is_counter = + match e with | ANY_FREE | LNK_FREE | LNK_ANY | LNK_TYPE _ | LNK_SOME -> false - | LNK_VALUE (j,_) -> - try + | LNK_VALUE (j, _) -> + (try let root = Raw_mixture.find counters j in - let (c,(eq,is_counter')) = - Mods.DynArray.get counters.Raw_mixture.rank root in - if is_counter' && not noCounters then - let () = Format.fprintf f "%t%a{%a%a}" - (if empty then Pp.empty else Pp.space) - (Signature.print_site sigs ag_ty) i - print_counter_test (c-1,eq) - (print_counter_delta created_counters j) switch - in true else false - with Invalid_argument _ -> false in - let () = if not(is_counter) then - Format.fprintf - f "%t%a%a%a" (if empty then Pp.empty else Pp.space) - (Signature.print_site sigs ag_ty) i - (print_rule_internal sigs ~show_erased ag_ty i) - ints.(i) - (print_rule_link sigs ~show_erased ~ltypes) - ports.(i) else () in + let c, (eq, is_counter') = + Mods.DynArray.get counters.Raw_mixture.rank root + in + if is_counter' && not noCounters then ( + Format.fprintf f "%t%a{%a%a}" + (if empty then + Pp.empty + else + Pp.space) + (Signature.print_site sigs ag_ty) + i print_counter_test + (c - 1, eq) + (print_counter_delta created_counters j) + switch; + true + ) else + false + with Invalid_argument _ -> false) + in + let () = + if not is_counter then + Format.fprintf f "%t%a%a%a" + (if empty then + Pp.empty + else + Pp.space) + (Signature.print_site sigs ag_ty) + i + (print_rule_internal sigs ~show_erased ag_ty i) + ints.(i) + (print_rule_link sigs ~show_erased ~ltypes) + ports.(i) + else + () + in aux false (succ i) - else aux empty (succ i) in + ) else + aux empty (succ i) + in aux true 0 let union_find_counters sigs mix = @@ -207,281 +237,352 @@ let union_find_counters sigs mix = | Some sigs -> List.iter (fun ag -> - match Signature.ports_if_counter_agent sigs ag.ra_type with - | None -> () - | Some (before,after) -> - let ((a,_),_) = ag.ra_ports.(after) in - let ((b,_),_) = ag.ra_ports.(before) in - match b with - | ANY_FREE | LNK_FREE | LNK_ANY | LNK_TYPE _ | LNK_SOME -> () - | LNK_VALUE (lnk_b,_) -> - match a with - | LNK_VALUE (lnk_a,_) -> Raw_mixture.union t lnk_b lnk_a - | ANY_FREE | LNK_FREE -> - let root = Raw_mixture.find t lnk_b in - let (s,_) = Mods.DynArray.get t.Raw_mixture.rank root in - Mods.DynArray.set t.Raw_mixture.rank root (s,(true,true)) - | LNK_ANY -> - let root = Raw_mixture.find t lnk_b in - let (s,_) = Mods.DynArray.get t.Raw_mixture.rank root in - Mods.DynArray.set t.Raw_mixture.rank root (s,(false,true)) - | LNK_TYPE _ | LNK_SOME -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - ("Port a of __incr agent not well specified")))) - mix in + match Signature.ports_if_counter_agent sigs ag.ra_type with + | None -> () + | Some (before, after) -> + let (a, _), _ = ag.ra_ports.(after) in + let (b, _), _ = ag.ra_ports.(before) in + (match b with + | ANY_FREE | LNK_FREE | LNK_ANY | LNK_TYPE _ | LNK_SOME -> () + | LNK_VALUE (lnk_b, _) -> + (match a with + | LNK_VALUE (lnk_a, _) -> Raw_mixture.union t lnk_b lnk_a + | ANY_FREE | LNK_FREE -> + let root = Raw_mixture.find t lnk_b in + let s, _ = Mods.DynArray.get t.Raw_mixture.rank root in + Mods.DynArray.set t.Raw_mixture.rank root (s, (true, true)) + | LNK_ANY -> + let root = Raw_mixture.find t lnk_b in + let s, _ = Mods.DynArray.get t.Raw_mixture.rank root in + Mods.DynArray.set t.Raw_mixture.rank root (s, (false, true)) + | LNK_TYPE _ | LNK_SOME -> + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy + "Port a of __counter_agent agent not well specified"))))) + mix + in t let print_rule_agent ~noCounters sigs ~ltypes counters created_counters f ag = - Format.fprintf f "%a(@[%a@])%t" - (Signature.print_agent sigs) ag.ra_type + Format.fprintf f "%a(@[%a@])%t" (Signature.print_agent sigs) ag.ra_type (print_rule_intf ~noCounters sigs ~show_erased:false ~ltypes ag.ra_type) - (ag.ra_ports,ag.ra_ints,counters,created_counters) - (fun f -> if ag.ra_erased then Format.pp_print_string f "-") + (ag.ra_ports, ag.ra_ints, counters, created_counters) (fun f -> + if ag.ra_erased then Format.pp_print_string f "-") let print_rule_mixture ~noCounters sigs ~ltypes created f mix = - let incr_agents = union_find_counters (Some sigs) mix in + let counter_agents = union_find_counters (Some sigs) mix in let created_incr = Raw_mixture.union_find_counters (Some sigs) created in let rec aux_print some = function | [] -> () - | h::t -> - if Signature.is_counter_agent sigs h.ra_type - && not noCounters - then aux_print some t - else + | h :: t -> + if Signature.is_counter_agent sigs h.ra_type && not noCounters then + aux_print some t + else ( let () = if some then Pp.comma f in - let () = print_rule_agent - ~noCounters sigs ~ltypes incr_agents created_incr f h in - aux_print true t in + let () = + print_rule_agent ~noCounters sigs ~ltypes counter_agents created_incr + f h + in + aux_print true t + ) + in aux_print false mix let print_internal_lhs sigs ag_ty site f = function | I_ANY -> () - | (I_ANY_CHANGED _ | I_ANY_ERASED) -> Format.pp_print_string f "{#}" - | (I_VAL_CHANGED (i,_) | I_VAL_ERASED i) -> + | I_ANY_CHANGED _ | I_ANY_ERASED -> Format.pp_print_string f "{#}" + | I_VAL_CHANGED (i, _) | I_VAL_ERASED i -> Format.fprintf f "{%a}" (Signature.print_internal_state sigs ag_ty site) i let print_internal_rhs sigs ag_ty site f = function | I_ANY -> () - | (I_ANY_CHANGED j | I_VAL_CHANGED (_,j)) -> + | I_ANY_CHANGED j | I_VAL_CHANGED (_, j) -> Format.fprintf f "{%a}" (Signature.print_internal_state sigs ag_ty site) j - | (I_ANY_ERASED | I_VAL_ERASED _) -> assert false + | I_ANY_ERASED | I_VAL_ERASED _ -> assert false -let print_link_lhs ~ltypes sigs f ((e,_),_) = +let print_link_lhs ~ltypes sigs f ((e, _), _) = print_link (Signature.print_site sigs) - (Signature.print_agent sigs) (print_link_annot ~ltypes sigs) + (Signature.print_agent sigs) + (print_link_annot ~ltypes sigs) f e -let print_link_rhs ~ltypes sigs f ((e,_),s) = +let print_link_rhs ~ltypes sigs f ((e, _), s) = match s with | Linked i -> print_link (Signature.print_site sigs) - (Signature.print_agent sigs) (fun _ () -> ()) - f (LNK_VALUE (i,())) + (Signature.print_agent sigs) + (fun _ () -> ()) + f + (LNK_VALUE (i, ())) | Freed -> Format.pp_print_string f "." | Maintained -> print_link (Signature.print_site sigs) - (Signature.print_agent sigs) (print_link_annot ~ltypes sigs) + (Signature.print_agent sigs) + (print_link_annot ~ltypes sigs) f e | Erased -> assert false -let print_intf_lhs ~ltypes sigs ag_ty f (ports,ints) = +let print_intf_lhs ~ltypes sigs ag_ty f (ports, ints) = let rec aux empty i = if i < Array.length ports then - if (match ports.(i) with - | (((LNK_SOME | LNK_FREE | ANY_FREE | - LNK_TYPE _ | LNK_VALUE _),_), _) -> true - | (LNK_ANY, _), _ -> - match ints.(i) with - | (I_ANY | I_ANY_ERASED | I_ANY_CHANGED _) -> false - | ( I_VAL_CHANGED _ | I_VAL_ERASED _) -> true) then - let () = Format.fprintf - f "%t%a%a[%a]" - (if empty then Pp.empty else Pp.space) - (Signature.print_site sigs ag_ty) i + if + match ports.(i) with + | ((LNK_SOME | LNK_FREE | ANY_FREE | LNK_TYPE _ | LNK_VALUE _), _), _ -> + true + | (LNK_ANY, _), _ -> + (match ints.(i) with + | I_ANY | I_ANY_ERASED | I_ANY_CHANGED _ -> false + | I_VAL_CHANGED _ | I_VAL_ERASED _ -> true) + then ( + let () = + Format.fprintf f "%t%a%a[%a]" + (if empty then + Pp.empty + else + Pp.space) + (Signature.print_site sigs ag_ty) + i (print_internal_lhs sigs ag_ty i) - ints.(i) (print_link_lhs ~ltypes sigs) ports.(i) in + ints.(i) + (print_link_lhs ~ltypes sigs) + ports.(i) + in aux false (succ i) - else aux empty (succ i) in + ) else + aux empty (succ i) + in aux true 0 -let print_intf_rhs ~ltypes sigs ag_ty f (ports,ints) = +let print_intf_rhs ~ltypes sigs ag_ty f (ports, ints) = let rec aux empty i = if i < Array.length ports then - if (match ports.(i) with - | (((LNK_SOME | LNK_FREE | ANY_FREE | - LNK_TYPE _ | LNK_VALUE _),_), _) -> true - | ((LNK_ANY, _), (Erased | Freed | Linked _)) -> true - | ((LNK_ANY, _), Maintained) -> - match ints.(i) with - | I_ANY -> false - | I_VAL_CHANGED (i,j) -> i <> j - | (I_ANY_ERASED | I_ANY_CHANGED _ | I_VAL_ERASED _) -> true) then - let () = Format.fprintf - f "%t%a%a[%a]" - (if empty then Pp.empty else Pp.space) - (Signature.print_site sigs ag_ty) i + if + match ports.(i) with + | ((LNK_SOME | LNK_FREE | ANY_FREE | LNK_TYPE _ | LNK_VALUE _), _), _ -> + true + | (LNK_ANY, _), (Erased | Freed | Linked _) -> true + | (LNK_ANY, _), Maintained -> + (match ints.(i) with + | I_ANY -> false + | I_VAL_CHANGED (i, j) -> i <> j + | I_ANY_ERASED | I_ANY_CHANGED _ | I_VAL_ERASED _ -> true) + then ( + let () = + Format.fprintf f "%t%a%a[%a]" + (if empty then + Pp.empty + else + Pp.space) + (Signature.print_site sigs ag_ty) + i (print_internal_rhs sigs ag_ty i) - ints.(i) (print_link_rhs ~ltypes sigs) ports.(i) in + ints.(i) + (print_link_rhs ~ltypes sigs) + ports.(i) + in aux false (succ i) - else aux empty (succ i) in + ) else + aux empty (succ i) + in aux true 0 let print_agent_lhs ~ltypes sigs f ag = - Format.fprintf - f "%a(@[%a@])" (Signature.print_agent sigs) ag.ra_type - (print_intf_lhs ~ltypes sigs ag.ra_type) (ag.ra_ports,ag.ra_ints) + Format.fprintf f "%a(@[%a@])" + (Signature.print_agent sigs) + ag.ra_type + (print_intf_lhs ~ltypes sigs ag.ra_type) + (ag.ra_ports, ag.ra_ints) let print_agent_rhs ~ltypes sigs f ag = if not ag.ra_erased then - Format.fprintf - f "%a(@[%a@])" (Signature.print_agent sigs) ag.ra_type - (print_intf_rhs ~ltypes sigs ag.ra_type) (ag.ra_ports,ag.ra_ints) + Format.fprintf f "%a(@[%a@])" + (Signature.print_agent sigs) + ag.ra_type + (print_intf_rhs ~ltypes sigs ag.ra_type) + (ag.ra_ports, ag.ra_ints) let print_rhs ~noCounters ~ltypes sigs created f mix = let rec aux empty = function - | [] -> Raw_mixture.print - ~noCounters ~initial_comma:(not empty) ~created:false ~sigs f created + | [] -> + Raw_mixture.print ~noCounters ~initial_comma:(not empty) ~created:false + ~sigs f created | h :: t -> - if h.ra_erased then - let () = Format.fprintf f "%t." - (if empty then Pp.empty else Pp.comma) in + if h.ra_erased then ( + let () = + Format.fprintf f "%t." + (if empty then + Pp.empty + else + Pp.comma) + in aux false t - else - let () = Format.fprintf f "%t%a" - (if empty then Pp.empty else Pp.comma) - (print_agent_rhs ~ltypes sigs) h in - aux false t in + ) else ( + let () = + Format.fprintf f "%t%a" + (if empty then + Pp.empty + else + Pp.comma) + (print_agent_rhs ~ltypes sigs) + h + in + aux false t + ) + in aux true mix let print_rates ~noCounters sigs pr_tok pr_var f r = let ltypes = false in - Format.fprintf - f " @@ %a%t" + Format.fprintf f " @@ %a%t" (Alg_expr.print - (fun f m -> Format.fprintf - f "|%a|" (print_rule_mixture ~noCounters sigs ~ltypes []) m) - pr_tok pr_var) (fst r.r_rate) + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ~ltypes []) + m) + pr_tok pr_var) + (fst r.r_rate) (fun f -> - match r.r_un_rate with - | None -> () - | Some ((ra,_),max_dist) -> - Format.fprintf - f " {%a%a}" - (Alg_expr.print - (fun f m -> Format.fprintf f "|%a|" - (print_rule_mixture ~noCounters sigs ~ltypes []) m) - pr_tok pr_var) ra - (Pp.option - (fun f (md,_) -> - Format.fprintf f ":%a" - (Alg_expr.print - (fun f m -> Format.fprintf f "|%a|" - (print_rule_mixture ~noCounters sigs ~ltypes []) m) - pr_tok pr_var) md)) max_dist) + match r.r_un_rate with + | None -> () + | Some ((ra, _), max_dist) -> + Format.fprintf f " {%a%a}" + (Alg_expr.print + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ~ltypes []) + m) + pr_tok pr_var) + ra + (Pp.option (fun f (md, _) -> + Format.fprintf f ":%a" + (Alg_expr.print + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ~ltypes []) + m) + pr_tok pr_var) + md)) + max_dist) let print_rule ~noCounters ~full sigs pr_tok pr_var f r = - Format.fprintf - f "@[%t%t%a%t@]" + Format.fprintf f "@[%t%t%a%t@]" (fun f -> - if full || r.r_editStyle then - Format.fprintf f "%a%a" - (print_rule_mixture ~noCounters sigs ~ltypes:false r.r_created) r.r_mix - (Raw_mixture.print - ~noCounters ~created:true ~initial_comma:(r.r_mix <> []) ~sigs) - r.r_created - else Format.fprintf f "%a%t%a -> %a" - (Pp.list Pp.comma (print_agent_lhs ~ltypes:false sigs)) r.r_mix - (fun f -> if r.r_mix <> [] && r.r_created <> [] then Pp.comma f) - (Pp.list Pp.comma (fun f _ -> Format.pp_print_string f ".")) - r.r_created - (print_rhs ~noCounters ~ltypes:false sigs r.r_created) r.r_mix) + if full || r.r_edit_style then + Format.fprintf f "%a%a" + (print_rule_mixture ~noCounters sigs ~ltypes:false r.r_created) + r.r_mix + (Raw_mixture.print ~noCounters ~created:true + ~initial_comma:(r.r_mix <> []) ~sigs) + r.r_created + else + Format.fprintf f "%a%t%a -> %a" + (Pp.list Pp.comma (print_agent_lhs ~ltypes:false sigs)) + r.r_mix + (fun f -> if r.r_mix <> [] && r.r_created <> [] then Pp.comma f) + (Pp.list Pp.comma (fun f _ -> Format.pp_print_string f ".")) + r.r_created + (print_rhs ~noCounters ~ltypes:false sigs r.r_created) + r.r_mix) (fun f -> - match r.r_delta_tokens with [] -> () - | _::_ -> Format.pp_print_string f " | ") - (Pp.list - Pp.comma - (fun f ((nb,_),tk) -> - Format.fprintf - f "%a %a" - (Alg_expr.print - (fun f m -> Format.fprintf - f "|%a|" (print_rule_mixture ~noCounters sigs ~ltypes:false []) m) - pr_tok pr_var) nb - pr_tok tk)) + match r.r_delta_tokens with + | [] -> () + | _ :: _ -> Format.pp_print_string f " | ") + (Pp.list Pp.comma (fun f ((nb, _), tk) -> + Format.fprintf f "%a %a" + (Alg_expr.print + (fun f m -> + Format.fprintf f "|%a|" + (print_rule_mixture ~noCounters sigs ~ltypes:false []) + m) + pr_tok pr_var) + nb pr_tok tk)) r.r_delta_tokens (fun f -> if full then print_rates ~noCounters sigs pr_tok pr_var f r) let rule_agent_to_json filenames a = - `Assoc [ - "type", `Int a.ra_type; - "bindings", - `List (Array.fold_right - (fun (e,s) c -> - (`List [ - Locality.annot_to_yojson - ~filenames - (link_to_json (fun _ i -> `Int i) (fun i -> `Int i) - (fun (s,a) -> [`Int s;`Int a])) e; - switching_to_json s])::c) - a.ra_ports []); - "states", - `List (Array.fold_right - (fun x c -> rule_internal_to_json x :: c) a.ra_ints []); - "erased", `Bool a.ra_erased; - ] + `Assoc + [ + "type", `Int a.ra_type; + ( "bindings", + `List + (Array.fold_right + (fun (e, s) c -> + `List + [ + Loc.yojson_of_annoted ~filenames + (link_to_json + (fun _ i -> `Int i) + (fun i -> `Int i) + (fun (s, a) -> [ `Int s; `Int a ])) + e; + switching_to_json s; + ] + :: c) + a.ra_ports []) ); + ( "states", + `List + (Array.fold_right + (fun x c -> rule_internal_to_json x :: c) + a.ra_ints []) ); + "erased", `Bool a.ra_erased; + ] + let rule_agent_of_json filenames = function | `Assoc l as x when List.length l = 4 -> - begin - try - let ports = - match List.assoc "bindings" l with - | `List s -> - Tools.array_map_of_list - (function - | `List [e;s] -> - (Locality.annot_of_yojson - ~filenames + (try + let ports = + match List.assoc "bindings" l with + | `List s -> + Tools.array_map_of_list + (function + | `List [ e; s ] -> + ( Loc.annoted_of_yojson ~filenames (link_of_json (fun _ -> Yojson.Basic.Util.to_int) Yojson.Basic.Util.to_int (function - | [`Int s; `Int a] -> (s,a) - | _ -> raise Not_found)) e, - switching_of_json s) - | _ -> raise Not_found) s - | _ -> raise Not_found in - let ints = - match List.assoc "states" l with - | `List s -> - Tools.array_map_of_list rule_internal_of_json s - | _ -> raise Not_found in - { - ra_type = Yojson.Basic.Util.to_int (List.assoc "type" l); - ra_ports = ports; - ra_ints = ints; - ra_erased = Yojson.Basic.Util.to_bool (List.assoc "erased" l); - ra_syntax = Some (ports,ints); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Invalid rule_agent",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid rule_agent",x)) + | [ `Int s; `Int a ] -> s, a + | _ -> raise Not_found)) + e, + switching_of_json s ) + | _ -> raise Not_found) + s + | _ -> raise Not_found + in + let ints = + match List.assoc "states" l with + | `List s -> Tools.array_map_of_list rule_internal_of_json s + | _ -> raise Not_found + in + { + ra_type = Yojson.Basic.Util.to_int (List.assoc "type" l); + ra_ports = ports; + ra_ints = ints; + ra_erased = Yojson.Basic.Util.to_bool (List.assoc "erased" l); + ra_syntax = Some (ports, ints); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Invalid rule_agent", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid rule_agent", x)) let rule_mixture_to_json filenames = JsonUtil.of_list (rule_agent_to_json filenames) + let rule_mixture_of_json filenames = JsonUtil.to_list (rule_agent_of_json filenames) let lalg_expr_to_json filenames = - Alg_expr.e_to_yojson - ~filenames (rule_mixture_to_json filenames) JsonUtil.of_int + Alg_expr.e_to_yojson ~filenames + (rule_mixture_to_json filenames) + JsonUtil.of_int + let lalg_expr_of_json filenames = - Alg_expr.e_of_yojson - ~filenames (rule_mixture_of_json filenames) + Alg_expr.e_of_yojson ~filenames + (rule_mixture_of_json filenames) (JsonUtil.to_int ?error_msg:None) let rule_to_json ~filenames r = @@ -489,172 +590,210 @@ let rule_to_json ~filenames r = [ "mixture", rule_mixture_to_json filenames r.r_mix; "created", Raw_mixture.to_json r.r_created; - "delta_tokens", - JsonUtil.of_list - (JsonUtil.of_pair ~lab1:"val" ~lab2:"tok" - (Locality.annot_to_yojson ~filenames (lalg_expr_to_json filenames)) - JsonUtil.of_int) - r.r_delta_tokens; - "rate", Locality.annot_to_yojson - ~filenames (lalg_expr_to_json filenames) r.r_rate; - "unary_rate", - JsonUtil.of_option - (JsonUtil.of_pair - (Locality.annot_to_yojson ~filenames (lalg_expr_to_json filenames)) - (JsonUtil.of_option - (Locality.annot_to_yojson - ~filenames (lalg_expr_to_json filenames)))) - r.r_un_rate; - "editStyle", `Bool r.r_editStyle; + ( "delta_tokens", + JsonUtil.of_list + (JsonUtil.of_pair ~lab1:"val" ~lab2:"tok" + (Loc.yojson_of_annoted ~filenames (lalg_expr_to_json filenames)) + JsonUtil.of_int) + r.r_delta_tokens ); + ( "rate", + Loc.yojson_of_annoted ~filenames (lalg_expr_to_json filenames) r.r_rate + ); + ( "unary_rate", + JsonUtil.of_option + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames (lalg_expr_to_json filenames)) + (JsonUtil.of_option + (Loc.yojson_of_annoted ~filenames (lalg_expr_to_json filenames)))) + r.r_un_rate ); + "edit_style", `Bool r.r_edit_style; ] + let rule_of_json ~filenames = function | `Assoc l as x when List.length l < 7 -> - begin - try - { - r_mix = rule_mixture_of_json filenames (List.assoc "mixture" l); - r_created = Raw_mixture.of_json (List.assoc "created" l); - r_delta_tokens = - JsonUtil.to_list - (JsonUtil.to_pair ~lab1:"val" ~lab2:"tok" - (Locality.annot_of_yojson - ~filenames (lalg_expr_of_json filenames)) - (JsonUtil.to_int ?error_msg:None)) - (List.assoc "delta_tokens" l); - r_rate = - Locality.annot_of_yojson ~filenames (lalg_expr_of_json filenames) - (List.assoc "rate" l); - r_un_rate = - (try - JsonUtil.to_option - (JsonUtil.to_pair - (Locality.annot_of_yojson - ~filenames (lalg_expr_of_json filenames)) - (JsonUtil.to_option - (Locality.annot_of_yojson - (lalg_expr_of_json filenames)))) - (List.assoc "unary_rate" l) - with Not_found -> None); - r_editStyle = Yojson.Basic.Util.to_bool (List.assoc "editStyle" l); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Incorrect rule",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect rule",x)) - -let forbid_modification pos = function + (try + { + r_mix = rule_mixture_of_json filenames (List.assoc "mixture" l); + r_created = Raw_mixture.of_json (List.assoc "created" l); + r_delta_tokens = + JsonUtil.to_list + (JsonUtil.to_pair ~lab1:"val" ~lab2:"tok" + (Loc.annoted_of_yojson ~filenames (lalg_expr_of_json filenames)) + (JsonUtil.to_int ?error_msg:None)) + (List.assoc "delta_tokens" l); + r_rate = + Loc.annoted_of_yojson ~filenames + (lalg_expr_of_json filenames) + (List.assoc "rate" l); + r_un_rate = + (try + JsonUtil.to_option + (JsonUtil.to_pair + (Loc.annoted_of_yojson ~filenames + (lalg_expr_of_json filenames)) + (JsonUtil.to_option + (Loc.annoted_of_yojson (lalg_expr_of_json filenames)))) + (List.assoc "unary_rate" l) + with Not_found -> None); + r_edit_style = Yojson.Basic.Util.to_bool (List.assoc "edit_style" l); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Incorrect rule", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect rule", x)) + +let raise_if_modification pos = function | None -> () - | Some _ -> - raise (ExceptionDefn.Malformed_Decl - ("A modification is forbidden here.",pos)) - -let several_internal_states pos = - raise (ExceptionDefn.Malformed_Decl - ("In a pattern, a site cannot have several internal states.",pos)) - -let not_enough_specified ~status ~side agent_name (na,pos) = - raise (ExceptionDefn.Malformed_Decl - ("The "^status^" state of agent '"^agent_name^"', site '"^na - ^"' on the "^side^" hand side is underspecified",pos)) - -let several_occurence_of_site agent_name (na,pos) = - raise (ExceptionDefn.Malformed_Decl - ("Site '"^na^ - "' occurs more than once in this agent '"^agent_name^"'",pos)) - -let counter_misused agent_name (na,pos) = - raise (ExceptionDefn.Malformed_Decl - ("Site '"^na^ - "' occurs both as port and as counter in '"^agent_name^"'",pos)) - - -let link_only_one_occurence i pos = - raise (ExceptionDefn.Malformed_Decl - ("The link '"^string_of_int i^ - "' occurs only one time in the mixture.", pos)) + | _ -> + raise + (ExceptionDefn.Malformed_Decl ("A modification is forbidden here.", pos)) + +let raise_several_internal_states pos = + raise + (ExceptionDefn.Malformed_Decl + ("In a pattern, a site cannot have several internal states.", pos)) + +let raise_not_enough_specified ~status ~side agent_name (na, pos) = + raise + (ExceptionDefn.Malformed_Decl + ( "The " ^ status ^ " state of agent '" ^ agent_name ^ "', site '" ^ na + ^ "' on the " ^ side ^ " hand side is underspecified", + pos )) + +let raise_several_occurence_of_site agent_name (na, pos) = + raise + (ExceptionDefn.Malformed_Decl + ( "Site '" ^ na ^ "' occurs more than once in this agent '" ^ agent_name + ^ "'", + pos )) + +let raise_counter_misused agent_name (na, pos) = + raise + (ExceptionDefn.Malformed_Decl + ( "Site '" ^ na ^ "' occurs both as port and as counter in '" + ^ agent_name ^ "'", + pos )) + +let raise_link_only_one_occurence i pos = + raise + (ExceptionDefn.Malformed_Decl + ( "The link '" ^ string_of_int i + ^ "' occurs only one time in the mixture.", + pos )) + +let raise_link_should_be_removed i agent_name (na, pos) = + raise + (ExceptionDefn.Malformed_Decl + ( "The link '" ^ string_of_int i ^ "' should be made free in the site '" + ^ na ^ "' of agent '" ^ agent_name + ^ "', since it will made be free by side-effect.", + pos )) let copy_rule_agent a = let p = Array.copy a.ra_ports in let i = Array.copy a.ra_ints in - { ra_type = a.ra_type; ra_erased = a.ra_erased; ra_ports = p; + { + ra_type = a.ra_type; + ra_erased = a.ra_erased; + ra_ports = p; ra_ints = i; ra_syntax = - Option_util.map (fun _ -> Array.copy p, Array.copy i) - a.ra_syntax;} + Option_util.map (fun _ -> Array.copy p, Array.copy i) a.ra_syntax; + } let agent_to_erased sigs r = - let ra_ports = Array.map (fun (a,_) -> a,Erased) r.ra_ports in + let ra_ports = Array.map (fun (a, _) -> a, Erased) r.ra_ports in let ra_ints = - Array.mapi (fun j -> function - | I_VAL_CHANGED (i,_) | I_VAL_ERASED i -> I_VAL_ERASED i + Array.mapi + (fun j -> function + | I_VAL_CHANGED (i, _) | I_VAL_ERASED i -> I_VAL_ERASED i | I_ANY | I_ANY_CHANGED _ | I_ANY_ERASED -> - match Signature.default_internal_state r.ra_type j - sigs with + (match Signature.default_internal_state r.ra_type j sigs with | Some _ -> I_ANY_ERASED - | None -> I_ANY) r.ra_ints in { - ra_type = r.ra_type; ra_erased = true; ra_ports; ra_ints; + | None -> I_ANY)) + r.ra_ints + in + { + ra_type = r.ra_type; + ra_erased = true; + ra_ports; + ra_ints; ra_syntax = - match r.ra_syntax with + (match r.ra_syntax with | None -> None - | Some _ -> Some (Array.copy ra_ports,Array.copy ra_ints); + | Some _ -> Some (Array.copy ra_ports, Array.copy ra_ints)); } -let to_erased sigs x = List.map (agent_to_erased sigs) x +let to_erased (sigs : Signature.s) (x : rule_mixture) : rule_mixture = + List.map (agent_to_erased sigs) x -let to_maintained x = +let to_maintained (x : rule_mixture) : rule_mixture = List.map (fun r -> - let ports = Array.map (fun (a,_) -> a,Maintained) r.ra_ports in - let ints = - Array.map (function - | I_VAL_CHANGED (i,_) | I_VAL_ERASED i -> I_VAL_CHANGED (i,i) - | I_ANY | I_ANY_CHANGED _ | I_ANY_ERASED -> I_ANY - ) r.ra_ints in - { ra_type = r.ra_type; ra_erased = false; ra_ports = ports; ra_ints=ints; - ra_syntax = - match r.ra_syntax with None -> None | Some _ -> Some (ports,ints);}) + let ports = Array.map (fun (a, _) -> a, Maintained) r.ra_ports in + let ints = + Array.map + (function + | I_VAL_CHANGED (i, _) | I_VAL_ERASED i -> I_VAL_CHANGED (i, i) + | I_ANY | I_ANY_CHANGED _ | I_ANY_ERASED -> I_ANY) + r.ra_ints + in + { + ra_type = r.ra_type; + ra_erased = false; + ra_ports = ports; + ra_ints = ints; + ra_syntax = + (match r.ra_syntax with + | None -> None + | Some _ -> Some (ports, ints)); + }) x let to_raw_mixture sigs x = List.map (fun r -> - let internals = - Array.mapi - (fun j -> function - | I_VAL_CHANGED (i,_) | I_VAL_ERASED i -> Some i - | (I_ANY | I_ANY_CHANGED _ | I_ANY_ERASED) -> - Signature.default_internal_state r.ra_type j sigs) - r.ra_ints in - let ports = - Array.mapi - (fun j -> function - | ((LNK_SOME, pos) | (LNK_TYPE _,pos)),_ -> - let ag_na = - Format.asprintf - "%a" (Signature.print_agent sigs) r.ra_type in - let p_na = - Format.asprintf - "%a" (Signature.print_site sigs r.ra_type) j in - not_enough_specified - ~status:"linking" ~side:"left" ag_na (p_na,pos) - | (LNK_VALUE (i,_), _),_ -> Raw_mixture.VAL i - | (((LNK_ANY | ANY_FREE | LNK_FREE), _)),_ -> - Raw_mixture.FREE - ) - r.ra_ports in - { Raw_mixture.a_type = r.ra_type; - Raw_mixture.a_ports = ports; Raw_mixture.a_ints = - internals; }) + let internals = + Array.mapi + (fun j -> function + | I_VAL_CHANGED (i, _) | I_VAL_ERASED i -> Some i + | I_ANY | I_ANY_CHANGED _ | I_ANY_ERASED -> + Signature.default_internal_state r.ra_type j sigs) + r.ra_ints + in + let ports = + Array.mapi + (fun j -> function + | (LNK_SOME, pos | LNK_TYPE _, pos), _ -> + let agent_name = + Format.asprintf "%a" (Signature.print_agent sigs) r.ra_type + in + let port_name = + Format.asprintf "%a" (Signature.print_site sigs r.ra_type) j + in + raise_not_enough_specified ~status:"linking" ~side:"left" + agent_name (port_name, pos) + | (LNK_VALUE (i, _), _), _ -> Raw_mixture.VAL i + | ((LNK_ANY | ANY_FREE | LNK_FREE), _), _ -> Raw_mixture.FREE) + r.ra_ports + in + { + Raw_mixture.a_type = r.ra_type; + Raw_mixture.a_ports = ports; + Raw_mixture.a_ints = internals; + }) x let max_link_id r = let max_s m = function | Linked i -> max i m - | Freed | Maintained | Erased -> m in + | Freed | Maintained | Erased -> m + in let max_link_id_sites max_id ag = - Array.fold_left (fun max_id -> function - | (LNK_VALUE (j,_),_),s -> max_s (max j max_id) s - | ((LNK_TYPE _|LNK_SOME| - LNK_FREE|LNK_ANY|ANY_FREE),_),s -> max_s max_id s) - max_id ag.ra_ports in + Array.fold_left + (fun max_id -> function + | (LNK_VALUE (j, _), _), s -> max_s (max j max_id) s + | ((LNK_TYPE _ | LNK_SOME | LNK_FREE | LNK_ANY | ANY_FREE), _), s -> + max_s max_id s) + max_id ag.ra_ports + in List.fold_left max_link_id_sites 0 r diff --git a/core/term/lKappa.mli b/core/term/lKappa.mli index 44dfcd07e9..d132b2a3c3 100644 --- a/core/term/lKappa.mli +++ b/core/term/lKappa.mli @@ -6,34 +6,37 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -(** Intermediate representation of model on wich sanity has been checked *) +(** Intermediate representation of model on which sanity has been checked *) -type ('a,'annot) link = +type ('a, 'annoted) link = | ANY_FREE - | LNK_VALUE of int * 'annot + | LNK_VALUE of int * 'annoted | LNK_FREE | LNK_ANY | LNK_SOME - | LNK_TYPE of 'a * 'a (** port * agent_type *) + | LNK_TYPE of 'a * 'a (** port * agent_type *) type switching = Linked of int | Freed | Maintained | Erased -type rule_internal = (*state*) +type rule_internal = + (* internal state of agent port *) | I_ANY | I_ANY_CHANGED of int | I_ANY_ERASED | I_VAL_CHANGED of int * int | I_VAL_ERASED of int -type rule_agent = - { ra_type: int; (*agent_id*) - ra_erased: bool; - ra_ports: ((int,int*int) link Locality.annot * switching) array; - (*((link nb, (dst_site,dst_ag_type)), _) , switch*) - ra_ints: rule_internal array; - ra_syntax: (((int,int*int) link Locality.annot * switching) array * - rule_internal array) option; - } +type rule_agent = { + ra_type: int; (*agent_id*) + ra_erased: bool; + ra_ports: ((int, int * int) link Loc.annoted * switching) array; + (*((link nb, (dst_site,dst_ag_type)), _) , switch*) + ra_ints: rule_internal array; + ra_syntax: + (((int, int * int) link Loc.annoted * switching) array + * rule_internal array) + option; +} (** A representation of 'left-hand-side' agent that stores how everything is transformed. In an observable (a mixture in an alg_expr), everything is [Maintained] (represented by [I_VAL_CHANGED (i,i)] for @@ -43,66 +46,91 @@ The field ra_syntax represents how the user describe the agent before compilation. Therefore, [compil_of_ast] in this module generates rule_agent where ra_syntax is [Some (Array.copy ra_ports, Array.copy ra_ints)]. *) +(* TODO Reference to compil_of_ast here is weird *) type rule_mixture = rule_agent list - -val forbid_modification : Locality.t -> 'a option -> unit -val several_internal_states : Locality.t -> 'a -val not_enough_specified : - status:string -> side:string -> string -> string * Locality.t -> 'a -val several_occurence_of_site : string -> string * Locality.t -> 'a -val counter_misused : string -> string * Locality.t -> 'a -val link_only_one_occurence : int -> Locality.t -> 'a +(** [rule_mixture] is the mixture description from the initial state of a rule *) + +type rule = { + r_mix: rule_mixture; (** Initial mixture state *) + r_created: Raw_mixture.t; (** Mixture state after rule is applied *) + r_delta_tokens: ((rule_mixture, int) Alg_expr.e Loc.annoted * int) list; + r_rate: (rule_mixture, int) Alg_expr.e Loc.annoted; + r_un_rate: + ((rule_mixture, int) Alg_expr.e Loc.annoted + * (rule_mixture, int) Alg_expr.e Loc.annoted option) + option; + r_edit_style: bool; + (** If rule was written in edit style, else it's rewrite style *) +} val agent_to_erased : Signature.s -> rule_agent -> rule_agent val to_erased : Signature.s -> rule_mixture -> rule_mixture val to_maintained : rule_mixture -> rule_mixture val to_raw_mixture : Signature.s -> rule_mixture -> Raw_mixture.t val copy_rule_agent : rule_agent -> rule_agent +val max_link_id : rule_mixture -> int +val raise_if_modification : Loc.t -> 'a option -> unit +val raise_several_internal_states : Loc.t -> 'a + +val raise_not_enough_specified : + status:string -> side:string -> string -> string Loc.annoted -> 'a + +val raise_several_occurence_of_site : string -> string Loc.annoted -> 'a +val raise_counter_misused : string -> string Loc.annoted -> 'a +val raise_link_only_one_occurence : int -> Loc.t -> 'a +val raise_link_should_be_removed : int -> string -> string Loc.annoted -> 'a + val print_rule_mixture : - noCounters:bool -> Signature.s -> ltypes:bool -> Raw_mixture.t -> - Format.formatter -> rule_mixture -> unit - -type rule = - { - r_mix: rule_mixture; - r_created: Raw_mixture.t; - r_delta_tokens : - ((rule_mixture,int) Alg_expr.e Locality.annot * int) list; - r_rate : (rule_mixture,int) Alg_expr.e Locality.annot; - r_un_rate : - ((rule_mixture,int) Alg_expr.e Locality.annot - * (rule_mixture,int) Alg_expr.e Locality.annot - option) option; - r_editStyle: bool; - } + noCounters:bool -> + Signature.s -> + ltypes:bool -> + Raw_mixture.t -> + Format.formatter -> + rule_mixture -> + unit val print_link : ('a -> Format.formatter -> 'a -> unit) -> (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> - Format.formatter -> ('a, 'b) link -> unit + Format.formatter -> + ('a, 'b) link -> + unit val link_to_json : - ('a -> 'a -> Yojson.Basic.t) -> ('a -> Yojson.Basic.t) -> - ('b -> Yojson.Basic.t list) -> ('a, 'b) link -> Yojson.Basic.t + ('a -> 'a -> Yojson.Basic.t) -> + ('a -> Yojson.Basic.t) -> + ('b -> Yojson.Basic.t list) -> + ('a, 'b) link -> + Yojson.Basic.t (** Fragile: the list MUST NOT be a singleton *) val link_of_json : - ('a -> Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'a) -> - (Yojson.Basic.t list -> 'b) -> Yojson.Basic.t -> ('a, 'b) link + ('a -> Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t list -> 'b) -> + Yojson.Basic.t -> + ('a, 'b) link val print_rates : - noCounters:bool -> Signature.s -> (Format.formatter -> int -> unit) -> - (Format.formatter -> int -> unit) -> Format.formatter -> rule -> unit + noCounters:bool -> + Signature.s -> + (Format.formatter -> int -> unit) -> + (Format.formatter -> int -> unit) -> + Format.formatter -> + rule -> + unit val print_rule : - noCounters:bool -> full:bool -> Signature.s -> - (Format.formatter -> int -> unit) -> (Format.formatter -> int -> unit) -> - Format.formatter -> rule -> unit - -val rule_to_json : - filenames : int Mods.StringMap.t -> rule -> Yojson.Basic.t -val rule_of_json : filenames : string array -> Yojson.Basic.t -> rule - -val max_link_id : rule_mixture -> int + noCounters:bool -> + full:bool -> + Signature.s -> + (Format.formatter -> int -> unit) -> + (Format.formatter -> int -> unit) -> + Format.formatter -> + rule -> + unit + +val rule_to_json : filenames:int Mods.StringMap.t -> rule -> Yojson.Basic.t +val rule_of_json : filenames:string array -> Yojson.Basic.t -> rule diff --git a/core/term/matching.ml b/core/term/matching.ml index 8f4a708781..caeb261ace 100644 --- a/core/term/matching.ml +++ b/core/term/matching.ml @@ -13,253 +13,297 @@ type t = Renaming.t Mods.IntMap.t * Mods.IntSet.t type matching = t -let empty = (Mods.IntMap.empty, Mods.IntSet.empty) +let empty = Mods.IntMap.empty, Mods.IntSet.empty -let add_cc (inj,co) id r = +let add_cc (inj, co) id r = let c = Renaming.image r in match Mods.IntSet.disjoint_union co c with | Some co' -> Some (Mods.IntMap.add id r inj, co') | None -> None -let debug_print f (m,_co) = - Format.fprintf - f "@[(%a)@]" - (Pp.set Mods.IntMap.bindings Pp.comma - (fun f (ccid,nm) -> - Pp.set Renaming.to_list Pp.comma - (fun f (node,dst) -> - Format.fprintf f "%i:%i->%i" ccid node dst) f nm)) m +let debug_print f (m, _co) = + Format.fprintf f "@[(%a)@]" + (Pp.set Mods.IntMap.bindings Pp.comma (fun f (ccid, nm) -> + Pp.set Renaming.to_list Pp.comma + (fun f (node, dst) -> Format.fprintf f "%i:%i->%i" ccid node dst) + f nm)) + m -let reconstruct_renaming ~debugMode domain graph cc_id root = +let reconstruct_renaming ~debug_mode domain graph cc_id root = let point = Pattern.Env.get domain cc_id in match Pattern.Env.roots point with | None -> failwith "Matching.reconstruct cc error" (*- rm - add : int -> int -> Renaming.t -> Renaming.t *) - | Some (rids,rty) -> + | Some (rids, rty) -> let inj = Renaming.empty () in - let _,injective = + let _, injective = match Pattern.reconstruction_navigation (Pattern.Env.content point) with - | _::_ as nav -> + | _ :: _ as nav -> List.fold_left - (fun (root,injective) nav -> - None,injective && - Navigation.imperative_edge_is_valid - ~debugMode ?root inj graph nav) - (Some (root,rty),true) nav + (fun (root, injective) nav -> + ( None, + injective + && Navigation.imperative_edge_is_valid ~debug_mode ?root inj graph + nav )) + (Some (root, rty), true) + nav (*- rm - find_root: cc -> (type, node) option *) - | [] -> None,match rids with - | [rid] -> Renaming.imperative_add ~debugMode rid root inj - | _ -> false in - if injective then inj else - failwith ("Matching.reconstruct renaming error at root "^string_of_int root) + | [] -> + ( None, + (match rids with + | [ rid ] -> Renaming.imperative_add ~debug_mode rid root inj + | _ -> false) ) + in + if injective then + inj + else + failwith + ("Matching.reconstruct renaming error at root " ^ string_of_int root) (* reconstruct: Pattern.Env.t -> Edges.t -> t -> int -> Pattern.id -> int -> t option*) -let reconstruct ~debugMode domain graph inj id cc_id root = - let rename = reconstruct_renaming ~debugMode domain graph cc_id root in +let reconstruct ~debug_mode domain graph inj id cc_id root = + let rename = reconstruct_renaming ~debug_mode domain graph cc_id root in match Mods.IntSet.disjoint_union (Renaming.image rename) (snd inj) with | None -> None - | Some co -> Some (Mods.IntMap.add id rename (fst inj),co) + | Some co -> Some (Mods.IntMap.add id rename (fst inj), co) -let rec aux_is_root_of ~debugMode graph root inj = function +let rec aux_is_root_of ~debug_mode graph root inj = function | [] -> true | h :: t -> - Navigation.imperative_edge_is_valid ~debugMode ?root inj graph h && - aux_is_root_of ~debugMode graph None inj t -let is_root_of ~debugMode domain graph (_,rty as root) cc_id = + Navigation.imperative_edge_is_valid ~debug_mode ?root inj graph h + && aux_is_root_of ~debug_mode graph None inj t + +let is_root_of ~debug_mode domain graph ((_, rty) as root) cc_id = let point = Pattern.Env.get domain cc_id in match Pattern.reconstruction_navigation (Pattern.Env.content point) with | [] -> (match Pattern.Env.roots point with - | Some (_,rty') -> rty = rty' - | None -> false) - | nav -> aux_is_root_of ~debugMode graph (Some root) (Renaming.empty ()) nav + | Some (_, rty') -> rty = rty' + | None -> false) + | nav -> aux_is_root_of ~debug_mode graph (Some root) (Renaming.empty ()) nav -let roots_of ~debugMode domain graph cc = +let roots_of ~debug_mode domain graph cc = Edges.all_agents_where - (fun x -> is_root_of ~debugMode domain graph x cc) graph + (fun x -> is_root_of ~debug_mode domain graph x cc) + graph (* get : (ContentAgent.t * int) -> t -> int *) -let get ~debugMode ((node,_),id) (t,_) = - Renaming.apply ~debugMode (Mods.IntMap.find_default Renaming.dummy id t) node +let get ~debug_mode ((node, _), id) (t, _) = + Renaming.apply ~debug_mode (Mods.IntMap.find_default Renaming.dummy id t) node -let elements_with_types domain ccs (t,_) = +let elements_with_types domain ccs (t, _) = let out = Array.make (Mods.IntMap.size t) [] in let () = Mods.IntMap.iter (fun id map -> - out.(id) <- Renaming.fold - (fun i out acc -> - (out,Pattern.find_ty - (Pattern.Env.content (Pattern.Env.get domain ccs.(id))) i)::acc) - map []) - t in - out + out.(id) <- + Renaming.fold + (fun i out acc -> + ( out, + Pattern.find_ty + (Pattern.Env.content (Pattern.Env.get domain ccs.(id))) + i ) + :: acc) + map []) + t + in + out module Cache = struct type t = Pattern.id * (int * int) option - let compare (a,a') (b,b') = + + let compare (a, a') (b, b') = let c = Pattern.compare_canonicals a b in - if c = 0 then - match a',b' with + if c = 0 then ( + match a', b' with | None, None -> 0 - | None,Some _ -> 1 + | None, Some _ -> 1 | Some _, None -> -1 | Some x, Some y -> Mods.int_pair_compare x y - else c - let print f (a,a') = + ) else + c + + let print f (a, a') = Format.fprintf f "%a%a" - (Pattern.print ~noCounters:true ?domain:None ~with_id:true) a - (Pp.option (Pp.pair Format.pp_print_int Format.pp_print_int)) a' + (Pattern.print ~noCounters:true ?domain:None ~with_id:true) + a + (Pp.option (Pp.pair Format.pp_print_int Format.pp_print_int)) + a' end -module CacheSetMap = SetMap.Make(Cache) + +module CacheSetMap = SetMap.Make (Cache) type cache = CacheSetMap.Set.t + let empty_cache = CacheSetMap.Set.empty -let survive_nav ~debugMode inj graph = +let survive_nav ~debug_mode inj graph = List.fold_left (fun inj step -> - match inj with - | None -> inj - | Some inj -> - Navigation.injection_for_one_more_edge ~debugMode inj graph step) + match inj with + | None -> inj + | Some inj -> + Navigation.injection_for_one_more_edge ~debug_mode inj graph step) (Some inj) (*edges: list of concrete edges, returns the roots of observables that are above in the domain*) -let from_edge ~debugMode domain graph (out,cache as acc) node site arrow = - let rec aux_from_edges cache (obs,rev_deps as acc) = function - | [] -> acc,cache - | (pid,point,inj_point2graph) :: remains -> +let from_edge ~debug_mode domain graph ((out, cache) as acc) node site arrow = + let rec aux_from_edges cache ((obs, rev_deps) as acc) = function + | [] -> acc, cache + | (pid, point, inj_point2graph) :: remains -> let acc' = match Pattern.Env.roots point with | None -> acc - |Some (ids,ty) -> - (List.fold_left - (fun acc id -> - (pid,(Renaming.apply ~debugMode inj_point2graph id,ty))::acc) - obs ids, - Operator.DepSet.union rev_deps (Pattern.Env.deps point)) in - let remains',cache' = + | Some (ids, ty) -> + ( List.fold_left + (fun acc id -> + (pid, (Renaming.apply ~debug_mode inj_point2graph id, ty)) + :: acc) + obs ids, + Operator.DepSet.union rev_deps (Pattern.Env.deps point) ) + in + let remains', cache' = List.fold_left - (fun (re,ca as pair) son -> - match survive_nav - ~debugMode inj_point2graph graph son.Pattern.Env.next with - | None -> pair - | Some inj' -> - let rename = - Renaming.compose ~debugMode false son.Pattern.Env.inj inj' in - let ca' = CacheSetMap.Set.add - (son.Pattern.Env.dst,Renaming.min_elt rename) ca in - if ca == ca' - then pair - else - let p' = Pattern.Env.get domain son.Pattern.Env.dst in - let next = (son.Pattern.Env.dst,p',rename) in - (next::re,ca')) - (remains,cache) (Pattern.Env.sons point) in - aux_from_edges cache' acc' remains' in - match Pattern.Env.get_elementary ~debugMode domain node site arrow with + (fun ((re, ca) as pair) son -> + match + survive_nav ~debug_mode inj_point2graph graph son.Pattern.Env.next + with + | None -> pair + | Some inj' -> + let rename = + Renaming.compose ~debug_mode false son.Pattern.Env.inj inj' + in + let ca' = + CacheSetMap.Set.add + (son.Pattern.Env.dst, Renaming.min_elt rename) + ca + in + if ca == ca' then + pair + else ( + let p' = Pattern.Env.get domain son.Pattern.Env.dst in + let next = son.Pattern.Env.dst, p', rename in + next :: re, ca' + )) + (remains, cache) (Pattern.Env.sons point) + in + aux_from_edges cache' acc' remains' + in + match Pattern.Env.get_elementary ~debug_mode domain node site arrow with | None -> acc | Some x -> aux_from_edges (*(*unnecessary*)CacheSetMap.Set.add (cc_id,Renaming.min_elt inj')*) - cache out [x] - -let observables_from_agent - domain graph ((obs,rdeps),cache as acc) (_,ty as node) = - if Edges.is_agent node graph - then match Pattern.Env.get_single_agent ty domain with - | Some (cc,deps) -> - ((cc,node)::obs,Operator.DepSet.union rdeps deps),cache + cache out [ x ] + +let observables_from_agent domain graph (((obs, rdeps), cache) as acc) + ((_, ty) as node) = + if Edges.is_agent node graph then ( + match Pattern.Env.get_single_agent ty domain with + | Some (cc, deps) -> + ((cc, node) :: obs, Operator.DepSet.union rdeps deps), cache | None -> acc - else acc + ) else + acc + +let observables_from_free ~debug_mode domain graph acc node site = + from_edge ~debug_mode domain graph acc node site Navigation.ToNothing + +let observables_from_internal ~debug_mode domain graph acc node site id = + from_edge ~debug_mode domain graph acc node site (Navigation.ToInternal id) -let observables_from_free ~debugMode domain graph acc node site = - from_edge ~debugMode domain graph acc node site Navigation.ToNothing -let observables_from_internal ~debugMode domain graph acc node site id = - from_edge ~debugMode domain graph acc node site (Navigation.ToInternal id) -let observables_from_link ~debugMode domain graph acc n site n' site' = - from_edge domain - ~debugMode graph acc n site (Navigation.ToNode (Navigation.Fresh n',site')) +let observables_from_link ~debug_mode domain graph acc n site n' site' = + from_edge domain ~debug_mode graph acc n site + (Navigation.ToNode (Navigation.Fresh n', site')) module Agent = struct - type t = - | Existing of Agent.t * int - | Fresh of int * int (* type, id *) + type t = Existing of Agent.t * int | Fresh of int * int (* type, id *) - let rename ~debugMode id inj = function + let rename ~debug_mode id inj = function | Existing (n, id') as x -> - if id <> id' then x else - let n' = Agent.rename ~debugMode inj n in - if n == n' then x else Existing (n',id') + if id <> id' then + x + else ( + let n' = Agent.rename ~debug_mode inj n in + if n == n' then + x + else + Existing (n', id') + ) | Fresh _ as x -> x let print ?sigs f = function - | Existing (n,id) -> - Format.fprintf - f "%a/*%i*/" (Agent.print ?sigs ~with_id:true) n id - | Fresh (ty,i) -> + | Existing (n, id) -> + Format.fprintf f "%a/*%i*/" (Agent.print ?sigs ~with_id:true) n id + | Fresh (ty, i) -> Format.fprintf f "%a/*%t %i*/" (match sigs with - | None -> Format.pp_print_int - | Some sigs -> Signature.print_agent sigs) ty Pp.nu i + | None -> Format.pp_print_int + | Some sigs -> Signature.print_agent sigs) + ty Pp.nu i let print_site ?sigs place f site = match place with - | Existing (n,_) -> Agent.print_site ?sigs n f site - | Fresh (ty,_) -> - match sigs with + | Existing (n, _) -> Agent.print_site ?sigs n f site + | Fresh (ty, _) -> + (match sigs with | None -> Format.pp_print_int f site - | Some sigs -> Signature.print_site sigs ty f site + | Some sigs -> Signature.print_site sigs ty f site) let print_internal ?sigs place site f id = match place with - | Existing (n,_) -> Agent.print_internal ?sigs n site f id - | Fresh (ty,_) -> - match sigs with + | Existing (n, _) -> Agent.print_internal ?sigs n site f id + | Fresh (ty, _) -> + (match sigs with | None -> Format.fprintf f "%i~%i" site id | Some sigs -> - Signature.print_site_internal_state sigs ty site f (Some id) + Signature.print_site_internal_state sigs ty site f (Some id)) let get_type = function - | Existing (n,_) -> Agent.sort n - | Fresh (i,_) -> i + | Existing (n, _) -> Agent.sort n + | Fresh (i, _) -> i let get_id = function - | Existing (n,_) -> Agent.id n - | Fresh (_,i) -> i + | Existing (n, _) -> Agent.id n + | Fresh (_, i) -> i let is_fresh = function | Existing _ -> false | Fresh _ -> true - let concretize ~debugMode (inj_nodes,inj_fresh) = function - | Existing (n,id) -> (get ~debugMode (n,id) inj_nodes,Agent.sort n) - | Fresh (ty,id) -> - match Mods.IntMap.find_option id inj_fresh with - | Some x -> (x,ty) - | None -> raise Not_found + let concretize ~debug_mode (inj_nodes, inj_fresh) = function + | Existing (n, id) -> get ~debug_mode (n, id) inj_nodes, Agent.sort n + | Fresh (ty, id) -> + (match Mods.IntMap.find_option id inj_fresh with + | Some x -> x, ty + | None -> raise Not_found) let to_yojson = function - | Existing (n,ty) -> - ((`Assoc ["Existing", - (`List [`Assoc ["agent",(Agent.to_json n)]; - `Assoc ["type",`Int ty]])]) - :Yojson.Basic.t) - | Fresh (id,ty) -> `Assoc ["Fresh",(`Assoc [ "id",`Int id; "type",`Int ty])] + | Existing (n, ty) -> + (`Assoc + [ + ( "Existing", + `List + [ + `Assoc [ "agent", Agent.to_json n ]; `Assoc [ "type", `Int ty ]; + ] ); + ] + : Yojson.Basic.t) + | Fresh (id, ty) -> + `Assoc [ "Fresh", `Assoc [ "id", `Int id; "type", `Int ty ] ] let of_yojson = function - |`Assoc ["Existing",`List list] -> + | `Assoc [ ("Existing", `List list) ] -> (match list with - | [`Assoc ["agent", a]; `Assoc ["type", `Int ty]] -> - Existing ((Agent.of_json a),ty) - | x::_ -> raise (Yojson.Basic.Util.Type_error ("Invalid agent",x)) - | [] -> raise (Yojson.Basic.Util.Type_error ("Invalid agent",`Null))) - |`Assoc ["Fresh",a] -> + | [ `Assoc [ ("agent", a) ]; `Assoc [ ("type", `Int ty) ] ] -> + Existing (Agent.of_json a, ty) + | x :: _ -> raise (Yojson.Basic.Util.Type_error ("Invalid agent", x)) + | [] -> raise (Yojson.Basic.Util.Type_error ("Invalid agent", `Null))) + | `Assoc [ ("Fresh", a) ] -> (match a with - | `Assoc ["id", `Int id; "type", `Int ty] -> Fresh (id,ty) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent",x))) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent",x)) + | `Assoc [ ("id", `Int id); ("type", `Int ty) ] -> Fresh (id, ty) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent", x)) end diff --git a/core/term/matching.mli b/core/term/matching.mli index 3bf693995b..4b76032801 100644 --- a/core/term/matching.mli +++ b/core/term/matching.mli @@ -13,78 +13,102 @@ type matching = t val empty : t val debug_print : Format.formatter -> t -> unit -val get : debugMode:bool -> (Agent.t * int) -> t -> int +val get : debug_mode:bool -> Agent.t * int -> t -> int val reconstruct_renaming : - debugMode:bool -> Pattern.Env.t -> Edges.t -> Pattern.id -> int -> Renaming.t + debug_mode:bool -> Pattern.Env.t -> Edges.t -> Pattern.id -> int -> Renaming.t (** [reconstruct_renaming domain graph cc root] *) val reconstruct : - debugMode:bool -> Pattern.Env.t -> Edges.t -> - t -> int -> Pattern.id -> int -> t option + debug_mode:bool -> + Pattern.Env.t -> + Edges.t -> + t -> + int -> + Pattern.id -> + int -> + t option (** [reconstruct domain graph matching_of_previous_cc cc_id_in_rule cc root] *) val add_cc : t -> int -> Renaming.t -> t option val is_root_of : - debugMode:bool -> Pattern.Env.t -> Edges.t -> Agent.t -> Pattern.id -> bool + debug_mode:bool -> Pattern.Env.t -> Edges.t -> Agent.t -> Pattern.id -> bool val roots_of : - debugMode:bool -> Pattern.Env.t -> Edges.t -> Pattern.id -> IntCollection.t + debug_mode:bool -> Pattern.Env.t -> Edges.t -> Pattern.id -> IntCollection.t val elements_with_types : Pattern.Env.t -> Pattern.id array -> t -> Agent.t list array type cache + val empty_cache : cache val observables_from_agent : - Pattern.Env.t -> Edges.t -> - (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) -> Agent.t -> - (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) + Pattern.Env.t -> + Edges.t -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache -> + Agent.t -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache (** [observables_from_free domain graph sort agent] the int * int in the return list and the following ones is a Instantiation.concrete *) val observables_from_free : - debugMode:bool -> Pattern.Env.t -> Edges.t -> - (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) -> Agent.t -> - int -> (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) + debug_mode:bool -> + Pattern.Env.t -> + Edges.t -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache -> + Agent.t -> + int -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache (** [observables_from_free domain graph sort agent site] *) val observables_from_internal : - debugMode:bool -> Pattern.Env.t -> Edges.t -> - (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) -> Agent.t -> - int -> int -> (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) + debug_mode:bool -> + Pattern.Env.t -> + Edges.t -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache -> + Agent.t -> + int -> + int -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache (** [observables_from_internal domain graph sort agent site internal_state] *) val observables_from_link : - debugMode:bool -> Pattern.Env.t -> Edges.t -> - (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) -> - Agent.t -> int -> Agent.t -> int -> - (((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache) + debug_mode:bool -> + Pattern.Env.t -> + Edges.t -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache -> + Agent.t -> + int -> + Agent.t -> + int -> + ((Pattern.id * (int * int)) list * Operator.DepSet.t) * cache (** [observables_from_link domain graph sort ag site sort' ag' site'] *) -module Agent: sig +module Agent : sig (** An agent in a connected component *) type t = | Existing of Agent.t * int (* node, cc_id *) | Fresh of int * int (* type, id *) - val rename : debugMode:bool -> int -> Renaming.t -> t -> t + val rename : debug_mode:bool -> int -> Renaming.t -> t -> t val concretize : - debugMode:bool -> (matching * int Mods.IntMap.t) -> t -> int * int + debug_mode:bool -> matching * int Mods.IntMap.t -> t -> int * int val get_type : t -> int val get_id : t -> int val is_fresh : t -> bool - val print : ?sigs:Signature.s -> Format.formatter -> t -> unit val print_site : ?sigs:Signature.s -> t -> Format.formatter -> int -> unit + val print_internal : ?sigs:Signature.s -> t -> int -> Format.formatter -> int -> unit + val to_yojson : t -> Yojson.Basic.t val of_yojson : Yojson.Basic.t -> t end diff --git a/core/term/model.ml b/core/term/model.ml index dbd06ac32d..9722b8161e 100644 --- a/core/term/model.ml +++ b/core/term/model.ml @@ -7,48 +7,61 @@ (******************************************************************************) type t = { - filenames : string list; - domain : Pattern.Env.t; - tokens : unit NamedDecls.t; - algs : (Primitives.alg_expr Locality.annot) NamedDecls.t; - observables : Primitives.alg_expr Locality.annot array; - ast_rules : - (string Locality.annot option * LKappa.rule Locality.annot) - array; - rules : Primitives.elementary_rule array; - interventions : Primitives.perturbation array; - dependencies_in_time : Operator.DepSet.t; - dependencies_in_event : Operator.DepSet.t; - algs_reverse_dependencies : Operator.DepSet.t array; - tokens_reverse_dependencies : Operator.DepSet.t array; - contact_map : Contact_map.t; + filenames: string list; + domain: Pattern.Env.t; + tokens: unit NamedDecls.t; + algs: Primitives.alg_expr Loc.annoted NamedDecls.t; + observables: Primitives.alg_expr Loc.annoted array; + ast_rules: (string Loc.annoted option * LKappa.rule Loc.annoted) array; + rules: Primitives.elementary_rule array; + interventions: Primitives.perturbation array; + dependencies_in_time: Operator.DepSet.t; + dependencies_in_event: Operator.DepSet.t; + algs_reverse_dependencies: Operator.DepSet.t array; + tokens_reverse_dependencies: Operator.DepSet.t array; + contact_map: Contact_map.t; } -let init ~filenames domain tokens algs (deps_in_t,deps_in_e,tok_rd,alg_rd) - (ast_rules,rules) observables interventions contact_map = - { filenames; domain; tokens; ast_rules; rules; algs; observables; - algs_reverse_dependencies = alg_rd; tokens_reverse_dependencies = tok_rd; - dependencies_in_time = deps_in_t; dependencies_in_event = deps_in_e; - interventions; contact_map; +let init ~filenames domain tokens algs (deps_in_t, deps_in_e, tok_rd, alg_rd) + (ast_rules, rules) observables interventions contact_map = + { + filenames; + domain; + tokens; + ast_rules; + rules; + algs; + observables; + algs_reverse_dependencies = alg_rd; + tokens_reverse_dependencies = tok_rd; + dependencies_in_time = deps_in_t; + dependencies_in_event = deps_in_e; + interventions; + contact_map; } let deconstruct env = - (env.filenames, env.domain, env.tokens, env.algs, - (env.dependencies_in_time, env.dependencies_in_event, - env.tokens_reverse_dependencies, env.algs_reverse_dependencies), - (env.ast_rules, env.rules), - env.observables, env.interventions, env.contact_map) + ( env.filenames, + env.domain, + env.tokens, + env.algs, + ( env.dependencies_in_time, + env.dependencies_in_event, + env.tokens_reverse_dependencies, + env.algs_reverse_dependencies ), + (env.ast_rules, env.rules), + env.observables, + env.interventions, + env.contact_map ) let domain env = env.domain let get_obs env = env.observables let get_rules env = env.rules - -let new_domain domain env = {env with domain} +let new_domain domain env = { env with domain } let signatures env = Pattern.Env.signatures env.domain let tokens_finder env = env.tokens.NamedDecls.finder let algs_finder env = env.algs.NamedDecls.finder let contact_map env = env.contact_map - let num_of_agent nme env = Signature.num_of_agent nme (signatures env) let fold_rules f x env = @@ -58,53 +71,55 @@ let fold_perturbations f x env = Tools.array_fold_lefti (fun i x p -> f i x p) x env.interventions let get_rule env i = env.rules.(i) - -let get_ast_rule_with_label env i = env.ast_rules.(i-1) - -let get_ast_rule env i = - fst (snd (get_ast_rule_with_label env i)) +let get_ast_rule_with_label env i = env.ast_rules.(i - 1) +let get_ast_rule env i = fst (snd (get_ast_rule_with_label env i)) let fold_ast_rules f x env = - Tools.array_fold_lefti (fun i x (_, _rule) -> - let lkappa_rule = get_ast_rule env i in - f i x lkappa_rule - ) x env.ast_rules + Tools.array_fold_lefti + (fun i x (_, _rule) -> + let lkappa_rule = get_ast_rule env i in + f i x lkappa_rule) + x env.ast_rules let get_ast_rule_rate_pos ~unary env i = - if unary then - match (fst (snd (env.ast_rules.(i-1)))).LKappa.r_un_rate with + if unary then ( + match (fst (snd env.ast_rules.(i - 1))).LKappa.r_un_rate with | None -> failwith "No unary rate to get position of" - | Some ((_,pos),_) -> pos - else snd (fst (snd (env.ast_rules.(i-1)))).LKappa.r_rate + | Some ((_, pos), _) -> pos + ) else + snd (fst (snd env.ast_rules.(i - 1))).LKappa.r_rate let nb_rules env = Array.length env.rules let nums_of_rule name env = fold_rules (fun i acc r -> - match env.ast_rules.(pred r.Primitives.syntactic_rule) with - | Some (x,_), _ -> if x = name then i::acc else acc - | None, _ -> acc) + match env.ast_rules.(pred r.Primitives.syntactic_rule) with + | Some (x, _), _ -> + if x = name then + i :: acc + else + acc + | None, _ -> acc) [] env let nb_syntactic_rules env = Array.length env.ast_rules - let num_of_alg s env = NamedDecls.elt_id ~kind:"variable" env.algs s -let get_alg env i = fst @@ snd env.algs.NamedDecls.decls.(i) +let get_alg env i = fst @@ NamedDecls.elt_val env.algs i let get_algs env = env.algs.NamedDecls.decls let nb_algs env = NamedDecls.size env.algs - let num_of_token str env = NamedDecls.elt_id ~kind:"token" env.tokens str let nb_tokens env = NamedDecls.size env.tokens - let get_perturbation env i = env.interventions.(i) let nb_perturbations env = Array.length env.interventions - let get_alg_reverse_dependencies env i = env.algs_reverse_dependencies.(i) let get_token_reverse_dependencies env i = env.tokens_reverse_dependencies.(i) + let all_dependencies env = - (env.dependencies_in_time,env.dependencies_in_event, - env.tokens_reverse_dependencies,env.algs_reverse_dependencies) + ( env.dependencies_in_time, + env.dependencies_in_event, + env.tokens_reverse_dependencies, + env.algs_reverse_dependencies ) let print_agent ?env f i = match env with @@ -124,21 +139,22 @@ let print_alg ?env f id = let print_token ?env f id = match env with | None -> Format.fprintf f "__token_%i" id - | Some env -> - Format.fprintf f "%s" (NamedDecls.elt_name env.tokens id) + | Some env -> Format.fprintf f "%s" (NamedDecls.elt_name env.tokens id) let print_ast_rule ~noCounters ?env f i = match env with | None -> Format.fprintf f "__ast_rule_%i" i | Some env -> let sigs = signatures env in - if i = 0 then Format.pp_print_string f "Interventions" - else + if i = 0 then + Format.pp_print_string f "Interventions" + else ( match env.ast_rules.(pred i) with - | (Some (na,_),_) -> Format.pp_print_string f na - | (None,(r,_)) -> - LKappa.print_rule ~noCounters ~full:false sigs - (print_token ~env) (print_alg ~env) f r + | Some (na, _), _ -> Format.pp_print_string f na + | None, (r, _) -> + LKappa.print_rule ~noCounters ~full:false sigs (print_token ~env) + (print_alg ~env) f r + ) let print_rule ~noCounters ?env f id = match env with @@ -146,44 +162,41 @@ let print_rule ~noCounters ?env f id = | Some env -> print_ast_rule ~noCounters ~env f env.rules.(id).Primitives.syntactic_rule -let map_observables f env = - Array.map (fun (x,_) -> f x) env.observables +let map_observables f env = Array.map (fun (x, _) -> f x) env.observables let print_kappa ~noCounters pr_alg ?pr_rule pr_pert f env = let sigs = signatures env in - Format.fprintf - f "@[%a@,%a%t@,%a%t%a@,%t%t%a@]" - (Contact_map.print_kappa ~noCounters sigs) env.contact_map - (NamedDecls.print - ~sep:Pp.space (fun _ n f () -> Format.fprintf f "%%token: %s" n)) + Format.fprintf f "@[%a@,%a%t@,%a%t%a@,%t%t%a@]" + (Contact_map.print_kappa ~noCounters sigs) + env.contact_map + (NamedDecls.print ~sep:Pp.space (fun _ n f () -> + Format.fprintf f "%%token: %s" n)) env.tokens (fun f -> if env.tokens.NamedDecls.decls <> [||] then Pp.space f) - (NamedDecls.print - ~sep:Pp.space - (fun i n f (e,_) -> - Format.fprintf f "@[%%var:/*%i*/ '%s' %a@]" i n (pr_alg env) e)) + (NamedDecls.print ~sep:Pp.space (fun i n f (e, _) -> + Format.fprintf f "@[%%var:/*%i*/ '%s' %a@]" i n (pr_alg env) e)) env.algs (fun f -> if env.algs.NamedDecls.decls <> [||] then Pp.space f) - (Pp.array Pp.space ~trailing:Pp.space - (fun _ f (e,_) -> Format.fprintf f "@[%%plot: %a@]" (pr_alg env) e)) + (Pp.array Pp.space ~trailing:Pp.space (fun _ f (e, _) -> + Format.fprintf f "@[%%plot: %a@]" (pr_alg env) e)) env.observables (fun f -> - match pr_rule with - | None -> - Pp.array Pp.space ~trailing:Pp.space - (fun _ f (na,(e,_)) -> - Format.fprintf f "%a%a" - (Pp.option ~with_space:false - (fun f (na,_) -> Format.fprintf f "'%s' " na)) na - (LKappa.print_rule - ~noCounters ~full:true - sigs (print_token ~env) (print_alg ~env)) - e) - f env.ast_rules - | Some pr_rule -> - Pp.array Pp.space ~trailing:Pp.space - (fun _ f r -> Format.fprintf f "@[<2>%a@]" (pr_rule env) r) - f env.rules) + match pr_rule with + | None -> + Pp.array Pp.space ~trailing:Pp.space + (fun _ f (na, (e, _)) -> + Format.fprintf f "%a%a" + (Pp.option ~with_space:false (fun f (na, _) -> + Format.fprintf f "'%s' " na)) + na + (LKappa.print_rule ~noCounters ~full:true sigs (print_token ~env) + (print_alg ~env)) + e) + f env.ast_rules + | Some pr_rule -> + Pp.array Pp.space ~trailing:Pp.space + (fun _ f r -> Format.fprintf f "@[<2>%a@]" (pr_rule env) r) + f env.rules) (fun f -> if env.interventions <> [||] then Pp.space f) (Pp.array Pp.space (fun i f p -> Format.fprintf f "@[/*%i*/%a@]" i (pr_pert env) p)) @@ -191,60 +204,74 @@ let print_kappa ~noCounters pr_alg ?pr_rule pr_pert f env = let print ~noCounters pr_alg pr_rule pr_pert f env = let () = print_kappa ~noCounters pr_alg pr_pert f env in - Format.fprintf - f "@,@[@[Rules:@,%a@]@]" - (Pp.array Pp.space - (fun i f r -> Format.fprintf f "@[<2>%i:@ %a@]" i (pr_rule env) r)) + Format.fprintf f "@,@[@[Rules:@,%a@]@]" + (Pp.array Pp.space (fun i f r -> + Format.fprintf f "@[<2>%i:@ %a@]" i (pr_rule env) r)) env.rules let check_if_counter_is_filled_enough x = - if not @@ - Primitives.exists_modification - (function Primitives.STOP _ -> true - | (Primitives.ITER_RULE _ | Primitives.UPDATE _ | - Primitives.SNAPSHOT _ | Primitives.CFLOW _ | - Primitives.DIN _ | Primitives.DINOFF _ | - Primitives.CFLOWOFF _ | Primitives.PLOTENTRY | - Primitives.PRINT _ | Primitives.SPECIES _ | - Primitives.SPECIES_OFF _ ) -> false) x.interventions then - raise (ExceptionDefn.Malformed_Decl - (Locality.dummy_annot - "There is no way for the simulation to stop.")) + if + not + @@ Primitives.exists_modification + (function + | Primitives.STOP _ -> true + | Primitives.ITER_RULE _ | Primitives.UPDATE _ + | Primitives.SNAPSHOT _ | Primitives.CFLOW _ | Primitives.DIN _ + | Primitives.DINOFF _ | Primitives.CFLOWOFF _ | Primitives.PLOTENTRY + | Primitives.PRINT _ | Primitives.SPECIES _ + | Primitives.SPECIES_OFF _ -> + false) + x.interventions + then + raise + (ExceptionDefn.Malformed_Decl + (Loc.annot_with_dummy "There is no way for the simulation to stop.")) let overwrite_vars alg_overwrite env = let algs' = - Array.map (fun (x,y) -> (Locality.dummy_annot x,y)) - env.algs.NamedDecls.decls in - let () = List.iter (fun (i,v) -> - algs'.(i) <- (fst algs'.(i),Locality.dummy_annot v)) alg_overwrite in + Array.map + (fun (x, y) -> Loc.annot_with_dummy x, y) + env.algs.NamedDecls.decls + in + let () = + List.iter + (fun (i, v) -> algs'.(i) <- fst algs'.(i), Loc.annot_with_dummy v) + alg_overwrite + in { env with algs = NamedDecls.create algs' } let fold_alg_expr f_alg f_bool x env = - let x1 = Array.fold_left - (fun acc (_,y) -> f_alg acc y) x env.algs.NamedDecls.decls in + let x1 = + Array.fold_left (fun acc (_, y) -> f_alg acc y) x env.algs.NamedDecls.decls + in let x2 = Array.fold_left f_alg x1 env.observables in - let x3 = - Array.fold_left (Primitives.fold_expr_rule f_alg) x2 env.rules in + let x3 = Array.fold_left (Primitives.fold_expr_rule f_alg) x2 env.rules in Array.fold_left - (Primitives.fold_expr_perturbation f_alg f_bool) x3 env.interventions + (Primitives.fold_expr_perturbation f_alg f_bool) + x3 env.interventions let fold_mixture_in_expr f = fold_alg_expr (Alg_expr.fold_on_mixture f) (Alg_expr.fold_bool_on_mixture f) -let propagate_constant - ~warning ?max_time ?max_events updated_vars alg_overwrite x = +let propagate_constant ~warning ?max_time ?max_events ~updated_vars + ~alg_overwrite x = let algs' = - Array.map (fun (x,y) -> (Locality.dummy_annot x,y)) - x.algs.NamedDecls.decls in - let () = List.iter (fun (i,v) -> - algs'.(i) <- (fst algs'.(i),Locality.dummy_annot v)) alg_overwrite in + Array.map (fun (x, y) -> Loc.annot_with_dummy x, y) x.algs.NamedDecls.decls + in + let () = + List.iter + (fun (i, v) -> algs'.(i) <- fst algs'.(i), Loc.annot_with_dummy v) + alg_overwrite + in let () = Array.iteri - (fun i (na,v) -> - algs'.(i) <- - (na,Alg_expr.propagate_constant - ~warning ?max_time ?max_events updated_vars algs' v)) - algs' in + (fun i (na, v) -> + algs'.(i) <- + ( na, + Alg_expr.propagate_constant ~warning ?max_time ?max_events + ~updated_vars ~vars:algs' v )) + algs' + in { filenames = x.filenames; domain = x.domain; @@ -252,21 +279,23 @@ let propagate_constant algs = NamedDecls.create algs'; observables = Array.map - (Alg_expr.propagate_constant - ~warning ?max_time ?max_events updated_vars algs') x.observables; + (Alg_expr.propagate_constant ~warning ?max_time ?max_events + ~updated_vars ~vars:algs') + x.observables; ast_rules = x.ast_rules; rules = Array.map (Primitives.map_expr_rule - (Alg_expr.propagate_constant - ~warning ?max_time ?max_events updated_vars algs')) x.rules; + (Alg_expr.propagate_constant ~warning ?max_time ?max_events + ~updated_vars ~vars:algs')) + x.rules; interventions = Array.map (Primitives.map_expr_perturbation - (Alg_expr.propagate_constant - ~warning ?max_time ?max_events updated_vars algs') - (Alg_expr.propagate_constant_bool - ~warning ?max_time ?max_events updated_vars algs')) + (Alg_expr.propagate_constant ~warning ?max_time ?max_events + ~updated_vars ~vars:algs') + (Alg_expr.propagate_constant_bool ~warning ?max_time ?max_events + ~updated_vars ~vars:algs')) x.interventions; dependencies_in_time = x.dependencies_in_time; dependencies_in_event = x.dependencies_in_event; @@ -280,122 +309,146 @@ let kappa_instance_to_yojson = let to_yojson env = let files = - Array.of_list (Lexing.dummy_pos.Lexing.pos_fname::env.filenames) in + Array.of_list (Lexing.dummy_pos.Lexing.pos_fname :: env.filenames) + in let filenames = Tools.array_fold_lefti (fun i map x -> Mods.StringMap.add x i map) - Mods.StringMap.empty files in - `Assoc [ - "filenames", JsonUtil.of_array JsonUtil.of_string files; - "update", Pattern.Env.to_yojson (domain env); - "tokens", NamedDecls.to_json (fun () -> `Null) env.tokens; - "algs", NamedDecls.to_json - (fun (x,_) -> - Alg_expr.e_to_yojson - ~filenames kappa_instance_to_yojson JsonUtil.of_int x) - env.algs; - "observables", - `List - (Array.fold_right - (fun (x,_) l -> - Alg_expr.e_to_yojson - ~filenames kappa_instance_to_yojson JsonUtil.of_int x :: l) - env.observables []); - "ast_rules", - `List - (Array.fold_right (fun (n,(r,_)) l -> - `List [(match n with None -> `Null | Some (n,_) -> `String n); - LKappa.rule_to_json ~filenames r]::l) env.ast_rules []); - "elementary_rules", - JsonUtil.of_array (Primitives.rule_to_yojson ~filenames) env.rules; - "contact_map", Contact_map.to_yojson (env.contact_map); - "interventions", - JsonUtil.of_array - (Primitives.perturbation_to_yojson ~filenames) env.interventions; - "dependencies_in_time", Operator.depset_to_yojson env.dependencies_in_time; - "dependencies_in_event", Operator.depset_to_yojson env.dependencies_in_event; - "algs_reverse_dependencies", - JsonUtil.of_array Operator.depset_to_yojson env.algs_reverse_dependencies; - "tokens_reverse_dependencies", - JsonUtil.of_array Operator.depset_to_yojson env.tokens_reverse_dependencies; - ] + Mods.StringMap.empty files + in + `Assoc + [ + "filenames", JsonUtil.of_array JsonUtil.of_string files; + "update", Pattern.Env.to_yojson (domain env); + "tokens", NamedDecls.to_json (fun () -> `Null) env.tokens; + ( "algs", + NamedDecls.to_json + (fun (x, _) -> + Alg_expr.e_to_yojson ~filenames kappa_instance_to_yojson + JsonUtil.of_int x) + env.algs ); + ( "observables", + `List + (Array.fold_right + (fun (x, _) l -> + Alg_expr.e_to_yojson ~filenames kappa_instance_to_yojson + JsonUtil.of_int x + :: l) + env.observables []) ); + ( "ast_rules", + `List + (Array.fold_right + (fun (n, (r, _)) l -> + `List + [ + (match n with + | None -> `Null + | Some (n, _) -> `String n); + LKappa.rule_to_json ~filenames r; + ] + :: l) + env.ast_rules []) ); + ( "elementary_rules", + JsonUtil.of_array (Primitives.rule_to_yojson ~filenames) env.rules ); + "contact_map", Contact_map.to_yojson env.contact_map; + ( "interventions", + JsonUtil.of_array + (Primitives.perturbation_to_yojson ~filenames) + env.interventions ); + "dependencies_in_time", Operator.depset_to_yojson env.dependencies_in_time; + ( "dependencies_in_event", + Operator.depset_to_yojson env.dependencies_in_event ); + ( "algs_reverse_dependencies", + JsonUtil.of_array Operator.depset_to_yojson + env.algs_reverse_dependencies ); + ( "tokens_reverse_dependencies", + JsonUtil.of_array Operator.depset_to_yojson + env.tokens_reverse_dependencies ); + ] let kappa_instance_of_yojson = JsonUtil.to_list (JsonUtil.to_array Pattern.id_of_yojson) let of_yojson = function | `Assoc l as x when List.length l = 13 -> - begin - try - let filenames = - JsonUtil.to_array (JsonUtil.to_string ?error_msg:None) - (List.assoc "filenames" l) in { - filenames = List.tl (Array.to_list filenames); - domain = Pattern.Env.of_yojson (List.assoc "update" l); - tokens = NamedDecls.of_json (fun _ -> ()) (List.assoc "tokens" l); - algs = NamedDecls.of_json - (fun x -> Locality.dummy_annot - (Alg_expr.e_of_yojson - ~filenames kappa_instance_of_yojson - (JsonUtil.to_int ?error_msg:None) x)) - (List.assoc "algs" l); - observables = (match List.assoc "observables" l with - | `List o -> - Tools.array_map_of_list - (fun x -> Locality.dummy_annot - (Alg_expr.e_of_yojson - ~filenames kappa_instance_of_yojson - (JsonUtil.to_int ?error_msg:None) x)) o - | `Null -> [||] - | _ -> raise Not_found); - ast_rules = (match List.assoc "ast_rules" l with - | `List o -> - Tools.array_map_of_list - (function - | `List [`Null;r]-> - (None, Locality.dummy_annot - (LKappa.rule_of_json ~filenames r)) - | `List [`String n;r]-> - (Some (Locality.dummy_annot n), - Locality.dummy_annot (LKappa.rule_of_json ~filenames r)) - | _ -> raise Not_found) o - | `Null -> [||] - | _ -> raise Not_found); - rules = (match (List.assoc "elementary_rules" l) with - | `List o -> - Tools.array_map_of_list - (Primitives.rule_of_yojson ~filenames) o - | _ -> raise Not_found); - interventions = - JsonUtil.to_array - (Primitives.perturbation_of_yojson ~filenames) - (Yojson.Basic.Util.member "interventions" x); - dependencies_in_time = - Operator.depset_of_yojson - (Yojson.Basic.Util.member "dependencies_in_time" x); - dependencies_in_event = - Operator.depset_of_yojson - (Yojson.Basic.Util.member "dependencies_in_event" x); - algs_reverse_dependencies = - JsonUtil.to_array Operator.depset_of_yojson - (Yojson.Basic.Util.member "algs_reverse_dependencies" x); - tokens_reverse_dependencies = - JsonUtil.to_array Operator.depset_of_yojson - (Yojson.Basic.Util.member "tokens_reverse_dependencies" x); - contact_map = Contact_map.of_yojson (List.assoc "contact_map" l); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct environment",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct environment",x)) + (try + let filenames = + JsonUtil.to_array + (JsonUtil.to_string ?error_msg:None) + (List.assoc "filenames" l) + in + { + filenames = List.tl (Array.to_list filenames); + domain = Pattern.Env.of_yojson (List.assoc "update" l); + tokens = NamedDecls.of_json (fun _ -> ()) (List.assoc "tokens" l); + algs = + NamedDecls.of_json + (fun x -> + Loc.annot_with_dummy + (Alg_expr.e_of_yojson ~filenames kappa_instance_of_yojson + (JsonUtil.to_int ?error_msg:None) + x)) + (List.assoc "algs" l); + observables = + (match List.assoc "observables" l with + | `List o -> + Tools.array_map_of_list + (fun x -> + Loc.annot_with_dummy + (Alg_expr.e_of_yojson ~filenames kappa_instance_of_yojson + (JsonUtil.to_int ?error_msg:None) + x)) + o + | `Null -> [||] + | _ -> raise Not_found); + ast_rules = + (match List.assoc "ast_rules" l with + | `List o -> + Tools.array_map_of_list + (function + | `List [ `Null; r ] -> + None, Loc.annot_with_dummy (LKappa.rule_of_json ~filenames r) + | `List [ `String n; r ] -> + ( Some (Loc.annot_with_dummy n), + Loc.annot_with_dummy (LKappa.rule_of_json ~filenames r) ) + | _ -> raise Not_found) + o + | `Null -> [||] + | _ -> raise Not_found); + rules = + (match List.assoc "elementary_rules" l with + | `List o -> + Tools.array_map_of_list (Primitives.rule_of_yojson ~filenames) o + | _ -> raise Not_found); + interventions = + JsonUtil.to_array + (Primitives.perturbation_of_yojson ~filenames) + (Yojson.Basic.Util.member "interventions" x); + dependencies_in_time = + Operator.depset_of_yojson + (Yojson.Basic.Util.member "dependencies_in_time" x); + dependencies_in_event = + Operator.depset_of_yojson + (Yojson.Basic.Util.member "dependencies_in_event" x); + algs_reverse_dependencies = + JsonUtil.to_array Operator.depset_of_yojson + (Yojson.Basic.Util.member "algs_reverse_dependencies" x); + tokens_reverse_dependencies = + JsonUtil.to_array Operator.depset_of_yojson + (Yojson.Basic.Util.member "tokens_reverse_dependencies" x); + contact_map = Contact_map.of_yojson (List.assoc "contact_map" l); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct environment", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct environment", x)) let unary_patterns env = fold_rules (fun _ acc r -> - match r.Primitives.unary_rate with - | None -> acc - | Some _ -> - Pattern.Set.add - r.Primitives.connected_components.(0) - (Pattern.Set.add r.Primitives.connected_components.(1) acc) - ) Pattern.Set.empty env + match r.Primitives.unary_rate with + | None -> acc + | Some _ -> + Pattern.Set.add + r.Primitives.connected_components.(0) + (Pattern.Set.add r.Primitives.connected_components.(1) acc)) + Pattern.Set.empty env diff --git a/core/term/model.mli b/core/term/model.mli index 698c457dae..eb088df0f0 100644 --- a/core/term/model.mli +++ b/core/term/model.mli @@ -11,54 +11,64 @@ type t val init : - filenames : string list -> Pattern.Env.t -> unit NamedDecls.t -> - Primitives.alg_expr Locality.annot NamedDecls.t -> - (Operator.DepSet.t * Operator.DepSet.t * - Operator.DepSet.t array * Operator.DepSet.t array) -> - ((string Locality.annot option * LKappa.rule Locality.annot) array * - Primitives.elementary_rule array) -> - Primitives.alg_expr Locality.annot array -> Primitives.perturbation array -> - Contact_map.t -> t + filenames:string list -> + Pattern.Env.t -> + unit NamedDecls.t -> + Primitives.alg_expr Loc.annoted NamedDecls.t -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array -> + (string Loc.annoted option * LKappa.rule Loc.annoted) array + * Primitives.elementary_rule array -> + Primitives.alg_expr Loc.annoted array -> + Primitives.perturbation array -> + Contact_map.t -> + t (** [init sigs tokens algs dependencies (ast_rules,rules) obs perts] *) - val deconstruct : t -> - string list * Pattern.Env.t * unit NamedDecls.t * - Primitives.alg_expr Locality.annot NamedDecls.t * - (Operator.DepSet.t * Operator.DepSet.t * - Operator.DepSet.t array * Operator.DepSet.t array) * - ((string Locality.annot option * LKappa.rule Locality.annot) array * - Primitives.elementary_rule array) * - Primitives.alg_expr Locality.annot array * Primitives.perturbation array * - Contact_map.t + string list + * Pattern.Env.t + * unit NamedDecls.t + * Primitives.alg_expr Loc.annoted NamedDecls.t + * (Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array) + * ((string Loc.annoted option * LKappa.rule Loc.annoted) array + * Primitives.elementary_rule array) + * Primitives.alg_expr Loc.annoted array + * Primitives.perturbation array + * Contact_map.t val nb_tokens : t -> int val nb_algs : t -> int val nb_rules : t -> int val nb_syntactic_rules : t -> int val nb_perturbations : t -> int - val domain : t -> Pattern.Env.t -val get_obs : t -> Primitives.alg_expr Locality.annot array +val get_obs : t -> Primitives.alg_expr Loc.annoted array val get_rules : t -> Primitives.elementary_rule array - val new_domain : Pattern.Env.t -> t -> t val signatures : t -> Signature.s val tokens_finder : t -> int Mods.StringMap.t val algs_finder : t -> int Mods.StringMap.t val contact_map : t -> Contact_map.t - val get_alg : t -> int -> Primitives.alg_expr -val get_algs : t -> (string * Primitives.alg_expr Locality.annot) array +val get_algs : t -> (string * Primitives.alg_expr Loc.annoted) array val get_perturbation : t -> int -> Primitives.perturbation val get_rule : t -> int -> Primitives.elementary_rule -val get_ast_rule: t -> int -> LKappa.rule -val get_ast_rule_with_label: t -> int -> - (string Locality.annot option * LKappa.rule Locality.annot) -val get_ast_rule_rate_pos: unary:bool -> t -> int -> Locality.t +val get_ast_rule : t -> int -> LKappa.rule + +val get_ast_rule_with_label : + t -> int -> string Loc.annoted option * LKappa.rule Loc.annoted + +val get_ast_rule_rate_pos : unary:bool -> t -> int -> Loc.t val map_observables : (Primitives.alg_expr -> 'a) -> t -> 'a array + val fold_rules : (int -> 'a -> Primitives.elementary_rule -> 'a) -> 'a -> t -> 'a @@ -69,21 +79,24 @@ val fold_perturbations : val get_alg_reverse_dependencies : t -> int -> Operator.DepSet.t val get_token_reverse_dependencies : t -> int -> Operator.DepSet.t -val all_dependencies : - t -> (Operator.DepSet.t * Operator.DepSet.t * - Operator.DepSet.t array * Operator.DepSet.t array) -val num_of_agent : string Locality.annot -> t -> int -val num_of_alg : string Locality.annot -> t -> int -val num_of_token : string Locality.annot -> t -> int +val all_dependencies : + t -> + Operator.DepSet.t + * Operator.DepSet.t + * Operator.DepSet.t array + * Operator.DepSet.t array + +val num_of_agent : string Loc.annoted -> t -> int +val num_of_alg : string Loc.annoted -> t -> int +val num_of_token : string Loc.annoted -> t -> int val nums_of_rule : string -> t -> int list val print_ast_rule : noCounters:bool -> ?env:t -> Format.formatter -> int -> unit (** The int is the ast_rule_id *) -val print_rule : - noCounters:bool -> ?env:t -> Format.formatter -> int -> unit +val print_rule : noCounters:bool -> ?env:t -> Format.formatter -> int -> unit (** Same as above but the int is this time the rule_id *) val print_agent : ?env:t -> Format.formatter -> int -> unit @@ -91,29 +104,37 @@ val print_alg : ?env:t -> Format.formatter -> int -> unit val print_token : ?env:t -> Format.formatter -> int -> unit val print : - noCounters:bool -> (t -> Format.formatter -> Primitives.alg_expr -> unit) -> + noCounters:bool -> + (t -> Format.formatter -> Primitives.alg_expr -> unit) -> (t -> Format.formatter -> Primitives.elementary_rule -> unit) -> (t -> Format.formatter -> Primitives.perturbation -> unit) -> - Format.formatter -> t -> unit + Format.formatter -> + t -> + unit val print_kappa : - noCounters:bool -> (t -> Format.formatter -> Primitives.alg_expr -> unit) -> + noCounters:bool -> + (t -> Format.formatter -> Primitives.alg_expr -> unit) -> ?pr_rule:(t -> Format.formatter -> Primitives.elementary_rule -> unit) -> (t -> Format.formatter -> Primitives.perturbation -> unit) -> - Format.formatter -> t -> unit + Format.formatter -> + t -> + unit val to_yojson : t -> Yojson.Basic.t val of_yojson : Yojson.Basic.t -> t - val check_if_counter_is_filled_enough : t -> unit val overwrite_vars : (int * Primitives.alg_expr) list -> t -> t + val propagate_constant : - warning:(pos:Locality.t -> (Format.formatter -> unit) -> unit) -> - ?max_time:float -> ?max_events:int -> - int list -> (int * Primitives.alg_expr) list -> t -> t + warning:(pos:Loc.t -> (Format.formatter -> unit) -> unit) -> + ?max_time:float -> + ?max_events:int -> + updated_vars:int list -> + alg_overwrite:(int * Primitives.alg_expr) list -> + t -> + t (** [propagate_constant updated_vars overwrite_vars env] *) -val fold_mixture_in_expr : - ('a -> Pattern.id array list -> 'a) -> 'a -> t -> 'a - +val fold_mixture_in_expr : ('a -> Pattern.id array list -> 'a) -> 'a -> t -> 'a val unary_patterns : t -> Pattern.Set.t diff --git a/core/term/pattern.ml b/core/term/pattern.ml index 1d6e5b6ee0..f664204ee6 100644 --- a/core/term/pattern.ml +++ b/core/term/pattern.ml @@ -12,8 +12,7 @@ let sharing_level_of_yojson = function | `String "no_sharing" -> No_sharing | `String "compatible_patterns" -> Compatible_patterns | `String "max_sharing" -> Max_sharing - | x -> raise - (Yojson.Basic.Util.Type_error ("Incorrect sharing_level",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect sharing_level", x)) let write_sharing_level ob = function | No_sharing -> Yojson.Basic.write_string ob "no_sharing" @@ -31,82 +30,85 @@ let read_sharing_level p lb = let sharing_level_of_string s = read_sharing_level (Yojson.Safe.init_lexer ()) (Lexing.from_string s) +type link = UnSpec | Free | Link of int * int (** node_id, site_id *) -type link = UnSpec | Free | Link of int * int (** node_id, site_id *) - +type cc = { + nodes_by_type: int list array; + nodes: (link * int) array Mods.IntMap.t; + (*pattern graph id -> [|... (link_j,state_j)...|] i.e agent_id on site_j has + a link link_j and internal state state_j (-1 means any) *) + recogn_nav: Navigation.abstract Navigation.t; +} (** The link of site k of node i is [fst nodes(i).(k)]. The internal state of site k of node i is [snd nodes(i).(k)]. A negative number means UnSpec. *) -type cc = - { - nodes_by_type: int list array; - nodes: (link * int) array Mods.IntMap.t; - (*pattern graph id -> [|... (link_j,state_j)...|] i.e agent_id on site_j has - a link link_j and internal state state_j (-1 means any) *) - recogn_nav: Navigation.abstract Navigation.t; - } type t = cc - type id = int let debug_print_id fmt id = Format.fprintf fmt "%d" id - let size_of_cc cc = Mods.IntMap.size cc.nodes - let compare_canonicals cc cc' = Mods.int_compare cc cc' - let is_equal_canonicals cc cc' = compare_canonicals cc cc' = 0 - let hash_prime = 29 let coarse_hash cc = let plus_internal acc s i = - if i < 0 then acc else Tools.cantor_pairing (succ s) (succ i) + acc in + if i < 0 then + acc + else + Tools.cantor_pairing (succ s) (succ i) + acc + in let node_shape = Mods.IntMap.fold (fun n e acc -> - Tools.array_fold_lefti - (fun s acc -> function - | UnSpec, i -> plus_internal acc s i - | Free, i -> plus_internal (3 + s*3 + acc) s i - | Link (n',s'), i -> - let acc' = plus_internal acc s i in - let extra = Tools.cantor_pairing (1+min s s') (1+max s s') in - if (n = n' && s < s') || n < n' then extra * 7 + acc' else acc') - acc e) - cc.nodes 0 in + Tools.array_fold_lefti + (fun s acc -> function + | UnSpec, i -> plus_internal acc s i + | Free, i -> plus_internal (3 + (s * 3) + acc) s i + | Link (n', s'), i -> + let acc' = plus_internal acc s i in + let extra = Tools.cantor_pairing (1 + min s s') (1 + max s s') in + if (n = n' && s < s') || n < n' then + (extra * 7) + acc' + else + acc') + acc e) + cc.nodes 0 + in Array.fold_right - (fun l acc -> List.length l + hash_prime * acc) + (fun l acc -> List.length l + (hash_prime * acc)) cc.nodes_by_type node_shape let id_to_yojson cc = `Int cc let id_of_yojson = function | `Int cc -> cc - | x -> - raise (Yojson.Basic.Util.Type_error ("Not a pattern id",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a pattern id", x)) module Set = Mods.IntSet - module Map = Mods.IntMap module ObsMap = struct include Mods.DynArray + let dummy x = make 0 x end let empty_cc sigs = let nbt = Array.make (Signature.size sigs) [] in - {nodes_by_type = nbt; recogn_nav = []; - nodes = Mods.IntMap.empty;} + { nodes_by_type = nbt; recogn_nav = []; nodes = Mods.IntMap.empty } let raw_find_ty tys id = let rec aux i = assert (i >= 0); - if List.mem id tys.(i) then i else aux (pred i) - in aux (Array.length tys - 1) + if List.mem id tys.(i) then + i + else + aux (pred i) + in + aux (Array.length tys - 1) let find_ty cc id = raw_find_ty cc.nodes_by_type id @@ -119,18 +121,19 @@ let reconstruction_navigation cc = cc.recogn_nav (** Errors *) let already_specified ?sigs x i = ExceptionDefn.Malformed_Decl - (Locality.dummy_annot + (Loc.annot_with_dummy (Format.asprintf "Site %a of agent %a already specified" (Agent.print_site ?sigs x) i - (Agent.print ?sigs ~with_id:false) x)) + (Agent.print ?sigs ~with_id:false) + x)) let dangling_node ~sigs tys x = ExceptionDefn.Malformed_Decl - (Locality.dummy_annot - (Format.asprintf - "Cannot proceed because last declared agent %a/*%i*/%a" - (Signature.print_agent sigs) (raw_find_ty tys x) x - Format.pp_print_string " is not linked to its connected component.")) + (Loc.annot_with_dummy + (Format.asprintf "Cannot proceed because last declared agent %a/*%i*/%a" + (Signature.print_agent sigs) + (raw_find_ty tys x) x Format.pp_print_string + " is not linked to its connected component.")) let identity_injection cc = Renaming.identity @@ -140,477 +143,640 @@ let identity_injection cc = In this case pick the first node of smallest type *) let raw_find_root nodes_by_type = let rec aux ty = - if ty = Array.length nodes_by_type - then None - else match nodes_by_type.(ty) with + if ty = Array.length nodes_by_type then + None + else ( + match nodes_by_type.(ty) with | [] -> aux (succ ty) - | h::_ -> Some(h,ty) - in aux 0 + | h :: _ -> Some (h, ty) + ) + in + aux 0 let find_root cc = raw_find_root cc.nodes_by_type let weight cc = - let links,double = + let links, double = Mods.IntMap.fold (fun _ -> - Array.fold_right - (fun (i,s) (l,d) -> if i <> UnSpec then - (succ (if s <> -1 then succ l else l), - if i <> Free then succ d else d) - else ((if s <> -1 then succ l else l),d))) - cc.nodes (0,0) in - (links - double/2) - -let are_compatible ~debugMode ?possibilities ~strict root1 cc1 root2 cc2 = + Array.fold_right (fun (i, s) (l, d) -> + if i <> UnSpec then + ( succ + (if s <> -1 then + succ l + else + l), + if i <> Free then + succ d + else + d ) + else + ( (if s <> -1 then + succ l + else + l), + d ))) + cc.nodes (0, 0) + in + links - (double / 2) + +let are_compatible ~debug_mode ?possibilities ~strict root1 cc1 root2 cc2 = let tick x = match possibilities with | None -> () - | Some s -> s := Mods.Int2Set.remove x !s in + | Some s -> s := Mods.Int2Set.remove x !s + in let rec aux at_least_one_edge rename = function - | [] -> if at_least_one_edge then (Some rename,None) else (None,None) - | (o,p as pair)::todos -> + | [] -> + if at_least_one_edge then + Some rename, None + else + None, None + | ((o, p) as pair) :: todos -> let () = tick pair in - match Tools.array_fold_left2i - (fun i c (lx,ix) (ly,iy) -> - match c with - | (None,_) -> c - | (Some (one_edge,todo,ren),_) -> - if ((not strict && (ix = -1||iy = -1)) || ix = iy) then - match lx, ly with - | (Link _, Free| Free, Link _) -> - (None,Some (cc1,o,cc2,p,i,false)) - | (UnSpec, Free| Free, UnSpec - | Link _, UnSpec |UnSpec, Link _) -> - if strict then - (None,Some (cc1,o,cc2,p,i,false)) - else - (Some (one_edge || (ix <> -1 && ix = iy),todo,ren),None) - | UnSpec, UnSpec -> - (Some (one_edge || (ix <> -1 && ix = iy),todo,ren),None) - | Free, Free -> (Some (true,todo,ren),None) - | Link (n1,s1), Link (n2,s2) -> - if s1 = s2 then - if Renaming.mem n1 ren then - if Renaming.apply ~debugMode ren n1 = n2 - then (Some (true,todo,ren),None) - else - (None,Some (cc1,o,cc2,p,i,false)) - else match Renaming.add ~debugMode n1 n2 ren with - | None -> - (None,Some (cc1,o,cc2,p,i,false)) - | Some r' -> - if find_ty cc1 n1 = find_ty cc2 n2 - then (Some (true,(n1,n2)::todo,r'),None) - else - (None,Some (cc1,o,cc2,p,i,false)) + (match + Tools.array_fold_left2i + (fun i c (lx, ix) (ly, iy) -> + match c with + | None, _ -> c + | Some (one_edge, todo, ren), _ -> + if ((not strict) && (ix = -1 || iy = -1)) || ix = iy then ( + match lx, ly with + | Link _, Free | Free, Link _ -> + None, Some (cc1, o, cc2, p, i, false) + | UnSpec, Free | Free, UnSpec | Link _, UnSpec | UnSpec, Link _ + -> + if strict then + None, Some (cc1, o, cc2, p, i, false) + else + Some (one_edge || (ix <> -1 && ix = iy), todo, ren), None + | UnSpec, UnSpec -> + Some (one_edge || (ix <> -1 && ix = iy), todo, ren), None + | Free, Free -> Some (true, todo, ren), None + | Link (n1, s1), Link (n2, s2) -> + if s1 = s2 then + if Renaming.mem n1 ren then + if Renaming.apply ~debug_mode ren n1 = n2 then + Some (true, todo, ren), None else - (None,Some (cc1,o,cc2,p,i,false)) + None, Some (cc1, o, cc2, p, i, false) + else ( + match Renaming.add ~debug_mode n1 n2 ren with + | None -> None, Some (cc1, o, cc2, p, i, false) + | Some r' -> + if find_ty cc1 n1 = find_ty cc2 n2 then + Some (true, (n1, n2) :: todo, r'), None + else + None, Some (cc1, o, cc2, p, i, false) + ) else - (None,Some (cc1,o,cc2,p,i,true)) - ) - (Some (at_least_one_edge,todos,rename),None) - (Mods.IntMap.find_default [||] o cc1.nodes) - (Mods.IntMap.find_default [||] p cc2.nodes) with - | (None,conflict) -> (None,conflict) - | (Some (one_edges',todos',ren'),_) -> aux one_edges' ren' todos' in - match Renaming.add ~debugMode root1 root2 (Renaming.empty ()) with + None, Some (cc1, o, cc2, p, i, false) + ) else + None, Some (cc1, o, cc2, p, i, true)) + (Some (at_least_one_edge, todos, rename), None) + (Mods.IntMap.find_default [||] o cc1.nodes) + (Mods.IntMap.find_default [||] p cc2.nodes) + with + | None, conflict -> None, conflict + | Some (one_edges', todos', ren'), _ -> aux one_edges' ren' todos') + in + match Renaming.add ~debug_mode root1 root2 (Renaming.empty ()) with | None -> assert false | Some r -> let a_single_agent = - Array.fold_left (fun b (l,i) -> b && i = -1 && l = UnSpec) - true (Mods.IntMap.find_default [||] root1 cc1.nodes) || - Array.fold_left (fun b (l,i) -> b && i = -1 && l = UnSpec) - true (Mods.IntMap.find_default [||] root2 cc2.nodes) in - aux a_single_agent r [root1,root2] + Array.fold_left + (fun b (l, i) -> b && i = -1 && l = UnSpec) + true + (Mods.IntMap.find_default [||] root1 cc1.nodes) + || Array.fold_left + (fun b (l, i) -> b && i = -1 && l = UnSpec) + true + (Mods.IntMap.find_default [||] root2 cc2.nodes) + in + aux a_single_agent r [ root1, root2 ] (** @return injection from a to b *) -let equal ~debugMode a b = - match Tools.array_min_equal_not_null - (Array.map (fun x -> List.length x,x) a.nodes_by_type) - (Array.map (fun x -> List.length x,x) b.nodes_by_type) with +let equal ~debug_mode a b = + match + Tools.array_min_equal_not_null + (Array.map (fun x -> List.length x, x) a.nodes_by_type) + (Array.map (fun x -> List.length x, x) b.nodes_by_type) + with | None -> None - | Some ([],ags) -> if ags = [] then Some (Renaming.empty ()) else None - | Some (h1::_,ags) -> + | Some ([], ags) -> + if ags = [] then + Some (Renaming.empty ()) + else + None + | Some (h1 :: _, ags) -> List.fold_left (fun bool ag -> - match bool with - | Some _ -> bool - | None -> - let (rename,_) = - are_compatible ~debugMode ~strict:true h1 a ag b in rename) + match bool with + | Some _ -> bool + | None -> + let rename, _ = are_compatible ~debug_mode ~strict:true h1 a ag b in + rename) None ags -let automorphisms ~debugMode a = +let automorphisms ~debug_mode a = match Array.fold_left - (fun acc x -> Tools.min_pos_int_not_zero acc (List.length x,x)) - (0,[]) a.nodes_by_type + (fun acc x -> Tools.min_pos_int_not_zero acc (List.length x, x)) + (0, []) a.nodes_by_type with - | _, [] -> [Renaming.empty ()] + | _, [] -> [ Renaming.empty () ] | _, (h :: _ as l) -> - List.fold_left (fun acc ag -> - match are_compatible ~debugMode ~strict:true h a ag a with - | (None,_) -> acc - | (Some r,_) -> r::acc) [] l + List.fold_left + (fun acc ag -> + match are_compatible ~debug_mode ~strict:true h a ag a with + | None, _ -> acc + | Some r, _ -> r :: acc) + [] l let potential_pairing sigs = Tools.array_fold_left2i (fun x acc la lb -> - if - Signature.is_counter_agent sigs x - then - acc - else - List.fold_left - (fun acc b -> - List.fold_left - (fun acc a -> Mods.Int2Set.add (a,b) acc) - acc la) - acc lb) - Mods.Int2Set.empty - -let matchings ~debugMode sigs a b = + if Signature.is_counter_agent sigs x then + acc + else + List.fold_left + (fun acc b -> + List.fold_left (fun acc a -> Mods.Int2Set.add (a, b) acc) acc la) + acc lb) + Mods.Int2Set.empty + +let matchings ~debug_mode sigs a b = let possibilities = - ref (potential_pairing sigs a.nodes_by_type b.nodes_by_type) + ref (potential_pairing sigs a.nodes_by_type b.nodes_by_type) in let rec for_one_root acc = match Mods.Int2Set.choose !possibilities with | None -> acc - | Some (x,y) -> - match are_compatible ~debugMode ~possibilities ~strict:false x a y b with - | (None,_) -> for_one_root acc - | (Some r,_) -> for_one_root (r::acc) in + | Some (x, y) -> + (match + are_compatible ~debug_mode ~possibilities ~strict:false x a y b + with + | None, _ -> for_one_root acc + | Some r, _ -> for_one_root (r :: acc)) + in for_one_root [] (*turns a cc into a path(:list) in the domain*) -let raw_to_navigation (full:bool) nodes_by_type nodes = - let rec build_for (first,out) don = function +let raw_to_navigation (full : bool) nodes_by_type nodes = + let rec build_for (first, out) don = function | [] -> List.rev out | h :: t -> - let first',out',todo = + let first', out', todo = Tools.array_fold_lefti - (fun i (first,ans,re as acc) (l,s) -> - let (first',ans',_ as acc') = - if (full || first) && s >= 0 then - (false, - (((if first - then Navigation.Fresh (h,raw_find_ty nodes_by_type h) - else Navigation.Existing h),i), - Navigation.ToInternal s)::ans,re) - else acc in - match l with - | UnSpec -> acc' - | Free -> - if full || first' - then (false, - (((if first' - then Navigation.Fresh (h,raw_find_ty nodes_by_type h) - else Navigation.Existing h),i), - Navigation.ToNothing)::ans',re) - else acc' - | Link (n,l) -> - if List.mem n don || (n = h && i > l) then acc' - else if n = h || List.mem n re - then - if full || first' - then (false, - (((if first' - then Navigation.Fresh (h,raw_find_ty nodes_by_type h) - else Navigation.Existing h),i), - Navigation.ToNode (Navigation.Existing n,l))::ans',re) - else acc' - else - (false, - (((if first' - then Navigation.Fresh (h,raw_find_ty nodes_by_type h) - else Navigation.Existing h),i), - Navigation.ToNode - (Navigation.Fresh(n,raw_find_ty nodes_by_type n),l))::ans', - n::re)) - (first,out,t) (Mods.IntMap.find_default [||] h nodes) in - build_for (first',out') (h::don) todo + (fun i ((first, ans, re) as acc) (l, s) -> + let ((first', ans', _) as acc') = + if (full || first) && s >= 0 then + ( false, + ( ( (if first then + Navigation.Fresh (h, raw_find_ty nodes_by_type h) + else + Navigation.Existing h), + i ), + Navigation.ToInternal s ) + :: ans, + re ) + else + acc + in + match l with + | UnSpec -> acc' + | Free -> + if full || first' then + ( false, + ( ( (if first' then + Navigation.Fresh (h, raw_find_ty nodes_by_type h) + else + Navigation.Existing h), + i ), + Navigation.ToNothing ) + :: ans', + re ) + else + acc' + | Link (n, l) -> + if List.mem n don || (n = h && i > l) then + acc' + else if n = h || List.mem n re then + if full || first' then + ( false, + ( ( (if first' then + Navigation.Fresh (h, raw_find_ty nodes_by_type h) + else + Navigation.Existing h), + i ), + Navigation.ToNode (Navigation.Existing n, l) ) + :: ans', + re ) + else + acc' + else + ( false, + ( ( (if first' then + Navigation.Fresh (h, raw_find_ty nodes_by_type h) + else + Navigation.Existing h), + i ), + Navigation.ToNode + (Navigation.Fresh (n, raw_find_ty nodes_by_type n), l) ) + :: ans', + n :: re )) + (first, out, t) + (Mods.IntMap.find_default [||] h nodes) + in + build_for (first', out') (h :: don) todo in match raw_find_root nodes_by_type with | None -> [] (*empty path for x0*) - | Some (x,_) -> (*(ag_sort,ag_id)*) - build_for (true,[]) (*wip*) [] (*already_done*) [x] (*todo*) + | Some (x, _) -> + (*(ag_sort,ag_id)*) + build_for (true, []) (*wip*) [] (*already_done*) [ x ] +(*todo*) -let rec sub_minimize_renaming ~debugMode r = function +let rec sub_minimize_renaming ~debug_mode r = function | [], _ -> r - | _::_, [] -> assert false - | x::q as l,y::q' -> - if x = y then - match Renaming.add ~debugMode x y r with - | Some r' -> sub_minimize_renaming ~debugMode r' (q,q') + | _ :: _, [] -> assert false + | (x :: q as l), y :: q' -> + if x = y then ( + match Renaming.add ~debug_mode x y r with + | Some r' -> sub_minimize_renaming ~debug_mode r' (q, q') | None -> assert false - else - let fsts,lst = List_util.pop_last l in - match Renaming.add ~debugMode lst y r with - | Some r' -> sub_minimize_renaming ~debugMode r' (fsts,q') + ) else ( + let fsts, lst = List_util.pop_last l in + match Renaming.add ~debug_mode lst y r with + | Some r' -> sub_minimize_renaming ~debug_mode r' (fsts, q') | None -> assert false + ) -let minimize_renaming ~debugMode dst_nbt ref_nbt = +let minimize_renaming ~debug_mode dst_nbt ref_nbt = let re = Renaming.empty () in Tools.array_fold_lefti - (fun ty r ids -> sub_minimize_renaming ~debugMode r (ids,ref_nbt.(ty))) + (fun ty r ids -> sub_minimize_renaming ~debug_mode r (ids, ref_nbt.(ty))) re dst_nbt -let minimize ~debugMode cand_nbt cand_nodes ref_nbt = - let re = minimize_renaming ~debugMode cand_nbt ref_nbt in +let minimize ~debug_mode cand_nbt cand_nodes ref_nbt = + let re = minimize_renaming ~debug_mode cand_nbt ref_nbt in let re_img = Renaming.image re in let nodes_by_type = - Array.map (List.filter (fun a -> Mods.IntSet.mem a re_img)) ref_nbt in + Array.map (List.filter (fun a -> Mods.IntSet.mem a re_img)) ref_nbt + in let nodes = Mods.IntMap.fold (fun id sites acc -> - let sites' = Array.map (function - | Link (n,s),i -> Link (Renaming.apply ~debugMode re n,s),i - | (UnSpec|Free),_ as x -> x) sites in - Mods.IntMap.add (Renaming.apply ~debugMode re id) sites' acc) - cand_nodes Mods.IntMap.empty in - { nodes_by_type; nodes; - recogn_nav = - raw_to_navigation false nodes_by_type nodes; } + let sites' = + Array.map + (function + | Link (n, s), i -> Link (Renaming.apply ~debug_mode re n, s), i + | ((UnSpec | Free), _) as x -> x) + sites + in + Mods.IntMap.add (Renaming.apply ~debug_mode re id) sites' acc) + cand_nodes Mods.IntMap.empty + in + { + nodes_by_type; + nodes; + recogn_nav = raw_to_navigation false nodes_by_type nodes; + } (* returns a list of cc where each cc is included in cc1*) -let infs ~debugMode sigs cc1 cc2 = +let infs ~debug_mode sigs cc1 cc2 = let possibilities = - ref (potential_pairing sigs cc1.nodes_by_type cc2.nodes_by_type) in + ref (potential_pairing sigs cc1.nodes_by_type cc2.nodes_by_type) + in let rec aux rename nodes = function | [] -> nodes - | (o,p as pair)::todos -> + | ((o, p) as pair) :: todos -> let () = possibilities := Mods.Int2Set.remove pair !possibilities in let lnk1 = Mods.IntMap.find_default [||] o cc1.nodes in - let (todos',ren'),outl = + let (todos', ren'), outl = Tools.array_fold_left_mapi - (fun k (todo,ren as acc) (ly,iy) -> - let (lx,ix) = lnk1.(k) in - match lx, ly with - | (Link _, Free| Free, Link _ - | Link _, UnSpec |UnSpec, Link _ - | UnSpec, Free| Free, UnSpec - | UnSpec, UnSpec) -> - acc,(UnSpec,if ix = iy then iy else -1) - | Free, Free -> acc,(Free,if ix = iy then iy else -1) - | Link (n1,s1) as x, Link (n2,s2) -> - if s1 = s2 then - if Renaming.mem n1 ren then - (acc, - ((if Renaming.apply ~debugMode ren n1 = n2 - then x else UnSpec), - if ix = iy then iy else -1)) - else match Renaming.add ~debugMode n1 n2 ren with - | None -> acc,(UnSpec,if ix = iy then iy else -1) - | Some r' -> - if find_ty cc1 n1 = find_ty cc2 n2 - then ((n1,n2)::todo,r'),(x,if ix = iy then iy else -1) - else acc,(UnSpec,if ix = iy then iy else -1) - else (acc,(UnSpec,if ix = iy then iy else -1)) - ) - (todos,rename) - (Mods.IntMap.find_default [||] p cc2.nodes) in - if Array.fold_left (fun b (l,i) -> b && l = UnSpec && i < 0) true outl - then aux ren' nodes todos' - else aux ren' (Mods.IntMap.add o outl nodes) todos' in + (fun k ((todo, ren) as acc) (ly, iy) -> + let lx, ix = lnk1.(k) in + match lx, ly with + | Link _, Free + | Free, Link _ + | Link _, UnSpec + | UnSpec, Link _ + | UnSpec, Free + | Free, UnSpec + | UnSpec, UnSpec -> + ( acc, + ( UnSpec, + if ix = iy then + iy + else + -1 ) ) + | Free, Free -> + ( acc, + ( Free, + if ix = iy then + iy + else + -1 ) ) + | (Link (n1, s1) as x), Link (n2, s2) -> + if s1 = s2 then + if Renaming.mem n1 ren then + ( acc, + ( (if Renaming.apply ~debug_mode ren n1 = n2 then + x + else + UnSpec), + if ix = iy then + iy + else + -1 ) ) + else ( + match Renaming.add ~debug_mode n1 n2 ren with + | None -> + ( acc, + ( UnSpec, + if ix = iy then + iy + else + -1 ) ) + | Some r' -> + if find_ty cc1 n1 = find_ty cc2 n2 then + ( ((n1, n2) :: todo, r'), + ( x, + if ix = iy then + iy + else + -1 ) ) + else + ( acc, + ( UnSpec, + if ix = iy then + iy + else + -1 ) ) + ) + else + ( acc, + ( UnSpec, + if ix = iy then + iy + else + -1 ) )) + (todos, rename) + (Mods.IntMap.find_default [||] p cc2.nodes) + in + if Array.fold_left (fun b (l, i) -> b && l = UnSpec && i < 0) true outl + then + aux ren' nodes todos' + else + aux ren' (Mods.IntMap.add o outl nodes) todos' + in let rec for_one_root acc = match Mods.Int2Set.choose !possibilities with | None -> acc - | Some (root1,root2) -> - match Renaming.add ~debugMode root1 root2 (Renaming.empty ()) with + | Some (root1, root2) -> + (match Renaming.add ~debug_mode root1 root2 (Renaming.empty ()) with | None -> assert false | Some r -> - let nodes = aux r Mods.IntMap.empty [root1,root2] in + let nodes = aux r Mods.IntMap.empty [ root1, root2 ] in let acc' = - if Mods.IntMap.is_empty nodes then acc else - let nodes_by_type = Array.map + if Mods.IntMap.is_empty nodes then + acc + else ( + let nodes_by_type = + Array.map (List.filter (fun a -> Mods.IntMap.mem a nodes)) - cc1.nodes_by_type in - (minimize ~debugMode nodes_by_type nodes cc1.nodes_by_type)::acc in - for_one_root acc' - in for_one_root [] + cc1.nodes_by_type + in + minimize ~debug_mode nodes_by_type nodes cc1.nodes_by_type :: acc + ) + in + for_one_root acc') + in + for_one_root [] (* renaming is a total morphism from cc1' to cc2; cc1' is included in cc1 *) let intersection renaming cc1 cc2 = - let nodes,image = + let nodes, image = Renaming.fold - (fun i j (accn,l as acc) -> - match Mods.IntMap.find_option i cc1.nodes with - | None -> acc - | Some nodes1 -> - match Mods.IntMap.find_option j cc2.nodes with - | None -> acc - | Some nodes2 -> - let out = Array.mapi - (fun k (l2,i2) -> - let (l1,i1) = nodes1.(k) in - ((if l1 = UnSpec then UnSpec else l2), - (if i1 = -1 then -1 else i2))) nodes2 in - (Mods.IntMap.add j out accn, j::l)) - renaming (Mods.IntMap.empty,[]) in - let nodes_by_type = Array.map - (List.filter (fun a -> List.mem a image)) cc2.nodes_by_type in - { nodes_by_type; nodes; - recogn_nav = raw_to_navigation false nodes_by_type nodes; } - -let rec counter_value nodes (nid,sid) count = + (fun i j ((accn, l) as acc) -> + match Mods.IntMap.find_option i cc1.nodes with + | None -> acc + | Some nodes1 -> + (match Mods.IntMap.find_option j cc2.nodes with + | None -> acc + | Some nodes2 -> + let out = + Array.mapi + (fun k (l2, i2) -> + let l1, i1 = nodes1.(k) in + ( (if l1 = UnSpec then + UnSpec + else + l2), + if i1 = -1 then + -1 + else + i2 )) + nodes2 + in + Mods.IntMap.add j out accn, j :: l)) + renaming (Mods.IntMap.empty, []) + in + let nodes_by_type = + Array.map (List.filter (fun a -> List.mem a image)) cc2.nodes_by_type + in + { + nodes_by_type; + nodes; + recogn_nav = raw_to_navigation false nodes_by_type nodes; + } + +let rec counter_value nodes (nid, sid) count = match Mods.IntMap.find_option nid nodes with | None -> count | Some ag -> - Tools.array_fold_lefti - (fun id acc (el,_) -> - if (id = sid) then acc - else - match el with - | UnSpec | Free -> acc - | Link (dn,di) -> counter_value nodes (dn,di) (acc+1)) count ag - -let counter_value_cc cc (nid,sid) count = + Tools.array_fold_lefti + (fun id acc (el, _) -> + if id = sid then + acc + else ( + match el with + | UnSpec | Free -> acc + | Link (dn, di) -> counter_value nodes (dn, di) (acc + 1) + )) + count ag + +let counter_value_cc cc (nid, sid) count = let nodes = cc.nodes in - counter_value nodes (nid,sid) count + counter_value nodes (nid, sid) count let dotcomma dotnet = - if dotnet - then (fun fmt -> Format.fprintf fmt ",") - else Pp.space -let print_cc - ~noCounters ?dotnet:(dotnet=false) - ?(full_species=false) ?sigs ?cc_id ~with_id f cc = - let print_intf (ag_i, _ as ag) link_ids neigh = + if dotnet then + fun fmt -> + Format.fprintf fmt "," + else + Pp.space + +let print_cc ~noCounters ?(dotnet = false) ?(full_species = false) ?sigs ?cc_id + ~with_id f cc = + let print_intf ((ag_i, _) as ag) link_ids neigh = snd (Tools.array_fold_lefti - (fun p (not_empty, (free, link_ids as out)) (el, st) -> - let () = - if st >= 0 - then Format.fprintf - f "%t%a" - (if not_empty then dotcomma dotnet - else Pp.empty) - (Agent.print_internal ?sigs ag p) st - else if el <> UnSpec then - Format.fprintf - f "%t%a" - (if not_empty then dotcomma dotnet - else Pp.empty) - (Agent.print_site ?sigs ag) p in - match el with - | UnSpec -> - if st >= 0 then - let () = if full_species then Format.pp_print_string f "[.]" in - (true,out) - else (not_empty,out) - | Free -> - let () = Format.pp_print_string f "[.]" in - (true,out) - | Link (dst_a,dst_p) -> - let dst_ty = find_ty cc dst_a in - if match sigs with - | None -> false - | Some sigs -> Signature.is_counter_agent sigs dst_ty - && not noCounters then - let counter = counter_value cc.nodes (dst_a,dst_p) 0 in - let () = Format.fprintf f "{=%d}" counter in - true,out - else - let i,out' = - match - Mods.Int2Map.find_option (dst_a,dst_p) link_ids - with - | Some x -> (x, out) - | None -> - (free, (succ free, - Mods.Int2Map.add (ag_i,p) free link_ids)) - in - let () = Format.fprintf f "[%i]" i in - true, out') + (fun p (not_empty, ((free, link_ids) as out)) (el, st) -> + let () = + if st >= 0 then + Format.fprintf f "%t%a" + (if not_empty then + dotcomma dotnet + else + Pp.empty) + (Agent.print_internal ?sigs ag p) + st + else if el <> UnSpec then + Format.fprintf f "%t%a" + (if not_empty then + dotcomma dotnet + else + Pp.empty) + (Agent.print_site ?sigs ag) + p + in + match el with + | UnSpec -> + if st >= 0 then ( + let () = if full_species then Format.pp_print_string f "[.]" in + true, out + ) else + not_empty, out + | Free -> + let () = Format.pp_print_string f "[.]" in + true, out + | Link (dst_a, dst_p) -> + let dst_ty = find_ty cc dst_a in + if + match sigs with + | None -> false + | Some sigs -> + Signature.is_counter_agent sigs dst_ty && not noCounters + then ( + let counter = counter_value cc.nodes (dst_a, dst_p) 0 in + let () = Format.fprintf f "{=%d}" counter in + true, out + ) else ( + let i, out' = + match Mods.Int2Map.find_option (dst_a, dst_p) link_ids with + | Some x -> x, out + | None -> + free, (succ free, Mods.Int2Map.add (ag_i, p) free link_ids) + in + let () = Format.fprintf f "[%i]" i in + true, out' + )) (false, link_ids) neigh) in - let () = match cc_id with + let () = + match cc_id with | None -> () - | Some cc_id -> Format.fprintf f "/*cc%i*/@ " cc_id in - let (_, _) = + | Some cc_id -> Format.fprintf f "/*cc%i*/@ " cc_id + in + let _, _ = Mods.IntMap.fold - (fun x el (not_empty,link_ids) -> - let ag_x = (x,find_ty cc x) in - if match sigs with - | None -> true - | Some sigs -> not (Signature.is_counter_agent sigs (snd ag_x)) - || noCounters then - let () = - Format.fprintf - f "%t@[%a(" - (if not_empty - then - begin - if dotnet then - (fun fmt -> Format.fprintf fmt ".") - else Pp.comma - end - else Pp.empty) - (Agent.print ?sigs ~with_id) ag_x in - let out = print_intf ag_x link_ids el in - let () = Format.fprintf f ")@]" in - true, out - else not_empty,link_ids) - cc.nodes (false, (1, Mods.Int2Map.empty)) + (fun x el (not_empty, link_ids) -> + let ag_x = x, find_ty cc x in + if + match sigs with + | None -> true + | Some sigs -> + (not (Signature.is_counter_agent sigs (snd ag_x))) || noCounters + then ( + let () = + Format.fprintf f "%t@[%a(" + (if not_empty then + if dotnet then + fun fmt -> + Format.fprintf fmt "." + else + Pp.comma + else + Pp.empty) + (Agent.print ?sigs ~with_id) + ag_x + in + let out = print_intf ag_x link_ids el in + let () = Format.fprintf f ")@]" in + true, out + ) else + not_empty, link_ids) + cc.nodes + (false, (1, Mods.Int2Map.empty)) in () let print_cc_as_id sigs f cc = - let print_intf (ag_i, _ as ag) link_ids neigh = + let print_intf ((ag_i, _) as ag) link_ids neigh = snd (Tools.array_fold_lefti - (fun p (not_empty, (free, link_ids as out)) (el, st) -> - let () = - if el <> UnSpec || st >= 0 then - Format.fprintf - f "%t%a" - (if not_empty then fun f -> Format.pp_print_string f "_" - else Pp.empty) - (Agent.print_site ~sigs ag) p in - let () = - if st >= 0 then Format.fprintf - f "~%a" (Agent.print_raw_internal ~sigs ag p) st in - match el with - | UnSpec -> (not_empty||st >= 0,out) - | Free -> (true,out) - | Link (dst_a,dst_p) -> - let dst_ty = find_ty cc dst_a in - if Signature.is_counter_agent sigs dst_ty then - let counter = counter_value cc.nodes (dst_a,dst_p) 0 in - let () = Format.fprintf f "~+%d" counter in - true,out - else - let i,out' = - match - Mods.Int2Map.find_option (dst_a,dst_p) link_ids - with - | Some x -> (x, out) - | None -> - (free, (succ free, - Mods.Int2Map.add (ag_i,p) free link_ids)) - in - let () = Format.fprintf f "~%i" i in - true, out') + (fun p (not_empty, ((free, link_ids) as out)) (el, st) -> + let () = + if el <> UnSpec || st >= 0 then + Format.fprintf f "%t%a" + (if not_empty then + fun f -> + Format.pp_print_string f "_" + else + Pp.empty) + (Agent.print_site ~sigs ag) + p + in + let () = + if st >= 0 then + Format.fprintf f "~%a" (Agent.print_raw_internal ~sigs ag p) st + in + match el with + | UnSpec -> not_empty || st >= 0, out + | Free -> true, out + | Link (dst_a, dst_p) -> + let dst_ty = find_ty cc dst_a in + if Signature.is_counter_agent sigs dst_ty then ( + let counter = counter_value cc.nodes (dst_a, dst_p) 0 in + let () = Format.fprintf f "~+%d" counter in + true, out + ) else ( + let i, out' = + match Mods.Int2Map.find_option (dst_a, dst_p) link_ids with + | Some x -> x, out + | None -> + free, (succ free, Mods.Int2Map.add (ag_i, p) free link_ids) + in + let () = Format.fprintf f "~%i" i in + true, out' + )) (false, link_ids) neigh) in - let (_, _) = + let _, _ = Mods.IntMap.fold - (fun x el (not_empty,link_ids) -> - let ag_x = (x,find_ty cc x) in - if not (Signature.is_counter_agent sigs (snd ag_x)) then - let () = - Format.fprintf - f "%t@[%a__" - (if not_empty - then fun f -> Format.pp_print_string f "__" - else Pp.empty) - (Agent.print ~sigs ~with_id:false) ag_x in - let out = print_intf ag_x link_ids el in - let () = Format.fprintf f "@]" in - true, out - else not_empty,link_ids) - cc.nodes (false, (1, Mods.Int2Map.empty)) + (fun x el (not_empty, link_ids) -> + let ag_x = x, find_ty cc x in + if not (Signature.is_counter_agent sigs (snd ag_x)) then ( + let () = + Format.fprintf f "%t@[%a__" + (if not_empty then + fun f -> + Format.pp_print_string f "__" + else + Pp.empty) + (Agent.print ~sigs ~with_id:false) + ag_x + in + let out = print_intf ag_x link_ids el in + let () = Format.fprintf f "@]" in + true, out + ) else + not_empty, link_ids) + cc.nodes + (false, (1, Mods.Int2Map.empty)) in () @@ -623,253 +789,374 @@ let to_yojson cc = let () = Array.iteri (fun ty -> List.iter (fun id -> sorts.(id) <- Some ty)) - cc.nodes_by_type in - `Assoc [ - "sorts", - `List - (Array.fold_right - (fun x acc -> (match x with None -> `Null | Some i -> `Int i)::acc) - sorts []); - "nodes", - `List (Tools.recti - (fun acc i -> (match Mods.IntMap.find_option i cc.nodes with - | None -> `Null - | Some a -> - `List (Array.fold_right - (fun (l,s) acc -> - `List [(match l with - | Free -> `Bool true - | Link (n,s) -> - `Assoc ["node",`Int n;"site",`Int s] - | UnSpec -> `Bool false); - if s < 0 then `Null else `Int s]::acc) - a []))::acc) - [] s); - ] + cc.nodes_by_type + in + `Assoc + [ + ( "sorts", + `List + (Array.fold_right + (fun x acc -> + (match x with + | None -> `Null + | Some i -> `Int i) + :: acc) + sorts []) ); + ( "nodes", + `List + (Tools.recti + (fun acc i -> + (match Mods.IntMap.find_option i cc.nodes with + | None -> `Null + | Some a -> + `List + (Array.fold_right + (fun (l, s) acc -> + `List + [ + (match l with + | Free -> `Bool true + | Link (n, s) -> + `Assoc [ "node", `Int n; "site", `Int s ] + | UnSpec -> `Bool false); + (if s < 0 then + `Null + else + `Int s); + ] + :: acc) + a [])) + :: acc) + [] s) ); + ] let of_yojson sig_decl = function - | `Assoc ["sorts",`List s;"nodes",`List n;] - | `Assoc ["nodes",`List n;"sorts",`List s] -> - let _,nodes = + | `Assoc [ ("sorts", `List s); ("nodes", `List n) ] + | `Assoc [ ("nodes", `List n); ("sorts", `List s) ] -> + let _, nodes = List.fold_left - (fun (i,acc) -> function - | `Null -> (succ i,acc) - | `List l -> - (succ i, + (fun (i, acc) -> function + | `Null -> succ i, acc + | `List l -> + ( succ i, Mods.IntMap.add i - (Tools.array_map_of_list (function - | `List [`Bool b;`Null] -> (if b then Free else UnSpec),-1 - | `List [`Assoc ["node",`Int n;"site",`Int s] - | `Assoc ["site",`Int s;"node",`Int n]; `Null] -> - Link (n,s),-1 - | `List [`Bool b;`Int s] -> (if b then Free else UnSpec),s - | `List [`Assoc ["node",`Int n;"site",`Int s] - | `Assoc ["site",`Int s;"node",`Int n]; `Int st] -> - Link (n,s),st + (Tools.array_map_of_list + (function + | `List [ `Bool b; `Null ] -> + ( (if b then + Free + else + UnSpec), + -1 ) + | `List + [ + ( `Assoc [ ("node", `Int n); ("site", `Int s) ] + | `Assoc [ ("site", `Int s); ("node", `Int n) ] ); + `Null; + ] -> + Link (n, s), -1 + | `List [ `Bool b; `Int s ] -> + ( (if b then + Free + else + UnSpec), + s ) + | `List + [ + ( `Assoc [ ("node", `Int n); ("site", `Int s) ] + | `Assoc [ ("site", `Int s); ("node", `Int n) ] ); + `Int st; + ] -> + Link (n, s), st | x -> - raise (Yojson.Basic.Util.Type_error ("Invalid node",x)) - ) l) acc) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid node links",x))) - (0,Mods.IntMap.empty) n in + raise (Yojson.Basic.Util.Type_error ("Invalid node", x))) + l) + acc ) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid node links", x))) + (0, Mods.IntMap.empty) n + in let nodes_by_type = Array.make (Signature.size sig_decl) [] in let () = - List.iteri (fun i -> function + List.iteri + (fun i -> function | `Null -> () | `Int ty -> nodes_by_type.(ty) <- i :: nodes_by_type.(ty) - | x -> raise (Yojson.Basic.Util.Type_error ("Wrong node type",x))) - s in - {nodes_by_type;nodes; - recogn_nav = raw_to_navigation false nodes_by_type nodes} + | x -> raise (Yojson.Basic.Util.Type_error ("Wrong node type", x))) + s + in + { + nodes_by_type; + nodes; + recogn_nav = raw_to_navigation false nodes_by_type nodes; + } | `Null -> empty_cc sig_decl - | x -> raise (Yojson.Basic.Util.Type_error ("Not a pattern",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Not a pattern", x)) -let merge_compatible ~debugMode reserved_ids free_id inj1_to_2 cc1 cc2 = +let merge_compatible ~debug_mode reserved_ids free_id inj1_to_2 cc1 cc2 = let img = Renaming.image inj1_to_2 in let available_ids = - Array.map (List.filter (fun id -> not (Mods.IntSet.mem id img))) - reserved_ids in + Array.map + (List.filter (fun id -> not (Mods.IntSet.mem id img))) + reserved_ids + in let used_ids = Array.map - (List_util.map_option - (fun id -> if Renaming.mem id inj1_to_2 - then Some (Renaming.apply ~debugMode inj1_to_2 id) - else None)) - cc1.nodes_by_type in + (List_util.map_option (fun id -> + if Renaming.mem id inj1_to_2 then + Some (Renaming.apply ~debug_mode inj1_to_2 id) + else + None)) + cc1.nodes_by_type + in let available_in_cc1 = Array.mapi (fun i l -> - List.filter (fun x -> not (List.mem x cc1.nodes_by_type.(i))) l) - reserved_ids in + List.filter (fun x -> not (List.mem x cc1.nodes_by_type.(i))) l) + reserved_ids + in let free_id_for_cc1 = ref free_id in - let get_cc2 j ((inj1,free_id),inj2,(todos1,todos2) as pack) = - if Renaming.mem j inj2 then (Renaming.apply ~debugMode inj2 j,pack) - else + let get_cc2 j (((inj1, free_id), inj2, (todos1, todos2)) as pack) = + if Renaming.mem j inj2 then + Renaming.apply ~debug_mode inj2 j, pack + else ( let ty = find_ty cc2 j in - let img,free_id' = + let img, free_id' = match available_ids.(ty) with - | [] -> free_id,succ free_id - | h :: t -> let () = available_ids.(ty) <- t in - h,free_id in + | [] -> free_id, succ free_id + | h :: t -> + let () = available_ids.(ty) <- t in + h, free_id + in let () = used_ids.(ty) <- img :: used_ids.(ty) in let o = match available_in_cc1.(ty) with - | [] -> let x = !free_id_for_cc1 in let () = incr free_id_for_cc1 in x - | h :: t -> let () = available_in_cc1.(ty) <- t in h in - img, - (((match Renaming.add ~debugMode o img inj1 with - | Some x -> x - | None -> assert false), - free_id'), - (match Renaming.add ~debugMode j img inj2 with - | Some x -> x - | None -> assert false), - (todos1,(j,img)::todos2)) in - - let get_cc1 i ((inj1,free_id),inj2,(todos1,todos2) as pack) = - if Renaming.mem i inj1 then (Renaming.apply ~debugMode inj1 i,pack) - else + | [] -> + let x = !free_id_for_cc1 in + let () = incr free_id_for_cc1 in + x + | h :: t -> + let () = available_in_cc1.(ty) <- t in + h + in + ( img, + ( ( (match Renaming.add ~debug_mode o img inj1 with + | Some x -> x + | None -> assert false), + free_id' ), + (match Renaming.add ~debug_mode j img inj2 with + | Some x -> x + | None -> assert false), + (todos1, (j, img) :: todos2) ) ) + ) + in + + let get_cc1 i (((inj1, free_id), inj2, (todos1, todos2)) as pack) = + if Renaming.mem i inj1 then + Renaming.apply ~debug_mode inj1 i, pack + else ( let ty = find_ty cc1 i in - let img,free_id' = + let img, free_id' = match available_ids.(ty) with - | [] -> free_id,succ free_id - | h :: t -> let () = available_ids.(ty) <- t in - h,free_id in + | [] -> free_id, succ free_id + | h :: t -> + let () = available_ids.(ty) <- t in + h, free_id + in let () = used_ids.(ty) <- img :: used_ids.(ty) in - img, - (((match Renaming.add ~debugMode i img inj1 with - | Some x -> x - | None -> assert false), - free_id'),inj2,((i,img)::todos1,todos2)) in - let pack',nodes = + ( img, + ( ( (match Renaming.add ~debug_mode i img inj1 with + | Some x -> x + | None -> assert false), + free_id' ), + inj2, + ((i, img) :: todos1, todos2) ) ) + ) + in + let pack', nodes = let rec glue pack inj2 nodes = function - | [], [] -> (pack,nodes) - | [], (i,j) :: todos2 -> + | [], [] -> pack, nodes + | [], (i, j) :: todos2 -> let nodesi = Mods.IntMap.find_default [||] i cc2.nodes in let nodeso = Array.copy nodesi in - let (pack',inj2',todos') = - Tools.array_fold_lefti - (fun k acc -> function - | (UnSpec | Free), _ -> acc - | Link (n,s),st -> - let n',acc' = get_cc2 n acc in - let () = nodeso.(k) <- (Link (n',s),st) in acc') - (pack,inj2,([],todos2)) nodesi in + let pack', inj2', todos' = + Tools.array_fold_lefti + (fun k acc -> function + | (UnSpec | Free), _ -> acc + | Link (n, s), st -> + let n', acc' = get_cc2 n acc in + let () = nodeso.(k) <- Link (n', s), st in + acc') + (pack, inj2, ([], todos2)) + nodesi + in glue pack' inj2' (Mods.IntMap.add j nodeso nodes) todos' - | (i,j) :: todos1, todos2 -> + | (i, j) :: todos1, todos2 -> let nodesi = Mods.IntMap.find_default [||] i cc1.nodes in let nodeso = Array.copy nodesi in - let (pack',inj2',todos') = + let pack', inj2', todos' = match Mods.IntMap.find_option j cc2.nodes with | None -> Tools.array_fold_lefti (fun k acc -> function - | (UnSpec | Free),_ -> acc - | Link (n,s),st -> - let n',acc' = get_cc1 n acc in - let () = nodeso.(k) <- (Link (n',s),st) in acc') - (pack,inj2,(todos1,todos2)) nodesi + | (UnSpec | Free), _ -> acc + | Link (n, s), st -> + let n', acc' = get_cc1 n acc in + let () = nodeso.(k) <- Link (n', s), st in + acc') + (pack, inj2, (todos1, todos2)) + nodesi | Some nodesj -> Tools.array_fold_lefti (fun k acc -> function - | Free,_ -> - let _,stj = nodesj.(k) in - let () = if stj <> -1 then nodeso.(k) <- (Free,stj) in acc - | Link (n,s),sti -> - let _,stj = nodesj.(k) in - let sto = if stj <> -1 then stj else sti in - let n',acc' = get_cc1 n acc in - let () = nodeso.(k) <- (Link (n',s),sto) in acc' - | UnSpec,sti -> match nodesj.(k) with - | UnSpec,stj -> - let () = - if stj <> -1 then nodeso.(k) <- (UnSpec,stj) in acc - | Free,stj -> - let () = - nodeso.(k) <- (Free,if stj <> -1 then stj else sti) in - acc - | Link (n,s),stj -> - let sto = if stj <> -1 then stj else sti in - let n',acc' = get_cc2 n acc in - let () = nodeso.(k) <- (Link (n',s),sto) in acc') - (pack,inj2,(todos1,todos2)) nodesi in - glue pack' inj2' (Mods.IntMap.add j nodeso nodes) todos' in - glue (inj1_to_2,free_id) (Renaming.identity (Mods.IntSet.elements img)) - Mods.IntMap.empty (Renaming.to_list inj1_to_2,[]) in + | Free, _ -> + let _, stj = nodesj.(k) in + let () = if stj <> -1 then nodeso.(k) <- Free, stj in + acc + | Link (n, s), sti -> + let _, stj = nodesj.(k) in + let sto = + if stj <> -1 then + stj + else + sti + in + let n', acc' = get_cc1 n acc in + let () = nodeso.(k) <- Link (n', s), sto in + acc' + | UnSpec, sti -> + (match nodesj.(k) with + | UnSpec, stj -> + let () = if stj <> -1 then nodeso.(k) <- UnSpec, stj in + acc + | Free, stj -> + let () = + nodeso.(k) <- + ( Free, + if stj <> -1 then + stj + else + sti ) + in + acc + | Link (n, s), stj -> + let sto = + if stj <> -1 then + stj + else + sti + in + let n', acc' = get_cc2 n acc in + let () = nodeso.(k) <- Link (n', s), sto in + acc')) + (pack, inj2, (todos1, todos2)) + nodesi + in + glue pack' inj2' (Mods.IntMap.add j nodeso nodes) todos' + in + glue (inj1_to_2, free_id) + (Renaming.identity (Mods.IntSet.elements img)) + Mods.IntMap.empty + (Renaming.to_list inj1_to_2, []) + in let nodes_by_type = Array.map (List.sort Mods.int_compare) used_ids in let () = Array.iteri - (fun i x -> reserved_ids.(i) <- + (fun i x -> + reserved_ids.(i) <- List_util.merge_uniq Mods.int_compare nodes_by_type.(i) x) - available_ids in - (pack', - { - nodes_by_type; nodes; - recogn_nav = raw_to_navigation false nodes_by_type nodes; - }) - -let build_navigation_between ~debugMode inj_d_to_o cc_o cc_d = + available_ids + in + ( pack', + { + nodes_by_type; + nodes; + recogn_nav = raw_to_navigation false nodes_by_type nodes; + } ) + +let build_navigation_between ~debug_mode inj_d_to_o cc_o cc_d = let rec handle_links discovered next_round recogn intern = function | [] -> - if next_round = [] then (List.rev_append recogn intern) - else handle_links discovered [] recogn intern next_round - | ((i,j,s),(n',s') as h) :: todos -> - let n = Renaming.apply ~debugMode inj_d_to_o n' in - match Mods.IntSet.mem j discovered, Mods.IntSet.mem n' discovered with - | (false, false) -> - handle_links discovered (h::next_round) recogn intern todos - | (true, true) -> + if next_round = [] then + List.rev_append recogn intern + else + handle_links discovered [] recogn intern next_round + | (((i, j, s), (n', s')) as h) :: todos -> + let n = Renaming.apply ~debug_mode inj_d_to_o n' in + (match Mods.IntSet.mem j discovered, Mods.IntSet.mem n' discovered with + | false, false -> + handle_links discovered (h :: next_round) recogn intern todos + | true, true -> let intern' = - ((Navigation.Existing i,s), - Navigation.ToNode (Navigation.Existing n,s'))::intern in + ( (Navigation.Existing i, s), + Navigation.ToNode (Navigation.Existing n, s') ) + :: intern + in handle_links discovered next_round recogn intern' todos | true, false -> let recogn' = - ((Navigation.Existing i,s), - Navigation.ToNode - (Navigation.Fresh (n,find_ty cc_d n'),s'))::recogn in + ( (Navigation.Existing i, s), + Navigation.ToNode (Navigation.Fresh (n, find_ty cc_d n'), s') ) + :: recogn + in handle_links - (Mods.IntSet.add n' discovered) next_round recogn' intern todos - | false, true -> - let recogn' = - ((Navigation.Existing n,s'), - Navigation.ToNode - (Navigation.Fresh (i,find_ty cc_d j),s))::recogn in - handle_links - (Mods.IntSet.add j discovered) next_round recogn' intern todos in - let discov,all_links,intern = - Renaming.fold - (fun j i (disc,links,inter) -> - let nodesd = Mods.IntMap.find_default [||] j cc_d.nodes in - let disc',nodeso = - match Mods.IntMap.find_option i cc_o.nodes with - | None -> - disc, - Array.make (Array.length nodesd) (UnSpec,-1) - | Some nodeso -> - Mods.IntSet.add j disc,nodeso in - Tools.array_fold_left2i - (fun s (dis,li,int as acc) (ol,os) (dl,ds) -> - let (_,_, int' as acc') = - if os = -1 && ds <> -1 - then (dis,li,((Navigation.Existing i,s),Navigation.ToInternal ds)::int) - else acc in - if ol <> UnSpec then acc' else - match dl with - | UnSpec -> acc' - | Free -> - dis,li,((Navigation.Existing i,s),Navigation.ToNothing)::int' - | Link (n,s') -> - if n > (*la*)j || (n = j && s > s') then acc' - else dis,((i,j,s),(n,s'))::li,int') - (disc',links,inter) nodeso nodesd) - inj_d_to_o (Mods.IntSet.empty,[],[]) in - handle_links discov [] [] intern all_links + (Mods.IntSet.add n' discovered) + next_round recogn' intern todos + | false, true -> + let recogn' = + ( (Navigation.Existing n, s'), + Navigation.ToNode (Navigation.Fresh (i, find_ty cc_d j), s) ) + :: recogn + in + handle_links + (Mods.IntSet.add j discovered) + next_round recogn' intern todos) + in + let discov, all_links, intern = + Renaming.fold + (fun j i (disc, links, inter) -> + let nodesd = Mods.IntMap.find_default [||] j cc_d.nodes in + let disc', nodeso = + match Mods.IntMap.find_option i cc_o.nodes with + | None -> disc, Array.make (Array.length nodesd) (UnSpec, -1) + | Some nodeso -> Mods.IntSet.add j disc, nodeso + in + Tools.array_fold_left2i + (fun s ((dis, li, int) as acc) (ol, os) (dl, ds) -> + let ((_, _, int') as acc') = + if os = -1 && ds <> -1 then + ( dis, + li, + ((Navigation.Existing i, s), Navigation.ToInternal ds) :: int + ) + else + acc + in + if ol <> UnSpec then + acc' + else ( + match dl with + | UnSpec -> acc' + | Free -> + ( dis, + li, + ((Navigation.Existing i, s), Navigation.ToNothing) :: int' ) + | Link (n, s') -> + if n > (*la*) j || (n = j && s > s') then + acc' + else + dis, ((i, j, s), (n, s')) :: li, int' + )) + (disc', links, inter) nodeso nodesd) + inj_d_to_o + (Mods.IntSet.empty, [], []) + in + handle_links discov [] [] intern all_links module Env : sig type transition = { next: Navigation.abstract Navigation.t; - dst: id (* id of cc and also address in the Env.domain map*); + dst: id; (* id of cc and also address in the Env.domain map*) inj: Renaming.t; (* From dst To ("this" cc + extra edge) *) } @@ -880,10 +1167,10 @@ module Env : sig mutable sons: transition list; } - val content: point -> cc - val roots: point -> (int list (*ids*) * int (*ty*)) option - val deps: point -> Operator.DepSet.t - val sons: point -> transition list + val content : point -> cc + val roots : point -> (int list (*ids*) * int (*ty*)) option + val deps : point -> Operator.DepSet.t + val sons : point -> transition list type t = { sig_decl: Signature.s; @@ -891,28 +1178,30 @@ module Env : sig max_obs: int; domain: point array; elementaries: (Navigation.abstract Navigation.step * id) list array array; - single_agent_points: (id*Operator.DepSet.t) option array; + single_agent_points: (id * Operator.DepSet.t) option array; } val get : t -> id -> point val get_single_agent : int -> t -> (id * Operator.DepSet.t) option - val to_navigation : t -> id -> Navigation.abstract Navigation.t val get_elementary : - debugMode:bool -> t -> Agent.t -> int -> - Navigation.abstract Navigation.arrow -> (id * point * Renaming.t) option + debug_mode:bool -> + t -> + Agent.t -> + int -> + Navigation.abstract Navigation.arrow -> + (id * point * Renaming.t) option val signatures : t -> Signature.s val new_obs_map : t -> (id -> 'a) -> 'a ObsMap.t - val print : noCounters:bool -> Format.formatter -> t -> unit val to_yojson : t -> Yojson.Basic.t val of_yojson : Yojson.Basic.t -> t end = struct type transition = { next: Navigation.abstract Navigation.t; - dst: id (* id of cc and also address in the Env.domain map*); + dst: id; (* id of cc and also address in the Env.domain map*) inj: Renaming.t; (* From dst To ("this" cc + extra edge) *) } @@ -934,39 +1223,31 @@ end = struct max_obs: int; domain: point array; elementaries: (Navigation.abstract Navigation.step * id) list array array; - single_agent_points: (id*Operator.DepSet.t) option array; + single_agent_points: (id * Operator.DepSet.t) option array; } let signatures env = env.sig_decl let print ~noCounters f env = let pp_point p_id f p = - Format.fprintf - f "@[@[%a@]@ %t-> @[(%a)@]@]" + Format.fprintf f "@[@[%a@]@ %t-> @[(%a)@]@]" (fun x -> - print_cc ~noCounters ~sigs:env.sig_decl ~cc_id:p_id ~with_id:true x) + print_cc ~noCounters ~sigs:env.sig_decl ~cc_id:p_id ~with_id:true x) p.content - (fun f -> if p.roots <> None then - Format.fprintf - f "@[[%a]@]@ " + (fun f -> + if p.roots <> None then + Format.fprintf f "@[[%a]@]@ " (Pp.set Operator.DepSet.elements Pp.space Operator.print_rev_dep) p.deps) - (Pp.list - Pp.space - (fun f s -> - Format.fprintf - f "@[%a(%a)@ %i@]" - (Navigation.print env.sig_decl (find_ty p.content)) - s.next - Renaming.print s.inj s.dst)) - p.sons in - Format.fprintf - f "@[%a@]" - (Pp.array Pp.space pp_point) - env.domain + (Pp.list Pp.space (fun f s -> + Format.fprintf f "@[%a(%a)@ %i@]" + (Navigation.print env.sig_decl (find_ty p.content)) + s.next Renaming.print s.inj s.dst)) + p.sons + in + Format.fprintf f "@[%a@]" (Pp.array Pp.space pp_point) env.domain let get_single_agent ty env = env.single_agent_points.(ty) - let get env cc_id = env.domain.(cc_id) let to_navigation env id = @@ -974,161 +1255,206 @@ end = struct raw_to_navigation true cc.nodes_by_type cc.nodes let transition_to_yojson t = - `Assoc [ - "dst", `Int t.dst; - "inj", Renaming.to_yojson t.inj; - "nav", Navigation.to_yojson t.next; - ] + `Assoc + [ + "dst", `Int t.dst; + "inj", Renaming.to_yojson t.inj; + "nav", Navigation.to_yojson t.next; + ] + let transition_of_yojson = function - | `Assoc [ "dst", `Int dst; "inj", r; "nav", n ] - | `Assoc [ "dst", `Int dst; "nav", n; "inj", r ] - | `Assoc [ "inj", r; "nav", n; "dst", `Int dst ] - | `Assoc [ "nav", n; "inj", r; "dst", `Int dst ] - | `Assoc [ "inj", r; "dst", `Int dst; "nav", n ] - | `Assoc [ "nav", n; "dst", `Int dst; "inj", r ] -> - { dst; inj = Renaming.of_yojson r; next = Navigation.of_yojson n; } - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect transition",x)) + | `Assoc [ ("dst", `Int dst); ("inj", r); ("nav", n) ] + | `Assoc [ ("dst", `Int dst); ("nav", n); ("inj", r) ] + | `Assoc [ ("inj", r); ("nav", n); ("dst", `Int dst) ] + | `Assoc [ ("nav", n); ("inj", r); ("dst", `Int dst) ] + | `Assoc [ ("inj", r); ("dst", `Int dst); ("nav", n) ] + | `Assoc [ ("nav", n); ("dst", `Int dst); ("inj", r) ] -> + { dst; inj = Renaming.of_yojson r; next = Navigation.of_yojson n } + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect transition", x)) let point_to_yojson p = - `Assoc [ - "content",to_yojson p.content; - "roots", JsonUtil.of_option - (fun (ids,ty) -> - `List [`List (List.map JsonUtil.of_int ids); `Int ty]) p.roots; - "deps", Operator.depset_to_yojson p.deps; - "sons", `List (List.map transition_to_yojson p.sons); - ] + `Assoc + [ + "content", to_yojson p.content; + ( "roots", + JsonUtil.of_option + (fun (ids, ty) -> + `List [ `List (List.map JsonUtil.of_int ids); `Int ty ]) + p.roots ); + "deps", Operator.depset_to_yojson p.deps; + "sons", `List (List.map transition_to_yojson p.sons); + ] let point_of_yojson sig_decl = function | `Assoc l as x when List.length l = 4 -> - begin - try { - content = of_yojson sig_decl (List.assoc "content" l); - roots = (match List.assoc "roots" l with - | `Null -> None - | `List [ `List ids; `Int ty ] -> - Some (List.map Yojson.Basic.Util.to_int ids,ty) - | _ -> raise Not_found); - deps = Operator.depset_of_yojson (List.assoc "deps" l); - sons = (match List.assoc "sons" l with - | `List l -> List.map transition_of_yojson l - | _ -> raise Not_found); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Incorrect domain point",x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect domain point",x)) + (try + { + content = of_yojson sig_decl (List.assoc "content" l); + roots = + (match List.assoc "roots" l with + | `Null -> None + | `List [ `List ids; `Int ty ] -> + Some (List.map Yojson.Basic.Util.to_int ids, ty) + | _ -> raise Not_found); + deps = Operator.depset_of_yojson (List.assoc "deps" l); + sons = + (match List.assoc "sons" l with + | `List l -> List.map transition_of_yojson l + | _ -> raise Not_found); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Incorrect domain point", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect domain point", x)) let to_yojson env = - `Assoc [ - "signatures", Signature.to_json env.sig_decl; - "single_agents", `List - (Array.fold_right (fun x acc -> - (match x with None -> `Null | Some (id,_deps) -> `Int id)::acc) - env.single_agent_points []); - "elementaries", `List - (Array.fold_right (fun x acc -> - `List (Array.fold_right (fun x acc -> - `List (List.map (fun (st,d) -> - `List [Navigation.step_to_yojson st; `Int d]) x) - ::acc) x []) - ::acc) - env.elementaries []); - "dag", `List - (Array.fold_right (fun x acc -> - (point_to_yojson x)::acc) env.domain []); - "id_by_type", `List - (Array.fold_right (fun x acc -> - `List (List.map (fun i -> `Int i) x)::acc) env.id_by_type []); - "max_obs", `Int env.max_obs - ] + `Assoc + [ + "signatures", Signature.to_json env.sig_decl; + ( "single_agents", + `List + (Array.fold_right + (fun x acc -> + (match x with + | None -> `Null + | Some (id, _deps) -> `Int id) + :: acc) + env.single_agent_points []) ); + ( "elementaries", + `List + (Array.fold_right + (fun x acc -> + `List + (Array.fold_right + (fun x acc -> + `List + (List.map + (fun (st, d) -> + `List [ Navigation.step_to_yojson st; `Int d ]) + x) + :: acc) + x []) + :: acc) + env.elementaries []) ); + ( "dag", + `List + (Array.fold_right + (fun x acc -> point_to_yojson x :: acc) + env.domain []) ); + ( "id_by_type", + `List + (Array.fold_right + (fun x acc -> `List (List.map (fun i -> `Int i) x) :: acc) + env.id_by_type []) ); + "max_obs", `Int env.max_obs; + ] let of_yojson = function | `Assoc l as x when List.length l = 6 -> - begin - let sig_decl = Signature.of_json (List.assoc "signatures" l) in - try - { - sig_decl; - single_agent_points = (match List.assoc "single_agents" l with - | `List l -> - Tools.array_map_of_list - (Yojson.Basic.Util.to_option - (function `Int i -> (i,Operator.DepSet.empty) - | x -> - raise (Yojson.Basic.Util.Type_error - ("Wrong single_agent",x))) - ) l - | _ -> raise Not_found); - elementaries = (match List.assoc "elementaries" l with - | `List l -> - Tools.array_map_of_list (function - | `List l -> Tools.array_map_of_list (function - | `List l -> List.map (function - | `List [s; `Int d] -> - (Navigation.step_of_yojson s,d) - | _ -> raise Not_found) l - | _ -> raise Not_found) l - | _ -> raise Not_found) l - | _ -> raise Not_found); - domain = (match List.assoc "dag" l with - | `List l -> - Tools.array_map_of_list (point_of_yojson sig_decl) l - | _ -> raise Not_found); - id_by_type = (match List.assoc "id_by_type" l with - | `List l -> - Tools.array_map_of_list (function - | `List l -> List.map (function - | `Int i -> i - | _ -> raise Not_found) l - | _ -> raise Not_found) l - | _ -> raise Not_found); - max_obs = (match List.assoc "max_obs" l with - | `Int i -> i - | _ -> raise Not_found) - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Incorrect update domain",x)) - end - | x -> - raise (Yojson.Basic.Util.Type_error ("Incorrect update domain",x)) + let sig_decl = Signature.of_json (List.assoc "signatures" l) in + (try + { + sig_decl; + single_agent_points = + (match List.assoc "single_agents" l with + | `List l -> + Tools.array_map_of_list + (Yojson.Basic.Util.to_option (function + | `Int i -> i, Operator.DepSet.empty + | x -> + raise + (Yojson.Basic.Util.Type_error ("Wrong single_agent", x)))) + l + | _ -> raise Not_found); + elementaries = + (match List.assoc "elementaries" l with + | `List l -> + Tools.array_map_of_list + (function + | `List l -> + Tools.array_map_of_list + (function + | `List l -> + List.map + (function + | `List [ s; `Int d ] -> + Navigation.step_of_yojson s, d + | _ -> raise Not_found) + l + | _ -> raise Not_found) + l + | _ -> raise Not_found) + l + | _ -> raise Not_found); + domain = + (match List.assoc "dag" l with + | `List l -> Tools.array_map_of_list (point_of_yojson sig_decl) l + | _ -> raise Not_found); + id_by_type = + (match List.assoc "id_by_type" l with + | `List l -> + Tools.array_map_of_list + (function + | `List l -> + List.map + (function + | `Int i -> i + | _ -> raise Not_found) + l + | _ -> raise Not_found) + l + | _ -> raise Not_found); + max_obs = + (match List.assoc "max_obs" l with + | `Int i -> i + | _ -> raise Not_found); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Incorrect update domain", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect update domain", x)) let new_obs_map env f = Mods.DynArray.init env.max_obs f - let get_elementary ~debugMode domain (_,ty as node) s arrow = + let get_elementary ~debug_mode domain ((_, ty) as node) s arrow = let sa = domain.elementaries.(ty) in - let rec find_good_edge = function (*one should use a hash here*) + let rec find_good_edge = function + (*one should use a hash here*) | [] -> None - | (st,cc_id) :: tail -> - match Navigation.compatible_fresh_point ~debugMode st node s arrow with - | None -> find_good_edge tail + | (st, cc_id) :: tail -> + (match + Navigation.compatible_fresh_point ~debug_mode st node s arrow + with + | None -> find_good_edge tail | Some inj' -> let dst = get domain cc_id in - Some (cc_id,dst,inj') in + Some (cc_id, dst, inj')) + in find_good_edge sa.(s) - end let print ~noCounters ?domain ~with_id f id = match domain with | None -> Format.pp_print_int f id | Some env -> - let cc_id = if with_id then Some id else None in - print_cc - ~noCounters ~sigs:(Env.signatures env) ?cc_id ~with_id - f env.Env.domain.(id).Env.content - -let embeddings_to_fully_specified ~debugMode domain a_id b = + let cc_id = + if with_id then + Some id + else + None + in + print_cc ~noCounters ~sigs:(Env.signatures env) ?cc_id ~with_id f + env.Env.domain.(id).Env.content + +let embeddings_to_fully_specified ~debug_mode domain a_id b = let a = domain.Env.domain.(a_id).Env.content in match find_root a with - | None -> [Renaming.empty ()] - | Some (h,ty) -> - List.fold_left (fun acc ag -> - match are_compatible ~debugMode ~strict:false h a ag b with - | (None,_) -> acc - | (Some r,_) -> r::acc) [] b.nodes_by_type.(ty) + | None -> [ Renaming.empty () ] + | Some (h, ty) -> + List.fold_left + (fun acc ag -> + match are_compatible ~debug_mode ~strict:false h a ag b with + | None, _ -> acc + | Some r, _ -> r :: acc) + [] b.nodes_by_type.(ty) type prepoint = { p_id: id; @@ -1143,7 +1469,7 @@ type work = { reserved_id: int list array; used_id: int list array; free_id: int; - cc_nodes: (link*int) array Mods.IntMap.t; + cc_nodes: (link * int) array Mods.IntMap.t; dangling: int; (* node_id *) } @@ -1159,13 +1485,7 @@ module PreEnv = struct type stat = { stat_nodes: int; stat_nav_steps: int } let fresh sigs id_by_type nb_id domain = - { - sig_decl = sigs; - id_by_type = id_by_type; - nb_id = nb_id; - domain = domain; - used_by_a_begin_new = false; - } + { sig_decl = sigs; id_by_type; nb_id; domain; used_by_a_begin_new = false } let empty sigs = let nbt' = Array.make (Signature.size sigs) [] in @@ -1189,193 +1509,282 @@ module PreEnv = struct let sigs env = env.sig_decl let empty_point sigs = - {Env.content = empty_cc sigs; Env.roots = None; - Env.deps = Operator.DepSet.empty; Env.sons = [];} + { + Env.content = empty_cc sigs; + Env.roots = None; + Env.deps = Operator.DepSet.empty; + Env.sons = []; + } let fill_elem sigs bottom = let elementaries = - Array.init (Signature.size sigs) - (fun i -> Array.make (Signature.arity sigs i) []) in + Array.init (Signature.size sigs) (fun i -> + Array.make (Signature.arity sigs i) []) + in let () = Mods.IntMap.iter - (fun _ -> List.iter (fun p -> - match p.element.recogn_nav with - | [] | ((Navigation.Existing _,_),_) :: _ -> assert false - | ((Navigation.Fresh _,_),_) :: _ :: _ -> () - | [(Navigation.Fresh (_,ty1),s1),arr as step] -> - let sa1 = elementaries.(ty1) in - let () = sa1.(s1) <- (step,p.p_id) :: sa1.(s1) in - match arr with - | Navigation.ToNode (Navigation.Fresh (_,ty2),s2) -> - if ty1 = ty2 && s1 <> s2 then - sa1.(s2) <- (step,p.p_id) :: sa1.(s2) - else - let sa2 = elementaries.(ty2) in - sa2.(s2) <- (step,p.p_id) :: sa2.(s2) - | Navigation.ToNode (Navigation.Existing _,s2) -> - sa1.(s2) <- (step,p.p_id) :: sa1.(s2) - | Navigation.ToNothing | Navigation.ToInternal _ -> ())) - bottom in + (fun _ -> + List.iter (fun p -> + match p.element.recogn_nav with + | [] | ((Navigation.Existing _, _), _) :: _ -> assert false + | ((Navigation.Fresh _, _), _) :: _ :: _ -> () + | [ (((Navigation.Fresh (_, ty1), s1), arr) as step) ] -> + let sa1 = elementaries.(ty1) in + let () = sa1.(s1) <- (step, p.p_id) :: sa1.(s1) in + (match arr with + | Navigation.ToNode (Navigation.Fresh (_, ty2), s2) -> + if ty1 = ty2 && s1 <> s2 then + sa1.(s2) <- (step, p.p_id) :: sa1.(s2) + else ( + let sa2 = elementaries.(ty2) in + sa2.(s2) <- (step, p.p_id) :: sa2.(s2) + ) + | Navigation.ToNode (Navigation.Existing _, s2) -> + sa1.(s2) <- (step, p.p_id) :: sa1.(s2) + | Navigation.ToNothing | Navigation.ToInternal _ -> ()))) + bottom + in elementaries - let present_in_dst ~debugMode dst inj2dst nav = + let present_in_dst ~debug_mode dst inj2dst nav = let rec aux_present_in_dst inj' = function | [] -> Some inj' | ((Navigation.Fresh _, _), _) :: _ -> assert false | ((Navigation.Existing ag, si), Navigation.ToNothing) :: t -> - begin match Mods.IntMap.find_option (Renaming.apply ~debugMode inj' ag) dst.nodes with - | None -> assert false - | Some n -> if fst n.(si) = Free then aux_present_in_dst inj' t else None - end + (match + Mods.IntMap.find_option + (Renaming.apply ~debug_mode inj' ag) + dst.nodes + with + | None -> assert false + | Some n -> + if fst n.(si) = Free then + aux_present_in_dst inj' t + else + None) | ((Navigation.Existing ag, si), Navigation.ToInternal i) :: t -> - begin match Mods.IntMap.find_option (Renaming.apply ~debugMode inj' ag) dst.nodes with - | None -> assert false - | Some n -> if snd n.(si) = i then aux_present_in_dst inj' t else None - end - | ((Navigation.Existing ag, si), Navigation.ToNode (Navigation.Existing ag',si')) :: t -> - begin match Mods.IntMap.find_option (Renaming.apply ~debugMode inj' ag) dst.nodes with - | None -> assert false - | Some n -> - if fst n.(si) = Link (Renaming.apply ~debugMode inj' ag',si') - then aux_present_in_dst inj' t - else None - end - | ((Navigation.Existing ag, si), Navigation.ToNode (Navigation.Fresh (ag',ty'),si')) :: t -> - begin match Mods.IntMap.find_option (Renaming.apply ~debugMode inj' ag) dst.nodes with - | None -> assert false - | Some n -> match n.(si) with - | Link (agl,sil), _ -> - if List.mem agl dst.nodes_by_type.(ty') && si' = sil - then match Renaming.add ~debugMode ag' agl inj' with - | None -> None - | Some inj' -> aux_present_in_dst inj' t - else None - | (Free | UnSpec) , _ -> None - end in + (match + Mods.IntMap.find_option + (Renaming.apply ~debug_mode inj' ag) + dst.nodes + with + | None -> assert false + | Some n -> + if snd n.(si) = i then + aux_present_in_dst inj' t + else + None) + | ( (Navigation.Existing ag, si), + Navigation.ToNode (Navigation.Existing ag', si') ) + :: t -> + (match + Mods.IntMap.find_option + (Renaming.apply ~debug_mode inj' ag) + dst.nodes + with + | None -> assert false + | Some n -> + if fst n.(si) = Link (Renaming.apply ~debug_mode inj' ag', si') then + aux_present_in_dst inj' t + else + None) + | ( (Navigation.Existing ag, si), + Navigation.ToNode (Navigation.Fresh (ag', ty'), si') ) + :: t -> + (match + Mods.IntMap.find_option + (Renaming.apply ~debug_mode inj' ag) + dst.nodes + with + | None -> assert false + | Some n -> + (match n.(si) with + | Link (agl, sil), _ -> + if List.mem agl dst.nodes_by_type.(ty') && si' = sil then ( + match Renaming.add ~debug_mode ag' agl inj' with + | None -> None + | Some inj' -> aux_present_in_dst inj' t + ) else + None + | (Free | UnSpec), _ -> None)) + in aux_present_in_dst inj2dst nav - let rec insert_navigation ~debugMode id_by_type nb_id domain dst_id dst inj2dst p_id = - if p_id = dst_id then 0 - else + let rec insert_navigation ~debug_mode id_by_type nb_id domain dst_id dst + inj2dst p_id = + if p_id = dst_id then + 0 + else ( let point = domain.(p_id) in let rec insert_nav_sons = function | [] -> - let (inj_e2sup,_),sup = - merge_compatible - ~debugMode - id_by_type nb_id - inj2dst point.Env.content dst in - (match equal ~debugMode sup dst with + let (inj_e2sup, _), sup = + merge_compatible ~debug_mode id_by_type nb_id inj2dst + point.Env.content dst + in + (match equal ~debug_mode sup dst with | None -> assert false | Some inj_sup2dst -> let inj_dst2p = Renaming.inverse - (Renaming.compose - ~debugMode false - inj_e2sup inj_sup2dst) in - let nav = build_navigation_between - ~debugMode inj_dst2p point.Env.content dst in + (Renaming.compose ~debug_mode false inj_e2sup inj_sup2dst) + in + let nav = + build_navigation_between ~debug_mode inj_dst2p point.Env.content + dst + in let () = point.Env.sons <- - {Env.dst = dst_id; Env.inj = inj_dst2p; Env.next = nav} :: point.Env.sons - in List.length nav) + { Env.dst = dst_id; Env.inj = inj_dst2p; Env.next = nav } + :: point.Env.sons + in + List.length nav) | h :: t -> - match present_in_dst ~debugMode dst inj2dst h.Env.next with + (match present_in_dst ~debug_mode dst inj2dst h.Env.next with | None -> insert_nav_sons t | Some inj_p'2dst -> - insert_navigation - ~debugMode id_by_type nb_id domain dst_id dst - (Renaming.compose ~debugMode false h.Env.inj inj_p'2dst) - h.Env.dst in + insert_navigation ~debug_mode id_by_type nb_id domain dst_id dst + (Renaming.compose ~debug_mode false h.Env.inj inj_p'2dst) + h.Env.dst) + in insert_nav_sons point.Env.sons + ) - let add_cc ~debugMode ~toplevel ?origin env p_id element = + let add_cc ~debug_mode ~toplevel ?origin env p_id element = let w = weight element in let hash = coarse_hash element in let rec aux = function | [] -> - let roots = if toplevel then + let roots = + if toplevel then ( match find_root element with | None -> None - | Some (rid,rty) -> - Some (List.sort Mods.int_compare - (List.map - (fun r -> Renaming.apply ~debugMode r rid) - (automorphisms ~debugMode element)),rty) - else None in - [{p_id; element;roots; - depending=add_origin Operator.DepSet.empty origin}], - identity_injection element,element,p_id - | h :: t -> match equal ~debugMode element h.element with - | None -> let a,b,c,d = aux t in h::a,b,c,d + | Some (rid, rty) -> + Some + ( List.sort Mods.int_compare + (List.map + (fun r -> Renaming.apply ~debug_mode r rid) + (automorphisms ~debug_mode element)), + rty ) + ) else + None + in + ( [ + { + p_id; + element; + roots; + depending = add_origin Operator.DepSet.empty origin; + }; + ], + identity_injection element, + element, + p_id ) + | h :: t -> + (match equal ~debug_mode element h.element with + | None -> + let a, b, c, d = aux t in + h :: a, b, c, d | Some r -> let roots = - if h.roots <> None || not toplevel then h.roots - else match find_root element with + if h.roots <> None || not toplevel then + h.roots + else ( + match find_root element with | None -> None - | Some (rid,rty) -> - Some (List.sort Mods.int_compare - (List.map - (fun r -> Renaming.apply ~debugMode r rid) - (automorphisms ~debugMode element)),rty) in - {p_id=h.p_id; element=h.element; - depending=add_origin h.depending origin; roots; - }::t,r,h.element,h.p_id in + | Some (rid, rty) -> + Some + ( List.sort Mods.int_compare + (List.map + (fun r -> Renaming.apply ~debug_mode r rid) + (automorphisms ~debug_mode element)), + rty ) + ) + in + ( { + p_id = h.p_id; + element = h.element; + depending = add_origin h.depending origin; + roots; + } + :: t, + r, + h.element, + h.p_id )) + in let env_w = Mods.IntMap.find_default Mods.IntMap.empty w env in - let env_w_h,r,out,out_id = aux (Mods.IntMap.find_default [] hash env_w) in - Mods.IntMap.add w (Mods.IntMap.add hash env_w_h env_w) env,r,out,out_id - - let rec saturate_one - ~debugMode ~sharing sigs this max_l level (_,domain as acc) = - function - | [] -> if level < max_l then - saturate_one - ~debugMode ~sharing sigs this max_l (succ level) acc - (Mods.IntMap.fold (fun _ -> List.rev_append) + let env_w_h, r, out, out_id = + aux (Mods.IntMap.find_default [] hash env_w) + in + Mods.IntMap.add w (Mods.IntMap.add hash env_w_h env_w) env, r, out, out_id + + let rec saturate_one ~debug_mode ~sharing sigs this max_l level + ((_, domain) as acc) = function + | [] -> + if level < max_l then + saturate_one ~debug_mode ~sharing sigs this max_l (succ level) acc + (Mods.IntMap.fold + (fun _ -> List.rev_append) (Mods.IntMap.find_default Mods.IntMap.empty (succ level) domain) []) - else acc + else + acc | h :: t -> let news = match sharing with | No_sharing -> assert false - | Max_sharing -> infs sigs ~debugMode this.element h.element + | Max_sharing -> infs sigs ~debug_mode this.element h.element | Compatible_patterns -> List.rev_map (fun r -> intersection r this.element h.element) - (matchings ~debugMode sigs this.element h.element) in + (matchings ~debug_mode sigs this.element h.element) + in let acc' = List.fold_left - (fun (mid,acc) cc -> - let id' = succ mid in - let x,_,_,id = add_cc ~debugMode ~toplevel:false acc id' cc in - ((if id = id' then id else mid),x)) - acc news in - saturate_one ~debugMode ~sharing sigs this max_l level acc' t - let rec saturate_level - ~debugMode ~sharing sigs max_l level (_,domain as acc) = - if level < 2 then acc else + (fun (mid, acc) cc -> + let id' = succ mid in + let x, _, _, id = add_cc ~debug_mode ~toplevel:false acc id' cc in + ( (if id = id' then + id + else + mid), + x )) + acc news + in + saturate_one ~debug_mode ~sharing sigs this max_l level acc' t + + let rec saturate_level ~debug_mode ~sharing sigs max_l level + ((_, domain) as acc) = + if level < 2 then + acc + else ( match Mods.IntMap.find_option level domain with - | None -> saturate_level ~debugMode ~sharing sigs max_l (pred level) acc + | None -> saturate_level ~debug_mode ~sharing sigs max_l (pred level) acc | Some list -> let rec aux acc = function - | [] -> saturate_level ~debugMode ~sharing sigs max_l (pred level) acc - | h::t -> - aux (saturate_one ~debugMode ~sharing sigs h max_l level acc t) t in + | [] -> + saturate_level ~debug_mode ~sharing sigs max_l (pred level) acc + | h :: t -> + aux (saturate_one ~debug_mode ~sharing sigs h max_l level acc t) t + in aux acc (Mods.IntMap.fold (fun _ -> List.rev_append) list []) - let saturate ~debugMode ~sharing sigs domain = + ) + + let saturate ~debug_mode ~sharing sigs domain = match Mods.IntMap.max_key domain with - | None -> 0,domain + | None -> 0, domain | Some l -> let si = Mods.IntMap.fold - (fun _ -> Mods.IntMap.fold - (fun _ l m -> List.fold_left (fun m p -> max m p.p_id) m l)) - domain 0 in - match sharing with - | No_sharing -> si,domain + (fun _ -> + Mods.IntMap.fold (fun _ l m -> + List.fold_left (fun m p -> max m p.p_id) m l)) + domain 0 + in + (match sharing with + | No_sharing -> si, domain | Compatible_patterns | Max_sharing -> - saturate_level ~debugMode ~sharing sigs l l (si,domain) + saturate_level ~debug_mode ~sharing sigs l l (si, domain)) let of_env env = let add_cc acc p = @@ -1383,13 +1792,23 @@ module PreEnv = struct let hash = coarse_hash p.element in let acc_w = Mods.IntMap.find_default Mods.IntMap.empty w acc in Mods.IntMap.add w - (Mods.IntMap.add hash (p::Mods.IntMap.find_default [] hash acc_w) acc_w) - acc in + (Mods.IntMap.add hash + (p :: Mods.IntMap.find_default [] hash acc_w) + acc_w) + acc + in let domain' = - Tools.array_fold_lefti (fun p_id acc p -> - add_cc acc {p_id; element=p.Env.content; - depending=p.Env.deps;roots=p.Env.roots;}) - Mods.IntMap.empty env.Env.domain in + Tools.array_fold_lefti + (fun p_id acc p -> + add_cc acc + { + p_id; + element = p.Env.content; + depending = p.Env.deps; + roots = p.Env.roots; + }) + Mods.IntMap.empty env.Env.domain + in { sig_decl = env.Env.sig_decl; nb_id = succ (Array.fold_left (List.fold_left max) 0 env.Env.id_by_type); @@ -1399,18 +1818,14 @@ module PreEnv = struct } let debug_print f env = - Pp.array - Pp.comma + Pp.array Pp.comma (fun ty f l -> - Format.fprintf f "%d: %t" ty - (fun f -> - Format.fprintf f "["; - Pp.list - Pp.comma - (fun f a -> Format.fprintf f "%d" a) f l; - Format.fprintf f "]")) + Format.fprintf f "%d: %t" ty (fun f -> + Format.fprintf f "["; + Pp.list Pp.comma (fun f a -> Format.fprintf f "%d" a) f l; + Format.fprintf f "]")) f env.id_by_type; - Format.fprintf f "used_by_a_begin_new = %B@." (env.used_by_a_begin_new) + Format.fprintf f "used_by_a_begin_new = %B@." env.used_by_a_begin_new end (** Operation to create cc *) @@ -1423,220 +1838,276 @@ let begin_new env = PreEnv.to_work env let fresh_cc_id domain = succ (Mods.IntMap.fold - (fun _ -> Mods.IntMap.fold - (fun _ x acc -> - List.fold_left (fun acc p -> max acc p.p_id) acc x)) + (fun _ -> + Mods.IntMap.fold (fun _ x acc -> + List.fold_left (fun acc p -> max acc p.p_id) acc x)) domain 0) -let raw_finish_new ~debugMode ~toplevel ?origin wk = +let raw_finish_new ~debug_mode ~toplevel ?origin wk = let () = check_dangling wk in (* rebuild env *) let () = Tools.iteri - (fun i -> wk.reserved_id.(i) <- - List.rev_append wk.used_id.(i) wk.reserved_id.(i)) - (Array.length wk.used_id) in + (fun i -> + wk.reserved_id.(i) <- List.rev_append wk.used_id.(i) wk.reserved_id.(i)) + (Array.length wk.used_id) + in let nodes_by_type = Array.map List.rev wk.used_id in let cc_candidate = - { nodes_by_type; nodes = wk.cc_nodes; - recogn_nav = raw_to_navigation false nodes_by_type wk.cc_nodes} in - let preenv,r,out,out_id = - PreEnv.add_cc - ~debugMode ~toplevel - ?origin wk.cc_env (fresh_cc_id wk.cc_env) cc_candidate in - PreEnv.fresh wk.sigs wk.reserved_id wk.free_id preenv,r,out,out_id - -let finish_new ~debugMode ?origin wk = - raw_finish_new ~debugMode ~toplevel:true ?origin wk - -let new_link wk ((x,_ as n1),i) ((y,_ as n2),j) = + { + nodes_by_type; + nodes = wk.cc_nodes; + recogn_nav = raw_to_navigation false nodes_by_type wk.cc_nodes; + } + in + let preenv, r, out, out_id = + PreEnv.add_cc ~debug_mode ~toplevel ?origin wk.cc_env + (fresh_cc_id wk.cc_env) cc_candidate + in + PreEnv.fresh wk.sigs wk.reserved_id wk.free_id preenv, r, out, out_id + +let finish_new ~debug_mode ?origin wk = + raw_finish_new ~debug_mode ~toplevel:true ?origin wk + +let new_link wk (((x, _) as n1), i) (((y, _) as n2), j) = let x_n = Mods.IntMap.find_default [||] x wk.cc_nodes in let y_n = Mods.IntMap.find_default [||] y wk.cc_nodes in match x_n.(i), y_n.(j) with - | (UnSpec, stx), (UnSpec,sty) -> - let () = x_n.(i) <- (Link (y,j),stx) in - let () = y_n.(j) <- (Link (x,i),sty) in - if wk.dangling = x || wk.dangling = y - then { wk with dangling = 0 } - else wk - | ((Free | Link _),_), _ -> - raise (already_specified ~sigs:wk.sigs n1 i) - | _, ((Free | Link _),_) -> - raise (already_specified ~sigs:wk.sigs n2 j) - -let new_free wk ((x,_ as n),i) = + | (UnSpec, stx), (UnSpec, sty) -> + let () = x_n.(i) <- Link (y, j), stx in + let () = y_n.(j) <- Link (x, i), sty in + if wk.dangling = x || wk.dangling = y then + { wk with dangling = 0 } + else + wk + | ((Free | Link _), _), _ -> raise (already_specified ~sigs:wk.sigs n1 i) + | _, ((Free | Link _), _) -> raise (already_specified ~sigs:wk.sigs n2 j) + +let new_free wk (((x, _) as n), i) = let x_n = Mods.IntMap.find_default [||] x wk.cc_nodes in match x_n.(i) with - | UnSpec,st -> let () = x_n.(i) <- (Free,st) in wk - | (Free | Link _),_ -> raise (already_specified ~sigs:wk.sigs n i) + | UnSpec, st -> + let () = x_n.(i) <- Free, st in + wk + | (Free | Link _), _ -> raise (already_specified ~sigs:wk.sigs n i) -let new_internal_state wk ((x,_ as n), i) va = +let new_internal_state wk (((x, _) as n), i) va = let x_n = Mods.IntMap.find_default [||] x wk.cc_nodes in - let (l,s) = x_n.(i) in - if s >= 0 then raise (already_specified ~sigs:wk.sigs n i) - else let () = x_n.(i) <- (l,va) in wk + let l, s = x_n.(i) in + if s >= 0 then + raise (already_specified ~sigs:wk.sigs n i) + else ( + let () = x_n.(i) <- l, va in + wk + ) let new_node wk type_id = let () = check_dangling wk in let arity = Signature.arity wk.sigs type_id in match wk.reserved_id.(type_id) with - | h::t -> + | h :: t -> let () = wk.used_id.(type_id) <- h :: wk.used_id.(type_id) in let () = wk.reserved_id.(type_id) <- t in - let node = (h,type_id) in - (node, - { - sigs = wk.sigs; cc_env = wk.cc_env; reserved_id = wk.reserved_id; - used_id = wk.used_id; free_id = wk.free_id; - dangling = if Mods.IntMap.is_empty wk.cc_nodes then 0 else h; - cc_nodes = Mods.IntMap.add h (Array.make arity (UnSpec,-1)) wk.cc_nodes; - }) + let node = h, type_id in + ( node, + { + sigs = wk.sigs; + cc_env = wk.cc_env; + reserved_id = wk.reserved_id; + used_id = wk.used_id; + free_id = wk.free_id; + dangling = + (if Mods.IntMap.is_empty wk.cc_nodes then + 0 + else + h); + cc_nodes = Mods.IntMap.add h (Array.make arity (UnSpec, -1)) wk.cc_nodes; + } ) | [] -> let () = wk.used_id.(type_id) <- wk.free_id :: wk.used_id.(type_id) in - let node = (wk.free_id, type_id) in - (node, - { - sigs = wk.sigs; cc_env = wk.cc_env; reserved_id = wk.reserved_id; - used_id = wk.used_id; free_id = succ wk.free_id; - dangling = if Mods.IntMap.is_empty wk.cc_nodes then 0 else wk.free_id; - cc_nodes = - Mods.IntMap.add wk.free_id (Array.make arity (UnSpec,-1)) wk.cc_nodes; - }) - -let minimal_env ~debugMode env contact_map = + let node = wk.free_id, type_id in + ( node, + { + sigs = wk.sigs; + cc_env = wk.cc_env; + reserved_id = wk.reserved_id; + used_id = wk.used_id; + free_id = succ wk.free_id; + dangling = + (if Mods.IntMap.is_empty wk.cc_nodes then + 0 + else + wk.free_id); + cc_nodes = + Mods.IntMap.add wk.free_id (Array.make arity (UnSpec, -1)) wk.cc_nodes; + } ) + +let minimal_env ~debug_mode env contact_map = Tools.array_fold_lefti (fun ty -> - Tools.array_fold_lefti - (fun s acc (ints,links) -> - let w = begin_new acc in - let n,w = new_node w ty in - let w = new_free w (n,s) in - let acc',_,_,_ = raw_finish_new ~debugMode ~toplevel:false w in - let acc'' = - Mods.IntSet.fold - (fun i acc -> - let w = begin_new acc in - let n,w = new_node w ty in - let w = new_internal_state w (n,s) i in - let out,_,_,_ = - raw_finish_new ~debugMode ~toplevel:false w in - out) ints acc' in - Mods.Int2Set.fold - (fun (ty',s') acc -> - let w = begin_new acc in - let n,w = new_node w ty in - let n',w = new_node w ty' in - let w = new_link w (n,s) (n',s') in - let out,_,_,_ = raw_finish_new ~debugMode ~toplevel:false w in - if ty = ty' && s < s' then - let w = begin_new out in - let n,w = new_node w ty in - let w = new_link w (n,s) (n,s') in - let out',_,_,_ = - raw_finish_new ~debugMode ~toplevel:false w in - out' - else out) links acc'' - )) + Tools.array_fold_lefti (fun s acc (ints, links) -> + let w = begin_new acc in + let n, w = new_node w ty in + let w = new_free w (n, s) in + let acc', _, _, _ = raw_finish_new ~debug_mode ~toplevel:false w in + let acc'' = + Mods.IntSet.fold + (fun i acc -> + let w = begin_new acc in + let n, w = new_node w ty in + let w = new_internal_state w (n, s) i in + let out, _, _, _ = + raw_finish_new ~debug_mode ~toplevel:false w + in + out) + ints acc' + in + Mods.Int2Set.fold + (fun (ty', s') acc -> + let w = begin_new acc in + let n, w = new_node w ty in + let n', w = new_node w ty' in + let w = new_link w (n, s) (n', s') in + let out, _, _, _ = raw_finish_new ~debug_mode ~toplevel:false w in + if ty = ty' && s < s' then ( + let w = begin_new out in + let n, w = new_node w ty in + let w = new_link w (n, s) (n, s') in + let out', _, _, _ = + raw_finish_new ~debug_mode ~toplevel:false w + in + out' + ) else + out) + links acc'')) env contact_map let fold_by_type f cc acc = Tools.array_fold_lefti (fun agent_type acc list_pos -> - List.fold_left - (fun acc pos -> - let intf = Mods.IntMap.find_default [||] pos cc.nodes in - f ~pos ~agent_type intf acc) - acc - list_pos) - acc - cc.nodes_by_type + List.fold_left + (fun acc pos -> + let intf = Mods.IntMap.find_default [||] pos cc.nodes in + f ~pos ~agent_type intf acc) + acc list_pos) + acc cc.nodes_by_type let fold f cc acc = Mods.IntMap.fold f cc.nodes acc -let finalize ~debugMode ~sharing env contact_map = +let finalize ~debug_mode ~sharing env contact_map = let sigs = PreEnv.sigs env in - let env = minimal_env ~debugMode env contact_map in - let si,complete_domain = - PreEnv.saturate ~debugMode ~sharing sigs env.PreEnv.domain in + let env = minimal_env ~debug_mode env contact_map in + let si, complete_domain = + PreEnv.saturate ~debug_mode ~sharing sigs env.PreEnv.domain + in let domain = Array.make (succ si) (PreEnv.empty_point env.PreEnv.sig_decl) in - let singles = - Mods.IntMap.find_default Mods.IntMap.empty 1 complete_domain in + let singles = Mods.IntMap.find_default Mods.IntMap.empty 1 complete_domain in let elementaries = PreEnv.fill_elem env.PreEnv.sig_decl singles in let () = Mods.IntMap.iter - (fun _ -> List.iter - (fun x -> - domain.(x.p_id) <- - { Env.content = x.element; Env.sons = []; - Env.deps = x.depending; Env.roots = x.roots; })) - singles in + (fun _ -> + List.iter (fun x -> + domain.(x.p_id) <- + { + Env.content = x.element; + Env.sons = []; + Env.deps = x.depending; + Env.roots = x.roots; + })) + singles + in let stat_nav_steps = Mods.IntMap.fold (fun level domain_level acc_level -> - if level <= 1 then acc_level else + if level <= 1 then + acc_level + else Mods.IntMap.fold (fun _ l acc -> - List.fold_left (fun acc x -> - let () = domain.(x.p_id) <- - { Env.content = x.element; Env.sons = []; - Env.roots = x.roots; Env.deps = x.depending;} in - Mods.IntMap.fold (fun _ ll accl-> - List.fold_left (fun acc e -> - match - matchings ~debugMode sigs e.element x.element - with - | [] -> acc - | injs -> - List.fold_left - (fun acc inj_e_x -> - PreEnv.insert_navigation - ~debugMode env.PreEnv.id_by_type env.PreEnv.nb_id - domain x.p_id x.element inj_e_x e.p_id - + acc - ) - acc injs - ) accl ll) singles acc) acc l) - domain_level acc_level) - complete_domain 0 in + List.fold_left + (fun acc x -> + let () = + domain.(x.p_id) <- + { + Env.content = x.element; + Env.sons = []; + Env.roots = x.roots; + Env.deps = x.depending; + } + in + Mods.IntMap.fold + (fun _ ll accl -> + List.fold_left + (fun acc e -> + match + matchings ~debug_mode sigs e.element x.element + with + | [] -> acc + | injs -> + List.fold_left + (fun acc inj_e_x -> + PreEnv.insert_navigation ~debug_mode + env.PreEnv.id_by_type env.PreEnv.nb_id domain + x.p_id x.element inj_e_x e.p_id + + acc) + acc injs) + accl ll) + singles acc) + acc l) + domain_level acc_level) + complete_domain 0 + in let level0 = Mods.IntMap.find_default Mods.IntMap.empty 0 complete_domain in let single_agent_points = - Array.make (Array.length env.PreEnv.id_by_type) None in + Array.make (Array.length env.PreEnv.id_by_type) None + in let () = - Mods.IntMap.iter (fun _ -> - List.iter - (fun p -> - match find_root p.element with - | None -> () - | Some (_,ty) -> - let () = domain.(p.p_id) <- - { Env.content = p.element; Env.roots = p.roots; - Env.deps = p.depending; Env.sons = []; } in - single_agent_points.(ty) <- Some (p.p_id,p.depending))) - level0 in - { - Env.sig_decl = env.PreEnv.sig_decl; - Env.id_by_type = env.PreEnv.id_by_type; - Env.max_obs = fresh_cc_id env.PreEnv.domain; - Env.domain; - Env.elementaries; - Env.single_agent_points; - },{ stat_nodes = si; PreEnv.stat_nav_steps } - -let merge_on_inf ~debugMode env m g1 g2 = + Mods.IntMap.iter + (fun _ -> + List.iter (fun p -> + match find_root p.element with + | None -> () + | Some (_, ty) -> + let () = + domain.(p.p_id) <- + { + Env.content = p.element; + Env.roots = p.roots; + Env.deps = p.depending; + Env.sons = []; + } + in + single_agent_points.(ty) <- Some (p.p_id, p.depending))) + level0 + in + ( { + Env.sig_decl = env.PreEnv.sig_decl; + Env.id_by_type = env.PreEnv.id_by_type; + Env.max_obs = fresh_cc_id env.PreEnv.domain; + Env.domain; + Env.elementaries; + Env.single_agent_points; + }, + { stat_nodes = si; PreEnv.stat_nav_steps } ) + +let merge_on_inf ~debug_mode env m g1 g2 = let m_list = Renaming.to_list m in - let (root1,root2) = List.hd m_list in + let root1, root2 = List.hd m_list in let pairing = List.fold_left - (fun acc (a,b) -> Mods.Int2Set.add (a,b) acc) - Mods.Int2Set.empty m_list in + (fun acc (a, b) -> Mods.Int2Set.add (a, b) acc) + Mods.Int2Set.empty m_list + in let possibilities = ref pairing in - match are_compatible - ~debugMode ~possibilities ~strict:false root1 g1 root2 g2 with - | (Some m',_) -> - let (_,pushout) = - merge_compatible - ~debugMode env.PreEnv.id_by_type env.PreEnv.nb_id m' g1 g2 in - (Some pushout,None) - | (None,conflict) -> (None,conflict) - -let length cc = Mods.IntMap.size (cc.nodes) + match + are_compatible ~debug_mode ~possibilities ~strict:false root1 g1 root2 g2 + with + | Some m', _ -> + let _, pushout = + merge_compatible ~debug_mode env.PreEnv.id_by_type env.PreEnv.nb_id m' g1 + g2 + in + Some pushout, None + | None, conflict -> None, conflict + +let length cc = Mods.IntMap.size cc.nodes diff --git a/core/term/pattern.mli b/core/term/pattern.mli index ff29aba487..78b115ed57 100644 --- a/core/term/pattern.mli +++ b/core/term/pattern.mli @@ -10,7 +10,9 @@ type link = UnSpec | Free | Link of int * int type cc -type t = cc (**type for domain points*) + +type t = cc +(**type for domain points*) type id @@ -22,154 +24,158 @@ module ObsMap : sig type 'a t val dummy : 'a -> 'a t - val get : 'a t -> id -> 'a val set : 'a t -> id -> 'a -> unit - val fold_lefti : (id -> 'a -> 'b -> 'a) -> 'a -> 'b t -> 'a val map : ('a -> 'b) -> 'a t -> 'b t - val iteri: (id -> 'a -> unit) -> 'a t -> unit + val iteri : (id -> 'a -> unit) -> 'a t -> unit + val print : ?trailing:(Format.formatter -> unit) -> (Format.formatter -> unit) -> (id -> Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a t -> unit + Format.formatter -> + 'a t -> + unit end module Env : sig type transition = private { next: Navigation.abstract Navigation.t; - dst: id; (** id of cc and also address in the Env.domain map *) - inj: Renaming.t; (** From dst To ("this" cc + extra edge) *) + dst: id; (** id of cc and also address in the Env.domain map *) + inj: Renaming.t; (** From dst To ("this" cc + extra edge) *) } type point - val content: point -> cc - - val roots: point -> (int list * int) option (** (ids,ty) *) + val content : point -> cc - val deps: point -> Operator.DepSet.t + val roots : point -> (int list * int) option + (** (ids,ty) *) - val sons: point -> transition list + val deps : point -> Operator.DepSet.t + val sons : point -> transition list type t val get : t -> id -> point - val get_single_agent : int -> t -> (id * Operator.DepSet.t) option val get_elementary : - debugMode:bool -> t -> Agent.t -> int -> - Navigation.abstract Navigation.arrow -> (id * point * Renaming.t) option + debug_mode:bool -> + t -> + Agent.t -> + int -> + Navigation.abstract Navigation.arrow -> + (id * point * Renaming.t) option val signatures : t -> Signature.s - val new_obs_map : t -> (id -> 'a) -> 'a ObsMap.t - val to_navigation : t -> id -> Navigation.abstract Navigation.t - val print : noCounters:bool -> Format.formatter -> t -> unit - val to_yojson : t -> Yojson.Basic.t - val of_yojson : Yojson.Basic.t -> t - end module PreEnv : sig type t - type stat = { stat_nodes: int; stat_nav_steps: int } val sigs : t -> Signature.s - val of_env : Env.t -> t - val empty : Signature.s -> t - val debug_print : Format.formatter -> t -> unit end (** {2 Create a connected component} *) -type work (** type of a PreEnv during a pattern construction *) +type work +(** type of a PreEnv during a pattern construction *) val empty_cc : Signature.s -> cc val begin_new : PreEnv.t -> work (** Starts creation *) -val new_node : work -> int -> (Agent.t*work) +val new_node : work -> int -> Agent.t * work (** [new_node wk node_type] *) -val new_link : - work -> (Agent.t * int) -> (Agent.t * int) -> work +val new_link : work -> Agent.t * int -> Agent.t * int -> work (** [new_link wk (node, site_id) (node', site_id')] *) -val new_free : work -> (Agent.t * int) -> work +val new_free : work -> Agent.t * int -> work -val new_internal_state : work -> (Agent.t * int) -> int -> work +val new_internal_state : work -> Agent.t * int -> int -> work (** [new_link_type work (node,site) type] *) val finish_new : - debugMode:bool -> ?origin:Operator.rev_dep -> work -> - (PreEnv.t*Renaming.t*cc*id) + debug_mode:bool -> + ?origin:Operator.rev_dep -> + work -> + PreEnv.t * Renaming.t * cc * id (** {2 Use a connected component } *) val compare_canonicals : id -> id -> int - val is_equal_canonicals : id -> id -> bool val print_cc : - noCounters:bool -> ?dotnet:bool -> ?full_species:bool -> - ?sigs:Signature.s -> ?cc_id:id -> with_id:bool -> - Format.formatter -> t -> unit + noCounters:bool -> + ?dotnet:bool -> + ?full_species:bool -> + ?sigs:Signature.s -> + ?cc_id:id -> + with_id:bool -> + Format.formatter -> + t -> + unit val print_cc_as_id : Signature.s -> Format.formatter -> t -> unit val print : - noCounters: bool -> ?domain:Env.t -> with_id:bool -> - Format.formatter -> id -> unit + noCounters:bool -> + ?domain:Env.t -> + with_id:bool -> + Format.formatter -> + id -> + unit (** [print ~domain ?with_id:None form cc] *) val id_to_yojson : id -> Yojson.Basic.t - val id_of_yojson : Yojson.Basic.t -> id - val reconstruction_navigation : t -> Navigation.abstract Navigation.t -val find_ty : cc -> int -> int (** Abstraction leak, please do not use *) +val find_ty : cc -> int -> int +(** Abstraction leak, please do not use *) -val automorphisms : debugMode:bool -> t -> Renaming.t list +val automorphisms : debug_mode:bool -> t -> Renaming.t list val embeddings_to_fully_specified : - debugMode:bool -> Env.t -> id -> cc -> Renaming.t list + debug_mode:bool -> Env.t -> id -> cc -> Renaming.t list val size_of_cc : cc -> int -val fold_by_type: +val fold_by_type : (pos:int -> agent_type:int -> (link * int) array -> 'a -> 'a) -> - cc -> 'a -> 'a + cc -> + 'a -> + 'a (** USE WITH CARE: Break some abstraction. The array must not be modified and internal state [-1] means unspecified *) -val fold: - (int -> (link * int) array -> 'acc -> 'acc) -> - cc -> 'acc -> 'acc +val fold : (int -> (link * int) array -> 'acc -> 'acc) -> cc -> 'acc -> 'acc (** USE WITH CARE: Break some abstraction. The array must not be modified and internal state [-1] means unspecified *) -type sharing_level = No_sharing | Compatible_patterns | Max_sharing -(** Heuristic to use on domain construction *) +type sharing_level = + | No_sharing + | Compatible_patterns + | Max_sharing (** Heuristic to use on domain construction *) -val write_sharing_level : - Buffer.t -> sharing_level -> unit - (** Output a JSON value of type {!sharing_level}. *) +val write_sharing_level : Buffer.t -> sharing_level -> unit +(** Output a JSON value of type {!sharing_level}. *) -val string_of_sharing_level : - ?len:int -> sharing_level -> string - (** Serialize a value of type {!sharing_level} +val string_of_sharing_level : ?len:int -> sharing_level -> string +(** Serialize a value of type {!sharing_level} into a JSON string. @param len specifies the initial length of the buffer used internally. @@ -177,26 +183,32 @@ val string_of_sharing_level : val read_sharing_level : Yojson.Safe.lexer_state -> Lexing.lexbuf -> sharing_level - (** Input JSON data of type {!sharing_level}. *) - -val sharing_level_of_string : - string -> sharing_level - (** Deserialize JSON data of type {!sharing_level}. *) +(** Input JSON data of type {!sharing_level}. *) +val sharing_level_of_string : string -> sharing_level +(** Deserialize JSON data of type {!sharing_level}. *) val finalize : - debugMode:bool -> sharing:sharing_level -> PreEnv.t -> Contact_map.t -> + debug_mode:bool -> + sharing:sharing_level -> + PreEnv.t -> + Contact_map.t -> Env.t * PreEnv.stat -val infs : debugMode:bool -> Signature.s -> t -> t -> t list -val matchings : debugMode:bool -> Signature.s -> t -> t -> Renaming.t list +val infs : debug_mode:bool -> Signature.s -> t -> t -> t list +val matchings : debug_mode:bool -> Signature.s -> t -> t -> Renaming.t list + val merge_on_inf : - debugMode:bool -> PreEnv.t -> Renaming.t -> t -> t -> + debug_mode:bool -> + PreEnv.t -> + Renaming.t -> + t -> + t -> t option * (t * int * t * int * int * bool) option -val length : t -> int -module Set : SetMap.Set with type elt=id +val length : t -> int -module Map : SetMap.Map with type elt=id +module Set : SetMap.Set with type elt = id +module Map : SetMap.Map with type elt = id -val counter_value_cc: cc -> Mods.IntMap.elt * int -> int -> int +val counter_value_cc : cc -> Mods.IntMap.elt * int -> int -> int diff --git a/core/term/pattern_compiler.ml b/core/term/pattern_compiler.ml index 1787a1a92c..7b8f114bfe 100644 --- a/core/term/pattern_compiler.ml +++ b/core/term/pattern_compiler.ml @@ -7,10 +7,12 @@ (******************************************************************************) let link_occurence_failure key pos = - raise (ExceptionDefn.Internal_Error - ("Bug: Link "^string_of_int key^ - " is problematic! LKappa is either broken"^ - " or unused! Please report.",pos)) + raise + (ExceptionDefn.Internal_Error + ( "Bug: Link " ^ string_of_int key + ^ " is problematic! LKappa is either broken" + ^ " or unused! Please report.", + pos )) let ports_from_contact_map contact_map ty_id p_id = snd contact_map.(ty_id).(p_id) @@ -18,733 +20,911 @@ let ports_from_contact_map contact_map ty_id p_id = let find_implicit_infos contact_map ags = let new_switch = function | LKappa.Maintained -> LKappa.Maintained - | LKappa.Freed | LKappa.Linked _ | LKappa.Erased -> LKappa.Freed in + | LKappa.Freed | LKappa.Linked _ | LKappa.Erased -> LKappa.Freed + in let rec aux_one free_id previous current todos ag_tail ag ports i = let ty_id = ag.LKappa.ra_type in - if i = Array.length ports then - let current' = { - LKappa.ra_type = ag.LKappa.ra_type; LKappa.ra_ports = ports; - LKappa.ra_ints = ag.LKappa.ra_ints; - LKappa.ra_erased = ag.LKappa.ra_erased; - LKappa.ra_syntax = ag.LKappa.ra_syntax - }::current in + if i = Array.length ports then ( + let current' = + { + LKappa.ra_type = ag.LKappa.ra_type; + LKappa.ra_ports = ports; + LKappa.ra_ints = ag.LKappa.ra_ints; + LKappa.ra_erased = ag.LKappa.ra_erased; + LKappa.ra_syntax = ag.LKappa.ra_syntax; + } + :: current + in aux_ags free_id previous current' todos ag_tail - else match ports.(i) with - | (LKappa.LNK_TYPE (p,a),_),s -> - let or_ty = (i,ty_id) in - let () = ports.(i) <- - (Locality.dummy_annot (LKappa.LNK_VALUE (free_id,(p,a))),s) in - aux_one - (succ free_id) previous current - ((free_id,(p,a),or_ty,new_switch s)::todos) ag_tail ag ports (succ i) - | (LKappa.LNK_SOME,_), s -> - let or_ty = (i,ty_id) in + ) else ( + match ports.(i) with + | (LKappa.LNK_TYPE (p, a), _), s -> + let or_ty = i, ty_id in + let () = + ports.(i) <- + Loc.annot_with_dummy (LKappa.LNK_VALUE (free_id, (p, a))), s + in + aux_one (succ free_id) previous current + ((free_id, (p, a), or_ty, new_switch s) :: todos) + ag_tail ag ports (succ i) + | (LKappa.LNK_SOME, _), s -> + let or_ty = i, ty_id in Mods.Int2Set.fold - (fun (a,p) prev' -> - let ports' = Array.copy ports in - let () = - ports'.(i) <- - (Locality.dummy_annot (LKappa.LNK_VALUE (free_id,(p,a))),s) in - let todos' = - (free_id,(p,a),or_ty,new_switch s)::todos in - aux_one - (succ free_id) prev' current todos' ag_tail ag ports' (succ i)) + (fun (a, p) prev' -> + let ports' = Array.copy ports in + let () = + ports'.(i) <- + Loc.annot_with_dummy (LKappa.LNK_VALUE (free_id, (p, a))), s + in + let todos' = (free_id, (p, a), or_ty, new_switch s) :: todos in + aux_one (succ free_id) prev' current todos' ag_tail ag ports' + (succ i)) (ports_from_contact_map contact_map ty_id i) previous - | (LKappa.LNK_VALUE _,_),_ -> + | (LKappa.LNK_VALUE _, _), _ -> aux_one free_id previous current todos ag_tail ag ports (succ i) - | (LKappa.LNK_FREE, pos), (LKappa.Maintained | LKappa.Erased as s) -> - let () = (* Do not make test if being free is the only possibility *) + | (LKappa.LNK_FREE, pos), ((LKappa.Maintained | LKappa.Erased) as s) -> + let () = + (* Do not make test if being free is the only possibility *) if Mods.Int2Set.is_empty (ports_from_contact_map contact_map ty_id i) - then ports.(i) <- (LKappa.LNK_ANY,pos), s - else () in + then + ports.(i) <- (LKappa.LNK_ANY, pos), s + else + () + in aux_one free_id previous current todos ag_tail ag ports (succ i) - | (LKappa.LNK_FREE, _), LKappa.Freed ->failwith "A free site cannot be freed" + | (LKappa.LNK_FREE, _), LKappa.Freed -> + failwith "A free site cannot be freed" | (LKappa.LNK_FREE, _), LKappa.Linked _ -> aux_one free_id previous current todos ag_tail ag ports (succ i) - | ((LKappa.LNK_ANY|LKappa.ANY_FREE),_), LKappa.Maintained -> + | ((LKappa.LNK_ANY | LKappa.ANY_FREE), _), LKappa.Maintained -> aux_one free_id previous current todos ag_tail ag ports (succ i) - | ((LKappa.LNK_ANY|LKappa.ANY_FREE),pos), - (LKappa.Erased | LKappa.Linked _ | LKappa.Freed as s) -> - if Mods.Int2Set.is_empty (ports_from_contact_map contact_map ty_id i) - && s = LKappa.Freed then + | ( ((LKappa.LNK_ANY | LKappa.ANY_FREE), pos), + ((LKappa.Erased | LKappa.Linked _ | LKappa.Freed) as s) ) -> + if + Mods.Int2Set.is_empty (ports_from_contact_map contact_map ty_id i) + && s = LKappa.Freed + then ( (* Do not make test is being free is the only possibility *) - let () = ports.(i) <- (LKappa.LNK_ANY,pos), LKappa.Maintained in + let () = ports.(i) <- (LKappa.LNK_ANY, pos), LKappa.Maintained in aux_one free_id previous current todos ag_tail ag ports (succ i) - else + ) else aux_one free_id previous current todos ag_tail ag ports (succ i) + ) and aux_ags free_id previous current todos = function - | [] -> (List.rev current,todos) :: previous + | [] -> (List.rev current, todos) :: previous | ag :: ag_tail -> - aux_one free_id previous current todos ag_tail ag ag.LKappa.ra_ports 0 in + aux_one free_id previous current todos ag_tail ag ag.LKappa.ra_ports 0 + in aux_ags (succ (LKappa.max_link_id ags)) [] [] [] ags -let complete_with_candidate - outs prevs ag ag_tail id todo p_id dst_info p_switch = +let complete_with_candidate outs prevs ag ag_tail id todo p_id dst_info p_switch + = Tools.array_fold_lefti (fun i acc port -> - if i <> p_id then acc else - match port with - | ((LKappa.LNK_ANY|LKappa.ANY_FREE),_), s -> - if s = LKappa.Maintained then - let ports' = Array.copy ag.LKappa.ra_ports in - let () = - ports'.(i) <- - (Locality.dummy_annot - (LKappa.LNK_VALUE (id,dst_info)),p_switch) in - (List.rev_append prevs - ({ LKappa.ra_type = ag.LKappa.ra_type; LKappa.ra_ports = ports'; + if i <> p_id then + acc + else ( + match port with + | ((LKappa.LNK_ANY | LKappa.ANY_FREE), _), s -> + if s = LKappa.Maintained then ( + let ports' = Array.copy ag.LKappa.ra_ports in + let () = + ports'.(i) <- + Loc.annot_with_dummy (LKappa.LNK_VALUE (id, dst_info)), p_switch + in + ( List.rev_append prevs + ({ + LKappa.ra_type = ag.LKappa.ra_type; + LKappa.ra_ports = ports'; LKappa.ra_ints = ag.LKappa.ra_ints; LKappa.ra_erased = ag.LKappa.ra_erased; - LKappa.ra_syntax = ag.LKappa.ra_syntax;}::ag_tail), todo) - :: acc - else if s = LKappa.Erased && p_switch = LKappa.Freed then - let ports' = Array.copy ag.LKappa.ra_ports in - let () = - ports'.(i) <- - (Locality.dummy_annot (LKappa.LNK_VALUE (id,dst_info)),s) in - (List.rev_append prevs - ({ LKappa.ra_type = ag.LKappa.ra_type; LKappa.ra_ports = ports'; + LKappa.ra_syntax = ag.LKappa.ra_syntax; + } + :: ag_tail), + todo ) + :: acc + ) else if s = LKappa.Erased && p_switch = LKappa.Freed then ( + let ports' = Array.copy ag.LKappa.ra_ports in + let () = + ports'.(i) <- + Loc.annot_with_dummy (LKappa.LNK_VALUE (id, dst_info)), s + in + ( List.rev_append prevs + ({ + LKappa.ra_type = ag.LKappa.ra_type; + LKappa.ra_ports = ports'; LKappa.ra_ints = ag.LKappa.ra_ints; LKappa.ra_erased = ag.LKappa.ra_erased; - LKappa.ra_syntax = ag.LKappa.ra_syntax;}::ag_tail), todo) - :: acc - else acc - | (LKappa.LNK_VALUE (k,x),_),s -> - if x = dst_info then - match - List.partition - (fun (j,_,(p',a'),sw') -> j=k && i=p' && a'= ag.LKappa.ra_type - && sw' = p_switch) todo with - | [ _ ], todo' -> - let ports' = Array.copy ag.LKappa.ra_ports in - let () = ports'.(i) <- - (Locality.dummy_annot (LKappa.LNK_VALUE (id,x)),s) in - (List.rev_append prevs - ({ LKappa.ra_type = ag.LKappa.ra_type; LKappa.ra_ports = ports'; + LKappa.ra_syntax = ag.LKappa.ra_syntax; + } + :: ag_tail), + todo ) + :: acc + ) else + acc + | (LKappa.LNK_VALUE (k, x), _), s -> + if x = dst_info then ( + match + List.partition + (fun (j, _, (p', a'), sw') -> + j = k && i = p' && a' = ag.LKappa.ra_type && sw' = p_switch) + todo + with + | [ _ ], todo' -> + let ports' = Array.copy ag.LKappa.ra_ports in + let () = + ports'.(i) <- Loc.annot_with_dummy (LKappa.LNK_VALUE (id, x)), s + in + ( List.rev_append prevs + ({ + LKappa.ra_type = ag.LKappa.ra_type; + LKappa.ra_ports = ports'; LKappa.ra_ints = ag.LKappa.ra_ints; LKappa.ra_erased = ag.LKappa.ra_erased; - LKappa.ra_syntax = ag.LKappa.ra_syntax;}::ag_tail), - todo') :: acc - |[], _ -> acc - | _ :: _ :: _, _ -> assert false - else acc - | ((LKappa.LNK_TYPE _ | LKappa.LNK_FREE | LKappa.LNK_SOME),_), _ -> acc) + LKappa.ra_syntax = ag.LKappa.ra_syntax; + } + :: ag_tail), + todo' ) + :: acc + | [], _ -> acc + | _ :: _ :: _, _ -> assert false + ) else + acc + | ((LKappa.LNK_TYPE _ | LKappa.LNK_FREE | LKappa.LNK_SOME), _), _ -> acc + )) outs ag.LKappa.ra_ports let new_agent_with_one_link sigs ty_id port link dst_info switch = let arity = Signature.arity sigs ty_id in let ports = - Array.make arity (Locality.dummy_annot LKappa.LNK_ANY, LKappa.Maintained) in + Array.make arity (Loc.annot_with_dummy LKappa.LNK_ANY, LKappa.Maintained) + in let internals = Array.make arity LKappa.I_ANY in - let () = ports.(port) <- - (Locality.dummy_annot (LKappa.LNK_VALUE (link,dst_info)),switch) in - { LKappa.ra_type = ty_id; LKappa.ra_ports = ports; LKappa.ra_ints = internals; - LKappa.ra_erased = false; LKappa.ra_syntax = None;} + let () = + ports.(port) <- + Loc.annot_with_dummy (LKappa.LNK_VALUE (link, dst_info)), switch + in + { + LKappa.ra_type = ty_id; + LKappa.ra_ports = ports; + LKappa.ra_ints = internals; + LKappa.ra_erased = false; + LKappa.ra_syntax = None; + } -let rec add_one_implicit_info sigs id ((port,ty_id),dst_info,s as info) acc out todo = - function +let rec add_one_implicit_info sigs id (((port, ty_id), dst_info, s) as info) acc + out todo = function | [] -> - (List.rev_append acc [new_agent_with_one_link sigs ty_id port id dst_info s],todo)::out + ( List.rev_append acc + [ new_agent_with_one_link sigs ty_id port id dst_info s ], + todo ) + :: out | ag :: ag_tail -> - let out_tail = add_one_implicit_info sigs id info (ag::acc) out todo ag_tail in + let out_tail = + add_one_implicit_info sigs id info (ag :: acc) out todo ag_tail + in if ty_id = ag.LKappa.ra_type then complete_with_candidate out_tail acc ag ag_tail id todo port dst_info s - else out_tail + else + out_tail let add_implicit_infos sigs l = let rec aux acc = function | [] -> acc - | (m,[]) :: t -> aux (m::acc) t - | (m,((id,info,dst_info,s) :: todo')) :: t -> - aux acc (add_one_implicit_info sigs id (info,dst_info,s) [] t todo' m) - in aux [] l + | (m, []) :: t -> aux (m :: acc) t + | (m, (id, info, dst_info, s) :: todo') :: t -> + aux acc (add_one_implicit_info sigs id (info, dst_info, s) [] t todo' m) + in + aux [] l let is_linked_on_port me i id = function - | (LKappa.LNK_VALUE (j,_),_),_ when i = j -> id <> me - | ((LKappa.LNK_VALUE _ | LKappa.LNK_FREE | LKappa.LNK_TYPE _ | - LKappa.LNK_ANY | LKappa.LNK_SOME | LKappa.ANY_FREE),_),_ -> false + | (LKappa.LNK_VALUE (j, _), _), _ when i = j -> id <> me + | ( ( ( LKappa.LNK_VALUE _ | LKappa.LNK_FREE | LKappa.LNK_TYPE _ + | LKappa.LNK_ANY | LKappa.LNK_SOME | LKappa.ANY_FREE ), + _ ), + _ ) -> + false let is_linked_on i ag = Tools.array_filter (is_linked_on_port (-1) i) ag.LKappa.ra_ports <> [] -let define_full_transformation - (removed,added as transf) links_transf place site (cand,_) switch = +let define_full_transformation ((removed, added) as transf) links_transf place + site (cand, _) switch = match switch with | LKappa.Freed -> - ((cand::removed, (Primitives.Transformation.Freed(place,site)::added)), - links_transf) - | LKappa.Maintained -> - (transf,links_transf) - | LKappa.Erased -> - ((cand::removed,added),links_transf) + ( (cand :: removed, Primitives.Transformation.Freed (place, site) :: added), + links_transf ) + | LKappa.Maintained -> transf, links_transf + | LKappa.Erased -> (cand :: removed, added), links_transf | LKappa.Linked i -> - match Mods.IntMap.find_option i links_transf with + (match Mods.IntMap.find_option i links_transf with | None -> - let links_transf' = - Mods.IntMap.add i (place,site) links_transf in - ((cand::removed,added),links_transf') + let links_transf' = Mods.IntMap.add i (place, site) links_transf in + (cand :: removed, added), links_transf' | Some dst' -> let links_transf' = Mods.IntMap.remove i links_transf in - ((cand::removed, - Primitives.Transformation.Linked((place,site),dst')::added), - links_transf') + ( ( cand :: removed, + Primitives.Transformation.Linked ((place, site), dst') :: added ), + links_transf' )) -let define_positive_transformation - (removed,added as transf) links_transf place site switch = +let define_positive_transformation ((removed, added) as transf) links_transf + place site switch = match switch with | LKappa.Freed -> - ((removed, - Primitives.Transformation.Freed (place,site)::added),links_transf) - | LKappa.Erased -> (transf,links_transf) - | LKappa.Maintained -> (transf,links_transf) + ( (removed, Primitives.Transformation.Freed (place, site) :: added), + links_transf ) + | LKappa.Erased -> transf, links_transf + | LKappa.Maintained -> transf, links_transf | LKappa.Linked i -> - match Mods.IntMap.find_option i links_transf with + (match Mods.IntMap.find_option i links_transf with | None -> - let links_transf' = - Mods.IntMap.add i (place,site) links_transf in - (transf,links_transf') + let links_transf' = Mods.IntMap.add i (place, site) links_transf in + transf, links_transf' | Some dst' -> let links_transf' = Mods.IntMap.remove i links_transf in - ((removed, - Primitives.Transformation.Linked((place,site),dst')::added), - links_transf') + ( ( removed, + Primitives.Transformation.Linked ((place, site), dst') :: added ), + links_transf' )) let add_instantiation_free actions pl s = function - | LKappa.Freed -> Instantiation.Free (pl,s) :: actions - | (LKappa.Linked _ | LKappa.Maintained | LKappa.Erased) -> actions + | LKappa.Freed -> Instantiation.Free (pl, s) :: actions + | LKappa.Linked _ | LKappa.Maintained | LKappa.Erased -> actions + let add_side_site side_sites bt pl s = function - | (LKappa.Freed | LKappa.Linked _ | LKappa.Erased) -> ((pl,s),bt)::side_sites + | LKappa.Freed | LKappa.Linked _ | LKappa.Erased -> + ((pl, s), bt) :: side_sites | LKappa.Maintained -> side_sites + let add_freed_side_effect side_effects pl s = function - | (LKappa.LNK_VALUE _,_),LKappa.Freed -> (pl,s)::side_effects - | (LKappa.LNK_VALUE _,_),(LKappa.Maintained | LKappa.Erased | LKappa.Linked _) - | ((LKappa.LNK_FREE | LKappa.LNK_ANY | LKappa.LNK_SOME | - LKappa.LNK_TYPE _ | LKappa.ANY_FREE),_),_ -> + | (LKappa.LNK_VALUE _, _), LKappa.Freed -> (pl, s) :: side_effects + | ( (LKappa.LNK_VALUE _, _), + (LKappa.Maintained | LKappa.Erased | LKappa.Linked _) ) + | ( ( ( LKappa.LNK_FREE | LKappa.LNK_ANY | LKappa.LNK_SOME | LKappa.LNK_TYPE _ + | LKappa.ANY_FREE ), + _ ), + _ ) -> side_effects + let add_extra_side_effects side_effects place refined = let rec aux side_effects site_id = - if site_id < 0 then side_effects + if site_id < 0 then + side_effects else aux (add_freed_side_effect side_effects place site_id refined.(site_id)) - (pred site_id) in + (pred site_id) + in aux side_effects (pred (Array.length refined)) (* Deals with tests, erasure internal state change and release (but not binding)*) -let make_instantiation place links event ref_ports is_erased = - function - | None -> { +let make_instantiation place links event ref_ports is_erased = function + | None -> + { Instantiation.tests = event.Instantiation.tests; Instantiation.actions = event.Instantiation.actions; Instantiation.side_effects_src = event.Instantiation.side_effects_src; - Instantiation.side_effects_dst = add_extra_side_effects - event.Instantiation.side_effects_dst place ref_ports; + Instantiation.side_effects_dst = + add_extra_side_effects event.Instantiation.side_effects_dst place + ref_ports; Instantiation.connectivity_tests = event.Instantiation.connectivity_tests; } | Some (ports, ints) -> - match event.Instantiation.tests with + (match event.Instantiation.tests with | [] -> assert false | this_cc_tests :: o_cc_tests -> - let rec aux site_id tests actions side_effects_src side_effects_dst links= - if site_id >= Array.length ports - then { Instantiation.tests = tests :: o_cc_tests; - Instantiation.actions; - Instantiation.side_effects_src; Instantiation.side_effects_dst; - Instantiation.connectivity_tests = - event.Instantiation.connectivity_tests; } - else - let tests',actions' = + let rec aux site_id tests actions side_effects_src side_effects_dst links + = + if site_id >= Array.length ports then + { + Instantiation.tests = tests :: o_cc_tests; + Instantiation.actions; + Instantiation.side_effects_src; + Instantiation.side_effects_dst; + Instantiation.connectivity_tests = + event.Instantiation.connectivity_tests; + } + else ( + let tests', actions' = match ints.(site_id) with - | (LKappa.I_ANY | LKappa.I_ANY_ERASED) -> tests,actions + | LKappa.I_ANY | LKappa.I_ANY_ERASED -> tests, actions | LKappa.I_ANY_CHANGED j -> - tests, - Instantiation.Mod_internal ((place,site_id),j) :: actions - | LKappa.I_VAL_CHANGED (i,j) -> - Instantiation.Has_Internal ((place,site_id),i) :: tests, - if i <> j then - Instantiation.Mod_internal ((place,site_id),j) :: actions - else actions + tests, Instantiation.Mod_internal ((place, site_id), j) :: actions + | LKappa.I_VAL_CHANGED (i, j) -> + ( Instantiation.Has_Internal ((place, site_id), i) :: tests, + if i <> j then + Instantiation.Mod_internal ((place, site_id), j) :: actions + else + actions ) | LKappa.I_VAL_ERASED i -> - Instantiation.Has_Internal ((place,site_id),i) :: tests, - actions in - let tests'',actions'',side_sites',side_effects',links' = + Instantiation.Has_Internal ((place, site_id), i) :: tests, actions + in + let tests'', actions'', side_sites', side_effects', links' = match ports.(site_id) with - | ((LKappa.LNK_ANY|LKappa.ANY_FREE),_), s -> + | ((LKappa.LNK_ANY | LKappa.ANY_FREE), _), s -> let side_effects' = match s with | LKappa.Maintained -> - add_freed_side_effect - side_effects_dst place site_id ref_ports.(site_id) + add_freed_side_effect side_effects_dst place site_id + ref_ports.(site_id) | LKappa.Erased | LKappa.Linked _ | LKappa.Freed -> - side_effects_dst in - tests', add_instantiation_free actions' place site_id s, - add_side_site side_effects_src Instantiation.ANY - place site_id s, - side_effects', - links - | (LKappa.LNK_FREE,_), s -> - (Instantiation.Is_Free (place,site_id) :: tests'), - add_instantiation_free actions' place site_id s,side_effects_src, - side_effects_dst, links - | (LKappa.LNK_SOME,_), s -> - Instantiation.Is_Bound (place,site_id) :: tests', - add_instantiation_free actions' place site_id s, - add_side_site side_effects_src Instantiation.BOUND - place site_id s, - side_effects_dst, links - | (LKappa.LNK_TYPE (b,a),_),s -> - Instantiation.Has_Binding_type ((place,site_id),(a,b)) - :: tests', - add_instantiation_free actions' place site_id s, - add_side_site - side_effects_src (Instantiation.BOUND_TYPE (a,b)) - place site_id s, - side_effects_dst, links - | (LKappa.LNK_VALUE (i,_),_),s -> - match Mods.IntMap.find_option i links with - | Some x -> x :: tests', - add_instantiation_free actions' place site_id s, - side_effects_src, side_effects_dst, - Mods.IntMap.remove i links + side_effects_dst + in + ( tests', + add_instantiation_free actions' place site_id s, + add_side_site side_effects_src Instantiation.ANY place site_id s, + side_effects', + links ) + | (LKappa.LNK_FREE, _), s -> + ( Instantiation.Is_Free (place, site_id) :: tests', + add_instantiation_free actions' place site_id s, + side_effects_src, + side_effects_dst, + links ) + | (LKappa.LNK_SOME, _), s -> + ( Instantiation.Is_Bound (place, site_id) :: tests', + add_instantiation_free actions' place site_id s, + add_side_site side_effects_src Instantiation.BOUND place site_id + s, + side_effects_dst, + links ) + | (LKappa.LNK_TYPE (b, a), _), s -> + ( Instantiation.Has_Binding_type ((place, site_id), (a, b)) + :: tests', + add_instantiation_free actions' place site_id s, + add_side_site side_effects_src + (Instantiation.BOUND_TYPE (a, b)) + place site_id s, + side_effects_dst, + links ) + | (LKappa.LNK_VALUE (i, _), _), s -> + (match Mods.IntMap.find_option i links with + | Some x -> + ( x :: tests', + add_instantiation_free actions' place site_id s, + side_effects_src, + side_effects_dst, + Mods.IntMap.remove i links ) | None -> - tests', add_instantiation_free actions' place site_id s, - side_effects_src, side_effects_dst, links in - aux (succ site_id) tests'' - actions'' side_sites' side_effects' links' in - aux 0 (Instantiation.Is_Here place :: this_cc_tests) - (if is_erased - then Instantiation.Remove place :: event.Instantiation.actions - else event.Instantiation.actions) event.Instantiation.side_effects_src - event.Instantiation.side_effects_dst links + ( tests', + add_instantiation_free actions' place site_id s, + side_effects_src, + side_effects_dst, + links )) + in + aux (succ site_id) tests'' actions'' side_sites' side_effects' links' + ) + in + aux 0 + (Instantiation.Is_Here place :: this_cc_tests) + (if is_erased then + Instantiation.Remove place :: event.Instantiation.actions + else + event.Instantiation.actions) + event.Instantiation.side_effects_src + event.Instantiation.side_effects_dst links) -let rec add_agents_in_cc sigs id wk registered_links (removed,added as transf) - links_transf instantiations remains = - function +let rec add_agents_in_cc sigs id wk registered_links + ((removed, added) as transf) links_transf instantiations remains = function | [] -> - begin match Mods.IntMap.root registered_links with - | None -> (wk,transf,links_transf,instantiations,remains) - | Some (key,_) -> link_occurence_failure key Locality.dummy - end + (match Mods.IntMap.root registered_links with + | None -> wk, transf, links_transf, instantiations, remains + | Some (key, _) -> link_occurence_failure key Loc.dummy) | ag :: ag_l -> - let (node,wk) = Pattern.new_node wk ag.LKappa.ra_type in - let place = Matching.Agent.Existing (node,id) in + let node, wk = Pattern.new_node wk ag.LKappa.ra_type in + let place = Matching.Agent.Existing (node, id) in let transf' = - if ag.LKappa.ra_erased - then Primitives.Transformation.Agent place::removed,added - else transf in - let rec handle_ports wk r_l c_l (removed,added) l_t re acc site_id = - if site_id = Array.length ag.LKappa.ra_ports - then - let instantiations' = - make_instantiation - place c_l instantiations ag.LKappa.ra_ports ag.LKappa.ra_erased ag.LKappa.ra_syntax in - add_agents_in_cc - sigs id wk r_l (removed,added) l_t instantiations' re acc + if ag.LKappa.ra_erased then + Primitives.Transformation.Agent place :: removed, added else - let transf,wk' = match ag.LKappa.ra_ints.(site_id) with - | LKappa.I_ANY -> (removed,added),wk + transf + in + let rec handle_ports wk r_l c_l (removed, added) l_t re acc site_id = + if site_id = Array.length ag.LKappa.ra_ports then ( + let instantiations' = + make_instantiation place c_l instantiations ag.LKappa.ra_ports + ag.LKappa.ra_erased ag.LKappa.ra_syntax + in + add_agents_in_cc sigs id wk r_l (removed, added) l_t instantiations' re + acc + ) else ( + let transf, wk' = + match ag.LKappa.ra_ints.(site_id) with + | LKappa.I_ANY -> (removed, added), wk | LKappa.I_ANY_ERASED -> - (Primitives.Transformation.NegativeInternalized (place,site_id)::removed,added), - wk + ( ( Primitives.Transformation.NegativeInternalized (place, site_id) + :: removed, + added ), + wk ) | LKappa.I_ANY_CHANGED j -> - (Primitives.Transformation.NegativeInternalized (place,site_id)::removed, - Primitives.Transformation.PositiveInternalized (place,site_id,j)::added), - wk - | LKappa.I_VAL_CHANGED (i,j) -> - (if i = j then (removed,added) - else - Primitives.Transformation.NegativeInternalized (place,site_id)::removed, - Primitives.Transformation.PositiveInternalized (place,site_id,j)::added), - Pattern.new_internal_state wk (node,site_id) i + ( ( Primitives.Transformation.NegativeInternalized (place, site_id) + :: removed, + Primitives.Transformation.PositiveInternalized + (place, site_id, j) + :: added ), + wk ) + | LKappa.I_VAL_CHANGED (i, j) -> + ( (if i = j then + removed, added + else + ( Primitives.Transformation.NegativeInternalized + (place, site_id) + :: removed, + Primitives.Transformation.PositiveInternalized + (place, site_id, j) + :: added )), + Pattern.new_internal_state wk (node, site_id) i ) | LKappa.I_VAL_ERASED i -> - (Primitives.Transformation.NegativeInternalized (place,site_id)::removed,added), - Pattern.new_internal_state wk (node,site_id) i + ( ( Primitives.Transformation.NegativeInternalized (place, site_id) + :: removed, + added ), + Pattern.new_internal_state wk (node, site_id) i ) in match ag.LKappa.ra_ports.(site_id) with - | ((LKappa.LNK_ANY|LKappa.ANY_FREE),pos), s -> - let transf',l_t' = - define_full_transformation - transf l_t place site_id - (Primitives.Transformation.NegativeWhatEver - (place,site_id),Some pos) s in + | ((LKappa.LNK_ANY | LKappa.ANY_FREE), pos), s -> + let transf', l_t' = + define_full_transformation transf l_t place site_id + ( Primitives.Transformation.NegativeWhatEver (place, site_id), + Some pos ) + s + in handle_ports wk' r_l c_l transf' l_t' re acc (succ site_id) - | (LKappa.LNK_FREE,_), s -> - let wk'' = Pattern.new_free wk' (node,site_id) in - let transf',l_t' = - define_full_transformation - transf l_t place site_id - (Primitives.Transformation.Freed (place,site_id),None) s in - handle_ports - wk'' r_l c_l transf' l_t' re acc (succ site_id) - | ((LKappa.LNK_SOME | LKappa.LNK_TYPE _),_),_ -> - raise (ExceptionDefn.Internal_Error - (Locality.dummy_annot - "Try to create the connected components of an ambiguous mixture.")) - | (LKappa.LNK_VALUE (i,_),pos),s -> - match Mods.IntMap.find_option i r_l with - | Some (node',site' as dst) -> - let dst_place = Matching.Agent.Existing (node',id),site' in - let wk'' = Pattern.new_link wk' (node,site_id) dst in + | (LKappa.LNK_FREE, _), s -> + let wk'' = Pattern.new_free wk' (node, site_id) in + let transf', l_t' = + define_full_transformation transf l_t place site_id + (Primitives.Transformation.Freed (place, site_id), None) + s + in + handle_ports wk'' r_l c_l transf' l_t' re acc (succ site_id) + | ((LKappa.LNK_SOME | LKappa.LNK_TYPE _), _), _ -> + raise + (ExceptionDefn.Internal_Error + (Loc.annot_with_dummy + "Try to create the connected components of an ambiguous \ + mixture.")) + | (LKappa.LNK_VALUE (i, _), pos), s -> + (match Mods.IntMap.find_option i r_l with + | Some ((node', site') as dst) -> + let dst_place = Matching.Agent.Existing (node', id), site' in + let wk'' = Pattern.new_link wk' (node, site_id) dst in let c_l' = - Mods.IntMap.add - i (Instantiation.Is_Bound_to ((place,site_id),dst_place)) - c_l in - let transf',l_t' = - define_full_transformation - transf l_t place site_id - (Primitives.Transformation.Linked - ((place,site_id),(dst_place)),Some pos) s in - handle_ports wk'' (Mods.IntMap.remove i r_l) c_l' transf' - l_t' re acc (succ site_id) + Mods.IntMap.add i + (Instantiation.Is_Bound_to ((place, site_id), dst_place)) + c_l + in + let transf', l_t' = + define_full_transformation transf l_t place site_id + ( Primitives.Transformation.Linked ((place, site_id), dst_place), + Some pos ) + s + in + handle_ports wk'' (Mods.IntMap.remove i r_l) c_l' transf' l_t' re + acc (succ site_id) | None -> - match Tools.array_filter - (is_linked_on_port site_id i) ag.LKappa.ra_ports with - | [site_id'] (* link between 2 sites of 1 agent *) - when List.for_all (fun x -> not(is_linked_on i x)) acc && - List.for_all (fun x -> not(is_linked_on i x)) re -> - let wk'',(transf',l_t') = + (match + Tools.array_filter + (is_linked_on_port site_id i) + ag.LKappa.ra_ports + with + | [ site_id' ] + (* link between 2 sites of 1 agent *) + when List.for_all (fun x -> not (is_linked_on i x)) acc + && List.for_all (fun x -> not (is_linked_on i x)) re -> + let wk'', (transf', l_t') = if site_id' > site_id then - (Pattern.new_link - wk' (node,site_id) (node,site_id'), - define_full_transformation - transf l_t place site_id - (Primitives.Transformation.Linked - ((place,site_id),(place,site_id')),Some pos) s) + ( Pattern.new_link wk' (node, site_id) (node, site_id'), + define_full_transformation transf l_t place site_id + ( Primitives.Transformation.Linked + ((place, site_id), (place, site_id')), + Some pos ) + s ) else - (wk',(define_positive_transformation - transf l_t place site_id s)) in + wk', define_positive_transformation transf l_t place site_id s + in let c_l' = - Mods.IntMap.add - i (Instantiation.Is_Bound_to - ((place,site_id),(place,site_id'))) c_l in - handle_ports - wk'' r_l c_l' transf' l_t' re acc (succ site_id) - | _ :: _ -> - link_occurence_failure i pos - | [] -> (* link between 2 agents *) - let r_l' = Mods.IntMap.add i (node,site_id) r_l in - let transf',l_t' = - define_positive_transformation - transf l_t place site_id s in - match List.partition (is_linked_on i) re with + Mods.IntMap.add i + (Instantiation.Is_Bound_to + ((place, site_id), (place, site_id'))) + c_l + in + handle_ports wk'' r_l c_l' transf' l_t' re acc (succ site_id) + | _ :: _ -> link_occurence_failure i pos + | [] -> + (* link between 2 agents *) + let r_l' = Mods.IntMap.add i (node, site_id) r_l in + let transf', l_t' = + define_positive_transformation transf l_t place site_id s + in + (match List.partition (is_linked_on i) re with | [], re' -> if List_util.exists_uniq (is_linked_on i) acc then - handle_ports - wk' r_l' c_l transf' l_t' re' acc (succ site_id) + handle_ports wk' r_l' c_l transf' l_t' re' acc (succ site_id) else link_occurence_failure i pos - | [n], re' when List.for_all - (fun x -> not(is_linked_on i x)) acc -> - handle_ports - wk' r_l' c_l transf' l_t' re' (n::acc) (succ site_id) - | _, _ -> link_occurence_failure i pos in - handle_ports wk registered_links Mods.IntMap.empty - transf' links_transf remains ag_l 0 + | [ n ], re' + when List.for_all (fun x -> not (is_linked_on i x)) acc -> + handle_ports wk' r_l' c_l transf' l_t' re' (n :: acc) + (succ site_id) + | _, _ -> link_occurence_failure i pos))) + ) + in + handle_ports wk registered_links Mods.IntMap.empty transf' links_transf + remains ag_l 0 -let rec complete_with_creation - sigs (removed,added) links_transf create_actions actions fresh = - function +let rec complete_with_creation sigs (removed, added) links_transf create_actions + actions fresh = function | [] -> - begin match Mods.IntMap.root links_transf with - | None -> List.rev_append actions create_actions, - (List.rev removed, List.rev added) - | Some (i,_) -> link_occurence_failure i Locality.dummy - end + (match Mods.IntMap.root links_transf with + | None -> + List.rev_append actions create_actions, (List.rev removed, List.rev added) + | Some (i, _) -> link_occurence_failure i Loc.dummy) | ag :: ag_l -> - let place = Matching.Agent.Fresh (ag.Raw_mixture.a_type,fresh) in + let place = Matching.Agent.Fresh (ag.Raw_mixture.a_type, fresh) in let rec handle_ports added l_t actions intf site_id = - if site_id = Array.length ag.Raw_mixture.a_ports then + if site_id = Array.length ag.Raw_mixture.a_ports then ( let create_actions' = - Instantiation.Create (place,List.rev intf) - :: create_actions in - complete_with_creation - sigs (removed,added) l_t create_actions' actions (succ fresh) ag_l - else - let added',actions',point = + Instantiation.Create (place, List.rev intf) :: create_actions + in + complete_with_creation sigs (removed, added) l_t create_actions' actions + (succ fresh) ag_l + ) else ( + let added', actions', point = match ag.Raw_mixture.a_ints.(site_id) with - | None -> added,actions,(site_id,None) + | None -> added, actions, (site_id, None) | Some i -> - Primitives.Transformation.PositiveInternalized (place,site_id,i)::added, - Instantiation.Mod_internal((place,site_id),i)::actions, - (site_id,Some i) in - let added'',actions'',l_t' = + ( Primitives.Transformation.PositiveInternalized (place, site_id, i) + :: added, + Instantiation.Mod_internal ((place, site_id), i) :: actions, + (site_id, Some i) ) + in + let added'', actions'', l_t' = match ag.Raw_mixture.a_ports.(site_id) with | Raw_mixture.FREE -> - Primitives.Transformation.Freed (place,site_id)::added', - (Instantiation.Free (place,site_id) :: actions'), - l_t + ( Primitives.Transformation.Freed (place, site_id) :: added', + Instantiation.Free (place, site_id) :: actions', + l_t ) | Raw_mixture.VAL i -> - match Mods.IntMap.pop i l_t with - | Some dst,l_t' -> - Primitives.Transformation.Linked((place,site_id),dst)::added', - (Instantiation.Bind_to((place,site_id),dst) - ::(Instantiation.Bind_to((dst,(place,site_id))))::actions'), - l_t' - | None,l_t -> - let l_t' = Mods.IntMap.add i (place,site_id) l_t in - (added',actions',l_t') in - handle_ports added'' l_t' actions'' (point::intf) (succ site_id) in + (match Mods.IntMap.pop i l_t with + | Some dst, l_t' -> + ( Primitives.Transformation.Linked ((place, site_id), dst) + :: added', + Instantiation.Bind_to ((place, site_id), dst) + :: Instantiation.Bind_to (dst, (place, site_id)) + :: actions', + l_t' ) + | None, l_t -> + let l_t' = Mods.IntMap.add i (place, site_id) l_t in + added', actions', l_t') + in + handle_ports added'' l_t' actions'' (point :: intf) (succ site_id) + ) + in handle_ports - (Primitives.Transformation.Agent place::added) links_transf actions [] 0 + (Primitives.Transformation.Agent place :: added) + links_transf actions [] 0 let incr_origin = function - | ( Operator.ALG _ | Operator.MODIF _ as x) -> x + | (Operator.ALG _ | Operator.MODIF _) as x -> x | Operator.RULE i -> Operator.RULE (succ i) -let connected_components_of_mixture ~debugMode created mix (env,origin) = +let connected_components_of_mixture ~debug_mode created mix (env, origin) = let sigs = Pattern.PreEnv.sigs env in let rec aux env transformations instantiations links_transf acc id = function | [] -> - let removed,added = transformations in + let removed, added = transformations in let actions' = List.fold_left (fun acs -> function - | Primitives.Transformation.Linked ((ax, _ as x),(ay, _ as y)) - when Matching.Agent.is_fresh ax || - Matching.Agent.is_fresh ay -> - Instantiation.Bind_to (x,y) :: acs - | Primitives.Transformation.Linked (x,y) -> - Instantiation.Bind (x,y) :: acs - | (Primitives.Transformation.Freed _ | - Primitives.Transformation.NegativeWhatEver _ | - Primitives.Transformation.PositiveInternalized _ | - Primitives.Transformation.NegativeInternalized _ | - Primitives.Transformation.Agent _) -> acs) - instantiations.Instantiation.actions added in - let transformations' = (List.rev removed, List.rev added) in - let actions'',transformations'' = - complete_with_creation - sigs transformations' links_transf [] actions' 0 created in - ((origin,Tools.array_rev_of_list acc, - { instantiations with Instantiation.actions = actions'' }, - transformations''), - (env,Option_util.map incr_origin origin)) + | Primitives.Transformation.Linked (((ax, _) as x), ((ay, _) as y)) + when Matching.Agent.is_fresh ax || Matching.Agent.is_fresh ay -> + Instantiation.Bind_to (x, y) :: acs + | Primitives.Transformation.Linked (x, y) -> + Instantiation.Bind (x, y) :: acs + | Primitives.Transformation.Freed _ + | Primitives.Transformation.NegativeWhatEver _ + | Primitives.Transformation.PositiveInternalized _ + | Primitives.Transformation.NegativeInternalized _ + | Primitives.Transformation.Agent _ -> + acs) + instantiations.Instantiation.actions added + in + let transformations' = List.rev removed, List.rev added in + let actions'', transformations'' = + complete_with_creation sigs transformations' links_transf [] actions' 0 + created + in + ( ( origin, + Tools.array_rev_of_list acc, + { instantiations with Instantiation.actions = actions'' }, + transformations'' ), + (env, Option_util.map incr_origin origin) ) | h :: t -> let wk = Pattern.begin_new env in - let instantiations' = { - Instantiation.tests = [] :: instantiations.Instantiation.tests; - Instantiation.actions = instantiations.Instantiation.actions; - Instantiation.side_effects_src = - instantiations.Instantiation.side_effects_src; - Instantiation.side_effects_dst = - instantiations.Instantiation.side_effects_dst; - Instantiation.connectivity_tests = - instantiations.Instantiation.connectivity_tests } in - let (wk_out,(removed,added),l_t,event, remains) = - add_agents_in_cc - sigs id wk Mods.IntMap.empty transformations - links_transf instantiations' t [h] in - let (env',inj, cc, cc_id) = - Pattern.finish_new ~debugMode ?origin wk_out in + let instantiations' = + { + Instantiation.tests = [] :: instantiations.Instantiation.tests; + Instantiation.actions = instantiations.Instantiation.actions; + Instantiation.side_effects_src = + instantiations.Instantiation.side_effects_src; + Instantiation.side_effects_dst = + instantiations.Instantiation.side_effects_dst; + Instantiation.connectivity_tests = + instantiations.Instantiation.connectivity_tests; + } + in + let wk_out, (removed, added), l_t, event, remains = + add_agents_in_cc sigs id wk Mods.IntMap.empty transformations + links_transf instantiations' t [ h ] + in + let env', inj, cc, cc_id = + Pattern.finish_new ~debug_mode ?origin wk_out + in let added' = List_util.smart_map - (Primitives.Transformation.rename ~debugMode id inj) added in + (Primitives.Transformation.rename ~debug_mode id inj) + added + in let removed' = List_util.smart_map - (Primitives.Transformation.rename ~debugMode id inj) removed in + (Primitives.Transformation.rename ~debug_mode id inj) + removed + in let event' = - Instantiation.rename_abstract_event ~debugMode id inj event in - let l_t' = Mods.IntMap.map - (fun (p,s as x) -> - let p' = Matching.Agent.rename ~debugMode id inj p in - if p == p' then x else (p',s)) l_t in - aux env' (removed',added') event' l_t' ((cc_id,cc)::acc) (succ id) remains - in aux env ([],[]) Instantiation.empty_event Mods.IntMap.empty [] 0 mix + Instantiation.rename_abstract_event ~debug_mode id inj event + in + let l_t' = + Mods.IntMap.map + (fun ((p, s) as x) -> + let p' = Matching.Agent.rename ~debug_mode id inj p in + if p == p' then + x + else + p', s) + l_t + in + aux env' (removed', added') event' l_t' ((cc_id, cc) :: acc) (succ id) + remains + in + aux env ([], []) Instantiation.empty_event Mods.IntMap.empty [] 0 mix let rule_mixtures_of_ambiguous_rule contact_map sigs precomp_mixs = - add_implicit_infos - sigs (find_implicit_infos - contact_map - (List.rev (List.rev_map LKappa.copy_rule_agent precomp_mixs))) + add_implicit_infos sigs + (find_implicit_infos contact_map + (List.rev (List.rev_map LKappa.copy_rule_agent precomp_mixs))) -let connected_components_sum_of_ambiguous_rule - ~debugMode ~compileModeOn contact_map env ?origin precomp_mixs created = - let noCounters = debugMode in +let connected_components_sum_of_ambiguous_rule ~debug_mode ~compile_mode_on + contact_map env ?origin precomp_mixs created = + let noCounters = debug_mode in let sigs = Pattern.PreEnv.sigs env in let all_mixs = - rule_mixtures_of_ambiguous_rule contact_map sigs precomp_mixs in + rule_mixtures_of_ambiguous_rule contact_map sigs precomp_mixs + in let () = - if compileModeOn then - Format.eprintf "@[_____(%i)@,%a@]@." - (List.length all_mixs) - (Pp.list - Pp.cut - (fun f x -> - Format.fprintf - f "@[%a%a@]" - (LKappa.print_rule_mixture - ~noCounters sigs ~ltypes:true created) x - (Raw_mixture.print - ~noCounters ~created:true ~initial_comma:(x <> []) ~sigs) - (List.rev created))) - all_mixs in - List_util.fold_right_map (connected_components_of_mixture ~debugMode created) - all_mixs (env,origin) + if compile_mode_on then + Format.eprintf "@[_____(%i)@,%a@]@." (List.length all_mixs) + (Pp.list Pp.cut (fun f x -> + Format.fprintf f "@[%a%a@]" + (LKappa.print_rule_mixture ~noCounters sigs ~ltypes:true created) + x + (Raw_mixture.print ~noCounters ~created:true + ~initial_comma:(x <> []) ~sigs) + (List.rev created))) + all_mixs + in + List_util.fold_right_map + (connected_components_of_mixture ~debug_mode created) + all_mixs (env, origin) -let connected_components_sum_of_ambiguous_mixture - ~debugMode ~compileModeOn contact_map env ?origin mix = - let rules,(cc_env,_) = - connected_components_sum_of_ambiguous_rule - ~debugMode ~compileModeOn contact_map env ?origin mix [] in - (cc_env, List.rev_map - (function _, l, event, ([],[]) -> l, event.Instantiation.tests - | _ -> assert false) rules) +let connected_components_sum_of_ambiguous_mixture ~debug_mode ~compile_mode_on + contact_map env ?origin mix = + let rules, (cc_env, _) = + connected_components_sum_of_ambiguous_rule ~debug_mode ~compile_mode_on + contact_map env ?origin mix [] + in + ( cc_env, + List.rev_map + (function + | _, l, event, ([], []) -> l, event.Instantiation.tests + | _ -> assert false) + rules ) let aux_lkappa_of_pattern free_id p = Pattern.fold_by_type - (fun ~pos ~agent_type intf (acc,lnk_pack) -> - let ra_ports = - Array.make - (Array.length intf) - (Locality.dummy_annot LKappa.LNK_ANY,LKappa.Maintained) in - let ra_ints = Array.make (Array.length intf) LKappa.I_ANY in - let out = { - LKappa.ra_type = agent_type; LKappa.ra_erased = false; - LKappa.ra_syntax = None; LKappa.ra_ports; LKappa.ra_ints } in - let acc' = Mods.IntMap.add pos out acc in - let lnk_pack' = Tools.array_fold_lefti - (fun site (free_id, known_src as pack) (link,int) -> - let () = if int <> -1 then - ra_ints.(site) <- LKappa.I_VAL_CHANGED (int,int) in - match link with - | Pattern.UnSpec -> pack - | Pattern.Free -> - let () = ra_ports.(site) <- - (Locality.dummy_annot LKappa.LNK_FREE,LKappa.Maintained) in + (fun ~pos ~agent_type intf (acc, lnk_pack) -> + let ra_ports = + Array.make (Array.length intf) + (Loc.annot_with_dummy LKappa.LNK_ANY, LKappa.Maintained) + in + let ra_ints = Array.make (Array.length intf) LKappa.I_ANY in + let out = + { + LKappa.ra_type = agent_type; + LKappa.ra_erased = false; + LKappa.ra_syntax = None; + LKappa.ra_ports; + LKappa.ra_ints; + } + in + let acc' = Mods.IntMap.add pos out acc in + let lnk_pack' = + Tools.array_fold_lefti + (fun site ((free_id, known_src) as pack) (link, int) -> + let () = + if int <> -1 then ra_ints.(site) <- LKappa.I_VAL_CHANGED (int, int) + in + match link with + | Pattern.UnSpec -> pack + | Pattern.Free -> + let () = + ra_ports.(site) <- + Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Maintained + in + pack + | Pattern.Link (dst_a, dst_s) -> + let src_info = site, agent_type in + (match Mods.Int2Map.find_option (dst_a, dst_s) known_src with + | Some (id, dst_info) -> + let () = + ra_ports.(site) <- + ( Loc.annot_with_dummy (LKappa.LNK_VALUE (id, dst_info)), + LKappa.Maintained ) + in + let () = + (Mods.IntMap.find_default out dst_a acc').LKappa.ra_ports.(dst_s) <- + ( Loc.annot_with_dummy (LKappa.LNK_VALUE (id, src_info)), + LKappa.Maintained ) + in pack - | Pattern.Link (dst_a,dst_s) -> - let src_info = (site,agent_type) in - match Mods.Int2Map.find_option (dst_a,dst_s) known_src with - | Some (id,dst_info) -> - let () = ra_ports.(site) <- - (Locality.dummy_annot (LKappa.LNK_VALUE (id,dst_info)), - LKappa.Maintained) in - let () = (Mods.IntMap.find_default out dst_a acc'). - LKappa.ra_ports.(dst_s) <- - (Locality.dummy_annot (LKappa.LNK_VALUE (id,src_info)), - LKappa.Maintained) in - pack - | None -> - (succ free_id, - Mods.Int2Map.add (pos,site) (free_id,src_info) known_src) - ) - lnk_pack - intf in - (acc',lnk_pack')) + | None -> + ( succ free_id, + Mods.Int2Map.add (pos, site) (free_id, src_info) known_src ))) + lnk_pack intf + in + acc', lnk_pack') p - (Mods.IntMap.empty,(free_id,Mods.Int2Map.empty)) + (Mods.IntMap.empty, (free_id, Mods.Int2Map.empty)) let register_positive_transformations sigs mixs free_id transfs = List.fold_left - (fun (fid,fr as pack) -> function - | Primitives.Transformation.NegativeWhatEver _ - | Primitives.Transformation.NegativeInternalized _ - | Primitives.Transformation.Agent (Matching.Agent.Existing _) -> - assert false - | Primitives.Transformation.Agent (Matching.Agent.Fresh (a_type,id)) -> - let si = Signature.arity sigs a_type in - let n = { - Raw_mixture.a_type; - Raw_mixture.a_ports = Array.make si Raw_mixture.FREE; - Raw_mixture.a_ints = Array.make si None; - } in - (fid,Mods.IntMap.add id n fr) - | Primitives.Transformation.PositiveInternalized - (Matching.Agent.Existing ((id,_),cc_id),s,i) -> - let () = match Mods.IntMap.find_option id mixs.(cc_id) with - | None -> assert false - | Some a -> match a.LKappa.ra_ints.(s) with - | LKappa.I_ANY_CHANGED _ | LKappa.I_ANY_ERASED - | LKappa.I_VAL_ERASED _ -> assert false - | LKappa.I_VAL_CHANGED (j,k) -> - let () = assert (j = k) in - a.LKappa.ra_ints.(s) <- LKappa.I_VAL_CHANGED (j,i) - | LKappa.I_ANY -> - a.LKappa.ra_ints.(s) <- LKappa.I_ANY_CHANGED i in - pack - | Primitives.Transformation.PositiveInternalized - (Matching.Agent.Fresh (_,id),s,i) -> - let () = match Mods.IntMap.find_option id fr with - | Some a -> a.Raw_mixture.a_ints.(s) <- Some i - | None -> () in - pack - | Primitives.Transformation.Freed (Matching.Agent.Fresh _,_) -> (fid,fr) - | Primitives.Transformation.Freed - (Matching.Agent.Existing ((id,_),cc_id),s) -> - let () = match Mods.IntMap.find_option id mixs.(cc_id) with - | Some a -> let (test,edit) = a.LKappa.ra_ports.(s) in - let () = assert (edit = LKappa.Maintained) in - a.LKappa.ra_ports.(s) <- (test, LKappa.Freed) - | None -> assert false in - pack - | Primitives.Transformation.Linked - ((Matching.Agent.Existing ((id1,_),cc_id1),s1), - (Matching.Agent.Existing ((id2,_),cc_id2),s2)) -> - let () = match Mods.IntMap.find_option id1 mixs.(cc_id1) with - | Some a -> let (test,edit) = a.LKappa.ra_ports.(s1) in - let () = assert (edit = LKappa.Maintained) in - a.LKappa.ra_ports.(s1) <- (test, LKappa.Linked fid) - | None -> assert false in - let () = match Mods.IntMap.find_option id2 mixs.(cc_id2) with - | Some a -> let (test,edit) = a.LKappa.ra_ports.(s2) in - let () = assert (edit = LKappa.Maintained) in - a.LKappa.ra_ports.(s2) <- (test, LKappa.Linked fid) - | None -> assert false in - (succ fid,fr) - | Primitives.Transformation.Linked - ((Matching.Agent.Fresh (_,id),s1), - (Matching.Agent.Existing ((eid,_),cc_id),s2)) | - Primitives.Transformation.Linked - ((Matching.Agent.Existing ((eid,_),cc_id),s2), - (Matching.Agent.Fresh (_,id),s1)) -> - let () = match Mods.IntMap.find_option id fr with - | Some a -> a.Raw_mixture.a_ports.(s1) <- Raw_mixture.VAL fid - | None -> assert false in - let () = match Mods.IntMap.find_option eid mixs.(cc_id) with - | Some a -> let (test,edit) = a.LKappa.ra_ports.(s2) in - let () = assert (edit = LKappa.Maintained) in - a.LKappa.ra_ports.(s2) <- (test, LKappa.Linked fid) - | None -> assert false in - (succ fid,fr) - | Primitives.Transformation.Linked - ((Matching.Agent.Fresh (_,id1),s1), - (Matching.Agent.Fresh (_,id2),s2)) -> - let () = match Mods.IntMap.find_option id1 fr with - | Some a -> a.Raw_mixture.a_ports.(s1) <- Raw_mixture.VAL fid - | None -> assert false in - let () = match Mods.IntMap.find_option id2 fr with - | Some a -> a.Raw_mixture.a_ports.(s2) <- Raw_mixture.VAL fid - | None -> assert false in - (succ fid,fr) - ) (free_id,Mods.IntMap.empty) transfs + (fun ((fid, fr) as pack) -> function + | Primitives.Transformation.NegativeWhatEver _ + | Primitives.Transformation.NegativeInternalized _ + | Primitives.Transformation.Agent (Matching.Agent.Existing _) -> + assert false + | Primitives.Transformation.Agent (Matching.Agent.Fresh (a_type, id)) -> + let si = Signature.arity sigs a_type in + let n = + { + Raw_mixture.a_type; + Raw_mixture.a_ports = Array.make si Raw_mixture.FREE; + Raw_mixture.a_ints = Array.make si None; + } + in + fid, Mods.IntMap.add id n fr + | Primitives.Transformation.PositiveInternalized + (Matching.Agent.Existing ((id, _), cc_id), s, i) -> + let () = + match Mods.IntMap.find_option id mixs.(cc_id) with + | None -> assert false + | Some a -> + (match a.LKappa.ra_ints.(s) with + | LKappa.I_ANY_CHANGED _ | LKappa.I_ANY_ERASED + | LKappa.I_VAL_ERASED _ -> + assert false + | LKappa.I_VAL_CHANGED (j, k) -> + let () = assert (j = k) in + a.LKappa.ra_ints.(s) <- LKappa.I_VAL_CHANGED (j, i) + | LKappa.I_ANY -> a.LKappa.ra_ints.(s) <- LKappa.I_ANY_CHANGED i) + in + pack + | Primitives.Transformation.PositiveInternalized + (Matching.Agent.Fresh (_, id), s, i) -> + let () = + match Mods.IntMap.find_option id fr with + | Some a -> a.Raw_mixture.a_ints.(s) <- Some i + | None -> () + in + pack + | Primitives.Transformation.Freed (Matching.Agent.Fresh _, _) -> fid, fr + | Primitives.Transformation.Freed + (Matching.Agent.Existing ((id, _), cc_id), s) -> + let () = + match Mods.IntMap.find_option id mixs.(cc_id) with + | Some a -> + let test, edit = a.LKappa.ra_ports.(s) in + let () = assert (edit = LKappa.Maintained) in + a.LKappa.ra_ports.(s) <- test, LKappa.Freed + | None -> assert false + in + pack + | Primitives.Transformation.Linked + ( (Matching.Agent.Existing ((id1, _), cc_id1), s1), + (Matching.Agent.Existing ((id2, _), cc_id2), s2) ) -> + let () = + match Mods.IntMap.find_option id1 mixs.(cc_id1) with + | Some a -> + let test, edit = a.LKappa.ra_ports.(s1) in + let () = assert (edit = LKappa.Maintained) in + a.LKappa.ra_ports.(s1) <- test, LKappa.Linked fid + | None -> assert false + in + let () = + match Mods.IntMap.find_option id2 mixs.(cc_id2) with + | Some a -> + let test, edit = a.LKappa.ra_ports.(s2) in + let () = assert (edit = LKappa.Maintained) in + a.LKappa.ra_ports.(s2) <- test, LKappa.Linked fid + | None -> assert false + in + succ fid, fr + | Primitives.Transformation.Linked + ( (Matching.Agent.Fresh (_, id), s1), + (Matching.Agent.Existing ((eid, _), cc_id), s2) ) + | Primitives.Transformation.Linked + ( (Matching.Agent.Existing ((eid, _), cc_id), s2), + (Matching.Agent.Fresh (_, id), s1) ) -> + let () = + match Mods.IntMap.find_option id fr with + | Some a -> a.Raw_mixture.a_ports.(s1) <- Raw_mixture.VAL fid + | None -> assert false + in + let () = + match Mods.IntMap.find_option eid mixs.(cc_id) with + | Some a -> + let test, edit = a.LKappa.ra_ports.(s2) in + let () = assert (edit = LKappa.Maintained) in + a.LKappa.ra_ports.(s2) <- test, LKappa.Linked fid + | None -> assert false + in + succ fid, fr + | Primitives.Transformation.Linked + ( (Matching.Agent.Fresh (_, id1), s1), + (Matching.Agent.Fresh (_, id2), s2) ) -> + let () = + match Mods.IntMap.find_option id1 fr with + | Some a -> a.Raw_mixture.a_ports.(s1) <- Raw_mixture.VAL fid + | None -> assert false + in + let () = + match Mods.IntMap.find_option id2 fr with + | Some a -> a.Raw_mixture.a_ports.(s2) <- Raw_mixture.VAL fid + | None -> assert false + in + succ fid, fr) + (free_id, Mods.IntMap.empty) + transfs |> snd let add_negative_transformations sigs mixs transfs = List.iter (function | Primitives.Transformation.Agent (Matching.Agent.Fresh _) - | Primitives.Transformation.NegativeInternalized (Matching.Agent.Fresh _,_) + | Primitives.Transformation.NegativeInternalized + (Matching.Agent.Fresh _, _) | Primitives.Transformation.PositiveInternalized _ - | Primitives.Transformation.Linked ((Matching.Agent.Fresh _,_),_) - | Primitives.Transformation.Linked (_,(Matching.Agent.Fresh _,_)) - | Primitives.Transformation.Freed (Matching.Agent.Fresh _,_) -> + | Primitives.Transformation.Linked ((Matching.Agent.Fresh _, _), _) + | Primitives.Transformation.Linked (_, (Matching.Agent.Fresh _, _)) + | Primitives.Transformation.Freed (Matching.Agent.Fresh _, _) -> assert false | Primitives.Transformation.NegativeWhatEver _ | Primitives.Transformation.NegativeInternalized - (Matching.Agent.Existing _,_) + (Matching.Agent.Existing _, _) | Primitives.Transformation.Linked - ((Matching.Agent.Existing _,_),(Matching.Agent.Existing _,_)) - | Primitives.Transformation.Freed (Matching.Agent.Existing _,_) -> + ((Matching.Agent.Existing _, _), (Matching.Agent.Existing _, _)) + | Primitives.Transformation.Freed (Matching.Agent.Existing _, _) -> () - | Primitives.Transformation.Agent (Matching.Agent.Existing ((id,_),cc_id)) -> - let ag = match Mods.IntMap.find_option id mixs.(cc_id) with + | Primitives.Transformation.Agent + (Matching.Agent.Existing ((id, _), cc_id)) -> + let ag = + match Mods.IntMap.find_option id mixs.(cc_id) with | None -> assert false - | Some a -> a in + | Some a -> a + in mixs.(cc_id) <- - Mods.IntMap.add id (LKappa.agent_to_erased sigs ag) mixs.(cc_id) - ) transfs + Mods.IntMap.add id (LKappa.agent_to_erased sigs ag) mixs.(cc_id)) + transfs let lkappa_of_elementary_rule sigs domain r = let nb_cc = Array.length r.Primitives.connected_components in @@ -752,25 +932,31 @@ let lkappa_of_elementary_rule sigs domain r = let free_id = Tools.array_fold_lefti (fun cc_id free_id cc -> - let (out,(free_id',_)) = aux_lkappa_of_pattern - free_id (Pattern.Env.content (Pattern.Env.get domain cc)) in - let () = mixs.(cc_id) <- out in - free_id') - 1 - r.Primitives.connected_components in - let news = register_positive_transformations - sigs mixs free_id r.Primitives.inserted in - let () = add_negative_transformations - sigs mixs r.Primitives.removed in + let out, (free_id', _) = + aux_lkappa_of_pattern free_id + (Pattern.Env.content (Pattern.Env.get domain cc)) + in + let () = mixs.(cc_id) <- out in + free_id') + 1 r.Primitives.connected_components + in + let news = + register_positive_transformations sigs mixs free_id r.Primitives.inserted + in + let () = add_negative_transformations sigs mixs r.Primitives.removed in let r_mix = Array.fold_left - (fun a b -> Mods.IntMap.fold (fun _ x acc -> x::acc) b a) [] mixs - |> List.rev in - let r_created =Mods.IntMap.fold (fun _ x acc -> x::acc) news [] |> List.rev in - (r_mix,r_created) - (*{ - LKappa.r_mix; LKappa.r_created; LKappa.r_editStyle = true; - LKappa.r_rate = r.Primitives.rate; - LKappa.r_un_rate = r.Primitives.unary_rate; - LKappa.r_delta_tokens = r.Primitives.delta_tokens; - }*) + (fun a b -> Mods.IntMap.fold (fun _ x acc -> x :: acc) b a) + [] mixs + |> List.rev + in + let r_created = + Mods.IntMap.fold (fun _ x acc -> x :: acc) news [] |> List.rev + in + r_mix, r_created +(*{ + LKappa.r_mix; LKappa.r_created; LKappa.r_edit_style = true; + LKappa.r_rate = r.Primitives.rate; + LKappa.r_un_rate = r.Primitives.unary_rate; + LKappa.r_delta_tokens = r.Primitives.delta_tokens; + }*) diff --git a/core/term/pattern_compiler.mli b/core/term/pattern_compiler.mli index c6d0e7f6ec..5e116f4bfb 100644 --- a/core/term/pattern_compiler.mli +++ b/core/term/pattern_compiler.mli @@ -9,22 +9,36 @@ (** Kappa pattern compiler *) val connected_components_sum_of_ambiguous_mixture : - debugMode:bool -> compileModeOn:bool -> Contact_map.t -> Pattern.PreEnv.t -> - ?origin:Operator.rev_dep -> LKappa.rule_mixture -> - Pattern.PreEnv.t * - ((Pattern.id * Pattern.cc) array * - Instantiation.abstract Instantiation.test list list) list + debug_mode:bool -> + compile_mode_on:bool -> + Contact_map.t -> + Pattern.PreEnv.t -> + ?origin:Operator.rev_dep -> + LKappa.rule_mixture -> + Pattern.PreEnv.t + * ((Pattern.id * Pattern.cc) array + * Instantiation.abstract Instantiation.test list list) + list val connected_components_sum_of_ambiguous_rule : - debugMode:bool -> compileModeOn:bool -> Contact_map.t -> Pattern.PreEnv.t -> - ?origin:Operator.rev_dep -> LKappa.rule_mixture -> Raw_mixture.t -> - (Operator.rev_dep option * (Pattern.id * Pattern.cc) array * - (Instantiation.abstract Instantiation.event) * - (Instantiation.abstract Primitives.Transformation.t list * - Instantiation.abstract Primitives.Transformation.t list)) - list * (Pattern.PreEnv.t * Operator.rev_dep option) + debug_mode:bool -> + compile_mode_on:bool -> + Contact_map.t -> + Pattern.PreEnv.t -> + ?origin:Operator.rev_dep -> + LKappa.rule_mixture -> + Raw_mixture.t -> + (Operator.rev_dep option + * (Pattern.id * Pattern.cc) array + * Instantiation.abstract Instantiation.event + * (Instantiation.abstract Primitives.Transformation.t list + * Instantiation.abstract Primitives.Transformation.t list)) + list + * (Pattern.PreEnv.t * Operator.rev_dep option) val lkappa_of_elementary_rule : - Signature.s -> Pattern.Env.t -> Primitives.elementary_rule -> + Signature.s -> + Pattern.Env.t -> + Primitives.elementary_rule -> LKappa.rule_mixture * Raw_mixture.t - (** @return: [(r_mix,r_create)] *) +(** @return: [(r_mix,r_create)] *) diff --git a/core/term/pattern_decompiler.ml b/core/term/pattern_decompiler.ml index 9a03a53e1d..05c78c7bb9 100644 --- a/core/term/pattern_decompiler.ml +++ b/core/term/pattern_decompiler.ml @@ -7,60 +7,72 @@ (******************************************************************************) let of_snapshot g = - let out,_ = + let out, _ = Tools.array_fold_lefti - (fun node (acc,pack) ag -> - let ra_type = ag.Snapshot.node_type in - let ar = Array.length ag.Snapshot.node_sites in - let ra_ports = - Array.make - ar (Locality.dummy_annot LKappa.LNK_FREE, LKappa.Maintained) in - let ra_ints = Array.make ar LKappa.I_ANY in - let pack' = - Tools.array_fold_lefti - (fun id (dangling, free_id as pack) p -> - let () = match p.Snapshot.site_state with - | None -> () - | Some i -> ra_ints.(id) <- LKappa.I_VAL_CHANGED (i,i) in - match p.Snapshot.site_link with - | None -> pack - | Some s -> - match Mods.Int2Map.pop s dangling with - | Some va,dangling' -> - let () = - ra_ports.(id) <- - (Locality.dummy_annot (LKappa.LNK_VALUE(va,(-1,-1))), - LKappa.Maintained) in - dangling',free_id - | None, dangling' -> - let () = - ra_ports.(id) <- - (Locality.dummy_annot (LKappa.LNK_VALUE(free_id,(-1,-1))), - LKappa.Maintained) in - Mods.Int2Map.add (node,id) free_id dangling',succ free_id - ) - pack - ag.Snapshot.node_sites in - let ra = - { LKappa.ra_type; ra_erased = false; ra_ports; ra_ints; - ra_syntax = Some (Array.copy ra_ports, Array.copy ra_ints)} in - ra::acc, - pack') - ([],(Mods.Int2Map.empty,1)) g in + (fun node (acc, pack) ag -> + let ra_type = ag.Snapshot.node_type in + let ar = Array.length ag.Snapshot.node_sites in + let ra_ports = + Array.make ar (Loc.annot_with_dummy LKappa.LNK_FREE, LKappa.Maintained) + in + let ra_ints = Array.make ar LKappa.I_ANY in + let pack' = + Tools.array_fold_lefti + (fun id ((dangling, free_id) as pack) p -> + let () = + match p.Snapshot.site_state with + | None -> () + | Some i -> ra_ints.(id) <- LKappa.I_VAL_CHANGED (i, i) + in + match p.Snapshot.site_link with + | None -> pack + | Some s -> + (match Mods.Int2Map.pop s dangling with + | Some va, dangling' -> + let () = + ra_ports.(id) <- + ( Loc.annot_with_dummy (LKappa.LNK_VALUE (va, (-1, -1))), + LKappa.Maintained ) + in + dangling', free_id + | None, dangling' -> + let () = + ra_ports.(id) <- + ( Loc.annot_with_dummy + (LKappa.LNK_VALUE (free_id, (-1, -1))), + LKappa.Maintained ) + in + Mods.Int2Map.add (node, id) free_id dangling', succ free_id)) + pack ag.Snapshot.node_sites + in + let ra = + { + LKappa.ra_type; + ra_erased = false; + ra_ports; + ra_ints; + ra_syntax = Some (Array.copy ra_ports, Array.copy ra_ints); + } + in + ra :: acc, pack') + ([], (Mods.Int2Map.empty, 1)) + g + in out -let patterns_of_mixture ~debugMode contact_map sigs pre_env e = +let patterns_of_mixture ~debug_mode contact_map sigs pre_env e = let snap = Edges.build_snapshot ~raw:false sigs e in let pre_env', acc = Snapshot.fold - (fun (cc_cache,acc) i m -> - match Pattern_compiler.connected_components_sum_of_ambiguous_mixture - ~debugMode ~compileModeOn:false contact_map - cc_cache (of_snapshot m) with - | cc_cache',[[|_,x|],_] -> - cc_cache',Tools.recti (fun a _ -> x::a) acc i - | _ -> assert false) - (pre_env,[]) snap + (fun (cc_cache, acc) i m -> + match + Pattern_compiler.connected_components_sum_of_ambiguous_mixture + ~debug_mode ~compile_mode_on:false contact_map cc_cache + (of_snapshot m) + with + | cc_cache', [ ([| (_, x) |], _) ] -> + cc_cache', Tools.recti (fun a _ -> x :: a) acc i + | _ -> assert false) + (pre_env, []) snap in - (pre_env', acc) - + pre_env', acc diff --git a/core/term/pattern_decompiler.mli b/core/term/pattern_decompiler.mli index 95bf55ad9f..368c24abb3 100644 --- a/core/term/pattern_decompiler.mli +++ b/core/term/pattern_decompiler.mli @@ -7,5 +7,9 @@ (******************************************************************************) val patterns_of_mixture : - debugMode:bool -> Contact_map.t -> Signature.s -> - Pattern.PreEnv.t -> Edges.t -> Pattern.PreEnv.t * Pattern.cc list + debug_mode:bool -> + Contact_map.t -> + Signature.s -> + Pattern.PreEnv.t -> + Edges.t -> + Pattern.PreEnv.t * Pattern.cc list diff --git a/core/term/primitives.ml b/core/term/primitives.ml index b10cd7c269..38c3e2c936 100644 --- a/core/term/primitives.ml +++ b/core/term/primitives.ml @@ -17,167 +17,225 @@ module Transformation = struct | NegativeInternalized of 'a Instantiation.site let to_yojson = function - | Agent a -> `Assoc ["Agent", Matching.Agent.to_yojson a] - | Freed (a,s) -> - `Assoc ["Freed", `List [Matching.Agent.to_yojson a; `Int s]] - | Linked ((a,s),(b,t)) -> - `Assoc ["Linked", - `List [Matching.Agent.to_yojson a;`Int s; - Matching.Agent.to_yojson b;`Int t]] - | NegativeWhatEver (a,s) -> - `Assoc ["NegativeWhatEver", `List [Matching.Agent.to_yojson a; `Int s]] - | PositiveInternalized (a,s,i) -> - `Assoc ["PositiveInternalized", - `List [Matching.Agent.to_yojson a;`Int s;`Int i]] - | NegativeInternalized (a,s) -> - `Assoc ["NegativeInternalized",`List [Matching.Agent.to_yojson a;`Int s]] + | Agent a -> `Assoc [ "Agent", Matching.Agent.to_yojson a ] + | Freed (a, s) -> + `Assoc [ "Freed", `List [ Matching.Agent.to_yojson a; `Int s ] ] + | Linked ((a, s), (b, t)) -> + `Assoc + [ + ( "Linked", + `List + [ + Matching.Agent.to_yojson a; + `Int s; + Matching.Agent.to_yojson b; + `Int t; + ] ); + ] + | NegativeWhatEver (a, s) -> + `Assoc + [ "NegativeWhatEver", `List [ Matching.Agent.to_yojson a; `Int s ] ] + | PositiveInternalized (a, s, i) -> + `Assoc + [ + ( "PositiveInternalized", + `List [ Matching.Agent.to_yojson a; `Int s; `Int i ] ); + ] + | NegativeInternalized (a, s) -> + `Assoc + [ "NegativeInternalized", `List [ Matching.Agent.to_yojson a; `Int s ] ] let of_yojson = function - | `Assoc ["Agent", a] -> Agent (Matching.Agent.of_yojson a) - | `Assoc ["Freed", `List [a;`Int s]] -> - Freed ((Matching.Agent.of_yojson a),s) - | `Assoc ["Linked",`List [a;(`Int s); b;(`Int t)]] -> - Linked ((Matching.Agent.of_yojson a,s),(Matching.Agent.of_yojson b,t)) - | `Assoc ["NegativeWhatEver",`List [a;`Int s]] -> - NegativeWhatEver (Matching.Agent.of_yojson a,s) - | `Assoc ["PositiveInternalized",`List [a;`Int s;`Int i]] -> - PositiveInternalized (Matching.Agent.of_yojson a,s,i) - | `Assoc ["NegativeInternalized",`List [a;`Int s]] -> - NegativeInternalized (Matching.Agent.of_yojson a,s) - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent",x)) - - let rename ~debugMode id inj = function - | Freed (p,s) as x -> - let p' = Matching.Agent.rename ~debugMode id inj p in - if p == p' then x else Freed (p',s) - | NegativeWhatEver (p,s) as x -> - let p' = Matching.Agent.rename ~debugMode id inj p in - if p == p' then x else NegativeWhatEver (p',s) - | Linked ((p1,s1),(p2,s2)) as x -> - let p1' = Matching.Agent.rename ~debugMode id inj p1 in - let p2' = Matching.Agent.rename ~debugMode id inj p2 in - if p1 == p1' && p2 == p2' then x else Linked ((p1',s1),(p2',s2)) - | PositiveInternalized (p,s,i) as x -> - let p' = Matching.Agent.rename ~debugMode id inj p in - if p == p' then x else PositiveInternalized (p',s,i) - | NegativeInternalized (p,s) as x -> - let p' = Matching.Agent.rename ~debugMode id inj p in - if p == p' then x else NegativeInternalized (p',s) + | `Assoc [ ("Agent", a) ] -> Agent (Matching.Agent.of_yojson a) + | `Assoc [ ("Freed", `List [ a; `Int s ]) ] -> + Freed (Matching.Agent.of_yojson a, s) + | `Assoc [ ("Linked", `List [ a; `Int s; b; `Int t ]) ] -> + Linked ((Matching.Agent.of_yojson a, s), (Matching.Agent.of_yojson b, t)) + | `Assoc [ ("NegativeWhatEver", `List [ a; `Int s ]) ] -> + NegativeWhatEver (Matching.Agent.of_yojson a, s) + | `Assoc [ ("PositiveInternalized", `List [ a; `Int s; `Int i ]) ] -> + PositiveInternalized (Matching.Agent.of_yojson a, s, i) + | `Assoc [ ("NegativeInternalized", `List [ a; `Int s ]) ] -> + NegativeInternalized (Matching.Agent.of_yojson a, s) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid agent", x)) + + let rename ~debug_mode id inj = function + | Freed (p, s) as x -> + let p' = Matching.Agent.rename ~debug_mode id inj p in + if p == p' then + x + else + Freed (p', s) + | NegativeWhatEver (p, s) as x -> + let p' = Matching.Agent.rename ~debug_mode id inj p in + if p == p' then + x + else + NegativeWhatEver (p', s) + | Linked ((p1, s1), (p2, s2)) as x -> + let p1' = Matching.Agent.rename ~debug_mode id inj p1 in + let p2' = Matching.Agent.rename ~debug_mode id inj p2 in + if p1 == p1' && p2 == p2' then + x + else + Linked ((p1', s1), (p2', s2)) + | PositiveInternalized (p, s, i) as x -> + let p' = Matching.Agent.rename ~debug_mode id inj p in + if p == p' then + x + else + PositiveInternalized (p', s, i) + | NegativeInternalized (p, s) as x -> + let p' = Matching.Agent.rename ~debug_mode id inj p in + if p == p' then + x + else + NegativeInternalized (p', s) | Agent p as x -> - let p' = Matching.Agent.rename ~debugMode id inj p in - if p == p' then x else Agent p' - - let concretize ~debugMode inj2graph = function - | Agent n -> Agent (Matching.Agent.concretize ~debugMode inj2graph n) - | Freed (n,s) -> Freed (Matching.Agent.concretize ~debugMode inj2graph n,s) - | Linked ((n,s),(n',s')) -> - Linked ((Matching.Agent.concretize ~debugMode inj2graph n,s), - (Matching.Agent.concretize ~debugMode inj2graph n',s')) - | NegativeWhatEver (n,s) -> - NegativeWhatEver (Matching.Agent.concretize ~debugMode inj2graph n,s) - | PositiveInternalized (n,s,i) -> + let p' = Matching.Agent.rename ~debug_mode id inj p in + if p == p' then + x + else + Agent p' + + let concretize ~debug_mode inj2graph = function + | Agent n -> Agent (Matching.Agent.concretize ~debug_mode inj2graph n) + | Freed (n, s) -> + Freed (Matching.Agent.concretize ~debug_mode inj2graph n, s) + | Linked ((n, s), (n', s')) -> + Linked + ( (Matching.Agent.concretize ~debug_mode inj2graph n, s), + (Matching.Agent.concretize ~debug_mode inj2graph n', s') ) + | NegativeWhatEver (n, s) -> + NegativeWhatEver (Matching.Agent.concretize ~debug_mode inj2graph n, s) + | PositiveInternalized (n, s, i) -> PositiveInternalized - (Matching.Agent.concretize ~debugMode inj2graph n,s,i) - | NegativeInternalized (n,s) -> - NegativeInternalized - (Matching.Agent.concretize ~debugMode inj2graph n,s) + (Matching.Agent.concretize ~debug_mode inj2graph n, s, i) + | NegativeInternalized (n, s) -> + NegativeInternalized (Matching.Agent.concretize ~debug_mode inj2graph n, s) let map_fold_agent f x acc = match x with - | Agent a -> let (a',acc') = f a acc in (Agent a',acc') - | Freed (a,s) -> let (a',acc') = f a acc in (Freed (a',s),acc') - | Linked ((a1,s1),(a2,s2)) -> - let (a1',acc') = f a1 acc in - let (a2',acc'') = f a2 acc' in - (Linked ((a1',s1),(a2',s2)), acc'') - | NegativeWhatEver (a,s) -> - let (a',acc') = f a acc in (NegativeWhatEver (a',s),acc') - | PositiveInternalized (a,s,i) -> - let (a',acc') = f a acc in (PositiveInternalized (a',s,i),acc') - | NegativeInternalized (a,s) -> - let (a',acc') = f a acc in (NegativeInternalized (a',s),acc') + | Agent a -> + let a', acc' = f a acc in + Agent a', acc' + | Freed (a, s) -> + let a', acc' = f a acc in + Freed (a', s), acc' + | Linked ((a1, s1), (a2, s2)) -> + let a1', acc' = f a1 acc in + let a2', acc'' = f a2 acc' in + Linked ((a1', s1), (a2', s2)), acc'' + | NegativeWhatEver (a, s) -> + let a', acc' = f a acc in + NegativeWhatEver (a', s), acc' + | PositiveInternalized (a, s, i) -> + let a', acc' = f a acc in + PositiveInternalized (a', s, i), acc' + | NegativeInternalized (a, s) -> + let a', acc' = f a acc in + NegativeInternalized (a', s), acc' let map_agent f = function | Agent a -> Agent (f a) - | Freed (a,s) -> Freed (f a,s) - | Linked ((a1,s1),(a2,s2)) -> Linked ((f a1,s1),(f a2,s2)) - | NegativeWhatEver (a,s) -> NegativeWhatEver (f a,s) - | PositiveInternalized (a,s,i) -> PositiveInternalized (f a,s,i) - | NegativeInternalized (a,s) -> NegativeInternalized (f a,s) + | Freed (a, s) -> Freed (f a, s) + | Linked ((a1, s1), (a2, s2)) -> Linked ((f a1, s1), (f a2, s2)) + | NegativeWhatEver (a, s) -> NegativeWhatEver (f a, s) + | PositiveInternalized (a, s, i) -> PositiveInternalized (f a, s, i) + | NegativeInternalized (a, s) -> NegativeInternalized (f a, s) let fold_agent f acc = function | Agent a -> f acc a - | Freed (a,_) -> f acc a - | Linked ((a1,_),(a2,_)) -> f (f acc a1) a2 - | NegativeWhatEver (a,_) -> f acc a - | PositiveInternalized (a,_,_) -> f acc a - | NegativeInternalized (a,_) -> f acc a + | Freed (a, _) -> f acc a + | Linked ((a1, _), (a2, _)) -> f (f acc a1) a2 + | NegativeWhatEver (a, _) -> f acc a + | PositiveInternalized (a, _, _) -> f acc a + | NegativeInternalized (a, _) -> f acc a let equal f a b = - match a,b with + match a, b with | Agent a, Agent a' -> f a a' - | Agent _, - (Freed _ | Linked _ | NegativeWhatEver _ | PositiveInternalized _ - | NegativeInternalized _) - | _, Agent _ -> false - | Freed (a,s), Freed (a',s') -> s=s' && f a a' - | Freed _, - (Linked _ | NegativeWhatEver _ | PositiveInternalized _ - | NegativeInternalized _) - | _, Freed _ -> false - | Linked ((a1,s1),(a2,s2)), Linked ((a1',s1'),(a2',s2')) -> + | ( Agent _, + ( Freed _ | Linked _ | NegativeWhatEver _ | PositiveInternalized _ + | NegativeInternalized _ ) ) + | _, Agent _ -> + false + | Freed (a, s), Freed (a', s') -> s = s' && f a a' + | ( Freed _, + ( Linked _ | NegativeWhatEver _ | PositiveInternalized _ + | NegativeInternalized _ ) ) + | _, Freed _ -> + false + | Linked ((a1, s1), (a2, s2)), Linked ((a1', s1'), (a2', s2')) -> (s1 = s1' && s2 = s2' && f a1 a1' && f a2 a2') || (s1 = s2' && s2 = s1' && f a1 a2' && f a2 a1') - | Linked _, - (NegativeWhatEver _ | PositiveInternalized _ - | NegativeInternalized _) - | _, Linked _ -> false - | NegativeWhatEver (a,s), NegativeWhatEver (a',s') -> s=s' && f a a' - | NegativeWhatEver _, - (PositiveInternalized _ | NegativeInternalized _) - | _, NegativeWhatEver _ -> false - | NegativeInternalized (a,s), NegativeInternalized (a',s') -> s=s' && f a a' + | ( Linked _, + (NegativeWhatEver _ | PositiveInternalized _ | NegativeInternalized _) ) + | _, Linked _ -> + false + | NegativeWhatEver (a, s), NegativeWhatEver (a', s') -> s = s' && f a a' + | NegativeWhatEver _, (PositiveInternalized _ | NegativeInternalized _) + | _, NegativeWhatEver _ -> + false + | NegativeInternalized (a, s), NegativeInternalized (a', s') -> + s = s' && f a a' | NegativeInternalized _, PositiveInternalized _ - | PositiveInternalized _, NegativeInternalized _ -> false - | PositiveInternalized (a,s,i), PositiveInternalized (a',s',i') -> + | PositiveInternalized _, NegativeInternalized _ -> + false + | PositiveInternalized (a, s, i), PositiveInternalized (a', s', i') -> i = i' && s = s' && f a a' let print ?sigs f = function - | Agent p -> - Format.fprintf f "@[%a@]" (Matching.Agent.print ?sigs) p - | Freed (p,s) -> - Format.fprintf - f "@[%a.%a = %t@]" (Matching.Agent.print ?sigs) p - (Matching.Agent.print_site ?sigs p) s Pp.bottom - | NegativeWhatEver (p,s) -> - Format.fprintf - f "@[%a.%a = ???@]" (Matching.Agent.print ?sigs) p - (Matching.Agent.print_site ?sigs p) s - | Linked ((p1,s1),(p2,s2)) -> - Format.fprintf - f "@[%a.%a = %a.%a@]" - (Matching.Agent.print ?sigs) p1 (Matching.Agent.print_site ?sigs p1) s1 - (Matching.Agent.print ?sigs) p2 (Matching.Agent.print_site ?sigs p2) s2 - | PositiveInternalized (p,s,i) -> - Format.fprintf - f "@[%a.%a =@]" (Matching.Agent.print ?sigs) p - (Matching.Agent.print_internal ?sigs p s) i - | NegativeInternalized (p,s) -> - Format.fprintf - f "@[%a.%a~ =@]" (Matching.Agent.print ?sigs) p - (Matching.Agent.print_site ?sigs p) s - - let get_negative_part created_agents lnk_dst ((a,_),_ as p) (don,out) = - if List.mem p don || List.mem a created_agents then don,out - else + | Agent p -> Format.fprintf f "@[%a@]" (Matching.Agent.print ?sigs) p + | Freed (p, s) -> + Format.fprintf f "@[%a.%a = %t@]" + (Matching.Agent.print ?sigs) + p + (Matching.Agent.print_site ?sigs p) + s Pp.bottom + | NegativeWhatEver (p, s) -> + Format.fprintf f "@[%a.%a = ???@]" + (Matching.Agent.print ?sigs) + p + (Matching.Agent.print_site ?sigs p) + s + | Linked ((p1, s1), (p2, s2)) -> + Format.fprintf f "@[%a.%a = %a.%a@]" + (Matching.Agent.print ?sigs) + p1 + (Matching.Agent.print_site ?sigs p1) + s1 + (Matching.Agent.print ?sigs) + p2 + (Matching.Agent.print_site ?sigs p2) + s2 + | PositiveInternalized (p, s, i) -> + Format.fprintf f "@[%a.%a =@]" + (Matching.Agent.print ?sigs) + p + (Matching.Agent.print_internal ?sigs p s) + i + | NegativeInternalized (p, s) -> + Format.fprintf f "@[%a.%a~ =@]" + (Matching.Agent.print ?sigs) + p + (Matching.Agent.print_site ?sigs p) + s + + let get_negative_part created_agents lnk_dst (((a, _), _) as p) (don, out) = + if List.mem p don || List.mem a created_agents then + don, out + else ( match lnk_dst p with - | None -> p::don, Freed p::out - | Some p' -> p::p'::don, Linked (p,p')::out + | None -> p :: don, Freed p :: out + | Some p' -> p :: p' :: don, Linked (p, p') :: out + ) let agents_created_by_action = function | Instantiation.Create ((ag_id, _), _) -> Some ag_id | Instantiation.Bind _ | Instantiation.Free _ | Instantiation.Bind_to _ - | Instantiation.Remove _ | Instantiation.Mod_internal _ -> None + | Instantiation.Remove _ | Instantiation.Mod_internal _ -> + None let agents_created_by_actions actions = List_util.map_option agents_created_by_action actions @@ -186,114 +244,118 @@ module Transformation = struct let created_agents = agents_created_by_actions actions in snd (List.fold_right - (fun x (don,out as acc) -> match x with - | Instantiation.Create (_,_) -> acc - | Instantiation.Mod_internal (((id, _), _ as p),_) -> - if List.mem id created_agents then don, out else - don, NegativeInternalized p::out - | Instantiation.Bind (p1,p2) - | Instantiation.Bind_to (p1,p2) -> - get_negative_part created_agents lnk_dst p1 - (get_negative_part created_agents lnk_dst p2 acc) - | Instantiation.Free p -> - get_negative_part created_agents lnk_dst p acc - | Instantiation.Remove (_,ty as a) -> - Tools.recti - (fun st s -> get_negative_part created_agents lnk_dst (a,s) st) - (don,Agent a::out) (Signature.arity sigs ty) - ) - actions ([],[])) + (fun x ((don, out) as acc) -> + match x with + | Instantiation.Create (_, _) -> acc + | Instantiation.Mod_internal ((((id, _), _) as p), _) -> + if List.mem id created_agents then + don, out + else + don, NegativeInternalized p :: out + | Instantiation.Bind (p1, p2) | Instantiation.Bind_to (p1, p2) -> + get_negative_part created_agents lnk_dst p1 + (get_negative_part created_agents lnk_dst p2 acc) + | Instantiation.Free p -> + get_negative_part created_agents lnk_dst p acc + | Instantiation.Remove ((_, ty) as a) -> + Tools.recti + (fun st s -> get_negative_part created_agents lnk_dst (a, s) st) + (don, Agent a :: out) + (Signature.arity sigs ty)) + actions ([], [])) let positive_transformations_of_actions sigs side_effect_dsts actions = - let rem,rev = + let rem, rev = List.fold_left - (fun (rem,out as acc) -> function - | Instantiation.Create ((_,ty as a),_) -> - Tools.recti (fun st s -> (a,s)::st) - rem (Signature.arity sigs ty), Agent a::out - | Instantiation.Mod_internal ((a,s),i) -> - rem, PositiveInternalized (a,s,i)::out - | Instantiation.Bind (p1,p2) - | Instantiation.Bind_to (p1,p2) -> - List.filter (fun p -> p <> p1 && p <> p2) rem, - Linked (p1,p2)::out - | Instantiation.Free p -> - List.filter (fun p' -> p' <> p) rem, Freed p::out - | Instantiation.Remove _ -> acc - ) - ([],[]) actions in + (fun ((rem, out) as acc) -> function + | Instantiation.Create (((_, ty) as a), _) -> + ( Tools.recti + (fun st s -> (a, s) :: st) + rem (Signature.arity sigs ty), + Agent a :: out ) + | Instantiation.Mod_internal ((a, s), i) -> + rem, PositiveInternalized (a, s, i) :: out + | Instantiation.Bind (p1, p2) | Instantiation.Bind_to (p1, p2) -> + ( List.filter (fun p -> p <> p1 && p <> p2) rem, + Linked (p1, p2) :: out ) + | Instantiation.Free p -> + List.filter (fun p' -> p' <> p) rem, Freed p :: out + | Instantiation.Remove _ -> acc) + ([], []) actions + in List.rev_append rev - (List_util.rev_map_append (fun p -> Freed p) rem + (List_util.rev_map_append + (fun p -> Freed p) + rem (List.map (fun p -> Freed p) side_effect_dsts)) end type alg_expr = (Pattern.id array list, int) Alg_expr.e type elementary_rule = { - rate : alg_expr Locality.annot; - unary_rate : (alg_expr Locality.annot * alg_expr option) option; - connected_components : Pattern.id array; (*id -> cc*) - removed : Instantiation.abstract Transformation.t list; - inserted : Instantiation.abstract Transformation.t list; - delta_tokens : (alg_expr Locality.annot * int) list; - syntactic_rule : int; - (** [0] means generated for perturbation. *) - instantiations : Instantiation.abstract Instantiation.event; + rate: alg_expr Loc.annoted; + unary_rate: (alg_expr Loc.annoted * alg_expr option) option; + connected_components: Pattern.id array; (*id -> cc*) + removed: Instantiation.abstract Transformation.t list; + inserted: Instantiation.abstract Transformation.t list; + delta_tokens: (alg_expr Loc.annoted * int) list; + syntactic_rule: int; (** [0] means generated for perturbation. *) + instantiations: Instantiation.abstract Instantiation.event; } let extract_cc_ids r = r.connected_components - let extract_abstract_event r = r.instantiations let alg_expr_to_yojson ~filenames = - Alg_expr.e_to_yojson - ~filenames + Alg_expr.e_to_yojson ~filenames (JsonUtil.of_list (JsonUtil.of_array Pattern.id_to_yojson)) JsonUtil.of_int let alg_expr_of_yojson ~filenames = - Alg_expr.e_of_yojson - ~filenames + Alg_expr.e_of_yojson ~filenames (JsonUtil.to_list (JsonUtil.to_array Pattern.id_of_yojson)) (JsonUtil.to_int ?error_msg:None) let rule_to_yojson ~filenames r = - JsonUtil.smart_assoc [ - "rate", Locality.annot_to_yojson ~filenames - (alg_expr_to_yojson ~filenames) r.rate; - "unary_rate", - JsonUtil.of_option - (JsonUtil.of_pair - (Locality.annot_to_yojson ~filenames (alg_expr_to_yojson ~filenames)) - (JsonUtil.of_option (alg_expr_to_yojson ~filenames))) - r.unary_rate; - "connected_components", - JsonUtil.of_array Pattern.id_to_yojson r.connected_components; + JsonUtil.smart_assoc + [ + ( "rate", + Loc.yojson_of_annoted ~filenames (alg_expr_to_yojson ~filenames) r.rate + ); + ( "unary_rate", + JsonUtil.of_option + (JsonUtil.of_pair + (Loc.yojson_of_annoted ~filenames (alg_expr_to_yojson ~filenames)) + (JsonUtil.of_option (alg_expr_to_yojson ~filenames))) + r.unary_rate ); + ( "connected_components", + JsonUtil.of_array Pattern.id_to_yojson r.connected_components ); "removed", JsonUtil.of_list Transformation.to_yojson r.removed; "inserted", JsonUtil.of_list Transformation.to_yojson r.inserted; - "delta_tokens", - JsonUtil.of_list - (JsonUtil.of_pair ~lab1:"val" ~lab2:"tok" - (Locality.annot_to_yojson ~filenames - (alg_expr_to_yojson ~filenames)) - JsonUtil.of_int) - r.delta_tokens; + ( "delta_tokens", + JsonUtil.of_list + (JsonUtil.of_pair ~lab1:"val" ~lab2:"tok" + (Loc.yojson_of_annoted ~filenames (alg_expr_to_yojson ~filenames)) + JsonUtil.of_int) + r.delta_tokens ); "syntactic_rule", `Int r.syntactic_rule; - "instantiations", - Instantiation.event_to_json Matching.Agent.to_yojson r.instantiations; - ] + ( "instantiations", + Instantiation.event_to_json Matching.Agent.to_yojson r.instantiations ); + ] let rule_of_yojson ~filenames r = match r with - | ((`Assoc l):Yojson.Basic.t) as x -> - begin - try { - rate = Locality.annot_of_yojson ~filenames - (alg_expr_of_yojson ~filenames) (List.assoc "rate" l); + | (`Assoc l : Yojson.Basic.t) as x -> + (try + { + rate = + Loc.annoted_of_yojson ~filenames + (alg_expr_of_yojson ~filenames) + (List.assoc "rate" l); unary_rate = JsonUtil.to_option (JsonUtil.to_pair - (Locality.annot_of_yojson ~filenames + (Loc.annoted_of_yojson ~filenames (alg_expr_of_yojson ~filenames)) (JsonUtil.to_option (alg_expr_of_yojson ~filenames))) (Yojson.Basic.Util.member "unary_rate" x); @@ -309,76 +371,96 @@ let rule_of_yojson ~filenames r = delta_tokens = JsonUtil.to_list (JsonUtil.to_pair ~lab1:"val" ~lab2:"tok" - (Locality.annot_of_yojson ~filenames + (Loc.annoted_of_yojson ~filenames (alg_expr_of_yojson ~filenames)) (JsonUtil.to_int ?error_msg:None)) (Yojson.Basic.Util.member "delta_tokens" x); - syntactic_rule = JsonUtil.to_int (List.assoc "syntactic_rule" l); - instantiations = - Instantiation.event_of_json Matching.Agent.of_yojson - (List.assoc "instantiations" l); + syntactic_rule = JsonUtil.to_int (List.assoc "syntactic_rule" l); + instantiations = + Instantiation.event_of_json Matching.Agent.of_yojson + (List.assoc "instantiations" l); } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Not a correct elementary rule",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Not a correct elementary rule",x)) + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Not a correct elementary rule", x))) + | x -> + raise (Yojson.Basic.Util.Type_error ("Not a correct elementary rule", x)) let fully_specified_pattern_to_positive_transformations cc = - let _,tr = + let _, tr = Pattern.fold_by_type - (fun ~pos ~agent_type intf (emb,g) -> - let a = (pos,agent_type) in - let g' = Transformation.Agent a::g in - let emb' = Mods.IntMap.add pos a emb in - emb', - Tools.array_fold_lefti - (fun site acc (l,i) -> + (fun ~pos ~agent_type intf (emb, g) -> + let a = pos, agent_type in + let g' = Transformation.Agent a :: g in + let emb' = Mods.IntMap.add pos a emb in + ( emb', + Tools.array_fold_lefti + (fun site acc (l, i) -> let acc' = if i <> -1 then - Transformation.PositiveInternalized (a,site,i)::acc - else acc in + Transformation.PositiveInternalized (a, site, i) :: acc + else + acc + in match l with - | Pattern.UnSpec - | Pattern.Free -> - Transformation.Freed (a,site)::acc' - | Pattern.Link (x',s') -> - match Mods.IntMap.find_option x' emb' with + | Pattern.UnSpec | Pattern.Free -> + Transformation.Freed (a, site) :: acc' + | Pattern.Link (x', s') -> + (match Mods.IntMap.find_option x' emb' with | None -> acc' | Some ag' -> - Transformation.Linked ((a,site),(ag',s'))::acc') - g' intf) - cc - (Mods.IntMap.empty,[]) in + Transformation.Linked ((a, site), (ag', s')) :: acc')) + g' intf )) + cc (Mods.IntMap.empty, []) + in List.rev tr type 'alg_expr print_expr = - Str_pexpr of string Locality.annot - | Alg_pexpr of 'alg_expr Locality.annot + | Str_pexpr of string Loc.annoted + | Alg_pexpr of 'alg_expr Loc.annoted let print_expr_to_yojson ~filenames f_mix f_var = function - | Str_pexpr s -> Locality.annot_to_yojson ~filenames JsonUtil.of_string s + | Str_pexpr s -> Loc.yojson_of_annoted ~filenames JsonUtil.of_string s | Alg_pexpr a -> - Locality.annot_to_yojson ~filenames - (Alg_expr.e_to_yojson ~filenames f_mix f_var) a + `Assoc + [ + ( "A", + Loc.yojson_of_annoted ~filenames + (Alg_expr.e_to_yojson ~filenames f_mix f_var) + a ); + ] let print_expr_of_yojson ~filenames f_mix f_var x = - try Str_pexpr (Locality.annot_of_yojson - ~filenames (JsonUtil.to_string ?error_msg:None) x) - with Yojson.Basic.Util.Type_error _ -> - try Alg_pexpr (Locality.annot_of_yojson - ~filenames (Alg_expr.e_of_yojson ~filenames f_mix f_var) x) - with Yojson.Basic.Util.Type_error _ -> - raise (Yojson.Basic.Util.Type_error ("Incorrect print expr",x)) + match x with + | `Assoc [ ("A", x) ] -> + (try + Alg_pexpr + (Loc.annoted_of_yojson ~filenames + (Alg_expr.e_of_yojson ~filenames f_mix f_var) + x) + with Yojson.Basic.Util.Type_error _ -> + raise (Yojson.Basic.Util.Type_error ("Incorrect print expr", x))) + | x -> + (try + Str_pexpr + (Loc.annoted_of_yojson ~filenames + (JsonUtil.to_string ?error_msg:None) + x) + with Yojson.Basic.Util.Type_error _ -> + raise (Yojson.Basic.Util.Type_error ("Incorrect print expr", x))) let map_expr_print f x = - List.map (function + List.map + (function | Str_pexpr _ as x -> x - | Alg_pexpr e -> Alg_pexpr (f e)) x + | Alg_pexpr e -> Alg_pexpr (f e)) + x let fold_expr_print f acc x = - List.fold_left (fun acc -> function + List.fold_left + (fun acc -> function | Str_pexpr _ -> acc - | Alg_pexpr e -> f acc e) acc x + | Alg_pexpr e -> f acc e) + acc x type din_kind = ABSOLUTE | RELATIVE | PROBABILITY @@ -391,11 +473,9 @@ let din_kind_of_yojson = function | `String "ABSOLUTE" -> ABSOLUTE | `String "RELATIVE" -> RELATIVE | `String "PROBABILITY" -> PROBABILITY - | x -> raise - (Yojson.Basic.Util.Type_error ("Incorrect din_kind",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect din_kind", x)) -let write_din_kind ob f = - Yojson.Basic.to_buffer ob (din_kind_to_yojson f) +let write_din_kind ob f = Yojson.Basic.to_buffer ob (din_kind_to_yojson f) let string_of_din_kind ?(len = 1024) x = let ob = Buffer.create len in @@ -409,248 +489,315 @@ let din_kind_of_string s = read_din_kind (Yojson.Safe.init_lexer ()) (Lexing.from_string s) type modification = - ITER_RULE of alg_expr Locality.annot * elementary_rule - | UPDATE of int * alg_expr Locality.annot + | ITER_RULE of alg_expr Loc.annoted * elementary_rule + | UPDATE of int * alg_expr Loc.annoted | SNAPSHOT of bool * alg_expr print_expr list | STOP of alg_expr print_expr list - | CFLOW of string option * Pattern.id array * - Instantiation.abstract Instantiation.test list list + | CFLOW of + string option + * Pattern.id array + * Instantiation.abstract Instantiation.test list list | DIN of din_kind * alg_expr print_expr list | DINOFF of alg_expr print_expr list | CFLOWOFF of string option * Pattern.id array | PLOTENTRY | PRINT of alg_expr print_expr list * alg_expr print_expr list - | SPECIES of alg_expr print_expr list * Pattern.id array * - Instantiation.abstract Instantiation.test list list + | SPECIES of + alg_expr print_expr list + * Pattern.id array + * Instantiation.abstract Instantiation.test list list | SPECIES_OFF of alg_expr print_expr list let print_t_expr_to_yojson ~filenames = - print_expr_to_yojson - ~filenames + print_expr_to_yojson ~filenames (JsonUtil.of_list (JsonUtil.of_array Pattern.id_to_yojson)) JsonUtil.of_int let print_t_expr_of_yojson ~filenames = - print_expr_of_yojson - ~filenames + print_expr_of_yojson ~filenames (JsonUtil.to_list (JsonUtil.to_array Pattern.id_of_yojson)) (JsonUtil.to_int ?error_msg:None) let modification_to_yojson ~filenames = function - | ITER_RULE(n,r) -> - `Assoc [ "action", `String "ITER"; - "repeats", Locality.annot_to_yojson ~filenames - (alg_expr_to_yojson ~filenames) n; - "rule", rule_to_yojson ~filenames r ] - | UPDATE(v,e) -> - `Assoc [ "action", `String "UPDATE"; - "var", `Int v; - "value", Locality.annot_to_yojson ~filenames - (alg_expr_to_yojson ~filenames) e ] - | SNAPSHOT (raw,f) -> - JsonUtil.smart_assoc [ - "action", `String "SNAPSHOT"; - "raw", `Bool raw; - "file", JsonUtil.of_list (print_t_expr_to_yojson ~filenames) f ] + | ITER_RULE (n, r) -> + `Assoc + [ + "action", `String "ITER"; + ( "repeats", + Loc.yojson_of_annoted ~filenames (alg_expr_to_yojson ~filenames) n ); + "rule", rule_to_yojson ~filenames r; + ] + | UPDATE (v, e) -> + `Assoc + [ + "action", `String "UPDATE"; + "var", `Int v; + ( "value", + Loc.yojson_of_annoted ~filenames (alg_expr_to_yojson ~filenames) e ); + ] + | SNAPSHOT (raw, f) -> + JsonUtil.smart_assoc + [ + "action", `String "SNAPSHOT"; + "raw", `Bool raw; + "file", JsonUtil.of_list (print_t_expr_to_yojson ~filenames) f; + ] | STOP f -> - JsonUtil.smart_assoc [ - "action", `String "STOP"; - "file", JsonUtil.of_list (print_t_expr_to_yojson ~filenames) f ] - | CFLOW (name,ids,tests) -> - JsonUtil.smart_assoc [ - "action", `String "CFLOW"; - "name", JsonUtil.of_option JsonUtil.of_string name; - "pattern", JsonUtil.of_array Pattern.id_to_yojson ids; - "tests", - JsonUtil.of_list - (JsonUtil.of_list - (Instantiation.test_to_json Matching.Agent.to_yojson)) - tests ] - | CFLOWOFF (name,ids) -> - `Assoc [ "action", `String "CFLOWOFF"; - "name", JsonUtil.of_option JsonUtil.of_string name; - "pattern", JsonUtil.of_array Pattern.id_to_yojson ids ] - | DIN(kind,f) -> - `Assoc [ "action", `String "DIN"; - "kind", din_kind_to_yojson kind; - "file", `List (List.map (print_t_expr_to_yojson ~filenames) f) ] + JsonUtil.smart_assoc + [ + "action", `String "STOP"; + "file", JsonUtil.of_list (print_t_expr_to_yojson ~filenames) f; + ] + | CFLOW (name, ids, tests) -> + JsonUtil.smart_assoc + [ + "action", `String "CFLOW"; + "name", JsonUtil.of_option JsonUtil.of_string name; + "pattern", JsonUtil.of_array Pattern.id_to_yojson ids; + ( "tests", + JsonUtil.of_list + (JsonUtil.of_list + (Instantiation.test_to_json Matching.Agent.to_yojson)) + tests ); + ] + | CFLOWOFF (name, ids) -> + `Assoc + [ + "action", `String "CFLOWOFF"; + "name", JsonUtil.of_option JsonUtil.of_string name; + "pattern", JsonUtil.of_array Pattern.id_to_yojson ids; + ] + | DIN (kind, f) -> + `Assoc + [ + "action", `String "DIN"; + "kind", din_kind_to_yojson kind; + "file", `List (List.map (print_t_expr_to_yojson ~filenames) f); + ] | DINOFF f -> - JsonUtil.smart_assoc [ - "action", `String "DINOFF"; - "file", JsonUtil.of_list (print_t_expr_to_yojson ~filenames) f ] + JsonUtil.smart_assoc + [ + "action", `String "DINOFF"; + "file", JsonUtil.of_list (print_t_expr_to_yojson ~filenames) f; + ] | PLOTENTRY -> `Assoc [ "action", `String "PLOTNOW" ] - | PRINT(f,t) -> - `Assoc [ "action", `String "PRINT"; - "text", `List (List.map (print_t_expr_to_yojson ~filenames) t); - "file", `List (List.map (print_t_expr_to_yojson ~filenames) f) ] - | SPECIES (f,ids,tests) -> - JsonUtil.smart_assoc [ - "action", `String "SPECIES"; - "file", `List (List.map (print_t_expr_to_yojson ~filenames) f); - "pattern", JsonUtil.of_array Pattern.id_to_yojson ids; - "tests", - JsonUtil.of_list - (JsonUtil.of_list - (Instantiation.test_to_json Matching.Agent.to_yojson)) - tests ] + | PRINT (f, t) -> + `Assoc + [ + "action", `String "PRINT"; + "text", `List (List.map (print_t_expr_to_yojson ~filenames) t); + "file", `List (List.map (print_t_expr_to_yojson ~filenames) f); + ] + | SPECIES (f, ids, tests) -> + JsonUtil.smart_assoc + [ + "action", `String "SPECIES"; + "file", `List (List.map (print_t_expr_to_yojson ~filenames) f); + "pattern", JsonUtil.of_array Pattern.id_to_yojson ids; + ( "tests", + JsonUtil.of_list + (JsonUtil.of_list + (Instantiation.test_to_json Matching.Agent.to_yojson)) + tests ); + ] | SPECIES_OFF f -> - `Assoc [ "action", `String "SPECIES_OFF"; - "file", `List (List.map (print_t_expr_to_yojson ~filenames) f)] - + `Assoc + [ + "action", `String "SPECIES_OFF"; + "file", `List (List.map (print_t_expr_to_yojson ~filenames) f); + ] let modification_of_yojson ~filenames = function - | `Assoc [ "action", `String "PRINT"; "file", `List f; "text", `List t ] - | `Assoc [ "text", `List t; "file", `List f; "action", `String "PRINT" ] - | `Assoc [ "action", `String "PRINT"; "text", `List t; "file", `List f ] - | `Assoc [ "text", `List t; "action", `String "PRINT"; "file", `List f ] - | `Assoc [ "file", `List f; "action", `String "PRINT"; "text", `List t ] - | `Assoc [ "file", `List f; "text", `List t; "action", `String "PRINT" ] -> - PRINT(List.map (print_t_expr_of_yojson ~filenames) f, - List.map (print_t_expr_of_yojson ~filenames) t) - | `Assoc [ "action", `String "PRINT"; "file", `Null; "text", `List t ] - | `Assoc [ "text", `List t; "file", `Null; "action", `String "PRINT" ] - | `Assoc [ "action", `String "PRINT"; "text", `List t; "file", `Null ] - | `Assoc [ "text", `List t; "action", `String "PRINT"; "file", `Null ] - | `Assoc [ "file", `Null; "action", `String "PRINT"; "text", `List t ] - | `Assoc [ "file", `Null; "text", `List t; "action", `String "PRINT" ] - | `Assoc [ "action", `String "PRINT"; "text", `List t ] - | `Assoc [ "text", `List t; "action", `String "PRINT" ] -> - PRINT([], List.map (print_t_expr_of_yojson ~filenames) t) - | `Assoc [ "action", `String "DIN"; "file", `List f; "kind", kind ] - | `Assoc [ "kind", kind; "file", `List f; "action", `String "DIN" ] - | `Assoc [ "action", `String "DIN"; "kind", kind; "file", `List f ] - | `Assoc [ "kind", kind; "action", `String "DIN"; "file", `List f ] - | `Assoc [ "file", `List f; "action", `String "DIN"; "kind", kind ] - | `Assoc [ "file", `List f; "kind", kind; "action", `String "DIN" ] -> - DIN(din_kind_of_yojson kind, - List.map (print_t_expr_of_yojson ~filenames) f) - | `Assoc [ "action", `String "UPDATE"; "var", `Int v; "value", e ] - | `Assoc [ "var", `Int v; "action", `String "UPDATE"; "value", e ] - | `Assoc [ "action", `String "UPDATE"; "value", e; "var", `Int v ] - | `Assoc [ "var", `Int v; "value", e; "action", `String "UPDATE" ] - | `Assoc [ "value", e; "action", `String "UPDATE"; "var", `Int v ] - | `Assoc [ "value", e; "var", `Int v; "action", `String "UPDATE" ] -> - UPDATE(v,Locality.annot_of_yojson ~filenames - (alg_expr_of_yojson ~filenames) e) - | `Assoc [ "action", `String "ITER"; "repeats", n; "rule", r ] - | `Assoc [ "action", `String "ITER"; "rule", r; "repeats", n ] - | `Assoc [ "repeats", n; "action", `String "ITER"; "rule", r ] - | `Assoc [ "rule", r; "action", `String "ITER"; "repeats", n ] - | `Assoc [ "repeats", n; "rule", r; "action", `String "ITER" ] - | `Assoc [ "rule", r; "repeats", n; "action", `String "ITER" ] -> - ITER_RULE (Locality.annot_of_yojson ~filenames - (alg_expr_of_yojson ~filenames) n, - rule_of_yojson ~filenames r) - | `Assoc [ "action", `String "PLOTNOW" ] -> PLOTENTRY - | `Assoc [ "action", `String "DINOFF"; "file", `List l ] - | `Assoc [ "file", `List l; "action", `String "DINOFF" ] -> + | `Assoc [ ("action", `String "PRINT"); ("file", `List f); ("text", `List t) ] + | `Assoc [ ("text", `List t); ("file", `List f); ("action", `String "PRINT") ] + | `Assoc [ ("action", `String "PRINT"); ("text", `List t); ("file", `List f) ] + | `Assoc [ ("text", `List t); ("action", `String "PRINT"); ("file", `List f) ] + | `Assoc [ ("file", `List f); ("action", `String "PRINT"); ("text", `List t) ] + | `Assoc [ ("file", `List f); ("text", `List t); ("action", `String "PRINT") ] + -> + PRINT + ( List.map (print_t_expr_of_yojson ~filenames) f, + List.map (print_t_expr_of_yojson ~filenames) t ) + | `Assoc [ ("action", `String "PRINT"); ("file", `Null); ("text", `List t) ] + | `Assoc [ ("text", `List t); ("file", `Null); ("action", `String "PRINT") ] + | `Assoc [ ("action", `String "PRINT"); ("text", `List t); ("file", `Null) ] + | `Assoc [ ("text", `List t); ("action", `String "PRINT"); ("file", `Null) ] + | `Assoc [ ("file", `Null); ("action", `String "PRINT"); ("text", `List t) ] + | `Assoc [ ("file", `Null); ("text", `List t); ("action", `String "PRINT") ] + | `Assoc [ ("action", `String "PRINT"); ("text", `List t) ] + | `Assoc [ ("text", `List t); ("action", `String "PRINT") ] -> + PRINT ([], List.map (print_t_expr_of_yojson ~filenames) t) + | `Assoc [ ("action", `String "DIN"); ("file", `List f); ("kind", kind) ] + | `Assoc [ ("kind", kind); ("file", `List f); ("action", `String "DIN") ] + | `Assoc [ ("action", `String "DIN"); ("kind", kind); ("file", `List f) ] + | `Assoc [ ("kind", kind); ("action", `String "DIN"); ("file", `List f) ] + | `Assoc [ ("file", `List f); ("action", `String "DIN"); ("kind", kind) ] + | `Assoc [ ("file", `List f); ("kind", kind); ("action", `String "DIN") ] -> + DIN (din_kind_of_yojson kind, List.map (print_t_expr_of_yojson ~filenames) f) + | `Assoc [ ("action", `String "UPDATE"); ("var", `Int v); ("value", e) ] + | `Assoc [ ("var", `Int v); ("action", `String "UPDATE"); ("value", e) ] + | `Assoc [ ("action", `String "UPDATE"); ("value", e); ("var", `Int v) ] + | `Assoc [ ("var", `Int v); ("value", e); ("action", `String "UPDATE") ] + | `Assoc [ ("value", e); ("action", `String "UPDATE"); ("var", `Int v) ] + | `Assoc [ ("value", e); ("var", `Int v); ("action", `String "UPDATE") ] -> + UPDATE + (v, Loc.annoted_of_yojson ~filenames (alg_expr_of_yojson ~filenames) e) + | `Assoc [ ("action", `String "ITER"); ("repeats", n); ("rule", r) ] + | `Assoc [ ("action", `String "ITER"); ("rule", r); ("repeats", n) ] + | `Assoc [ ("repeats", n); ("action", `String "ITER"); ("rule", r) ] + | `Assoc [ ("rule", r); ("action", `String "ITER"); ("repeats", n) ] + | `Assoc [ ("repeats", n); ("rule", r); ("action", `String "ITER") ] + | `Assoc [ ("rule", r); ("repeats", n); ("action", `String "ITER") ] -> + ITER_RULE + ( Loc.annoted_of_yojson ~filenames (alg_expr_of_yojson ~filenames) n, + rule_of_yojson ~filenames r ) + | `Assoc [ ("action", `String "PLOTNOW") ] -> PLOTENTRY + | `Assoc [ ("action", `String "DINOFF"); ("file", `List l) ] + | `Assoc [ ("file", `List l); ("action", `String "DINOFF") ] -> DINOFF (List.map (print_t_expr_of_yojson ~filenames) l) - | `Assoc [ "action", `String "DINOFF"; "file", `Null ] - | `Assoc [ "file", `Null; "action", `String "DINOFF" ] - | `Assoc [ "action", `String "DINOFF" ] -> DINOFF [] - | `Assoc [ "action", `String "SNAPSHOT"; "file", `List l ] - | `Assoc [ "file", `List l; "action", `String "SNAPSHOT" ] -> - SNAPSHOT (false,List.map (print_t_expr_of_yojson ~filenames) l) - | `Assoc [ "raw", `Bool raw; "action", `String "SNAPSHOT"; "file", `List l ] - | `Assoc [ "raw", `Bool raw; "file", `List l; "action", `String "SNAPSHOT" ] - | `Assoc [ "action", `String "SNAPSHOT"; "raw", `Bool raw; "file", `List l ] - | `Assoc [ "file", `List l; "raw", `Bool raw; "action", `String "SNAPSHOT" ] - | `Assoc [ "action", `String "SNAPSHOT"; "file", `List l; "raw", `Bool raw ] - | `Assoc [ "file", `List l; "action", `String "SNAPSHOT"; "raw", `Bool raw ] -> - SNAPSHOT (raw,List.map (print_t_expr_of_yojson ~filenames) l) - | `Assoc [ "action", `String "SNAPSHOT"; "file", `Null ] - | `Assoc [ "file", `Null; "action", `String "SNAPSHOT" ] - | `Assoc [ "action", `String "SNAPSHOT" ] -> SNAPSHOT (false,[]) - | `Assoc [ "action", `String "STOP"; "file", `List l ] - | `Assoc [ "file", `List l; "action", `String "STOP" ] -> + | `Assoc [ ("action", `String "DINOFF"); ("file", `Null) ] + | `Assoc [ ("file", `Null); ("action", `String "DINOFF") ] + | `Assoc [ ("action", `String "DINOFF") ] -> + DINOFF [] + | `Assoc [ ("action", `String "SNAPSHOT"); ("file", `List l) ] + | `Assoc [ ("file", `List l); ("action", `String "SNAPSHOT") ] -> + SNAPSHOT (false, List.map (print_t_expr_of_yojson ~filenames) l) + | `Assoc + [ ("raw", `Bool raw); ("action", `String "SNAPSHOT"); ("file", `List l) ] + | `Assoc + [ ("raw", `Bool raw); ("file", `List l); ("action", `String "SNAPSHOT") ] + | `Assoc + [ ("action", `String "SNAPSHOT"); ("raw", `Bool raw); ("file", `List l) ] + | `Assoc + [ ("file", `List l); ("raw", `Bool raw); ("action", `String "SNAPSHOT") ] + | `Assoc + [ ("action", `String "SNAPSHOT"); ("file", `List l); ("raw", `Bool raw) ] + | `Assoc + [ ("file", `List l); ("action", `String "SNAPSHOT"); ("raw", `Bool raw) ] + -> + SNAPSHOT (raw, List.map (print_t_expr_of_yojson ~filenames) l) + | `Assoc + [ ("raw", `Bool raw); ("action", `String "SNAPSHOT"); ("file", `Null) ] + | `Assoc + [ ("raw", `Bool raw); ("file", `Null); ("action", `String "SNAPSHOT") ] + | `Assoc + [ ("action", `String "SNAPSHOT"); ("raw", `Bool raw); ("file", `Null) ] + | `Assoc + [ ("file", `Null); ("raw", `Bool raw); ("action", `String "SNAPSHOT") ] + | `Assoc + [ ("action", `String "SNAPSHOT"); ("file", `Null); ("raw", `Bool raw) ] + | `Assoc + [ ("file", `Null); ("action", `String "SNAPSHOT"); ("raw", `Bool raw) ] + | `Assoc [ ("raw", `Bool raw); ("action", `String "SNAPSHOT") ] + | `Assoc [ ("action", `String "SNAPSHOT"); ("raw", `Bool raw) ] -> + SNAPSHOT (raw, []) + | `Assoc [ ("action", `String "SNAPSHOT"); ("file", `Null) ] + | `Assoc [ ("file", `Null); ("action", `String "SNAPSHOT") ] + | `Assoc [ ("action", `String "SNAPSHOT") ] -> + SNAPSHOT (false, []) + | `Assoc [ ("action", `String "STOP"); ("file", `List l) ] + | `Assoc [ ("file", `List l); ("action", `String "STOP") ] -> STOP (List.map (print_t_expr_of_yojson ~filenames) l) - | `Assoc [ "action", `String "STOP"; "file", `Null ] - | `Assoc [ "file", `Null; "action", `String "STOP" ] - | `Assoc [ "action", `String "STOP" ] -> STOP [] + | `Assoc [ ("action", `String "STOP"); ("file", `Null) ] + | `Assoc [ ("file", `Null); ("action", `String "STOP") ] + | `Assoc [ ("action", `String "STOP") ] -> + STOP [] | `Assoc _ as l when Yojson.Basic.Util.member "action" l = `String "CFLOW" -> - CFLOW ( - JsonUtil.to_option (JsonUtil.to_string ?error_msg:None) - (Yojson.Basic.Util.member "name" l), - JsonUtil.to_array Pattern.id_of_yojson - (Yojson.Basic.Util.member "pattern" l), - JsonUtil.to_list (JsonUtil.to_list - (Instantiation.test_of_json Matching.Agent.of_yojson)) - (Yojson.Basic.Util.member "tests" l)) - | `Assoc _ as l when Yojson.Basic.Util.member "action" l = `String "CFLOWOFF" -> - CFLOWOFF( - JsonUtil.to_option (JsonUtil.to_string ?error_msg:None) - (Yojson.Basic.Util.member "name" l), - JsonUtil.to_array Pattern.id_of_yojson - (Yojson.Basic.Util.member "pattern" l)) - | `Assoc [ "action", `String "SPECIES_OFF"; "file", p ] - | `Assoc [ "file", p; "action", `String "SPECIES_OFF" ] -> - SPECIES_OFF(JsonUtil.to_list (print_t_expr_of_yojson ~filenames) p) - | `Assoc _ as l when Yojson.Basic.Util.member "action" l = `String "SPECIES" -> - SPECIES ( - JsonUtil.to_list (print_t_expr_of_yojson ~filenames) - (Yojson.Basic.Util.member "file" l), - JsonUtil.to_array Pattern.id_of_yojson - (Yojson.Basic.Util.member "pattern" l), - JsonUtil.to_list (JsonUtil.to_list - (Instantiation.test_of_json Matching.Agent.of_yojson)) - (Yojson.Basic.Util.member "tests" l)) - | x -> raise - (Yojson.Basic.Util.Type_error ("Invalid modification",x)) - -type perturbation = - { alarm: Nbr.t option; - precondition: (Pattern.id array list,int) Alg_expr.bool Locality.annot; - effect : modification list; - repeat : (Pattern.id array list,int) Alg_expr.bool Locality.annot; - needs_backtrack : bool; - } + CFLOW + ( JsonUtil.to_option + (JsonUtil.to_string ?error_msg:None) + (Yojson.Basic.Util.member "name" l), + JsonUtil.to_array Pattern.id_of_yojson + (Yojson.Basic.Util.member "pattern" l), + JsonUtil.to_list + (JsonUtil.to_list + (Instantiation.test_of_json Matching.Agent.of_yojson)) + (Yojson.Basic.Util.member "tests" l) ) + | `Assoc _ as l when Yojson.Basic.Util.member "action" l = `String "CFLOWOFF" + -> + CFLOWOFF + ( JsonUtil.to_option + (JsonUtil.to_string ?error_msg:None) + (Yojson.Basic.Util.member "name" l), + JsonUtil.to_array Pattern.id_of_yojson + (Yojson.Basic.Util.member "pattern" l) ) + | `Assoc [ ("action", `String "SPECIES_OFF"); ("file", p) ] + | `Assoc [ ("file", p); ("action", `String "SPECIES_OFF") ] -> + SPECIES_OFF (JsonUtil.to_list (print_t_expr_of_yojson ~filenames) p) + | `Assoc _ as l when Yojson.Basic.Util.member "action" l = `String "SPECIES" + -> + SPECIES + ( JsonUtil.to_list + (print_t_expr_of_yojson ~filenames) + (Yojson.Basic.Util.member "file" l), + JsonUtil.to_array Pattern.id_of_yojson + (Yojson.Basic.Util.member "pattern" l), + JsonUtil.to_list + (JsonUtil.to_list + (Instantiation.test_of_json Matching.Agent.of_yojson)) + (Yojson.Basic.Util.member "tests" l) ) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid modification", x)) + +type perturbation = { + alarm: Nbr.t option; + precondition: (Pattern.id array list, int) Alg_expr.bool Loc.annoted; + effect: modification list; + repeat: (Pattern.id array list, int) Alg_expr.bool Loc.annoted; + needs_backtrack: bool; +} let bool_expr_to_yojson ~filenames = - Alg_expr.bool_to_yojson - ~filenames + Alg_expr.bool_to_yojson ~filenames (JsonUtil.of_list (JsonUtil.of_array Pattern.id_to_yojson)) JsonUtil.of_int let bool_expr_of_yojson ~filenames = - Alg_expr.bool_of_yojson - ~filenames + Alg_expr.bool_of_yojson ~filenames (JsonUtil.to_list (JsonUtil.to_array Pattern.id_of_yojson)) (JsonUtil.to_int ?error_msg:None) let perturbation_to_yojson ~filenames p = - `Assoc [ - "alarm", JsonUtil.of_option (fun n -> Nbr.to_yojson n) p.alarm; - "condition", Locality.annot_to_yojson ~filenames - (bool_expr_to_yojson ~filenames) p.precondition; - "effect", JsonUtil.of_list (modification_to_yojson ~filenames) p.effect; - "repeat", Locality.annot_to_yojson ~filenames - (bool_expr_to_yojson ~filenames) p.repeat; - "needs_backtrack", `Bool p.needs_backtrack ] + `Assoc + [ + "alarm", JsonUtil.of_option (fun n -> Nbr.to_yojson n) p.alarm; + ( "condition", + Loc.yojson_of_annoted ~filenames + (bool_expr_to_yojson ~filenames) + p.precondition ); + "effect", JsonUtil.of_list (modification_to_yojson ~filenames) p.effect; + ( "repeat", + Loc.yojson_of_annoted ~filenames + (bool_expr_to_yojson ~filenames) + p.repeat ); + "needs_backtrack", `Bool p.needs_backtrack; + ] let perturbation_of_yojson ~filenames = function | `Assoc l as x when List.length l = 5 -> - begin - try { - alarm = JsonUtil.to_option Nbr.of_yojson (List.assoc "alarm" l); - precondition = - Locality.annot_of_yojson ~filenames - (bool_expr_of_yojson ~filenames) (List.assoc "condition" l); - effect = - JsonUtil.to_list - (modification_of_yojson ~filenames) (List.assoc "effect" l); - repeat = - Locality.annot_of_yojson ~filenames - (bool_expr_of_yojson ~filenames) (List.assoc "repeat" l); - needs_backtrack = - (function - | `Bool b -> b - | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect bool",x))) - (List.assoc "needs_backtrack" l); - } - with Not_found -> - raise (Yojson.Basic.Util.Type_error ("Invalid perturbation",x)) - end - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid perturbation",x)) + (try + { + alarm = JsonUtil.to_option Nbr.of_yojson (List.assoc "alarm" l); + precondition = + Loc.annoted_of_yojson ~filenames + (bool_expr_of_yojson ~filenames) + (List.assoc "condition" l); + effect = + JsonUtil.to_list + (modification_of_yojson ~filenames) + (List.assoc "effect" l); + repeat = + Loc.annoted_of_yojson ~filenames + (bool_expr_of_yojson ~filenames) + (List.assoc "repeat" l); + needs_backtrack = + (function + | `Bool b -> b + | x -> raise (Yojson.Basic.Util.Type_error ("Incorrect bool", x))) + (List.assoc "needs_backtrack" l); + } + with Not_found -> + raise (Yojson.Basic.Util.Type_error ("Invalid perturbation", x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid perturbation", x)) let exists_modification check l = Array.fold_left (fun acc p -> acc || List.exists check p.effect) false l @@ -658,89 +805,98 @@ let exists_modification check l = let extract_connected_components_expr acc e = List.fold_left (List.fold_left (fun acc a -> List.rev_append (Array.to_list a) acc)) - acc (Alg_expr.extract_connected_components e) + acc + (Alg_expr.extract_connected_components e) let extract_connected_components_bool e = List.fold_left (List.fold_left (fun acc a -> List.rev_append (Array.to_list a) acc)) - [] (Alg_expr.extract_connected_components_bool e) + [] + (Alg_expr.extract_connected_components_bool e) let extract_connected_components_rule acc r = let a = List.fold_left - (fun acc (x,_) -> extract_connected_components_expr acc x) - acc r.delta_tokens in - let b = match r.unary_rate with + (fun acc (x, _) -> extract_connected_components_expr acc x) + acc r.delta_tokens + in + let b = + match r.unary_rate with | None -> a - | Some (x,_) -> extract_connected_components_expr a x in + | Some (x, _) -> extract_connected_components_expr a x + in let c = extract_connected_components_expr b r.rate in List.rev_append (Array.to_list r.connected_components) c let extract_connected_components_print acc x = - List.fold_left (fun acc -> function + List.fold_left + (fun acc -> function | Str_pexpr _ -> acc | Alg_pexpr e -> extract_connected_components_expr acc e) acc x let extract_connected_components_modification acc = function - | ITER_RULE (e,r) -> + | ITER_RULE (e, r) -> extract_connected_components_rule - (extract_connected_components_expr acc e) r - | UPDATE (_,e) -> extract_connected_components_expr acc e - | SNAPSHOT (_,p) | STOP p | SPECIES_OFF p - | DIN (_,p) | DINOFF p -> extract_connected_components_print acc p - | PRINT (fn,p) -> + (extract_connected_components_expr acc e) + r + | UPDATE (_, e) -> extract_connected_components_expr acc e + | SNAPSHOT (_, p) | STOP p | SPECIES_OFF p | DIN (_, p) | DINOFF p -> + extract_connected_components_print acc p + | PRINT (fn, p) -> extract_connected_components_print - (extract_connected_components_print acc p) fn - | CFLOW (_,x,_) | CFLOWOFF (_,x) | SPECIES (_,x,_) -> - List.rev_append (Array.to_list x) acc + (extract_connected_components_print acc p) + fn + | CFLOW (_, x, _) | CFLOWOFF (_, x) | SPECIES (_, x, _) -> + List.rev_append (Array.to_list x) acc | PLOTENTRY -> acc let extract_connected_components_modifications l = List.fold_left extract_connected_components_modification [] l -let map_expr_rule f x = { - rate = f x.rate; - unary_rate = Option_util.map (fun (x,d) -> (f x,d)) x.unary_rate; - connected_components = x.connected_components; - removed = x.removed; - inserted = x.inserted; - delta_tokens = List.map (fun (x,t) -> (f x,t)) x.delta_tokens; - syntactic_rule = x.syntactic_rule; - instantiations = x.instantiations; -} +let map_expr_rule f x = + { + rate = f x.rate; + unary_rate = Option_util.map (fun (x, d) -> f x, d) x.unary_rate; + connected_components = x.connected_components; + removed = x.removed; + inserted = x.inserted; + delta_tokens = List.map (fun (x, t) -> f x, t) x.delta_tokens; + syntactic_rule = x.syntactic_rule; + instantiations = x.instantiations; + } let fold_expr_rule f x r = List.fold_left - (fun acc (y,_) -> f acc y) - (Option_util.fold - (fun a (e,_) -> f a e) (f x r.rate) r.unary_rate) + (fun acc (y, _) -> f acc y) + (Option_util.fold (fun a (e, _) -> f a e) (f x r.rate) r.unary_rate) r.delta_tokens let map_expr_modification f = function - | ITER_RULE (e,r) -> ITER_RULE (f e, map_expr_rule f r) - | UPDATE (i,e) -> UPDATE (i,f e) - | SNAPSHOT (raw,p) -> SNAPSHOT (raw,map_expr_print f p) + | ITER_RULE (e, r) -> ITER_RULE (f e, map_expr_rule f r) + | UPDATE (i, e) -> UPDATE (i, f e) + | SNAPSHOT (raw, p) -> SNAPSHOT (raw, map_expr_print f p) | STOP p -> STOP (map_expr_print f p) - | PRINT (fn,p) -> PRINT (map_expr_print f fn, map_expr_print f p) - | DIN (b,p) -> DIN (b,map_expr_print f p) + | PRINT (fn, p) -> PRINT (map_expr_print f fn, map_expr_print f p) + | DIN (b, p) -> DIN (b, map_expr_print f p) | DINOFF p -> DINOFF (map_expr_print f p) | (CFLOW _ | CFLOWOFF _ | SPECIES_OFF _ | PLOTENTRY) as x -> x - | SPECIES (p,x,t) -> SPECIES ((map_expr_print f p),x,t) + | SPECIES (p, x, t) -> SPECIES (map_expr_print f p, x, t) let fold_expr_modification f x = function - | ITER_RULE (e,r) -> fold_expr_rule f (f x e) r - | UPDATE (_,e) -> f x e - | SNAPSHOT (_,p) -> fold_expr_print f x p + | ITER_RULE (e, r) -> fold_expr_rule f (f x e) r + | UPDATE (_, e) -> f x e + | SNAPSHOT (_, p) -> fold_expr_print f x p | STOP p -> fold_expr_print f x p - | PRINT (fn,p) -> fold_expr_print f (fold_expr_print f x p) fn - | DIN (_,p) -> fold_expr_print f x p + | PRINT (fn, p) -> fold_expr_print f (fold_expr_print f x p) fn + | DIN (_, p) -> fold_expr_print f x p | DINOFF p -> fold_expr_print f x p - | (CFLOW _ | CFLOWOFF _ | SPECIES_OFF _ | PLOTENTRY) -> x - | SPECIES (p,_,_) -> fold_expr_print f x p + | CFLOW _ | CFLOWOFF _ | SPECIES_OFF _ | PLOTENTRY -> x + | SPECIES (p, _, _) -> fold_expr_print f x p let map_expr_perturbation f_alg f_bool x = - { alarm = x.alarm; + { + alarm = x.alarm; precondition = f_bool x.precondition; effect = List.map (map_expr_modification f_alg) x.effect; repeat = f_bool x.repeat; diff --git a/core/term/primitives.mli b/core/term/primitives.mli index f32e65cedb..f21d777b63 100644 --- a/core/term/primitives.mli +++ b/core/term/primitives.mli @@ -9,8 +9,7 @@ (** Compiled kappa model unit *) (** Elementary rule transformations *) -module Transformation : -sig +module Transformation : sig type 'a t = | Agent of 'a | Freed of 'a Instantiation.site @@ -23,16 +22,20 @@ sig val map_agent : ('a -> 'b) -> 'a t -> 'b t val fold_agent : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val map_fold_agent : ('a -> 'b -> 'c * 'b) -> 'a t -> 'b -> 'c t * 'b - val equal : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val rename : - debugMode:bool -> int -> Renaming.t -> - Instantiation.abstract t -> Instantiation.abstract t + debug_mode:bool -> + int -> + Renaming.t -> + Instantiation.abstract t -> + Instantiation.abstract t val concretize : - debugMode:bool -> Matching.t * int Mods.IntMap.t -> - Instantiation.abstract t -> Instantiation.concrete t + debug_mode:bool -> + Matching.t * int Mods.IntMap.t -> + Instantiation.abstract t -> + Instantiation.concrete t val print : ?sigs:Signature.s -> Format.formatter -> Instantiation.abstract t -> unit @@ -40,13 +43,14 @@ sig val negative_transformations_of_actions : Signature.s -> (Instantiation.concrete Instantiation.site -> - Instantiation.concrete Instantiation.site option) -> + Instantiation.concrete Instantiation.site option) -> Instantiation.concrete Instantiation.action list -> Instantiation.concrete t list (** [negative_transformation_of_actions signature link_dst actions] *) val positive_transformations_of_actions : - Signature.s -> Instantiation.concrete Instantiation.site list -> + Signature.s -> + Instantiation.concrete Instantiation.site list -> Instantiation.concrete Instantiation.action list -> Instantiation.concrete t list (** [positive_transformations_of_actions signature side_effect_dsts actions] *) @@ -55,101 +59,106 @@ end type alg_expr = (Pattern.id array list, int) Alg_expr.e type elementary_rule = { - rate : alg_expr Locality.annot; - unary_rate : (alg_expr Locality.annot * alg_expr option) option; - connected_components : Pattern.id array; - removed : Instantiation.abstract Transformation.t list; - inserted : Instantiation.abstract Transformation.t list; - delta_tokens : (alg_expr Locality.annot * int) list; - syntactic_rule : int; - (** [0] means generated for perturbation. *) - instantiations : Instantiation.abstract Instantiation.event; - (** In the reverse order on purpose so that we rev_map when we + rate: alg_expr Loc.annoted; + unary_rate: (alg_expr Loc.annoted * alg_expr option) option; + connected_components: Pattern.id array; + removed: Instantiation.abstract Transformation.t list; + inserted: Instantiation.abstract Transformation.t list; + delta_tokens: (alg_expr Loc.annoted * int) list; + syntactic_rule: int; (** [0] means generated for perturbation. *) + instantiations: Instantiation.abstract Instantiation.event; + (** In the reverse order on purpose so that we rev_map when we concretize *) } (** If [unary_rate] is [Some _], [rate] means binary rate. Else [rate] is the rate independently of the connectivity *) val extract_cc_ids : elementary_rule -> Pattern.id array + val extract_abstract_event : elementary_rule -> Instantiation.abstract Instantiation.event val rule_to_yojson : - filenames : int Mods.StringMap.t -> elementary_rule -> Yojson.Basic.t + filenames:int Mods.StringMap.t -> elementary_rule -> Yojson.Basic.t -val rule_of_yojson : - filenames : string array -> Yojson.Basic.t -> elementary_rule +val rule_of_yojson : filenames:string array -> Yojson.Basic.t -> elementary_rule val fully_specified_pattern_to_positive_transformations : Pattern.cc -> Instantiation.concrete Transformation.t list type 'alg_expr print_expr = - Str_pexpr of string Locality.annot - | Alg_pexpr of 'alg_expr Locality.annot + | Str_pexpr of string Loc.annoted + | Alg_pexpr of 'alg_expr Loc.annoted val print_expr_to_yojson : - filenames : int Mods.StringMap.t -> - ('a -> Yojson.Basic.t) -> ('b -> Yojson.Basic.t) -> - ('a,'b) Alg_expr.e print_expr -> Yojson.Basic.t + filenames:int Mods.StringMap.t -> + ('a -> Yojson.Basic.t) -> + ('b -> Yojson.Basic.t) -> + ('a, 'b) Alg_expr.e print_expr -> + Yojson.Basic.t + val print_expr_of_yojson : - filenames : string array -> - (Yojson.Basic.t -> 'a) -> (Yojson.Basic.t -> 'b) -> - Yojson.Basic.t -> ('a,'b) Alg_expr.e print_expr + filenames:string array -> + (Yojson.Basic.t -> 'a) -> + (Yojson.Basic.t -> 'b) -> + Yojson.Basic.t -> + ('a, 'b) Alg_expr.e print_expr type din_kind = ABSOLUTE | RELATIVE | PROBABILITY val din_kind_to_yojson : din_kind -> Yojson.Basic.t val din_kind_of_yojson : Yojson.Basic.t -> din_kind -val write_din_kind : - Buffer.t -> din_kind -> unit - (** Output a JSON value of type {!din_kind}. *) +val write_din_kind : Buffer.t -> din_kind -> unit +(** Output a JSON value of type {!din_kind}. *) -val string_of_din_kind : - ?len:int -> din_kind -> string - (** Serialize a value of type {!din_kind} +val string_of_din_kind : ?len:int -> din_kind -> string +(** Serialize a value of type {!din_kind} into a JSON string. @param len specifies the initial length of the buffer used internally. Default: 1024. *) -val read_din_kind : - Yojson.Safe.lexer_state -> Lexing.lexbuf -> din_kind - (** Input JSON data of type {!din_kind}. *) +val read_din_kind : Yojson.Safe.lexer_state -> Lexing.lexbuf -> din_kind +(** Input JSON data of type {!din_kind}. *) -val din_kind_of_string : - string -> din_kind - (** Deserialize JSON data of type {!din_kind}. *) +val din_kind_of_string : string -> din_kind +(** Deserialize JSON data of type {!din_kind}. *) type modification = - | ITER_RULE of alg_expr Locality.annot * elementary_rule - | UPDATE of int * alg_expr Locality.annot + | ITER_RULE of alg_expr Loc.annoted * elementary_rule + | UPDATE of int * alg_expr Loc.annoted | SNAPSHOT of bool * alg_expr print_expr list | STOP of alg_expr print_expr list - | CFLOW of string option * Pattern.id array * - Instantiation.abstract Instantiation.test list list - (** First string is the named used by the user *) + | CFLOW of + string option + * Pattern.id array + * Instantiation.abstract Instantiation.test list list + (** First string is the named used by the user *) | DIN of din_kind * alg_expr print_expr list | DINOFF of alg_expr print_expr list | CFLOWOFF of string option * Pattern.id array | PLOTENTRY | PRINT of alg_expr print_expr list * alg_expr print_expr list - | SPECIES of alg_expr print_expr list * Pattern.id array * - Instantiation.abstract Instantiation.test list list + | SPECIES of + alg_expr print_expr list + * Pattern.id array + * Instantiation.abstract Instantiation.test list list | SPECIES_OFF of alg_expr print_expr list -type perturbation = - { alarm: Nbr.t option; - precondition: (Pattern.id array list,int) Alg_expr.bool Locality.annot; - effect : modification list; - repeat : (Pattern.id array list,int) Alg_expr.bool Locality.annot; - needs_backtrack : bool; - } +type perturbation = { + alarm: Nbr.t option; + precondition: (Pattern.id array list, int) Alg_expr.bool Loc.annoted; + effect: modification list; + repeat: (Pattern.id array list, int) Alg_expr.bool Loc.annoted; + needs_backtrack: bool; +} val perturbation_to_yojson : - filenames : int Mods.StringMap.t -> perturbation -> Yojson.Basic.t + filenames:int Mods.StringMap.t -> perturbation -> Yojson.Basic.t + val perturbation_of_yojson : - filenames : string array -> Yojson.Basic.t -> perturbation + filenames:string array -> Yojson.Basic.t -> perturbation val exists_modification : (modification -> bool) -> perturbation array -> bool @@ -157,21 +166,26 @@ val extract_connected_components_modifications : modification list -> Pattern.id list val extract_connected_components_bool : - (Pattern.id array list,int) Alg_expr.bool Locality.annot -> Pattern.id list + (Pattern.id array list, int) Alg_expr.bool Loc.annoted -> Pattern.id list -val map_expr_rule : (alg_expr Locality.annot -> alg_expr Locality.annot) -> - elementary_rule -> elementary_rule +val map_expr_rule : + (alg_expr Loc.annoted -> alg_expr Loc.annoted) -> + elementary_rule -> + elementary_rule val map_expr_perturbation : - (alg_expr Locality.annot -> alg_expr Locality.annot) -> - ((Pattern.id array list,int) Alg_expr.bool Locality.annot -> - (Pattern.id array list,int) Alg_expr.bool Locality.annot) -> - perturbation -> perturbation + (alg_expr Loc.annoted -> alg_expr Loc.annoted) -> + ((Pattern.id array list, int) Alg_expr.bool Loc.annoted -> + (Pattern.id array list, int) Alg_expr.bool Loc.annoted) -> + perturbation -> + perturbation val fold_expr_rule : - ('a -> alg_expr Locality.annot -> 'a) -> 'a -> elementary_rule -> 'a + ('a -> alg_expr Loc.annoted -> 'a) -> 'a -> elementary_rule -> 'a val fold_expr_perturbation : - ('a -> alg_expr Locality.annot -> 'a) -> - ('a -> (Pattern.id array list,int) Alg_expr.bool Locality.annot -> 'a) -> - 'a -> perturbation -> 'a + ('a -> alg_expr Loc.annoted -> 'a) -> + ('a -> (Pattern.id array list, int) Alg_expr.bool Loc.annoted -> 'a) -> + 'a -> + perturbation -> + 'a diff --git a/core/term/raw_mixture.ml b/core/term/raw_mixture.ml index e2f705c434..fda0907e08 100644 --- a/core/term/raw_mixture.ml +++ b/core/term/raw_mixture.ml @@ -7,65 +7,65 @@ (******************************************************************************) type internal = int option - type link = FREE | VAL of int +type agent = { a_type: int; a_ports: link array; a_ints: internal array } +type t = agent list -type agent = +let copy_agent agent = { - a_type: int; - a_ports: link array; - a_ints: internal array; + a_type = agent.a_type; + a_ports = Array.copy agent.a_ports; + a_ints = Array.copy agent.a_ints; } -type t = agent list - -let copy_agent agent = { - a_type = agent.a_type; - a_ports = Array.copy agent.a_ports; - a_ints = Array.copy agent.a_ints; -} - type incr_t = { - father : int Mods.DynArray.t; - rank : (int * (bool * bool)) Mods.DynArray.t; - } + father: int Mods.DynArray.t; + rank: (int * (bool * bool)) Mods.DynArray.t; +} let create n = - { father = Mods.DynArray.init n (fun i -> i); - rank = Mods.DynArray.make n (1,(true,false)); + { + father = Mods.DynArray.init n (fun i -> i); + rank = Mods.DynArray.make n (1, (true, false)); } let rec find_aux a i = let ai = - if (Mods.DynArray.length a) <= i then i else - Mods.DynArray.get a i in - if ai == i then i - else + if Mods.DynArray.length a <= i then + i + else + Mods.DynArray.get a i + in + if ai == i then + i + else ( let root = find_aux a ai in let () = Mods.DynArray.set a i root in root + ) -let find h x = - find_aux h.father x - -let combine_ranks (ix,(bx,_)) (iy,(by,_)) = (ix+iy,(bx&&by,true)) +let find h x = find_aux h.father x +let combine_ranks (ix, (bx, _)) (iy, (by, _)) = ix + iy, (bx && by, true) let union h x y = let root_x = find h x in let root_y = find h y in - if root_x == root_y then () - else + if root_x == root_y then + () + else ( let rank_x = Mods.DynArray.get h.rank root_x in let rank_y = Mods.DynArray.get h.rank root_y in - if (fst rank_x) > (fst rank_y) then + if fst rank_x > fst rank_y then ( let () = Mods.DynArray.set h.rank root_x (combine_ranks rank_x rank_y) in Mods.DynArray.set h.father root_y root_x - else if (fst rank_x) < (fst rank_y) then + ) else if fst rank_x < fst rank_y then ( let () = Mods.DynArray.set h.rank root_y (combine_ranks rank_x rank_y) in Mods.DynArray.set h.father root_x root_y - else + ) else ( let () = Mods.DynArray.set h.rank root_x (combine_ranks rank_x rank_y) in Mods.DynArray.set h.father root_y root_x + ) + ) let union_find_counters sigs mix = let t = create 1 in @@ -75,53 +75,69 @@ let union_find_counters sigs mix = | Some sigs -> List.iter (fun ag -> - match Signature.ports_if_counter_agent sigs ag.a_type with - | None -> () - | Some (before,after) -> - let a = ag.a_ports.(after) in - let b = ag.a_ports.(before) in - match b with - | FREE -> () - | VAL lnk_b -> - match a with - | FREE -> - (* in this case the endpoint of the chain of increments is raw: - the agent is created with a counter value*) - let root = find t lnk_b in - let (s,_) = Mods.DynArray.get t.rank root in - Mods.DynArray.set t.rank root (s-1,(true,true)) - | VAL lnk_a -> union t lnk_b lnk_a) mix in + match Signature.ports_if_counter_agent sigs ag.a_type with + | None -> () + | Some (before, after) -> + let a = ag.a_ports.(after) in + let b = ag.a_ports.(before) in + (match b with + | FREE -> () + | VAL lnk_b -> + (match a with + | FREE -> + (* in this case the endpoint of the chain of increments is raw: + the agent is created with a counter value*) + let root = find t lnk_b in + let s, _ = Mods.DynArray.get t.rank root in + Mods.DynArray.set t.rank root (s - 1, (true, true)) + | VAL lnk_a -> union t lnk_b lnk_a))) + mix + in t -let print_link ~noCounters incr_agents f = function +let print_link ~noCounters counter_agents f = function | FREE -> Format.pp_print_string f "[.]" | VAL i -> - try - let root = find incr_agents i in - let (counter,(_,is_counter)) = Mods.DynArray.get incr_agents.rank root in + (try + let root = find counter_agents i in + let counter, (_, is_counter) = + Mods.DynArray.get counter_agents.rank root + in if is_counter && not noCounters then Format.fprintf f "{=%d}" counter - else Format.fprintf f "[%i]" i - with Invalid_argument _ -> Format.fprintf f "[%i]" i + else + Format.fprintf f "[%i]" i + with Invalid_argument _ -> Format.fprintf f "[%i]" i) let aux_pp_si sigs a s f i = match sigs with | Some sigs -> Signature.print_site_internal_state sigs a s f i | None -> - match i with + (match i with | Some i -> Format.fprintf f "%i{%i}" s i - | None -> Format.pp_print_int f s + | None -> Format.pp_print_int f s) -let print_intf ~noCounters with_link ?sigs incr_agents ag_ty f (ports,ints) = +let print_intf ~noCounters with_link ?sigs counter_agents ag_ty f (ports, ints) + = let rec aux empty i = - if i < Array.length ports then - let () = Format.fprintf - f "%t%a%a" - (if empty then Pp.empty else Pp.space) + if i < Array.length ports then ( + let () = + Format.fprintf f "%t%a%a" + (if empty then + Pp.empty + else + Pp.space) (aux_pp_si sigs ag_ty i) ints.(i) - (if with_link then print_link ~noCounters incr_agents else (fun _ _ -> ())) - ports.(i) in - aux false (succ i) in + (if with_link then + print_link ~noCounters counter_agents + else + fun _ _ -> + ()) + ports.(i) + in + aux false (succ i) + ) + in aux true 0 let aux_pp_ag sigs f a = @@ -129,62 +145,87 @@ let aux_pp_ag sigs f a = | Some sigs -> Signature.print_agent sigs f a | None -> Format.pp_print_int f a -let print_agent ~noCounters created link ?sigs incr_agents f ag = - Format.fprintf f "%a(@[%a@])%t" - (aux_pp_ag sigs) ag.a_type - (print_intf ~noCounters link ?sigs incr_agents ag.a_type) (ag.a_ports, ag.a_ints) - (fun f -> if created then Format.pp_print_string f "+") +let print_agent ~noCounters created link ?sigs counter_agents f ag = + Format.fprintf f "%a(@[%a@])%t" (aux_pp_ag sigs) ag.a_type + (print_intf ~noCounters link ?sigs counter_agents ag.a_type) + (ag.a_ports, ag.a_ints) (fun f -> + if created then Format.pp_print_string f "+") let print ~noCounters ~created ~initial_comma ?sigs f mix = - let incr_agents = union_find_counters sigs mix in + let counter_agents = union_find_counters sigs mix in let rec aux_print some = function | [] -> () - | h::t -> - if match sigs with + | h :: t -> + if + match sigs with | None -> false | Some sigs -> Signature.is_counter_agent sigs h.a_type && not noCounters - then aux_print some t - else + then + aux_print some t + else ( let () = if some then Pp.comma f in - let () = print_agent ~noCounters created true ?sigs incr_agents f h in - aux_print true t in + let () = + print_agent ~noCounters created true ?sigs counter_agents f h + in + aux_print true t + ) + in aux_print initial_comma mix let agent_to_json a = `Assoc - [("type",`Int a.a_type); - ("sites", `List - (Array.fold_right (fun x acc -> - (match x with FREE -> `Null|VAL i -> `Int i)::acc) a.a_ports [])); - ("internals", `List - (Array.fold_right (fun x acc -> - (match x with None -> `Null|Some i -> `Int i)::acc) a.a_ints []))] + [ + "type", `Int a.a_type; + ( "sites", + `List + (Array.fold_right + (fun x acc -> + (match x with + | FREE -> `Null + | VAL i -> `Int i) + :: acc) + a.a_ports []) ); + ( "internals", + `List + (Array.fold_right + (fun x acc -> + (match x with + | None -> `Null + | Some i -> `Int i) + :: acc) + a.a_ints []) ); + ] + let agent_of_json = function - | (`Assoc [("type",`Int t);("sites",`List s);("internals",`List i)] | - `Assoc [("type",`Int t);("internals",`List i);("sites",`List s)] | - `Assoc [("internals",`List i);("type",`Int t);("sites",`List s)] | - `Assoc [("internals",`List i);("sites",`List s);("type",`Int t)] | - `Assoc [("sites",`List s);("internals",`List i);("type",`Int t)] | - `Assoc [("sites",`List s);("type",`Int t);("internals",`List i)]) -> - { a_type = t; + | `Assoc [ ("type", `Int t); ("sites", `List s); ("internals", `List i) ] + | `Assoc [ ("type", `Int t); ("internals", `List i); ("sites", `List s) ] + | `Assoc [ ("internals", `List i); ("type", `Int t); ("sites", `List s) ] + | `Assoc [ ("internals", `List i); ("sites", `List s); ("type", `Int t) ] + | `Assoc [ ("sites", `List s); ("internals", `List i); ("type", `Int t) ] + | `Assoc [ ("sites", `List s); ("type", `Int t); ("internals", `List i) ] -> + { + a_type = t; a_ports = - Tools.array_map_of_list (function + Tools.array_map_of_list + (function | `Null -> FREE | `Int p -> VAL p - | x -> - raise (Yojson.Basic.Util.Type_error ("Invalid site link",x))) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid site link", x))) s; a_ints = - Tools.array_map_of_list (function + Tools.array_map_of_list + (function | `Null -> None | `Int p -> Some p | x -> - raise (Yojson.Basic.Util.Type_error ("Invalid internal state",x))) - i} - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid raw_agent",x)) + raise (Yojson.Basic.Util.Type_error ("Invalid internal state", x))) + i; + } + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid raw_agent", x)) let to_json m = `List (List.map agent_to_json m) + let of_json = function | `List l -> List.map agent_of_json l - | x -> raise (Yojson.Basic.Util.Type_error ("Invalid raw_mixture",x)) + | x -> raise (Yojson.Basic.Util.Type_error ("Invalid raw_mixture", x)) diff --git a/core/term/raw_mixture.mli b/core/term/raw_mixture.mli index 112dc942ce..288ea813af 100644 --- a/core/term/raw_mixture.mli +++ b/core/term/raw_mixture.mli @@ -8,27 +8,33 @@ type internal = int option type link = FREE | VAL of int -type agent = - { a_type: int; a_ports: link array; a_ints: internal array; } +type agent = { a_type: int; a_ports: link array; a_ints: internal array } + type t = agent list +(** This is a simple `raw` type of mixture, used as the mixture state after a rule was applied *) val copy_agent : agent -> agent val print : - noCounters:bool -> created:bool -> initial_comma:bool -> ?sigs:Signature.s -> - Format.formatter -> t -> unit + noCounters:bool -> + created:bool -> + initial_comma:bool -> + ?sigs:Signature.s -> + Format.formatter -> + t -> + unit val to_json : t -> Yojson.Basic.t val of_json : Yojson.Basic.t -> t +(* TODO Change this to have equal bool as sum type *) type incr_t = { - father : int Mods.DynArray.t; - rank : (int * (bool * bool)) Mods.DynArray.t; - (*size of the equivalence * (true - CEQ, false - CGTE) * (is_incr) array*) - } + father: int Mods.DynArray.t; + rank: (int * (bool * bool)) Mods.DynArray.t; + (*size of the equivalence * (true - CEQ, false - CGTE) * (is_incr) array*) +} val union_find_counters : Signature.s option -> t -> incr_t - val find : incr_t -> int -> int -val union: incr_t -> int -> int -> unit +val union : incr_t -> int -> int -> unit val create : int -> incr_t diff --git a/core/version/dune b/core/version/dune index bb2ff8a52e..d90329b17b 100644 --- a/core/version/dune +++ b/core/version/dune @@ -1,7 +1,7 @@ (library - (name kappa_version) - (libraries yojson result re) - (flags (:standard))) + (name kappa_version) + (libraries yojson result re) + (flags (:standard))) (rule (targets git_version.ml) diff --git a/core/version/version.ml b/core/version/version.ml index 99d65d4809..13da61ad98 100644 --- a/core/version/version.ml +++ b/core/version/version.ml @@ -10,17 +10,14 @@ let raw_version_string = "$Format:%D$" let extract_tag_re = Re.compile - (Re.seq [ Re.str "tag: "; Re.group (Re.rep (Re.compl [Re.char ',']))]) + (Re.seq [ Re.str "tag: "; Re.group (Re.rep (Re.compl [ Re.char ',' ])) ]) let version_string = match Re.exec_opt extract_tag_re raw_version_string with | Some gr -> Re.Group.get gr 1 | None -> Git_version.t -let version_msg = "Kappa Simulator: "^version_string - -let version_kasa_full_name = "Kappa Static Analyzer ("^version_string^")" - -let version_kade_full_name = "KaDE ("^version_string^")" - +let version_msg = "Kappa Simulator: " ^ version_string +let version_kasa_full_name = "Kappa Static Analyzer (" ^ version_string ^ ")" +let version_kade_full_name = "KaDE (" ^ version_string ^ ")" let tk_is_initialized = ref false diff --git a/dev/get-git-version.ml b/dev/get-git-version.ml index 97a67f6b03..4c12078074 100755 --- a/dev/get-git-version.ml +++ b/dev/get-git-version.ml @@ -6,8 +6,10 @@ let version = let chan = Unix.open_process_in "git describe --always --dirty" in try let out = input_line chan in - if Unix.close_process_in chan = Unix.WEXITED 0 then out - else "unkown" + if Unix.close_process_in chan = Unix.WEXITED 0 then + out + else + "unkown" with End_of_file -> "unkown" let () = Printf.printf "let t = \"%s\"\n" version diff --git a/dev/raw_printers.ml b/dev/raw_printers.ml index a596f31b07..2fd431dceb 100644 --- a/dev/raw_printers.ml +++ b/dev/raw_printers.ml @@ -1,14 +1,23 @@ let print_ast_alg f a = - Alg_expr.print (fun _ () -> ()) (fun f (x,_) -> Format.pp_print_string f x) - (fun f (x,_) -> Format.fprintf f "'%s'" x) f a + Alg_expr.print + (fun _ () -> ()) + (fun f (x, _) -> Format.pp_print_string f x) + (fun f (x, _) -> Format.fprintf f "'%s'" x) + f a + let print_alg = Kappa_printer.alg_expr ?env:None + let print_bool f a = - Alg_expr.print_bool (fun _ () -> ()) - (fun f (x,_) -> Format.pp_print_string f x) - (fun f (x,_) -> Format.pp_print_string f x) f a + Alg_expr.print_bool + (fun _ () -> ()) + (fun f (x, _) -> Format.pp_print_string f x) + (fun f (x, _) -> Format.pp_print_string f x) + f a + let print_cc = - Pattern.print_cc ~with_id:true ?sigs:None - ?cc_id:None ?dotnet:None ?full_species:None + Pattern.print_cc ~with_id:true ?sigs:None ?cc_id:None ?dotnet:None + ?full_species:None + let print_cc_id = Pattern.print ?domain:None ~with_id:true let print_place = Matching.Agent.print ?sigs:None let print_transformation = Primitives.Transformation.print ?sigs:None diff --git a/examples/parametric_models/CMSB2017-KaDE-kinase_phosphatase/kinase_phosphatase.ml b/examples/parametric_models/CMSB2017-KaDE-kinase_phosphatase/kinase_phosphatase.ml index e363ce2939..0ed64a82b3 100644 --- a/examples/parametric_models/CMSB2017-KaDE-kinase_phosphatase/kinase_phosphatase.ml +++ b/examples/parametric_models/CMSB2017-KaDE-kinase_phosphatase/kinase_phosphatase.ml @@ -42,38 +42,30 @@ let rate_symbol format = | Kappa -> "@" | BNGL | BNGL_compact -> "" -let internal_states = [U;P] -let binding_states = [FREE, Bound 1] +let internal_states = [ U; P ] +let binding_states = [ FREE, Bound 1 ] -let string_of_internal_state = - function +let string_of_internal_state = function | U -> "u" | P -> "p" -let dual_internal = - function +let dual_internal = function | U -> P | P -> U -let string_of_binding_state = - function +let string_of_binding_state = function | FREE -> "" - | Bound i -> "!"^(string_of_int i) + | Bound i -> "!" ^ string_of_int i - -let dual_binding = - function +let dual_binding = function | FREE -> Bound 1 | Bound _ -> FREE - let site_name format k = - Format.sprintf "x%s" - begin - match format with - | Kappa | BNGL -> (string_of_int k) - | BNGL_compact -> "" - end + Format.sprintf "x%s" + (match format with + | Kappa | BNGL -> string_of_int k + | BNGL_compact -> "") (********************************************************) (*initial states*) @@ -82,22 +74,23 @@ let site_name format k = (*full sites information*) let print_sites_init fmt format n = let rec aux k = - if k>n then () - else - let () = - if k>1 then Format.fprintf fmt "," - in + if k > n then + () + else ( + let () = if k > 1 then Format.fprintf fmt "," in let () = Format.fprintf fmt "%s" (site_name format k) in let () = - match internal_states with + match internal_states with | [] -> () - | x :: _ -> Format.fprintf fmt "~%s" (string_of_internal_state x) + | x :: _ -> Format.fprintf fmt "~%s" (string_of_internal_state x) in - aux (k+1) + aux (k + 1) + ) in let () = aux 1 in - let () = Format.fprintf fmt ")" in - let () = match format with + let () = Format.fprintf fmt ")" in + let () = + match format with | Kappa -> () | BNGL | BNGL_compact -> Format.fprintf fmt " Stot" in @@ -122,28 +115,27 @@ let print_init fmt format n = let () = print_sites_init fmt format n in Format.fprintf fmt "end seed species\n\n" - (********************************************************) (*Print Signatures*) let print_sites fmt format n = let rec aux k = - if k>n then () - else - let () = - if k>1 then Format.fprintf fmt "," - in + if k > n then + () + else ( + let () = if k > 1 then Format.fprintf fmt "," in let () = Format.fprintf fmt "%s" (site_name format k) in let () = List.iter (fun state -> - Format.fprintf fmt "~%s" (string_of_internal_state state)) + Format.fprintf fmt "~%s" (string_of_internal_state state)) internal_states in - aux (k+1) + aux (k + 1) + ) in let () = aux 1 in - let () = Format.fprintf fmt ")\n" in + let () = Format.fprintf fmt ")\n" in () (*print agent and init*) @@ -166,8 +158,7 @@ let print_signatures fmt format n = let () = match format with | Kappa -> () - | BNGL | BNGL_compact -> - Format.fprintf fmt "end molecule types\n" + | BNGL | BNGL_compact -> Format.fprintf fmt "end molecule types\n" in Format.fprintf fmt "\n" @@ -185,47 +176,39 @@ let print_agent fmt s interface = in print_elements interface - let print_agent_binding fmt s interface = - let rec print_elements = function - | [] -> () - | (site, _state, state') :: tl -> - Format.fprintf fmt "%s" s; - Format.fprintf fmt "(%s~%s)" site state'; - print_elements tl - in - print_elements interface +let print_agent_binding fmt s interface = + let rec print_elements = function + | [] -> () + | (site, _state, state') :: tl -> + Format.fprintf fmt "%s" s; + Format.fprintf fmt "(%s~%s)" site state'; + print_elements tl + in + print_elements interface let rate format k = match format with - | Kappa -> Format.sprintf "'%s'" k + | Kappa -> Format.sprintf "'%s'" k | BNGL | BNGL_compact -> k - - (******************************************************) (*rate*) let declare_rate_list fmt format l = match format with | Kappa -> - List.iter - (fun (a,b) -> Format.fprintf fmt "%%var: '%s' %s\n" a b ) - l + List.iter (fun (a, b) -> Format.fprintf fmt "%%var: '%s' %s\n" a b) l | BNGL | BNGL_compact -> let () = Format.fprintf fmt "begin parameters\n" in - let () = - List.iter - (fun (a,b) -> Format.fprintf fmt "%s %s\n" a b ) - l - in + let () = List.iter (fun (a, b) -> Format.fprintf fmt "%s %s\n" a b) l in let () = Format.fprintf fmt "end parameters\n\n" in () let declare_rate fmt format = declare_rate_list fmt format parameters + let declare_rate_equal fmt format = declare_rate_list fmt format parameters_equal - (******************************************************) (*print a list of site *) @@ -233,16 +216,18 @@ let print_module fmt format n = let site = site_name format n in let doit k u p = let () = - Format.fprintf fmt "%s(s)%sS(%s~%s) <-> %s(s!1)%sS(%s~%s!1) %s %s,%s \n" - k (agent_sep_not_bound format) site u k (agent_sep_bound format) site u - (rate_symbol format) - (rate format ("k"^k^"S")) (rate format ("kd"^k^"S")) + Format.fprintf fmt "%s(s)%sS(%s~%s) <-> %s(s!1)%sS(%s~%s!1) %s %s,%s \n" k + (agent_sep_not_bound format) + site u k (agent_sep_bound format) site u (rate_symbol format) + (rate format ("k" ^ k ^ "S")) + (rate format ("kd" ^ k ^ "S")) in let () = - Format.fprintf fmt "%s(s!1)%sS(%s~%s!1) -> %s(s)%sS(%s~%s) %s %s \n" - k (agent_sep_bound format) site u k (agent_sep_not_bound format) site p - (rate_symbol format) - (rate format ("k"^p^"S")) + Format.fprintf fmt "%s(s!1)%sS(%s~%s!1) -> %s(s)%sS(%s~%s) %s %s \n" k + (agent_sep_bound format) site u k + (agent_sep_not_bound format) + site p (rate_symbol format) + (rate format ("k" ^ p ^ "S")) in () in @@ -282,12 +267,12 @@ let declare_rules fmt format n = match format with | Kappa -> let rec aux k = - if k>n then () - else - begin - print_module fmt format k ; - aux (k+1) - end + if k > n then + () + else ( + print_module fmt format k; + aux (k + 1) + ) in let () = aux 1 in () @@ -295,12 +280,12 @@ let declare_rules fmt format n = let () = Format.fprintf fmt "begin reaction rules\n" in (*print BNGL*) let rec aux k = - if k>n then () - else - begin - print_module fmt format k ; - aux (k+1) - end + if k > n then + () + else ( + print_module fmt format k; + aux (k + 1) + ) in let () = aux 1 in () @@ -322,23 +307,34 @@ let declare_rules fmt format n = (*main function*) let main rep eq format n = - let equal_rate = if eq then "equal_rate_" else "" in + let equal_rate = + if eq then + "equal_rate_" + else + "" + in let ext = - match format with - | Kappa -> ".ka" - | BNGL -> ".bngl" - | BNGL_compact -> "_sym.bngl" - in - let file = rep^"/"^ex_file_name^equal_rate^(string_of_int n)^ext in - let channel = open_out file in - let fmt = Format.formatter_of_out_channel channel in - let () = (if eq then declare_rate_equal else declare_rate) fmt format in - let () = print_signatures fmt format n in - let () = print_init fmt format n in - let () = Format.fprintf fmt "\n" in - let () = declare_rules fmt format n in - let () = close_out channel in - () + match format with + | Kappa -> ".ka" + | BNGL -> ".bngl" + | BNGL_compact -> "_sym.bngl" + in + let file = rep ^ "/" ^ ex_file_name ^ equal_rate ^ string_of_int n ^ ext in + let channel = open_out file in + let fmt = Format.formatter_of_out_channel channel in + let () = + (if eq then + declare_rate_equal + else + declare_rate) + fmt format + in + let () = print_signatures fmt format n in + let () = print_init fmt format n in + let () = Format.fprintf fmt "\n" in + let () = declare_rules fmt format n in + let () = close_out channel in + () let do_it rep k = main rep true Kappa k; @@ -352,16 +348,16 @@ let do_it rep k = let () = match Array.length Sys.argv with - | 3 -> - do_it - Sys.argv.(1) (int_of_string Sys.argv.(2)) + | 3 -> do_it Sys.argv.(1) (int_of_string Sys.argv.(2)) | 4 -> let n = int_of_string Sys.argv.(3) in let rec aux k = - if k>n then () - else - let () = do_it Sys.argv.(1) k in - aux (k+1) + if k > n then + () + else ( + let () = do_it Sys.argv.(1) k in + aux (k + 1) + ) in let () = aux (int_of_string Sys.argv.(2)) in () diff --git a/examples/parametric_models/CMSB2017-KaDE-n_phos_sites/n_phos_sites.ml b/examples/parametric_models/CMSB2017-KaDE-n_phos_sites/n_phos_sites.ml index 440e7fda0b..aaf6c08975 100644 --- a/examples/parametric_models/CMSB2017-KaDE-n_phos_sites/n_phos_sites.ml +++ b/examples/parametric_models/CMSB2017-KaDE-n_phos_sites/n_phos_sites.ml @@ -4,19 +4,18 @@ type format = Kappa | BNGL | BNGL_compact type label = int type state = U | P -let states = [U;P] -let string_of_state = - function +let states = [ U; P ] + +let string_of_state = function | U -> "u" | P -> "p" let rate_symbol format = - match format with - | Kappa -> "@" - | BNGL | BNGL_compact -> "" + match format with + | Kappa -> "@" + | BNGL | BNGL_compact -> "" -let dual_internal = - function +let dual_internal = function | U -> P | P -> U @@ -24,47 +23,47 @@ let dual_internal = let print_interface fmt lst = let rec print_elements = function | [] -> () - | [site,state] -> Format.fprintf fmt "%s~%s" site (string_of_state state) - | (site,state) :: tl -> Format.fprintf fmt "%s~%s," site (string_of_state state); + | [ (site, state) ] -> + Format.fprintf fmt "%s~%s" site (string_of_state state) + | (site, state) :: tl -> + Format.fprintf fmt "%s~%s," site (string_of_state state); print_elements tl in - Format.fprintf fmt "("; + Format.fprintf fmt "("; print_elements lst; - Format.fprintf fmt ")" + Format.fprintf fmt ")" let string_of_site format k = match format with - | Kappa | BNGL -> "s"^(string_of_int k) + | Kappa | BNGL -> "s" ^ string_of_int k | BNGL_compact -> "s" let print_signatures fmt format n = let () = match format with - | Kappa -> - Format.fprintf fmt "%%agent: A(" - | BNGL | BNGL_compact -> - Format.fprintf fmt "begin molecule types\nA(" + | Kappa -> Format.fprintf fmt "%%agent: A(" + | BNGL | BNGL_compact -> Format.fprintf fmt "begin molecule types\nA(" in let rec aux k = - if k>n then () - else - let () = - if k>1 then Format.fprintf fmt "," - in + if k > n then + () + else ( + let () = if k > 1 then Format.fprintf fmt "," in let () = Format.fprintf fmt "%s" (string_of_site format k) in - let () = List.iter - (fun state -> - Format.fprintf fmt "~%s" (string_of_state state)) states + let () = + List.iter + (fun state -> Format.fprintf fmt "~%s" (string_of_state state)) + states in - aux (k+1) + aux (k + 1) + ) in let () = aux 1 in - let () = Format.fprintf fmt ")" in + let () = Format.fprintf fmt ")" in let () = match format with | Kappa -> () - | BNGL | BNGL_compact -> - Format.fprintf fmt "\nend molecule types" + | BNGL | BNGL_compact -> Format.fprintf fmt "\nend molecule types" in let () = Format.fprintf fmt "\n\n" in () @@ -73,31 +72,28 @@ let print_agent fmt interface = Format.fprintf fmt "A"; print_interface fmt interface - - let site_list format n = let rec aux k l = - if k=0 then l - else aux (k-1) ((string_of_site format k)::l) - in aux n [] + if k = 0 then + l + else + aux (k - 1) (string_of_site format k :: l) + in + aux n [] let print_init fmt format n = match format with | Kappa -> Format.fprintf fmt "%%init: 100 "; print_agent fmt - (List.rev_map - (fun site -> site,U) - (List.rev (site_list format n))); + (List.rev_map (fun site -> site, U) (List.rev (site_list format n))); Format.fprintf fmt "\n" | BNGL | BNGL_compact -> let () = Format.fprintf fmt "begin seed species\n" in let () = Format.fprintf fmt "%%init: " in let () = print_agent fmt - (List.rev_map - (fun site -> site,U) - (List.rev (site_list format n))); + (List.rev_map (fun site -> site, U) (List.rev (site_list format n))) in Format.fprintf fmt " Stot\nend seed species\n\n" @@ -108,58 +104,57 @@ let potential_valuations format list = let rec aux remaining_site partial_valuations = match remaining_site with | [] -> partial_valuations - | h::tl -> + | h :: tl -> let partial_valuations = List.fold_left (fun extended_partial_valuations state -> - List.fold_left - (fun extended_partial_valuations partial_valuation -> - ((h,state)::partial_valuation)::extended_partial_valuations) - extended_partial_valuations - partial_valuations) - [] - states - in aux tl partial_valuations + List.fold_left + (fun extended_partial_valuations partial_valuation -> + ((h, state) :: partial_valuation) + :: extended_partial_valuations) + extended_partial_valuations partial_valuations) + [] states + in + aux tl partial_valuations in - aux list [[]] + aux list [ [] ] | BNGL_compact -> let n = List.length list in let rec aux state k list = - if k=0 then list else aux state (k-1) (state::list) + if k = 0 then + list + else + aux state (k - 1) (state :: list) in - let valuation k = aux U k (aux P (n-k) []) in + let valuation k = aux U k (aux P (n - k) []) in let rec aux k l = - if k > n then l - else + if k > n then + l + else ( let valuation = - List.rev_map2 - (fun a b -> a,b) - (List.rev list) - (valuation k) + List.rev_map2 (fun a b -> a, b) (List.rev list) (valuation k) in - aux (k+1) (valuation::l) + aux (k + 1) (valuation :: l) + ) in aux 0 [] - - -let flip (s,state) = - match state - with - | U -> P,(s,P) - | P -> U,(s,U) +let flip (s, state) = + match state with + | U -> P, (s, P) + | P -> U, (s, U) let count_p interface = List.fold_left - (fun n (_,state) -> - match state with - | P -> n+1 - | U -> n) + (fun n (_, state) -> + match state with + | P -> n + 1 + | U -> n) 0 interface let rate_of kind interface = let n = count_p interface in - "k"^(string_of_state kind)^(string_of_int n) + "k" ^ string_of_state kind ^ string_of_int n (* kp_i/n-i ku_i/i @@ -172,68 +167,73 @@ let rate_of_sym kind interface n = | P -> let rec aux k = let i = n - k in - "k"^(string_of_state kind)^(string_of_int k)^"/"^"n_k"^(string_of_int i) + "k" ^ string_of_state kind ^ string_of_int k ^ "/" ^ "n_k" + ^ string_of_int i in aux n_p | U -> - "k"^(string_of_state kind)^(string_of_int n_p)^"/"^"n_k"^(string_of_int n_p) + "k" ^ string_of_state kind ^ string_of_int n_p ^ "/" ^ "n_k" + ^ string_of_int n_p in s let string_of_rate format rate = match format with - Kappa -> "'"^rate^"'" + | Kappa -> "'" ^ rate ^ "'" | BNGL | BNGL_compact -> rate let print_rule fmt format interface interface_post rate = - print_agent fmt interface ; - Format.fprintf fmt " -> " ; - print_agent fmt interface_post ; + print_agent fmt interface; + Format.fprintf fmt " -> "; + print_agent fmt interface_post; Format.fprintf fmt " %s%s\n" (rate_symbol format) (string_of_rate format rate) let rec exp i j = - if j=0 then 1 - else if j=1 then i - else let q,r = j/2, j mod 2 in + if j = 0 then + 1 + else if j = 1 then + i + else ( + let q, r = j / 2, j mod 2 in let root = exp i q in - let square = root*root in - if r=0 then square - else i*square + let square = root * root in + if r = 0 then + square + else + i * square + ) let rate state k = match state with - | U -> 3*(exp 5 k) - | P -> 2*(exp 7 k) + | U -> 3 * exp 5 k + | P -> 2 * exp 7 k let declare_rate_list fmt format l = match format with | Kappa -> - List.iter - (fun (a,b) -> Format.fprintf fmt "%%var: '%s' %i\n" a b ) - l + List.iter (fun (a, b) -> Format.fprintf fmt "%%var: '%s' %i\n" a b) l | BNGL | BNGL_compact -> let () = Format.fprintf fmt "begin parameters\n" in - let () = - List.iter - (fun (a,b) -> Format.fprintf fmt "%s %i\n" a b ) - l - in + let () = List.iter (fun (a, b) -> Format.fprintf fmt "%s %i\n" a b) l in let () = Format.fprintf fmt "end parameters\n\n" in () let declare_rate fmt format n = let rec aux k list = - if k<0 then list + if k < 0 then + list else - aux (k-1) - (("n_k"^(string_of_int k), k):: - ("kp"^(string_of_int k),rate U k)::("ku"^(string_of_int (k+1)),rate P (k+1))::list) + aux (k - 1) + (("n_k" ^ string_of_int k, k) + :: ("kp" ^ string_of_int k, rate U k) + :: ("ku" ^ string_of_int (k + 1), rate P (k + 1)) + :: list) in let list = aux n [] in let list = match format with | Kappa -> list - | BNGL | BNGL_compact -> ("Stot",100)::list + | BNGL | BNGL_compact -> ("Stot", 100) :: list in let () = declare_rate_list fmt format list in () @@ -244,14 +244,14 @@ let deal_with_one_valuation fmt format interface = let rec aux suffix prefix = match suffix with | [] -> () - | (h:string*state)::tl -> - let kind,h' = flip h in + | (h : string * state) :: tl -> + let kind, h' = flip h in let interface_post = - List.fold_left (fun list elt -> elt::list) (h'::prefix) tl + List.fold_left (fun list elt -> elt :: list) (h' :: prefix) tl in let rate = rate_of kind interface in let () = print_rule fmt format interface interface_post rate in - aux tl (h::prefix) + aux tl (h :: prefix) in aux (List.rev interface) [] | BNGL_compact -> @@ -259,33 +259,30 @@ let deal_with_one_valuation fmt format interface = let rec aux suffix prefix = match suffix with | [] -> () - | (h:string*state)::tl -> - let kind,h' = flip h in + | (h : string * state) :: tl -> + let kind, h' = flip h in let interface_post = - List.fold_left (fun list elt -> elt::list) (h'::prefix) tl + List.fold_left (fun list elt -> elt :: list) (h' :: prefix) tl in let rate = rate_of_sym kind interface n in let () = print_rule fmt format interface interface_post rate in - aux tl (h::prefix) + aux tl (h :: prefix) in aux (List.rev interface) [] - let declare_rules fmt format n = let () = match format with | Kappa -> () - | BNGL - | BNGL_compact -> - Format.fprintf fmt "begin reaction rules\n" + | BNGL | BNGL_compact -> Format.fprintf fmt "begin reaction rules\n" in let sites = site_list format n in let potential_valuations = potential_valuations format sites in let () = List.iter (fun valuation -> - deal_with_one_valuation fmt format valuation; - Format.fprintf fmt "\n\n") + deal_with_one_valuation fmt format valuation; + Format.fprintf fmt "\n\n") potential_valuations in let () = @@ -304,7 +301,7 @@ let main rep format n = | BNGL -> ".bngl" | BNGL_compact -> "_sym.bngl" in - let file = rep^"/"^ex_name^(string_of_int n)^ext in + let file = rep ^ "/" ^ ex_name ^ string_of_int n ^ ext in let channel = open_out file in let fmt = Format.formatter_of_out_channel channel in let () = declare_rate fmt format n in @@ -322,14 +319,16 @@ let do_it rep k = let () = match Array.length Sys.argv with - | 3 -> - do_it - Sys.argv.(1) (int_of_string Sys.argv.(2)) + | 3 -> do_it Sys.argv.(1) (int_of_string Sys.argv.(2)) | 4 -> let n = int_of_string Sys.argv.(3) in let rec aux k = - if k>n then () - else - let () = do_it Sys.argv.(1) k in aux (k+1) - in aux (int_of_string Sys.argv.(2)) + if k > n then + () + else ( + let () = do_it Sys.argv.(1) k in + aux (k + 1) + ) + in + aux (int_of_string Sys.argv.(2)) | _ -> Printf.printf "Please call with two or three int arguments\n\n" diff --git a/examples/parametric_models/CMSB2017-KaDE-n_phos_sites_with_counters/n_phos_sites_with_counter.ml b/examples/parametric_models/CMSB2017-KaDE-n_phos_sites_with_counters/n_phos_sites_with_counter.ml index 4d38ed0975..13be29eac9 100644 --- a/examples/parametric_models/CMSB2017-KaDE-n_phos_sites_with_counters/n_phos_sites_with_counter.ml +++ b/examples/parametric_models/CMSB2017-KaDE-n_phos_sites_with_counters/n_phos_sites_with_counter.ml @@ -4,7 +4,6 @@ type format = Kappa | BNGL | BNGL_compact type label = int type state = U | P - let agent_sep format = match format with | Kappa -> " , " @@ -15,83 +14,80 @@ let rate_symbol format = | Kappa -> "@" | BNGL | BNGL_compact -> "" -let states = [U;P] -let string_of_state = - function +let states = [ U; P ] + +let string_of_state = function | U -> "u" | P -> "p" -let dual = - function + +let dual = function | U -> P | P -> U let int_list i k = let rec aux k list = - if k - List.rev_map - (fun i -> "s"^(string_of_int i)) - (List.rev (int_list 1 k)) - | BNGL_compact -> ["s"] + List.rev_map (fun i -> "s" ^ string_of_int i) (List.rev (int_list 1 k)) + | BNGL_compact -> [ "s" ] + let site_list_init k format = match format with | Kappa | BNGL -> - List.rev_map - (fun i -> "s"^(string_of_int i)) - (List.rev (int_list 1 k)) - | BNGL_compact -> List.rev_map - (fun i -> "s") - (List.rev (int_list 1 k)) + List.rev_map (fun i -> "s" ^ string_of_int i) (List.rev (int_list 1 k)) + | BNGL_compact -> List.rev_map (fun i -> "s") (List.rev (int_list 1 k)) -let next (l : label) = (succ l : label) -let string_of_label (l : label) = (string_of_int l : string) +let next (l : label) : label = succ l +let string_of_label (l : label) : string = string_of_int l (*Print Signatures*) let print_interface fmt lst = let rec print_elements = function | [] -> () - | (site,state) :: tl -> Format.fprintf fmt "%s~%s," site state; + | (site, state) :: tl -> + Format.fprintf fmt "%s~%s," site state; print_elements tl in - Format.fprintf fmt "("; + Format.fprintf fmt "("; print_elements lst; Format.fprintf fmt "p!1"; - Format.fprintf fmt ")" + Format.fprintf fmt ")" let print_signatures fmt n format = let () = match format with | Kappa -> Format.fprintf fmt "%%agent: A(" - | BNGL | BNGL_compact -> - Format.fprintf fmt "begin molecule types\nA(" + | BNGL | BNGL_compact -> Format.fprintf fmt "begin molecule types\nA(" in let rec aux k = - if k>n then () - else - let () = - if k>1 then Format.fprintf fmt "," - in + if k > n then + () + else ( + let () = if k > 1 then Format.fprintf fmt "," in let () = match format with - | Kappa | BNGL -> - Format.fprintf fmt "s%i" k - | BNGL_compact -> - Format.fprintf fmt "s" + | Kappa | BNGL -> Format.fprintf fmt "s%i" k + | BNGL_compact -> Format.fprintf fmt "s" in let () = List.iter - (fun state -> Format.fprintf fmt "~%s" (string_of_state state)) states + (fun state -> Format.fprintf fmt "~%s" (string_of_state state)) + states in - aux (k+1) + aux (k + 1) + ) in let () = aux 1 in let () = Format.fprintf fmt ",p" in - let () = Format.fprintf fmt ")\n" in + let () = Format.fprintf fmt ")\n" in let () = match format with | Kappa -> Format.fprintf fmt "%%agent: P(l,r)\n\n" @@ -107,17 +103,24 @@ let print_combinator fmt k l_opt format = let s = match l_opt with | None -> "" - | Some label -> "!"^(string_of_label label) + | Some label -> "!" ^ string_of_label label in Format.fprintf fmt "%sP(l!%i,r%s)" (agent_sep format) k s let rec print_chain fmt n label format = - if n=0 then () - else + if n = 0 then + () + else ( let next_label = next label in - let succ_k = if n=1 then None else Some next_label in + let succ_k = + if n = 1 then + None + else + Some next_label + in print_combinator fmt label succ_k format; - print_chain fmt (n-1) next_label format + print_chain fmt (n - 1) next_label format + ) let print_pattern_n fmt interface n format = print_agent fmt interface; @@ -132,67 +135,79 @@ let print_init fmt n format = match format with | Kappa -> Format.fprintf fmt "%%init: 100 "; - print_pattern_n fmt [] 1 format ; + print_pattern_n fmt [] 1 format; Format.fprintf fmt "\n" | BNGL | BNGL_compact -> Format.fprintf fmt "begin seed species\n"; - print_pattern_n fmt (List.rev_map (fun s -> (s,"u")) (List.rev (site_list_init n format))) 1 format; + print_pattern_n fmt + (List.rev_map (fun s -> s, "u") (List.rev (site_list_init n format))) + 1 format; Format.fprintf fmt " Stot\nend seed species\n" - -let rate_of state k = - "k"^(string_of_state (dual state))^(string_of_int k) - +let rate_of state k = "k" ^ string_of_state (dual state) ^ string_of_int k let print_rule fmt site state k format = let k' = succ k in match state with | U -> - print_pattern_n fmt [site,string_of_state state] k' format; - Format.fprintf fmt " -> " ; - print_pattern_succ_n fmt [site,string_of_state (dual state)] k' format; + print_pattern_n fmt [ site, string_of_state state ] k' format; + Format.fprintf fmt " -> "; + print_pattern_succ_n fmt [ site, string_of_state (dual state) ] k' format; Format.fprintf fmt " %s%s\n" (rate_symbol format) (rate_of state k) | P -> - print_pattern_succ_n fmt [site,string_of_state state] k format; - Format.fprintf fmt " -> " ; - print_pattern_n fmt [site,string_of_state (dual state)] k format; + print_pattern_succ_n fmt [ site, string_of_state state ] k format; + Format.fprintf fmt " -> "; + print_pattern_n fmt [ site, string_of_state (dual state) ] k format; Format.fprintf fmt " %s%s\n" (rate_symbol format) (rate_of state k) let rec exp i j = - if j=0 then 1 - else if j=1 then i - else let q,r = j/2, j mod 2 in + if j = 0 then + 1 + else if j = 1 then + i + else ( + let q, r = j / 2, j mod 2 in let root = exp i q in - let square = root*root in - if r=0 then square - else i*square + let square = root * root in + if r = 0 then + square + else + i * square + ) let rate state k = - if state = "u" then 3*(exp 5 k) - else if state = "p" then 2*(exp 7 k) - else 0 + if state = "u" then + 3 * exp 5 k + else if state = "p" then + 2 * exp 7 k + else + 0 let declare_rate fmt n format = match format with | Kappa -> let rec aux k = - if k=n then () - else + if k = n then + () + else ( let () = Format.fprintf fmt "%%var: 'kp%i' %i\n" k (rate "u" k) in - let () = Format.fprintf fmt "%%var: 'ku%i' %i\n" (k+1) (rate "p" (k+1)) - in - aux (k+1) + let () = + Format.fprintf fmt "%%var: 'ku%i' %i\n" (k + 1) (rate "p" (k + 1)) + in + aux (k + 1) + ) in aux 0 | BNGL | BNGL_compact -> let () = Format.fprintf fmt "begin parameters\n" in let rec aux k = - if k=n then () - else + if k = n then + () + else ( let () = Format.fprintf fmt "kp%i %i\n" k (rate "u" k) in - let () = Format.fprintf fmt "ku%i %i\n" (k+1) (rate "p" (k+1)) - in - aux (k+1) + let () = Format.fprintf fmt "ku%i %i\n" (k + 1) (rate "p" (k + 1)) in + aux (k + 1) + ) in let () = aux 0 in let () = Format.fprintf fmt "Stot 100\n" in @@ -200,12 +215,12 @@ let declare_rate fmt n format = let main rep n format = let ext = - match format with - | Kappa -> ".ka" - | BNGL -> ".bngl" - | BNGL_compact -> "_sym.bngl" + match format with + | Kappa -> ".ka" + | BNGL -> ".bngl" + | BNGL_compact -> "_sym.bngl" in - let file = rep^"/"^ex_file_name^(string_of_int n)^ext in + let file = rep ^ "/" ^ ex_file_name ^ string_of_int n ^ ext in let channel = open_out file in let fmt = Format.formatter_of_out_channel channel in let () = declare_rate fmt n format in @@ -218,33 +233,31 @@ let main rep n format = let () = match format with | Kappa -> () - | BNGL | BNGL_compact -> - Format.fprintf fmt "begin reaction rules\n" + | BNGL | BNGL_compact -> Format.fprintf fmt "begin reaction rules\n" in let () = List.iter (fun k -> - let states = - if k=0 - then [U] - else if k=n - then [P] - else states - in - List.iter - (fun site -> - List.iter - (fun state -> print_rule fmt site state k format) - states - ) - sites) + let states = + if k = 0 then + [ U ] + else if k = n then + [ P ] + else + states + in + List.iter + (fun site -> + List.iter (fun state -> print_rule fmt site state k format) states) + sites) intlist in let () = match format with | Kappa -> () | BNGL | BNGL_compact -> - Format.fprintf fmt "end reaction rules\n\ngenerate_network({overwrite=>1});" + Format.fprintf fmt + "end reaction rules\n\ngenerate_network({overwrite=>1});" in let () = close_out channel in () @@ -257,16 +270,16 @@ let do_it rep k = let () = match Array.length Sys.argv with - | 3 -> - do_it - Sys.argv.(1) (int_of_string Sys.argv.(2)) + | 3 -> do_it Sys.argv.(1) (int_of_string Sys.argv.(2)) | 4 -> let n = int_of_string Sys.argv.(3) in let rec aux k = - if k>n then () - else - let () = do_it Sys.argv.(1) k in - aux (k+1) + if k > n then + () + else ( + let () = do_it Sys.argv.(1) k in + aux (k + 1) + ) in let () = aux (int_of_string Sys.argv.(2)) in () diff --git a/examples/parametric_models/counters/counters.ml b/examples/parametric_models/counters/counters.ml index 6654e1e69c..0fd6578307 100644 --- a/examples/parametric_models/counters/counters.ml +++ b/examples/parametric_models/counters/counters.ml @@ -4,63 +4,67 @@ type label = int type state = int let string_of_state i = - if i =0 then "u" else "p"^(string_of_int i) -let string_of_site k = "s"^(string_of_int k) -let rate_symbol = "@" + if i = 0 then + "u" + else + "p" ^ string_of_int i +let string_of_site k = "s" ^ string_of_int k +let rate_symbol = "@" let next_internal = succ (*Print Signatures*) let print_interface fmt lst counter = let rec print_elements = function | [] -> () - | [site,state] -> Format.fprintf fmt "%s{%s}" (string_of_site site) (string_of_state state) - | (site,state) :: tl -> Format.fprintf fmt "%s{%s}," (string_of_site site) (string_of_state state); + | [ (site, state) ] -> + Format.fprintf fmt "%s{%s}" (string_of_site site) (string_of_state state) + | (site, state) :: tl -> + Format.fprintf fmt "%s{%s}," (string_of_site site) (string_of_state state); print_elements tl in - let () = Format.fprintf fmt "(" in + let () = Format.fprintf fmt "(" in let () = print_elements lst in - let () = match counter with None -> () - | Some i -> if i>0 then - Format.fprintf fmt ",c{+=%i}" i - else if i<0 then - Format.fprintf fmt ",c{-=%i}" (-i) - else () + let () = + match counter with + | None -> () + | Some i -> + if i > 0 then + Format.fprintf fmt ",c{+=%i}" i + else if i < 0 then + Format.fprintf fmt ",c{-=%i}" (-i) + else + () in - Format.fprintf fmt ")" - + Format.fprintf fmt ")" let list_first_last first last = let rec aux k l = - if k - let () = if site>1 then Format.fprintf fmt "," in - let () = Format.fprintf fmt "%s{" (string_of_site site) in - let () = - List.iter - (fun state -> - let () = - if state > 0 - then - Format.fprintf fmt " " - in - Format.fprintf fmt "%s" (string_of_state state) - ) - l_states - in - let () = Format.fprintf fmt "}" in ()) + let () = if site > 1 then Format.fprintf fmt "," in + let () = Format.fprintf fmt "%s{" (string_of_site site) in + let () = + List.iter + (fun state -> + let () = if state > 0 then Format.fprintf fmt " " in + Format.fprintf fmt "%s" (string_of_state state)) + l_states + in + let () = Format.fprintf fmt "}" in + ()) l_sites in Format.fprintf fmt ")\n" @@ -69,59 +73,59 @@ let print_agent fmt interface counter = Format.fprintf fmt "A"; print_interface fmt interface counter - let site_list n = let rec aux k l = - if k=0 then l - else aux (k-1) ((string_of_site k)::l) - in aux n [] + if k = 0 then + l + else + aux (k - 1) (string_of_site k :: l) + in + aux n [] -let print_init fmt = - Format.fprintf fmt "%%init: 100 A()\n" +let print_init fmt = Format.fprintf fmt "%%init: 100 A()\n" let print_rule fmt interface interface_post counter = - print_agent fmt interface None ; - Format.fprintf fmt " -> " ; + print_agent fmt interface None; + Format.fprintf fmt " -> "; print_agent fmt interface_post counter; Format.fprintf fmt " %s 1\n" rate_symbol - - - -let declare_rules fmt n_sites n_phos = - let site_list = list_first_last 1 n_sites in +let declare_rules fmt n_sites n_phos = + let site_list = list_first_last 1 n_sites in let state_list = list_first_last 0 n_phos in let () = List.iter (fun site -> - List.iter - (fun state -> - let state' = state+1 in - let () = - if state' <= n_phos - then - print_rule fmt [site,state] [site,state'] (Some (+1)) - in - let state' = state-1 in - let () = - if state' >= 0 - then - print_rule fmt [site,state] [site,state'] (Some (-1)) - in - ()) - state_list ) + List.iter + (fun state -> + let state' = state + 1 in + let () = + if state' <= n_phos then + print_rule fmt [ site, state ] [ site, state' ] (Some 1) + in + let state' = state - 1 in + let () = + if state' >= 0 then + print_rule fmt [ site, state ] [ site, state' ] (Some (-1)) + in + ()) + state_list) site_list in () let string_of_int_bis i = - if i>=0 && i<10 then "0"^(string_of_int i) - else + if i >= 0 && i < 10 then + "0" ^ string_of_int i + else string_of_int i -let main rep n_sites n_phos = +let main rep n_sites n_phos = let ext = ".ka" in - let file = rep^"/"^ex_name^(string_of_int_bis n_sites)^"_"^(string_of_int_bis n_phos)^ext in + let file = + rep ^ "/" ^ ex_name ^ string_of_int_bis n_sites ^ "_" + ^ string_of_int_bis n_phos ^ ext + in let channel = open_out file in let fmt = Format.formatter_of_out_channel channel in let () = print_signatures fmt n_sites n_phos in @@ -131,32 +135,36 @@ let main rep n_sites n_phos = let () = close_out channel in () - let () = match Array.length Sys.argv with | 4 -> - main - Sys.argv.(1) (int_of_string Sys.argv.(2)) (int_of_string Sys.argv.(3)) + main Sys.argv.(1) (int_of_string Sys.argv.(2)) (int_of_string Sys.argv.(3)) | 5 -> let n = int_of_string Sys.argv.(3) in let rec aux k = - if k>n then () - else + if k > n then + () + else ( let () = main Sys.argv.(1) k (int_of_string Sys.argv.(4)) in - aux (k+1) - in aux (int_of_string Sys.argv.(2)) + aux (k + 1) + ) + in + aux (int_of_string Sys.argv.(2)) | 6 -> let n = int_of_string Sys.argv.(3) in let n' = int_of_string Sys.argv.(5) in let rec aux k = - if k>n then () + if k > n then + () else aux2 k (int_of_string Sys.argv.(4)) and aux2 k k' = - if k'>n' then aux (k+1) - else + if k' > n' then + aux (k + 1) + else ( let () = main Sys.argv.(1) k k' in - aux2 k (k'+1) + aux2 k (k' + 1) + ) in aux (int_of_string Sys.argv.(2)) - | _ -> Printf.printf "Please call with two, three, or four int arguments\n\n" + | _ -> Printf.printf "Please call with two, three, or four int arguments\n\n" diff --git a/externals.mk b/externals.mk index 3fedfe90c0..997faccad1 100644 --- a/externals.mk +++ b/externals.mk @@ -1,4 +1,4 @@ -CODEMIRROR_VERSION:=5.53.2 +CODEMIRROR_VERSION:=5.65.11 BOOTSTRAP_VERSION:=3.4.1 JQUERY_VERSION:=3.5.0 JQUERY_UI_VERSION:=1.12.1 diff --git a/gui/JsNode.ml b/gui/JsNode.ml index e8d6ccc552..037ea6996e 100644 --- a/gui/JsNode.ml +++ b/gui/JsNode.ml @@ -6,59 +6,52 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -class type process_configuration = - object - method command : Js.js_string Js.t Js.prop - method args : Js.js_string Js.t Js.js_array Js.t Js.prop - method onStdout : (Js.js_string Js.t -> unit) Js.prop - method onStderr : (Js.js_string Js.t -> unit) Js.prop - method onClose : (unit -> unit) Js.prop - method onError : (unit -> unit) Js.prop - end +class type process_configuration = object + method command : Js.js_string Js.t Js.prop + method args : Js.js_string Js.t Js.js_array Js.t Js.prop + method onStdout : (Js.js_string Js.t -> unit) Js.prop + method onStderr : (Js.js_string Js.t -> unit) Js.prop + method onClose : (unit -> unit) Js.prop + method onError : (unit -> unit) Js.prop +end let constructor_process_configuration : process_configuration Js.t Js.constr = - (Js.Unsafe.pure_js_expr "Object") + Js.Unsafe.pure_js_expr "Object" let create_process_configuration ?(onStdout : (Js.js_string Js.t -> unit) option) ?(onStderr : (Js.js_string Js.t -> unit) option) - ?(onClose : (unit -> unit) option) - ?(onError : (unit -> unit) option) - (command : string) - (args : string list) - : process_configuration Js.t = + ?(onClose : (unit -> unit) option) ?(onError : (unit -> unit) option) + (command : string) (args : string list) : process_configuration Js.t = let configuration : process_configuration Js.t = - new%js constructor_process_configuration in + new%js constructor_process_configuration + in let () = configuration##.command := Js.string command; - configuration##.args := - Js.array (Array.of_list (List.map Js.string args)); + configuration##.args := Js.array (Array.of_list (List.map Js.string args)); (match onStdout with - | Some onStdout -> configuration##.onStdout := onStdout - | None -> () - ); + | Some onStdout -> configuration##.onStdout := onStdout + | None -> ()); (match onStderr with - | Some onStderr -> configuration##.onStderr := onStderr - | None -> () - ); + | Some onStderr -> configuration##.onStderr := onStderr + | None -> ()); (match onClose with - | Some onClose -> configuration##.onClose := onClose - | None -> () - ); + | Some onClose -> configuration##.onClose := onClose + | None -> ()); (match onError with - | Some onError -> configuration##.onError := onError - | None -> () - ); + | Some onError -> configuration##.onError := onError + | None -> ()); () - in configuration + in + configuration -class type process = - object - method write : Js.js_string Js.t -> unit Js.meth - method kill : unit Js.meth - end +class type process = object + method write : Js.js_string Js.t -> unit Js.meth + method kill : unit Js.meth +end -let spawn_process (configuration : process_configuration Js.t) : process Js.t Js.opt = +let spawn_process (configuration : process_configuration Js.t) : + process Js.t Js.opt = Js.Unsafe.fun_call (Js.Unsafe.js_expr "spawnProcess") [| Js.Unsafe.inject configuration |] @@ -67,41 +60,41 @@ let launch_agent onClose message_delimiter command args handler = let buffer = Buffer.create 512 in let rec onStdout msg = match Tools.string_split_on_char message_delimiter (Js.to_string msg) with - | (prefix,None) -> - Buffer.add_string buffer prefix - | (prefix,Some suffix) -> + | prefix, None -> Buffer.add_string buffer prefix + | prefix, Some suffix -> let () = Buffer.add_string buffer prefix in let () = handler (Buffer.contents buffer) in let () = Buffer.reset buffer in - onStdout (Js.string suffix) in - let configuration : process_configuration Js.t = - create_process_configuration ~onStdout ~onClose command args in + onStdout (Js.string suffix) + in + let configuration : process_configuration Js.t = + create_process_configuration ~onStdout ~onClose command args + in Js.Opt.case (spawn_process configuration) (fun () -> - let () = onClose () in - failwith ("Launching '"^command^"' failed")) + let () = onClose () in + failwith ("Launching '" ^ command ^ "' failed")) (fun x -> x) -class manager - ?(message_delimiter : char = Tools.default_message_delimter) - (command : string) - (args : string list) : Api.concrete_manager = +class manager ?(message_delimiter : char = Tools.default_message_delimter) + (command : string) (args : string list) : + Api.concrete_manager = let switch_re = Re.compile (Re.str "KappaSwitchman") in - let stor_command = Re.replace_string switch_re ~by:"KaStor" command in + let stor_command = Re.replace_string switch_re ~by:"KaStor" command in let switch_mailbox = Switchman_client.new_mailbox () in - let stor_state,update_stor_state = Kastor_client.init_state () in + let stor_state, update_stor_state = Kastor_client.init_state () in let running_ref = ref true in let onClose () = running_ref := false in let stor_process = - launch_agent - onClose message_delimiter - stor_command args (Kastor_client.receive update_stor_state) in + launch_agent onClose message_delimiter stor_command args + (Kastor_client.receive update_stor_state) + in let switch_process = - launch_agent - onClose message_delimiter - command args (Switchman_client.receive switch_mailbox) in - object(self) + launch_agent onClose message_delimiter command args + (Switchman_client.receive switch_mailbox) + in + object (self) method private sleep timeout = Js_of_ocaml_lwt.Lwt_js.sleep timeout method is_running = !running_ref @@ -113,18 +106,18 @@ class manager method is_computing = Switchman_client.is_computing switch_mailbox || self#story_is_computing - inherit Kastor_client.new_client + inherit + Kastor_client.new_client ~post:(fun message_text -> - stor_process##write - (Js.string - (Format.sprintf "%s%c" message_text message_delimiter))) + stor_process##write + (Js.string (Format.sprintf "%s%c" message_text message_delimiter))) stor_state - inherit Switchman_client.new_client + inherit + Switchman_client.new_client ~is_running:(fun () -> true) ~post:(fun message_text -> - switch_process##write - (Js.string - (Format.sprintf "%s%c" message_text message_delimiter))) + switch_process##write + (Js.string (Format.sprintf "%s%c" message_text message_delimiter))) switch_mailbox end diff --git a/gui/JsNode.mli b/gui/JsNode.mli index 4261d5ae07..920ac09ea8 100644 --- a/gui/JsNode.mli +++ b/gui/JsNode.mli @@ -1,20 +1,19 @@ -class type process_configuration = - object - method command : Js.js_string Js.t Js.prop - method args : Js.js_string Js.t Js.js_array Js.t Js.prop - method onStdout : (Js.js_string Js.t -> unit) Js.prop - method onStderr : (Js.js_string Js.t -> unit) Js.prop - method onClose : (unit -> unit) Js.prop - method onError : (unit -> unit) Js.prop - end +class type process_configuration = object + method command : Js.js_string Js.t Js.prop + method args : Js.js_string Js.t Js.js_array Js.t Js.prop + method onStdout : (Js.js_string Js.t -> unit) Js.prop + method onStderr : (Js.js_string Js.t -> unit) Js.prop + method onClose : (unit -> unit) Js.prop + method onError : (unit -> unit) Js.prop +end -class type process = - object - method write : Js.js_string Js.t -> unit Js.meth - method kill : unit Js.meth - end +class type process = object + method write : Js.js_string Js.t -> unit Js.meth + method kill : unit Js.meth +end -class manager: - ?message_delimiter:char -> - string -> - string list -> Api.concrete_manager +class manager : + ?message_delimiter:char -> + string -> + string list -> + Api.concrete_manager diff --git a/gui/JsSim.ml b/gui/JsSim.ml index 4d0308fdda..4ba17d3946 100644 --- a/gui/JsSim.ml +++ b/gui/JsSim.ml @@ -9,24 +9,27 @@ let onload _ = let () = State_ui.onload () in let main = Ui_common.id_dom "main" in - let () = Dom.appendChild main - (Tyxml_js.To_dom.of_div (Panel_projects.content ())) in + let () = + Dom.appendChild main (Tyxml_js.To_dom.of_div (Panel_projects.content ())) + in let () = Dom.appendChild main (Panel_tab.navtabs ()) in let () = Dom.appendChild main (Panel_tab.navcontents ()) in - let () = Dom.appendChild main - (Tyxml_js.To_dom.of_div (Panel_settings.content ())) in + let () = + Dom.appendChild main (Tyxml_js.To_dom.of_div (Panel_settings.content ())) + in let () = Panel_projects.onload () in let () = Panel_tab.onload () in let () = Panel_settings.onload () in - let _ = Dom_html.window##.onresize := - Dom_html.handler - (fun _ -> + let _ = + Dom_html.window##.onresize := + Dom_html.handler (fun _ -> let () = Panel_projects.onresize () in let () = Panel_tab.onresize () in let () = Panel_settings.onresize () in Js._true) - in Js._true + in + Js._true let _ = Dom_html.window##.onload := Dom_html.handler onload diff --git a/gui/KaMoHaWorker.ml b/gui/KaMoHaWorker.ml index 0760d289bc..a708a87186 100644 --- a/gui/KaMoHaWorker.ml +++ b/gui/KaMoHaWorker.ml @@ -8,9 +8,10 @@ let on_message = let f = - Kappa_grammar.Kamoha_mpi.on_message - Js_of_ocaml_lwt.Lwt_js.yield - (fun s -> let () = Js_of_ocaml.Worker.post_message s in Lwt.return_unit) - in fun text_message -> Lwt.ignore_result (f text_message) + Kappa_grammar.Kamoha_mpi.on_message Js_of_ocaml_lwt.Lwt_js.yield (fun s -> + let () = Js_of_ocaml.Worker.post_message s in + Lwt.return_unit) + in + fun text_message -> Lwt.ignore_result (f text_message) let () = Js_of_ocaml.Worker.set_onmessage on_message diff --git a/gui/KaSaWorker.ml b/gui/KaSaWorker.ml index be805dc736..259ae377f6 100644 --- a/gui/KaSaWorker.ml +++ b/gui/KaSaWorker.ml @@ -7,8 +7,6 @@ (******************************************************************************) let on_message (text_message : string) : unit = - Kasa_mpi.on_message - (fun s -> Worker.post_message s) - text_message + Kasa_mpi.on_message (fun s -> Worker.post_message s) text_message let () = Worker.set_onmessage on_message diff --git a/gui/KaSimWorker.ml b/gui/KaSimWorker.ml index 170ac6f2fd..00d1682d37 100644 --- a/gui/KaSimWorker.ml +++ b/gui/KaSimWorker.ml @@ -12,6 +12,7 @@ class system_process () : Kappa_facade.system_process = let () = Common.debug exn in let () = Common.debug msg in Lwt.return_unit + method yield () : unit Lwt.t = Js_of_ocaml_lwt.Lwt_js.yield () method min_run_duration () = 0.1 end @@ -21,8 +22,10 @@ let manager : Api.manager_simulation = new Api_runtime.manager sytem_process let on_message (text_message : string) : unit = Lwt.ignore_result - (Mpi_api.on_message - manager - (fun s -> let () = Worker.post_message s in Lwt.return_unit) + (Mpi_api.on_message manager + (fun s -> + let () = Worker.post_message s in + Lwt.return_unit) text_message) + let () = Worker.set_onmessage on_message diff --git a/gui/KaStorWorker.ml b/gui/KaStorWorker.ml index 307f2bb482..dbb90ec15c 100644 --- a/gui/KaStorWorker.ml +++ b/gui/KaStorWorker.ml @@ -7,8 +7,7 @@ (******************************************************************************) let on_message = - Kastor_mpi.on_message - ~none:false ~weak:true ~strong:false + Kastor_mpi.on_message ~none:false ~weak:true ~strong:false ~send_message:Worker.post_message let () = Worker.set_onmessage on_message diff --git a/gui/codemirror.ml b/gui/codemirror.ml index 3949a6fd8b..6a4f6a71bc 100644 --- a/gui/codemirror.ml +++ b/gui/codemirror.ml @@ -12,75 +12,92 @@ http://peppermint.jp/temp/ao/ao.ml *) let prototype = Js.Unsafe.js_expr "CodeMirror.prototype" + let create_handler label = let head : char = Char.uppercase_ascii (String.get label 0) in - let tail : string = String.sub label 1 ((String.length label) -1) in - let on_label = "on"^(Char.escaped head)^tail in + let tail : string = String.sub label 1 (String.length label - 1) in + let on_label = "on" ^ Char.escaped head ^ tail in let wrapper handler = (Js.Unsafe.pure_js_expr "this")##on label handler in - let () = Js.Unsafe.set prototype - (Js.string on_label) - wrapper - in + let () = Js.Unsafe.set prototype (Js.string on_label) wrapper in () + (* add on handlers to the prototypes so they can be strongly typed *) -let () = List.iter create_handler - ["beforeChange";"beforeCursorEnter" - ;"beforeSelectionChange";"blur" - ;"changes";"clear" - ;"contextmenu";"copy" - ;"cursorActivity";"cut" - ;"dblclick";"delete" - ;"dragenter";"dragleave" - ;"dragover";"dragstart" - ;"drop";"electricInput" - ;"focus";"gutterClick" - ;"gutterContextMenu";"hide" - ;"inputRead";"keyHandled" - ;"keypress";"keyup" - ;"mousedown";"paste" - ;"redraw";"renderLine" - ;"scroll";"scrollCursorIntoView" - ;"swapDoc";"touchstart" - ;"unhide";"update" - ;"viewportChange";"change" - ;"keydown"] - -class type position = - object - method ch : int Js.readonly_prop - method line : int Js.readonly_prop - end - -class type dimension = - object - method left : int Js.readonly_prop - method right : int Js.readonly_prop - method top : int Js.readonly_prop - method bottom : int Js.readonly_prop - end +let () = + List.iter create_handler + [ + "beforeChange"; + "beforeCursorEnter"; + "beforeSelectionChange"; + "blur"; + "changes"; + "clear"; + "contextmenu"; + "copy"; + "cursorActivity"; + "cut"; + "dblclick"; + "delete"; + "dragenter"; + "dragleave"; + "dragover"; + "dragstart"; + "drop"; + "electricInput"; + "focus"; + "gutterClick"; + "gutterContextMenu"; + "hide"; + "inputRead"; + "keyHandled"; + "keypress"; + "keyup"; + "mousedown"; + "paste"; + "redraw"; + "renderLine"; + "scroll"; + "scrollCursorIntoView"; + "swapDoc"; + "touchstart"; + "unhide"; + "update"; + "viewportChange"; + "change"; + "keydown"; + ] +class type position = object + method ch : int Js.readonly_prop + method line : int Js.readonly_prop +end + +class type dimension = object + method left : int Js.readonly_prop + method right : int Js.readonly_prop + method top : int Js.readonly_prop + method bottom : int Js.readonly_prop +end let position : (int -> int -> position Js.t) Js.constr = (Js.Unsafe.js_expr "CodeMirror")##._Pos type severity = Error | Warning -class type lint = - object - method message: Js.js_string Js.t Js.prop - method severity: Js.js_string Js.t Js.prop - method from : position Js.t Js.prop - method to_ : position Js.t Js.prop - end - -let constructor_lint : lint Js.t Js.constr = (Js.Unsafe.pure_js_expr "Object") -let create_lint ~(message : string) - ~(severity : severity) - ~(from : position Js.t) - ~(to_ : position Js.t) : lint Js.t = + +class type lint = object + method message : Js.js_string Js.t Js.prop + method severity : Js.js_string Js.t Js.prop + method from : position Js.t Js.prop + method to_ : position Js.t Js.prop +end + +let constructor_lint : lint Js.t Js.constr = Js.Unsafe.pure_js_expr "Object" + +let create_lint ~(message : string) ~(severity : severity) + ~(from : position Js.t) ~(to_ : position Js.t) : lint Js.t = let result = new%js constructor_lint in - let () = result##.message := Js.string message - in - let () = result##.severity := + let () = result##.message := Js.string message in + let () = + result##.severity := match severity with | Error -> Js.string "error" | Warning -> Js.string "warning" @@ -89,358 +106,347 @@ let create_lint ~(message : string) let () = result##.to_ := to_ in result -class type change = - object - method from : position Js.t Js.prop - method to_ : position Js.t Js.prop - method text : Js.string_array Js.t Js.prop - method removed : string Js.t Js.prop - method origin : string Js.t Js.prop - end;; - -let constructor_change : change Js.t Js.constr = (Js.Unsafe.pure_js_expr "Object") -let create_change () : change Js.t = new%js constructor_change - -class type codemirror = - object - method getValue : Js.js_string Js.t Js.meth - method setValue : Js.js_string Js.t -> unit Js.meth - method focus : unit Js.t Js.meth - - (* Programmatically set the size of the editor (overriding the - applicable CSS rules). width and height can be either numbers - (interpreted as pixels) or CSS units ("100%", for example). - You can pass null for either of them to indicate that that - dimension should not be changed. - *) - method setSize : int Js.t Js.opt -> int Js.t Js.opt -> unit Js.meth - (* Scroll the editor to a given (pixel) position. Both arguments - may be left as null or undefined to have no effect. *) - method scrollTo : int Js.opt -> int Js.opt -> unit Js.meth - - method charCoords : - position Js.t -> - Js.js_string Js.t Js.opt -> - dimension Js.t Js.meth - - method getScrollerElement : Dom_html.element Js.t Js.meth - - method on : - (Js.js_string Js.t) -> - (Dom_html.event Js.t -> unit) -> - unit Js.meth - (* fired when content is changed *) - method onChange : - (codemirror Js.t -> - change Js.t -> - unit) -> unit Js.meth - (* batched changed operation *) - method onChanges : - (codemirror Js.t -> - change Js.js_array Js.t -> - unit) -> unit Js.meth - (* before a change is applied *) - method onBeforeChange : - (codemirror Js.t -> - change Js.t -> - unit) -> unit Js.meth - (* cursor moves, or any change *) - method onCursorActivity : - (codemirror Js.t -> - unit) -> unit Js.meth - (* when new input is read *) - method onKeyHandled : - (codemirror Js.t -> - Js.js_string -> - Dom_html.event -> - unit) -> unit Js.meth - (* when new input is read *) - method onInputRead : - (codemirror Js.t -> - change Js.t -> - unit ) -> unit Js.meth - (* when text matches electric pattern *) - method onElectricInput : - (codemirror Js.t -> int Js.t -> unit) -> - unit Js.meth - (* before a selection is moved TODO *) - method onBeforeSelectionChange : - (codemirror Js.t -> 'a -> unit) -> - unit Js.meth - (* the view port changed *) - method onViewportChange : - (codemirror Js.t -> - int Js.t -> - int Js.t -> - unit) -> unit Js.meth - (* document swapped *) - method onSwapDoc : - (codemirror Js.t -> 'a -> unit) -> - unit Js.meth - (* gutter clicked *) - method onGutterClick : - (codemirror Js.t -> - int Js.t -> - Js.js_string -> - Dom_html.event Js.t -> unit) -> - unit Js.meth - (* context menu event from gutter *) - method onGutterContextMenu : - (codemirror Js.t -> - int Js.t -> - Js.js_string -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - (* focus *) - method onFocus : - (codemirror Js.t -> - unit) -> unit Js.meth - (* blur *) - method onBlur : - (codemirror Js.t -> - unit) -> unit Js.meth - (* scroll *) - method onScroll : - (codemirror Js.t -> - unit) -> unit Js.meth - (* cursor scrolled in view*) - method onScrollCursorIntoView : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - (* dom updated *) - method onUpdate : - (codemirror Js.t -> - unit) -> unit Js.meth - (* line rendered *) - method onRenderLine : - (codemirror Js.t -> - 'a -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onMousedown : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onDblclick : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onTouchstart : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onContextmenu : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onKeydown : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onKeypress : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onKeyup : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onCut : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onCopy : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onPaste : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onDragstart : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onDragenter : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onDragover : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onDragleave : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onDrop : - (codemirror Js.t -> - Dom_html.event Js.t -> - unit) -> unit Js.meth - method onDelete : - (unit -> - unit) -> unit Js.meth - method onBeforeCursorEnter : - (unit -> - unit) -> unit Js.meth - method onClear : - (position Js.t -> - position Js.t -> - unit) -> unit Js.meth - method onHide : - (unit -> - unit) -> unit Js.meth - method onUnhide : - (unit -> - unit) -> unit Js.meth - method onRedraw : - (unit -> - unit) -> unit Js.meth - - method setCursor : position Js.t -> unit Js.meth - - method getCursor : position Js.t Js.meth - - method setSelection : position Js.t -> position Js.t -> unit Js.meth - - method performLint : unit Js.t Js.meth - end;; - -class type lint_configuration = - object - method delay : int Js.t Js.prop - method async : bool Js.t Js.prop - method getAnnotations : - (Js.js_string -> lint_configuration Js.t -> codemirror Js.t -> lint Js.t Js.js_array Js.t) Js.writeonly_prop - method lintOnChange : bool Js.t Js.prop - end +class type change = object + method from : position Js.t Js.prop + method to_ : position Js.t Js.prop + method text : Js.string_array Js.t Js.prop + method removed : string Js.t Js.prop + method origin : string Js.t Js.prop +end + +let constructor_change : change Js.t Js.constr = Js.Unsafe.pure_js_expr "Object" +let create_change () : change Js.t = new%js constructor_change + +class type codemirror = object + method getValue : Js.js_string Js.t Js.meth + method setValue : Js.js_string Js.t -> unit Js.meth + method focus : unit Js.meth + + (* Programmatically set the size of the editor (overriding the + applicable CSS rules). width and height can be either numbers + (interpreted as pixels) or CSS units ("100%", for example). + You can pass null for either of them to indicate that that + dimension should not be changed. + *) + method setSize : int Js.t Js.opt -> int Js.t Js.opt -> unit Js.meth + + (* Scroll the editor to a given (pixel) position. Both arguments + may be left as null or undefined to have no effect. *) + method scrollTo : int Js.opt -> int Js.opt -> unit Js.meth + + method charCoords : + position Js.t -> Js.js_string Js.t Js.opt -> dimension Js.t Js.meth + + method getScrollerElement : Dom_html.element Js.t Js.meth + method on : Js.js_string Js.t -> (Dom_html.event Js.t -> unit) -> unit Js.meth + + (* fired when content is changed *) + method onChange : (codemirror Js.t -> change Js.t -> unit) -> unit Js.meth + + (* batched changed operation *) + method onChanges : + (codemirror Js.t -> change Js.js_array Js.t -> unit) -> unit Js.meth + + (* before a change is applied *) + method onBeforeChange : + (codemirror Js.t -> change Js.t -> unit) -> unit Js.meth + + (* cursor moves, or any change *) + method onCursorActivity : (codemirror Js.t -> unit) -> unit Js.meth + + (* when new input is read *) + method onKeyHandled : + (codemirror Js.t -> Js.js_string -> Dom_html.event -> unit) -> unit Js.meth + + (* when new input is read *) + method onInputRead : (codemirror Js.t -> change Js.t -> unit) -> unit Js.meth + + (* when text matches electric pattern *) + method onElectricInput : (codemirror Js.t -> int Js.t -> unit) -> unit Js.meth + + (* before a selection is moved TODO *) + method onBeforeSelectionChange : + (codemirror Js.t -> 'a -> unit) -> unit Js.meth + + (* the view port changed *) + method onViewportChange : + (codemirror Js.t -> int Js.t -> int Js.t -> unit) -> unit Js.meth + + (* document swapped *) + method onSwapDoc : (codemirror Js.t -> 'a -> unit) -> unit Js.meth + + (* gutter clicked *) + method onGutterClick : + (codemirror Js.t -> int Js.t -> Js.js_string -> Dom_html.event Js.t -> unit) -> + unit Js.meth + + (* context menu event from gutter *) + method onGutterContextMenu : + (codemirror Js.t -> int Js.t -> Js.js_string -> Dom_html.event Js.t -> unit) -> + unit Js.meth + + (* focus *) + method onFocus : (codemirror Js.t -> unit) -> unit Js.meth + + (* blur *) + method onBlur : (codemirror Js.t -> unit) -> unit Js.meth + + (* scroll *) + method onScroll : (codemirror Js.t -> unit) -> unit Js.meth + + (* cursor scrolled in view*) + method onScrollCursorIntoView : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + (* dom updated *) + method onUpdate : (codemirror Js.t -> unit) -> unit Js.meth + + (* line rendered *) + method onRenderLine : + (codemirror Js.t -> 'a -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onMousedown : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onDblclick : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onTouchstart : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onContextmenu : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onKeydown : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onKeypress : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onKeyup : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onCut : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onCopy : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onPaste : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onDragstart : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onDragenter : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onDragover : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onDragleave : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onDrop : + (codemirror Js.t -> Dom_html.event Js.t -> unit) -> unit Js.meth + + method onDelete : (unit -> unit) -> unit Js.meth + method onBeforeCursorEnter : (unit -> unit) -> unit Js.meth + method onClear : (position Js.t -> position Js.t -> unit) -> unit Js.meth + method onHide : (unit -> unit) -> unit Js.meth + method onUnhide : (unit -> unit) -> unit Js.meth + method onRedraw : (unit -> unit) -> unit Js.meth + method setCursor : position Js.t -> unit Js.meth + method getCursor : position Js.t Js.meth + method setSelection : position Js.t -> position Js.t -> unit Js.meth + method performLint : unit Js.meth +end + +class type lint_configuration = object + method delay : int Js.t Js.prop + method async : bool Js.t Js.prop + + method getAnnotations : + (Js.js_string -> + lint_configuration Js.t -> + codemirror Js.t -> + lint Js.t Js.js_array Js.t) + Js.writeonly_prop + + method lintOnChange : bool Js.t Js.prop +end + let constructor_lint_configuration : lint_configuration Js.t Js.constr = - (Js.Unsafe.pure_js_expr "Object") -let create_lint_configuration () : lint_configuration Js.t = + Js.Unsafe.pure_js_expr "Object" + +let create_lint_configuration () : lint_configuration Js.t = new%js constructor_lint_configuration -class type configuration = - object - (* The starting value of the editor. *) - method value: Js.js_string Js.t Js.prop - (* The mode to use. *) - method mode : Js.js_string Js.t Js.prop - (* Explicitly set the line separator for the editor. *) - method lineSeparator : Js.js_string Js.opt Js.t Js.prop - (* The theme to style the editor with. *) - method theme: Js.js_string Js.t Js.prop - (* How many spaces a block should be indented. *) - method indentUnit: int Js.t Js.prop - (* Whether to use the context-sensitive indentation *) - method smartIndent: bool Js.t Js.prop - (* The width of a tab character. *) - method tabSize: int Js.t Js.prop - (* The first N*tabSize in indentation should N tabs. *) - method indentWithTabs: bool Js.t Js.prop - (* The editor should re-indent the current line. *) - method electricChars: bool Js.t Js.prop - (* A regular expression used to determine special placeholder. *) - method specialChars: Js.regExp Js.t Js.prop - (* A function identifies specialChars and produces a DOM node *) - method specialCharPlaceholder: (int -> Dom_html.element Js.t) Js.prop - (* Horizontal cursor movement through right-to-left. *) - method rtlMoveVisually: bool Js.t Js.prop - (* Configures the key map to use. *) - method keyMap: string Js.t Js.prop - (* specify extra key bindings for the editor *) - method extraKeys : 'a Js.prop - (* Scroll or wrap for long lines *) - method lineWrapping: bool Js.t Js.prop - (* Show line numbers to the left of the editor *) - method lineNumbers : bool Js.t Js.prop - (* At which number to start counting lines. Default is 1. *) - method firstLineNumber : int Js.t Js.prop - (* A function used to format line numbers. *) - method lineNumberFormatter: (int Js.t -> Js.js_string) Js.t Js.prop - (* Add extra gutters *) - method gutters : Js.string_array Js.t Js.prop - (* Gutter scrolls along with the content horizontally *) - method fixedGutter: bool Js.t Js.prop - (* Chooses a scrollbar implementation. *) - method scrollbarStyle: string Js.t Js.prop - (* cover gutter with with class CodeMirror-gutter-filler. *) - method coverGutterNextToScrollbar: bool Js.t Js.prop - (* Selects the way CodeMirror handles input and focus. *) - method inputStyle: string Js.t Js.prop - (* disable editing of the editor content *) - method readOnly: bool Js.t Js.prop - (* the cursor should be drawn when a selection is active. *) - method showCursorWhenSelecting: bool Js.t Js.prop - (* copy or cut when there is no selection will copy or cut whole lines *) - method lineWiseCopyCut: bool Js.t Js.prop - (* When pasting something from an external source (not from the - editor itself), if the number of lines matches the number of - selection, CodeMirror will by default insert one line per - selection. You can set this to false to disable that - behavior. *) - method pasteLinesPerSelection: bool Js.t Js.prop - (* Determines whether multiple selections are joined as soon as - they touch (the default) or only when they overlap (true). *) - method selectionsMayTouch: bool Js.t Js.prop - (* maximum number of undo *) - method undoDepth: int Js.t Js.prop - (* milliseconds of inactivity to create a new history event *) - method historyEventDelay: int Js.t Js.prop - (* tab index of editor *) - method tabindex: int Js.t Js.prop - (* CodeMirror focus itself on initialization *) - method autofocus: bool Js.t Js.prop - (* enable drag-and-drop *) - method dragDrop: bool Js.t Js.prop - (* when set files wit mime type can be dropped into the editor *) - method allowDropFileTypes: Js.string_array Js.opt Js.t Js.prop - (* Half-period in milliseconds used for cursor blinking. *) - method cursorBlinkRate: int Js.t Js.prop - (* How much extra space to always keep above and below the cursor *) - method cursorScrollMargin: int Js.t Js.prop - (* Determines the height of the cursor. *) - method cursorHeight: int Js.t Js.prop - (* the context menu is opened with a click outside of the - current selection, move cursor to the point of the click*) - method resetSelectionOnContextMenu: bool Js.t Js.prop - (* time to run highlighting thread *) - method workTime: int Js.t Js.prop - (* delay to run highlighting thread *) - method workDelay: int Js.t Js.prop - (* how often to poll for changes *) - method pollInterval: int Js.t Js.prop - (* combine tokens to a single span *) - method flattenSpans: bool Js.t Js.prop - (* prefix css *) - method addModeClass: bool Js.t Js.prop - (* length to highlight *) - method maxHighlightLength: bool Js.t Js.prop - (* amount of lines that are rendered above and below the - visible document*) - method viewportMargin: int Js.t Js.prop - - (* ADDON selection/active-line.js *) - method styleActiveLine: bool Js.t Js.prop - (* ADDON lint/lint.js *) - method lint : lint_configuration Js.t Js.prop - (* ADDON edit/matchbrackets.js *) - method matchBrackets: bool Js.t Js.prop - end -let default_configuration : configuration Js.t = +class type configuration = object + (* The starting value of the editor. *) + method value : Js.js_string Js.t Js.prop + + (* The mode to use. *) + method mode : Js.js_string Js.t Js.prop + + (* Explicitly set the line separator for the editor. *) + method lineSeparator : Js.js_string Js.opt Js.t Js.prop + + (* The theme to style the editor with. *) + method theme : Js.js_string Js.t Js.prop + + (* How many spaces a block should be indented. *) + method indentUnit : int Js.t Js.prop + + (* Whether to use the context-sensitive indentation *) + method smartIndent : bool Js.t Js.prop + + (* The width of a tab character. *) + method tabSize : int Js.t Js.prop + + (* The first N*tabSize in indentation should N tabs. *) + method indentWithTabs : bool Js.t Js.prop + + (* The editor should re-indent the current line. *) + method electricChars : bool Js.t Js.prop + + (* A regular expression used to determine special placeholder. *) + method specialChars : Js.regExp Js.t Js.prop + + (* A function identifies specialChars and produces a DOM node *) + method specialCharPlaceholder : (int -> Dom_html.element Js.t) Js.prop + + (* Horizontal cursor movement through right-to-left. *) + method rtlMoveVisually : bool Js.t Js.prop + + (* Configures the key map to use. *) + method keyMap : string Js.t Js.prop + + (* specify extra key bindings for the editor *) + method extraKeys : 'a Js.prop + + (* Scroll or wrap for long lines *) + method lineWrapping : bool Js.t Js.prop + + (* Show line numbers to the left of the editor *) + method lineNumbers : bool Js.t Js.prop + + (* At which number to start counting lines. Default is 1. *) + method firstLineNumber : int Js.t Js.prop + + (* A function used to format line numbers. *) + method lineNumberFormatter : (int Js.t -> Js.js_string) Js.t Js.prop + + (* Add extra gutters *) + method gutters : Js.string_array Js.t Js.prop + + (* Gutter scrolls along with the content horizontally *) + method fixedGutter : bool Js.t Js.prop + + (* Chooses a scrollbar implementation. *) + method scrollbarStyle : string Js.t Js.prop + + (* cover gutter with with class CodeMirror-gutter-filler. *) + method coverGutterNextToScrollbar : bool Js.t Js.prop + + (* Selects the way CodeMirror handles input and focus. *) + method inputStyle : string Js.t Js.prop + + (* disable editing of the editor content *) + method readOnly : bool Js.t Js.prop + + (* the cursor should be drawn when a selection is active. *) + method showCursorWhenSelecting : bool Js.t Js.prop + + (* copy or cut when there is no selection will copy or cut whole lines *) + method lineWiseCopyCut : bool Js.t Js.prop + + (* When pasting something from an external source (not from the + editor itself), if the number of lines matches the number of + selection, CodeMirror will by default insert one line per + selection. You can set this to false to disable that + behavior. *) + method pasteLinesPerSelection : bool Js.t Js.prop + + (* Determines whether multiple selections are joined as soon as + they touch (the default) or only when they overlap (true). *) + method selectionsMayTouch : bool Js.t Js.prop + + (* maximum number of undo *) + method undoDepth : int Js.t Js.prop + + (* milliseconds of inactivity to create a new history event *) + method historyEventDelay : int Js.t Js.prop + + (* tab index of editor *) + method tabindex : int Js.t Js.prop + + (* CodeMirror focus itself on initialization *) + method autofocus : bool Js.t Js.prop + + (* enable drag-and-drop *) + method dragDrop : bool Js.t Js.prop + + (* when set files wit mime type can be dropped into the editor *) + method allowDropFileTypes : Js.string_array Js.opt Js.t Js.prop + + (* Half-period in milliseconds used for cursor blinking. *) + method cursorBlinkRate : int Js.t Js.prop + + (* How much extra space to always keep above and below the cursor *) + method cursorScrollMargin : int Js.t Js.prop + + (* Determines the height of the cursor. *) + method cursorHeight : int Js.t Js.prop + + (* the context menu is opened with a click outside of the + current selection, move cursor to the point of the click*) + method resetSelectionOnContextMenu : bool Js.t Js.prop + + (* time to run highlighting thread *) + method workTime : int Js.t Js.prop + + (* delay to run highlighting thread *) + method workDelay : int Js.t Js.prop + + (* how often to poll for changes *) + method pollInterval : int Js.t Js.prop + + (* combine tokens to a single span *) + method flattenSpans : bool Js.t Js.prop + + (* prefix css *) + method addModeClass : bool Js.t Js.prop + + (* length to highlight *) + method maxHighlightLength : bool Js.t Js.prop + + (* amount of lines that are rendered above and below the + visible document*) + method viewportMargin : int Js.t Js.prop + + (* ADDON selection/active-line.js *) + method styleActiveLine : bool Js.t Js.prop + + (* ADDON lint/lint.js *) + method lint : lint_configuration Js.t Js.prop + + (* ADDON edit/matchbrackets.js *) + method matchBrackets : bool Js.t Js.prop +end + +let default_configuration : configuration Js.t = (Js.Unsafe.js_expr "CodeMirror")##.defaults -let fromTextArea - (dom : Dom_html.element Js.t) - (configuration : configuration Js.t) - : codemirror Js.t = +let fromTextArea (dom : Dom_html.element Js.t) + (configuration : configuration Js.t) : codemirror Js.t = (* let () = Js.debugger() in *) (Js.Unsafe.js_expr "CodeMirror")##fromTextArea - (Js.Unsafe.inject dom) (Js.Unsafe.inject configuration) + (Js.Unsafe.inject dom) + (Js.Unsafe.inject configuration) class type commands = object method save : (codemirror Js.t -> unit) Js.prop end -let commands : commands Js.t = - (Js.Unsafe.js_expr "CodeMirror")##.commands +let commands : commands Js.t = (Js.Unsafe.js_expr "CodeMirror")##.commands diff --git a/gui/common.ml b/gui/common.ml index d7db11bb52..8fc249703a 100644 --- a/gui/common.ml +++ b/gui/common.ml @@ -7,102 +7,82 @@ (******************************************************************************) (* need to specify messages where there is an error *) -let toss : 'a 'b . 'a -> 'b = - fun e -> - let () = Js.Unsafe.fun_call - (Js.Unsafe.js_expr "toss") - [| Js.Unsafe.inject e |] - in assert false +let toss : 'a 'b. 'a -> 'b = + fun e -> + let () = + Js.Unsafe.fun_call (Js.Unsafe.js_expr "toss") [| Js.Unsafe.inject e |] + in + assert false let id value = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "id") - [| Js.Unsafe.inject value |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "id") [| Js.Unsafe.inject value |] let debug value = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "debug") - [| Js.Unsafe.inject value |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "debug") [| Js.Unsafe.inject value |] let info value = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "info") - [| Js.Unsafe.inject value |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "info") [| Js.Unsafe.inject value |] let notice value = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "notice") - [| Js.Unsafe.inject value |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "notice") [| Js.Unsafe.inject value |] let warning value = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "warning") - [| Js.Unsafe.inject value |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "warning") [| Js.Unsafe.inject value |] let error value = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "error") - [| Js.Unsafe.inject value |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "error") [| Js.Unsafe.inject value |] let fatal value = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "fatal") - [| Js.Unsafe.inject value |] -let jquery_on - (selector : string) - (event : string) - handler = + Js.Unsafe.fun_call (Js.Unsafe.js_expr "fatal") [| Js.Unsafe.inject value |] + +let jquery_on (selector : string) (event : string) handler = Js.Unsafe.fun_call (Js.Unsafe.js_expr "jqueryOn") - [| Js.Unsafe.inject (Js.string selector); - Js.Unsafe.inject (Js.string event); - Js.Unsafe.inject handler |] + [| + Js.Unsafe.inject (Js.string selector); + Js.Unsafe.inject (Js.string event); + Js.Unsafe.inject handler; + |] let option_string (id : string option) = match id with - Some id -> Js.some (Js.string id) + | Some id -> Js.some (Js.string id) | None -> Js.null -let plotPNG - ?(plotStyleId : string option) - (plotDivId : string) - (title:string) +let plotPNG ?(plotStyleId : string option) (plotDivId : string) (title : string) (plotName : string) = Js.Unsafe.fun_call (Js.Unsafe.js_expr "plotPNG") - [| Js.Unsafe.inject (Js.string plotDivId); - Js.Unsafe.inject (Js.string title); - Js.Unsafe.inject (Js.string plotName); - Js.Unsafe.inject (option_string plotStyleId) + [| + Js.Unsafe.inject (Js.string plotDivId); + Js.Unsafe.inject (Js.string title); + Js.Unsafe.inject (Js.string plotName); + Js.Unsafe.inject (option_string plotStyleId); |] -let plotSVG - ?(plotStyleId : string option) - (plotDivId : string) - (title:string) +let plotSVG ?(plotStyleId : string option) (plotDivId : string) (title : string) (plotName : string) = Js.Unsafe.fun_call (Js.Unsafe.js_expr "plotSVG") - [| Js.Unsafe.inject (Js.string plotDivId); - Js.Unsafe.inject (Js.string title); - Js.Unsafe.inject (Js.string plotName); - Js.Unsafe.inject (option_string plotStyleId) + [| + Js.Unsafe.inject (Js.string plotDivId); + Js.Unsafe.inject (Js.string title); + Js.Unsafe.inject (Js.string plotName); + Js.Unsafe.inject (option_string plotStyleId); |] -let saveFile - ~(data : 'a Js.t) - ~(mime : string) - ~(filename : string) : unit = +let saveFile ~(data : 'a Js.t) ~(mime : string) ~(filename : string) : unit = Js.Unsafe.fun_call (Js.Unsafe.js_expr "saveFile") - [| Js.Unsafe.inject data; - Js.Unsafe.inject (Js.string mime); - Js.Unsafe.inject (Js.string filename) + [| + Js.Unsafe.inject data; + Js.Unsafe.inject (Js.string mime); + Js.Unsafe.inject (Js.string filename); |] type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] -let method_to_string : meth -> string = - function + +let method_to_string : meth -> string = function | `DELETE -> "DELETE" | `GET -> "GET" | `HEAD -> "HEAD" @@ -111,38 +91,32 @@ let method_to_string : meth -> string = | `POST -> "POST" | `PUT -> "PUT" -let ajax_request - ?(timeout: float option) - ~(url : string) - ~(meth : meth) - ?(data : string option) - ~(handler : int -> string -> unit) = +let ajax_request ?(timeout : float option) ~(url : string) ~(meth : meth) + ?(data : string option) ~(handler : int -> string -> unit) = Js.Unsafe.fun_call (Js.Unsafe.js_expr "ajaxRequest") - [| Js.Unsafe.inject - (Js.string url); - Js.Unsafe.inject - (Js.string (method_to_string meth)); - Js.Unsafe.inject - (Js.Opt.option - (match data with - | None -> None - | Some data -> Some (Js.string data))); - Js.Unsafe.inject - (Js.wrap_callback - (fun status response -> - let () = - debug - (Js.string ("request "^url^" answer: "^string_of_int status)) in - let () = debug response in - handler - status - (Js.to_string response))); - Js.Unsafe.inject - (Js.Opt.option - (match timeout with - | None -> None - | Some timeout -> Some timeout)); + [| + Js.Unsafe.inject (Js.string url); + Js.Unsafe.inject (Js.string (method_to_string meth)); + Js.Unsafe.inject + (Js.Opt.option + (match data with + | None -> None + | Some data -> Some (Js.string data))); + Js.Unsafe.inject + (Js.wrap_callback (fun status response -> + let () = + debug + (Js.string + ("request " ^ url ^ " answer: " ^ string_of_int status)) + in + let () = debug response in + handler status (Js.to_string response))); + Js.Unsafe.inject + (Js.Opt.option + (match timeout with + | None -> None + | Some timeout -> Some timeout)); |] (* This is to handle errors being lost in asyncs @@ -150,65 +124,46 @@ let ajax_request code. *) let async loc (task : unit -> 'a Lwt.t) : unit = - Js_of_ocaml_lwt.Lwt_js_events.async - (fun () -> - Lwt.catch - task - (fun exn -> - let () = info (Js.string (loc^Printexc.to_string exn)) in - let () = debug (Js.string (Printexc.get_backtrace ())) in - Lwt.return_unit - ) - ) + Js_of_ocaml_lwt.Lwt_js_events.async (fun () -> + Lwt.catch task (fun exn -> + let () = info (Js.string (loc ^ Printexc.to_string exn)) in + let () = debug (Js.string (Printexc.get_backtrace ())) in + Lwt.return_unit)) let guid () : string = - Js.to_string - (Js.Unsafe.fun_call - (Js.Unsafe.js_expr "guid") - [| |]) + Js.to_string (Js.Unsafe.fun_call (Js.Unsafe.js_expr "guid") [||]) -let modal ~(id: string) ~(action: string) : unit = +let modal ~(id : string) ~(action : string) : unit = Js.Unsafe.fun_call (Js.Unsafe.js_expr "modal") - [| Js.Unsafe.inject (Js.string id); - Js.Unsafe.inject (Js.string action); |] - -let element_data - (element : Dom_html.element Js.t) - (label : string) : Js.js_string Js.t Js.opt = - (Js.Unsafe.fun_call - (Js.Unsafe.js_expr "elementData") - [| Js.Unsafe.inject element; - Js.Unsafe.inject (Js.string label) |]) - -let create_sort - (id : string) - (handler : Dom_html.event Js.t -> 'b -> unit) : unit = + [| Js.Unsafe.inject (Js.string id); Js.Unsafe.inject (Js.string action) |] + +let element_data (element : Dom_html.element Js.t) (label : string) : + Js.js_string Js.t Js.opt = + Js.Unsafe.fun_call + (Js.Unsafe.js_expr "elementData") + [| Js.Unsafe.inject element; Js.Unsafe.inject (Js.string label) |] + +let create_sort (id : string) (handler : Dom_html.event Js.t -> 'b -> unit) : + unit = Js.Unsafe.fun_call (Js.Unsafe.js_expr "createSort") - [| Js.Unsafe.inject (Js.string id); - Js.Unsafe.inject handler - |] + [| Js.Unsafe.inject (Js.string id); Js.Unsafe.inject handler |] -let children_value - (element : Dom_html.element Js.t) - (selector : string) +let children_value (element : Dom_html.element Js.t) (selector : string) (map : Dom_html.element Js.t -> 'a) : 'a list = Array.to_list (Js.to_array (Js.Unsafe.fun_call (Js.Unsafe.js_expr "childrenValue") - [| Js.Unsafe.inject element ; - Js.Unsafe.inject (Js.string selector); - Js.Unsafe.inject map + [| + Js.Unsafe.inject element; + Js.Unsafe.inject (Js.string selector); + Js.Unsafe.inject map; |])) let hide_codemirror () : unit = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "hideCodeMirror") - [| |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "hideCodeMirror") [||] let show_codemirror () : unit = - Js.Unsafe.fun_call - (Js.Unsafe.js_expr "showCodeMirror") - [| |] + Js.Unsafe.fun_call (Js.Unsafe.js_expr "showCodeMirror") [||] diff --git a/gui/common.mli b/gui/common.mli index f2e069657c..af81a3868b 100644 --- a/gui/common.mli +++ b/gui/common.mli @@ -19,20 +19,27 @@ val option_string : string option -> Js.js_string Js.t Js.opt val plotPNG : ?plotStyleId:string -> string -> string -> string -> unit val plotSVG : ?plotStyleId:string -> string -> string -> string -> unit val saveFile : data:'a Js.t -> mime:string -> filename:string -> unit + type meth = [ `DELETE | `GET | `HEAD | `OPTIONS | `PATCH | `POST | `PUT ] + val method_to_string : meth -> string + val ajax_request : ?timeout:float -> url:string -> - meth:meth -> ?data:string -> handler:(int -> string -> unit) -> 'a + meth:meth -> + ?data:string -> + handler:(int -> string -> unit) -> + 'a + val async : string -> (unit -> unit Lwt.t) -> unit val guid : unit -> string val modal : id:string -> action:string -> unit -val element_data : - Dom_html.element Js.t -> string -> Js.js_string Js.t Js.opt +val element_data : Dom_html.element Js.t -> string -> Js.js_string Js.t Js.opt val create_sort : string -> (Dom_html.event Js.t -> 'b -> unit) -> unit + val children_value : - Dom_html.element Js.t -> - string -> (Dom_html.element Js.t -> 'a) -> 'a list + Dom_html.element Js.t -> string -> (Dom_html.element Js.t -> 'a) -> 'a list + val hide_codemirror : unit -> unit val show_codemirror : unit -> unit diff --git a/gui/common_state.ml b/gui/common_state.ml index 12f8e40c20..483c9fda7b 100644 --- a/gui/common_state.ml +++ b/gui/common_state.ml @@ -6,12 +6,11 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) - -let url_args ?(default = [] ) key : string list = +let url_args ?(default = []) key : string list = (* Hosts the user specified on the url in the form key=...&key=..&... *) let args = Url.Current.arguments in - match (List.map snd (List.filter (fun (k,_) -> k = key) args)) with + match List.map snd (List.filter (fun (k, _) -> k = key) args) with | [] -> default | some -> some diff --git a/gui/js_contact.ml b/gui/js_contact.ml index 3f9871ec63..32cda24ace 100644 --- a/gui/js_contact.ml +++ b/gui/js_contact.ml @@ -6,14 +6,13 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -class type contact_map = - object - method setData : Js.js_string Js.t -> unit Js.meth - method redraw : unit Js.meth - method clearData : unit Js.meth - end +class type contact_map = object + method setData : Js.js_string Js.t -> unit Js.meth + method redraw : unit Js.meth + method clearData : unit Js.meth +end -let create_contact_map - (id : string) (coloring : unit Js.t) : contact_map Js.t = - Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "ContactMap") +let create_contact_map (id : string) (coloring : unit Js.t) : contact_map Js.t = + Js.Unsafe.new_obj + (Js.Unsafe.pure_js_expr "ContactMap") [| Js.Unsafe.inject (Js.string id); Js.Unsafe.inject coloring |] diff --git a/gui/js_flux.ml b/gui/js_flux.ml index 2d8c95a426..cb0193819b 100644 --- a/gui/js_flux.ml +++ b/gui/js_flux.ml @@ -19,59 +19,36 @@ class type flux_configuration = object val width : int Js.t Js.prop val shortLabels : bool Js.t Js.prop end + let constructor_configuration : flux_configuration Js.t Js.constr = - (Js.Unsafe.pure_js_expr "Object") -let create_configuration - ~(short_labels : bool) - ~(begin_time_id : string) - ~(end_time_id : string) - ~(select_correction_id : string) - ~(toggle_rules_id : string) - ~(checkbox_self_influence_id : string) - ~(nb_events_id : string) - ~(svg_id : string) - ~(rules_checkboxes_id : string) - ~(height: int) - ~(width: int) - : flux_configuration Js.t = + Js.Unsafe.pure_js_expr "Object" + +let create_configuration ~(short_labels : bool) ~(begin_time_id : string) + ~(end_time_id : string) ~(select_correction_id : string) + ~(toggle_rules_id : string) ~(checkbox_self_influence_id : string) + ~(nb_events_id : string) ~(svg_id : string) ~(rules_checkboxes_id : string) + ~(height : int) ~(width : int) : flux_configuration Js.t = let configuration : flux_configuration Js.t = new%js constructor_configuration in let () = - (Js.Unsafe.coerce configuration) - ##. - beginTimeId := Js.string begin_time_id; - (Js.Unsafe.coerce configuration) - ##. - endTimeId := Js.string end_time_id; - (Js.Unsafe.coerce configuration) - ##. - selectCorrectionId := Js.string select_correction_id; - (Js.Unsafe.coerce configuration) - ##. - checkboxSelfInfluenceId := Js.string checkbox_self_influence_id; - (Js.Unsafe.coerce configuration) - ##. - toggleRulesId := Js.string toggle_rules_id; - (Js.Unsafe.coerce configuration) - ##. - nbEventsId := Js.string nb_events_id; - (Js.Unsafe.coerce configuration) - ##. - svgId := Js.string svg_id; - (Js.Unsafe.coerce configuration) - ##. - rulesCheckboxesId := Js.string rules_checkboxes_id; - (Js.Unsafe.coerce configuration) - ##. - height := height; - (Js.Unsafe.coerce configuration) - ##. - width := width; - (Js.Unsafe.coerce configuration) - ##. - shortLabels := short_labels; - in configuration + (Js.Unsafe.coerce configuration)##.beginTimeId := Js.string begin_time_id; + (Js.Unsafe.coerce configuration)##.endTimeId := Js.string end_time_id; + (Js.Unsafe.coerce configuration)##.selectCorrectionId + := Js.string select_correction_id; + (Js.Unsafe.coerce configuration)##.checkboxSelfInfluenceId + := Js.string checkbox_self_influence_id; + (Js.Unsafe.coerce configuration)##.toggleRulesId + := Js.string toggle_rules_id; + (Js.Unsafe.coerce configuration)##.nbEventsId := Js.string nb_events_id; + (Js.Unsafe.coerce configuration)##.svgId := Js.string svg_id; + (Js.Unsafe.coerce configuration)##.rulesCheckboxesId + := Js.string rules_checkboxes_id; + (Js.Unsafe.coerce configuration)##.height := height; + (Js.Unsafe.coerce configuration)##.width := width; + (Js.Unsafe.coerce configuration)##.shortLabels := short_labels + in + configuration class type flux_data = object val bioBeginTime : float Js.t Js.prop @@ -82,16 +59,15 @@ class type flux_data = object val fluxs : int Js.js_array Js.js_array Js.t Js.prop end -let constructor_data : flux_data Js.t Js.constr = (Js.Unsafe.pure_js_expr "Object") -let create_data ~(flux_begin_time : float) - ~(flux_end_time : float) - ~(normalized : bool) - ~(flux_rules : string array) - ~(flux_hits: int array) - ~(flux_fluxs : float array array) - : flux_data Js.t = +let constructor_data : flux_data Js.t Js.constr = + Js.Unsafe.pure_js_expr "Object" + +let create_data ~(flux_begin_time : float) ~(flux_end_time : float) + ~(normalized : bool) ~(flux_rules : string array) ~(flux_hits : int array) + ~(flux_fluxs : float array array) : flux_data Js.t = let data : flux_data Js.t = new%js constructor_data in - let () = (Js.Unsafe.coerce data)##.bioBeginTime := flux_begin_time; + let () = + (Js.Unsafe.coerce data)##.bioBeginTime := flux_begin_time; (Js.Unsafe.coerce data)##.bioEndTime := flux_end_time; (Js.Unsafe.coerce data)##.normalized := normalized; (Js.Unsafe.coerce data)##.rules := Js.array (Array.map Js.string flux_rules); @@ -102,10 +78,11 @@ let create_data ~(flux_begin_time : float) data class type flux_map = object - method exportJSON : Js.js_string Js.t -> unit Js.meth + method exportJSON : Js.js_string Js.t -> unit Js.meth method setFlux : flux_data Js.t -> unit Js.meth -end;; +end let create_flux_map (configuration : flux_configuration Js.t) : flux_map Js.t = - Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "fluxMap") + Js.Unsafe.new_obj + (Js.Unsafe.pure_js_expr "fluxMap") [| Js.Unsafe.inject configuration |] diff --git a/gui/js_graphlogger.ml b/gui/js_graphlogger.ml index 1739b0dd9a..ee48ab6743 100644 --- a/gui/js_graphlogger.ml +++ b/gui/js_graphlogger.ml @@ -6,13 +6,13 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -class type graph_logger = - object - method setData : Js.js_string Js.t -> unit Js.meth - method clearData : unit Js.meth - end;; +class type graph_logger = object + method setData : Js.js_string Js.t -> unit Js.meth + method clearData : unit Js.meth +end -let create_graph_logger (id : string) (on_click : Js.js_string Js.t -> unit) - : graph_logger Js.t = - Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "GraphLogger") +let create_graph_logger (id : string) (on_click : Js.js_string Js.t -> unit) : + graph_logger Js.t = + Js.Unsafe.new_obj + (Js.Unsafe.pure_js_expr "GraphLogger") [| Js.Unsafe.inject (Js.string id); Js.Unsafe.inject on_click |] diff --git a/gui/js_plot.ml b/gui/js_plot.ml index 4692e9e508..8dbf415772 100644 --- a/gui/js_plot.ml +++ b/gui/js_plot.ml @@ -8,13 +8,13 @@ (*module ApiTypes = Api_types_j*) -class type observable_plot = - object - method setData : Js.js_string Js.t -> unit Js.meth - method clearData : unit Js.meth - method redraw : unit Js.meth - end +class type observable_plot = object + method setData : Js.js_string Js.t -> unit Js.meth + method clearData : unit Js.meth + method redraw : unit Js.meth +end let create_observable_plot main_div_id : observable_plot Js.t = - Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "ObservablePlot") + Js.Unsafe.new_obj + (Js.Unsafe.pure_js_expr "ObservablePlot") [| Js.Unsafe.inject (Js.string main_div_id) |] diff --git a/gui/js_snapshot.ml b/gui/js_snapshot.ml index 3221c9682d..05b47792d8 100644 --- a/gui/js_snapshot.ml +++ b/gui/js_snapshot.ml @@ -6,14 +6,15 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -class type snapshot = - object - method setData : - contact_map : Js.js_string Js.t -> Js.js_string Js.t -> unit Js.meth - method redraw : unit Js.meth - method clearData : unit Js.meth - end +class type snapshot = object + method setData : + contact_map:Js.js_string Js.t -> Js.js_string Js.t -> unit Js.meth + + method redraw : unit Js.meth + method clearData : unit Js.meth +end let create_snapshot (id : string) (coloring : unit Js.t) : snapshot Js.t = - Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "Snapshot") + Js.Unsafe.new_obj + (Js.Unsafe.pure_js_expr "Snapshot") [| Js.Unsafe.inject (Js.string id); Js.Unsafe.inject coloring |] diff --git a/gui/js_story.ml b/gui/js_story.ml index 0dbec64dfc..428e1d5ab8 100644 --- a/gui/js_story.ml +++ b/gui/js_story.ml @@ -6,13 +6,13 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -class type story_rendering = - object - method setData : Js.js_string Js.t -> unit Js.meth - method redraw : unit Js.meth - method clearData : unit Js.meth - end +class type story_rendering = object + method setData : Js.js_string Js.t -> unit Js.meth + method redraw : unit Js.meth + method clearData : unit Js.meth +end let create_story_rendering (id : string) : story_rendering Js.t = - Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "StoryRendering") + Js.Unsafe.new_obj + (Js.Unsafe.pure_js_expr "StoryRendering") [| Js.Unsafe.inject (Js.string id) |] diff --git a/gui/menu_editor_file.ml b/gui/menu_editor_file.ml index 9a134b2f3a..ab97c811f7 100644 --- a/gui/menu_editor_file.ml +++ b/gui/menu_editor_file.ml @@ -19,347 +19,313 @@ let file_export_li_id = "menu-editor-file-export-li" let file_compile_checkbox = "menu-editor-file-compile-checkbox" (* list filename annotation *) -let element_get_filename - (element : Dom_html.element Js.t) : Js.js_string Js.t Js.opt= - Common.element_data - (element : Dom_html.element Js.t) - "file-id" -let element_set_filename - (name : string) = - Html.Unsafe.string_attrib - "data-file-id" - name +let element_get_filename (element : Dom_html.element Js.t) : + Js.js_string Js.t Js.opt = + Common.element_data (element : Dom_html.element Js.t) "file-id" + +let element_set_filename (name : string) = + Html.Unsafe.string_attrib "data-file-id" name let file_new_input = Html.input - ~a:[ Html.a_id file_new_input_id ; - Html.a_input_type `Text ; - Html.a_class [ "form-control" ]; - Html.a_placeholder "file name" ; - Html.a_size 40; - ] () + ~a: + [ + Html.a_id file_new_input_id; + Html.a_input_type `Text; + Html.a_class [ "form-control" ]; + Html.a_placeholder "file name"; + Html.a_size 40; + ] + () + let file_new_input_dom = Tyxml_js.To_dom.of_input file_new_input let file_checkbox file_id is_checked = let checked_attribute = if is_checked then [ Html.a_checked () ] - else [] + else + [] in Html.input - ~a:([ Html.a_input_type `Checkbox ; - Html.a_class [ file_compile_checkbox ] ; - element_set_filename file_id ; - ]@checked_attribute) () + ~a: + ([ + Html.a_input_type `Checkbox; + Html.a_class [ file_compile_checkbox ]; + element_set_filename file_id; + ] + @ checked_attribute) + () let open_input = Html.input - ~a:[ Html.a_id file_open_selector_id ; - Html.a_class [ "hidden" ] ; - Html.Unsafe.string_attrib "type" "file" ; - Html.Unsafe.string_attrib "accept" ".ka" ; - ] + ~a: + [ + Html.a_id file_open_selector_id; + Html.a_class [ "hidden" ]; + Html.Unsafe.string_attrib "type" "file"; + Html.Unsafe.string_attrib "accept" ".ka"; + ] () let dropdown (model : State_file.model) = (* directories *) let hide_on_empty l = - if Mods.IntMap.is_empty model.State_file.directory then [] else l in + if Mods.IntMap.is_empty model.State_file.directory then + [] + else + l + in let file_li = let current_file_pos = - Option_util.map (fun {State_file.rank; _ } -> rank) model.State_file.current in + Option_util.map + (fun { State_file.rank; _ } -> rank) + model.State_file.current + in List.map (fun (rank, { State_file.name; State_file.local }) -> - let compile = local = None in - let li_class = - (if current_file_pos = Some rank then - [ "active" ] - else - [])@["ui-state-sortable"] - in - Html.li - ~a:[ Html.a_class li_class ; - element_set_filename name ; ] - [ Html.a ~a:[ element_set_filename name ; ] - [ Html.div - ~a:[ Html.a_class [ "checkbox-control-div" ] ; - element_set_filename name ; ] - [ file_checkbox name compile ; - Html.span - ~a:[ Html.a_class [ "checkbox-control-label" ] ; - element_set_filename name ; - ] - [ Html.cdata name ] ] ] ]) - (Mods.IntMap.bindings model.State_file.directory) in + let compile = local = None in + let li_class = + (if current_file_pos = Some rank then + [ "active" ] + else + []) + @ [ "ui-state-sortable" ] + in + Html.li + ~a:[ Html.a_class li_class; element_set_filename name ] + [ + Html.a + ~a:[ element_set_filename name ] + [ + Html.div + ~a: + [ + Html.a_class [ "checkbox-control-div" ]; + element_set_filename name; + ] + [ + file_checkbox name compile; + Html.span + ~a: + [ + Html.a_class [ "checkbox-control-label" ]; + element_set_filename name; + ] + [ Html.cdata name ]; + ]; + ]; + ]) + (Mods.IntMap.bindings model.State_file.directory) + in let separator_li = hide_on_empty - [ Html.li - ~a:[ Html.Unsafe.string_attrib "role" "separator" ; - Html.a_class [ "divider" ; - "ui-sort-disabled" ; - "ui-sort-bottom-anchor" ; ] ; - ] [ ] ] + [ + Html.li + ~a: + [ + Html.Unsafe.string_attrib "role" "separator"; + Html.a_class + [ "divider"; "ui-sort-disabled"; "ui-sort-bottom-anchor" ]; + ] + []; + ] in let new_li = - [ Html.li - ~a:[ Html.a_class [ "ui-sort-disabled" ; - "ui-sort-bottom-anchor" ; ] ; ] - [ Html.a - ~a:[ Html.a_id file_new_li_id ; ] - [ Html.cdata "New" ] ] ] - + [ + Html.li + ~a:[ Html.a_class [ "ui-sort-disabled"; "ui-sort-bottom-anchor" ] ] + [ Html.a ~a:[ Html.a_id file_new_li_id ] [ Html.cdata "New" ] ]; + ] in + let open_li = - [ Html.li - ~a:[ Html.a_class [ "ui-sort-disabled" ; - "ui-sort-bottom-anchor" ; ] ; ] - [ Html.a - ~a:[ Html.a_id file_open_li_id ; ] - [ Html.cdata "Open" ] ; - open_input - ] + [ + Html.li + ~a:[ Html.a_class [ "ui-sort-disabled"; "ui-sort-bottom-anchor" ] ] + [ + Html.a ~a:[ Html.a_id file_open_li_id ] [ Html.cdata "Open" ]; + open_input; + ]; ] - in + let close_li = hide_on_empty - [ Html.li - ~a:[ Html.a_class [ "ui-sort-disabled" ; - "ui-sort-bottom-anchor" ; ] ; ] - [ Html.a - ~a:[ Html.a_id file_close_li_id ; ] - [ Html.cdata "Close" ] ] ] + [ + Html.li + ~a:[ Html.a_class [ "ui-sort-disabled"; "ui-sort-bottom-anchor" ] ] + [ Html.a ~a:[ Html.a_id file_close_li_id ] [ Html.cdata "Close" ] ]; + ] in let export_li = hide_on_empty - [ Html.li - ~a:[ Html.a_class [ "ui-sort-disabled" ; - "ui-sort-bottom-anchor" ; ] ; ] - [ Html.a - ~a:[ Html.a_id file_export_li_id ; ] - [ Html.cdata "Export" ] ; - ] + [ + Html.li + ~a:[ Html.a_class [ "ui-sort-disabled"; "ui-sort-bottom-anchor" ] ] + [ Html.a ~a:[ Html.a_id file_export_li_id ] [ Html.cdata "Export" ] ]; ] in - [] - @ file_li - @ separator_li - @ new_li - @ open_li - @ close_li - @ export_li + [] @ file_li @ separator_li @ new_li @ open_li @ close_li @ export_li let content = - let li_list, li_handle = ReactiveData.RList.create [] in - let _ = - React.S.bind - State_file.model - (fun model -> - let () = - ReactiveData.RList.set - li_handle - (dropdown model) - in - React.S.const ()) + let li_list = + ReactiveData.RList.from_signal + (React.S.map (fun model -> dropdown model) State_file.model) in - [ Html.button - ~a:[ Html.Unsafe.string_attrib "type" "button" ; - Html.a_class [ "btn btn-default"; "dropdown-toggle" ] ; - Html.Unsafe.string_attrib "data-toggle" "dropdown" ; - Html.Unsafe.string_attrib "aria-haspopup" "true" ; - Html.Unsafe.string_attrib "aria-expanded" "false" ; - (Tyxml_js.R.filter_attrib - (Html.a_disabled ()) - (React.S.l2 - (fun model file -> - match model.State_project.model_current_id with - | None -> true - | Some _ -> - match file.State_file.current with - | None -> false - | Some { State_file.out_of_sync; _ } -> out_of_sync) - State_project.model - State_file.model - ) - ); - ] - [ Html.txt "File" ; - Html.span ~a:[ Html.a_class ["caret"]] [ ] - ] ; - Tyxml_js.R.Html.ul - ~a:[ Html.a_id file_dropdown_menu_id ; - Html.a_class [ "dropdown-menu" ] ] - li_list ; - Ui_common.create_modal - ~id:file_new_modal_id - ~title_label:"New File" - ~body:[[%html - {|
    |}[file_new_input]{|
    |}] ; - ] - ~submit_label:"Create File" - ~submit: - (Dom_html.handler - (fun _ -> - let filename : string = Js.to_string file_new_input_dom##.value in - let () = Menu_editor_file_controller.create_file filename in - let () = Common.modal ~id:("#"^file_new_modal_id) ~action:"hide" in - Js._false)) - ] + [ + Html.button + ~a: + [ + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "btn btn-default"; "dropdown-toggle" ]; + Html.Unsafe.string_attrib "data-toggle" "dropdown"; + Html.Unsafe.string_attrib "aria-haspopup" "true"; + Html.Unsafe.string_attrib "aria-expanded" "false"; + Tyxml_js.R.filter_attrib (Html.a_disabled ()) + (React.S.l2 + (fun model file -> + match model.State_project.model_current_id with + | None -> true + | Some _ -> + (match file.State_file.current with + | None -> false + | Some { State_file.out_of_sync; _ } -> out_of_sync)) + State_project.model State_file.model); + ] + [ Html.txt "File"; Html.span ~a:[ Html.a_class [ "caret" ] ] [] ]; + Tyxml_js.R.Html.ul + ~a:[ Html.a_id file_dropdown_menu_id; Html.a_class [ "dropdown-menu" ] ] + li_list; + Ui_common.create_modal ~id:file_new_modal_id ~title_label:"New File" + ~body: + [ [%html {|
    |} [ file_new_input ] {|
    |}] ] + ~submit_label:"Create File" + ~submit: + (Dom_html.handler (fun _ -> + let filename : string = Js.to_string file_new_input_dom##.value in + let () = Menu_editor_file_controller.create_file filename in + let () = + Common.modal ~id:("#" ^ file_new_modal_id) ~action:"hide" + in + Js._false)); + ] let order_files (element : Dom_html.element Js.t) = let filenames : string list = - Common.children_value - element - "li[data-file-id]" - (fun element -> - let () = Common.debug element in - Js.Opt.case - (element_get_filename element) - (fun () -> failwith "missing filename") - Js.to_string - ) + Common.children_value element "li[data-file-id]" (fun element -> + let () = Common.debug element in + Js.Opt.case + (element_get_filename element) + (fun () -> failwith "missing filename") + Js.to_string) in let () = Menu_editor_file_controller.order_files filenames in () let file_select_handler _ _ : unit Lwt.t = let open_input_dom = Tyxml_js.To_dom.of_input open_input in - let files = Js.Optdef.get (open_input_dom##.files) - (fun () -> assert false) - in - let file = Js.Opt.get (files##item (0)) - (fun () -> assert false) - in + let files = Js.Optdef.get open_input_dom##.files (fun () -> assert false) in + let file = Js.Opt.get (files##item 0) (fun () -> assert false) in let file_id = Js.to_string file##.name in - let () = Menu_editor_file_controller.create_file - ~text:(Js_of_ocaml_lwt.File.readAsText file) file_id in + let () = + Menu_editor_file_controller.create_file + ~text:(Js_of_ocaml_lwt.File.readAsText file) + file_id + in let () = open_input_dom##.value := Js.string "" in Lwt.return_unit let onload () = let open_input_dom = Tyxml_js.To_dom.of_input open_input in let () = - Common.jquery_on - ("#"^file_new_li_id) - "click" - (Dom_html.handler - (fun _ -> - let () = - Common.modal - ~id:("#"^file_new_modal_id) - ~action:"show" - in - Js._false)) in + Common.jquery_on ("#" ^ file_new_li_id) "click" + (Dom_html.handler (fun _ -> + let () = Common.modal ~id:("#" ^ file_new_modal_id) ~action:"show" in + Js._false)) + in let () = - Common.jquery_on - ("#"^file_open_li_id) - "click" - (Dom_html.handler - (fun _ -> - (* click : unit Js.meth; *) - let () = open_input_dom##click in - Js._false)) in + Common.jquery_on ("#" ^ file_open_li_id) "click" + (Dom_html.handler (fun _ -> + (* click : unit Js.meth; *) + let () = open_input_dom##click in + Js._false)) + in let () = - Common.jquery_on - ("#"^file_close_li_id) - "click" - (Dom_html.handler - (fun _ -> - let () = Menu_editor_file_controller.close_file () in - Js._false)) in + Common.jquery_on ("#" ^ file_close_li_id) "click" + (Dom_html.handler (fun _ -> + let () = Menu_editor_file_controller.close_file () in + Js._false)) + in let () = - Common.jquery_on - ("#"^file_export_li_id) - "click" - (Dom_html.handler - (fun _ -> - let () = Menu_editor_file_controller.export_current_file () in - Js._false)) in + Common.jquery_on ("#" ^ file_export_li_id) "click" + (Dom_html.handler (fun _ -> + let () = Menu_editor_file_controller.export_current_file () in + Js._false)) + in let () = - Common.jquery_on - ("span[data-file-id]") - "click" - (Dom_html.handler - (fun (event : Dom_html.event Js.t) -> - (* let () = Common.debug event in *) - let target : Dom_html.element Js.t Js.opt = event##.target in - let file_id : Js.js_string Js.t Js.opt = - Js.Opt.bind - target - (fun (element : Dom_html.element Js.t) -> - element_get_filename element) - in - let () = - Js.Opt.case - file_id - (fun _ -> ()) - (fun file_id -> - Menu_editor_file_controller.set_file - (Js.to_string file_id)) - in - Js._false)) + Common.jquery_on "span[data-file-id]" "click" + (Dom_html.handler (fun (event : Dom_html.event Js.t) -> + (* let () = Common.debug event in *) + let target : Dom_html.element Js.t Js.opt = event##.target in + let file_id : Js.js_string Js.t Js.opt = + Js.Opt.bind target (fun (element : Dom_html.element Js.t) -> + element_get_filename element) + in + let () = + Js.Opt.case file_id + (fun _ -> ()) + (fun file_id -> + Menu_editor_file_controller.set_file (Js.to_string file_id)) + in + Js._false)) in let () = - Common.create_sort - file_dropdown_menu_id - (fun event _ (* ui *) -> - let target : Dom_html.element Js.t Js.opt = event##.target in - Js.Opt.case - target - (fun _ -> ()) - (fun (element : Dom_html.element Js.t) -> - let id : string = Js.to_string element##.id in - if file_dropdown_menu_id = id then - order_files element - else - Common.debug (Format.sprintf "unexpected id %s" id) - ) - ) + Common.create_sort file_dropdown_menu_id (fun event _ (* ui *) -> + let target : Dom_html.element Js.t Js.opt = event##.target in + Js.Opt.case target + (fun _ -> ()) + (fun (element : Dom_html.element Js.t) -> + let id : string = Js.to_string element##.id in + if file_dropdown_menu_id = id then + order_files element + else + Common.debug (Format.sprintf "unexpected id %s" id))) in let () = Common.jquery_on (Format.sprintf "input.%s" file_compile_checkbox) "change" - (Dom_html.handler - (fun event -> - let target : Dom_html.element Js.t Js.opt = event##.target in - let file_id : Js.js_string Js.t Js.opt = - Js.Opt.bind - target - (fun (element : Dom_html.element Js.t) -> - element_get_filename element) - in - let is_checked : bool = - Js.to_bool - (Js.Opt.case - target - (fun _ -> Js._false) - (fun (element : Dom_html.element Js.t) -> - ((Js.Unsafe.coerce element : Dom_html.inputElement Js.t)##.checked) - ) - ) - in - let () = - Js.Opt.case - file_id - (fun _ -> ()) - (fun file_id -> - let () = Common.debug file_id in - let () = - Menu_editor_file_controller.set_file_compile - (Js.to_string file_id) - is_checked - in - () - ) - in - Js._false)) + (Dom_html.handler (fun event -> + let target : Dom_html.element Js.t Js.opt = event##.target in + let file_id : Js.js_string Js.t Js.opt = + Js.Opt.bind target (fun (element : Dom_html.element Js.t) -> + element_get_filename element) + in + let is_checked : bool = + Js.to_bool + (Js.Opt.case target + (fun _ -> Js._false) + (fun (element : Dom_html.element Js.t) -> + (Js.Unsafe.coerce element : Dom_html.inputElement Js.t)##.checked)) + in + let () = + Js.Opt.case file_id + (fun _ -> ()) + (fun file_id -> + let () = Common.debug file_id in + let () = + Menu_editor_file_controller.set_file_compile + (Js.to_string file_id) is_checked + in + ()) + in + Js._false)) in - let () = - Lwt.async - (fun () -> - Js_of_ocaml_lwt.Lwt_js_events.changes - (Tyxml_js.To_dom.of_input open_input) - file_select_handler) + let () = + Lwt.async (fun () -> + Js_of_ocaml_lwt.Lwt_js_events.changes + (Tyxml_js.To_dom.of_input open_input) + file_select_handler) in () diff --git a/gui/menu_editor_file.mli b/gui/menu_editor_file.mli index b52dab67bc..b37a6c615e 100644 --- a/gui/menu_editor_file.mli +++ b/gui/menu_editor_file.mli @@ -6,6 +6,7 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -val content : [> `Button | `Div | `Ul | `A of [> `PCDATA | `Span ]] Tyxml_js.Html5.elt list +val content : + [> `Button | `Div | `Ul | `A of [> `PCDATA | `Span ] ] Tyxml_js.Html5.elt list val onload : unit -> unit diff --git a/gui/menu_editor_file_controller.ml b/gui/menu_editor_file_controller.ml index fbf2888ed0..775422151b 100644 --- a/gui/menu_editor_file_controller.ml +++ b/gui/menu_editor_file_controller.ml @@ -8,95 +8,63 @@ open Lwt.Infix -let create_file - ?(text = Lwt.return (Js.string "")) - (file_id : string) : unit = - Common.async - __LOC__ - (fun () -> - (State_error.wrap - __LOC__ - (text >>= fun txt -> - let content = Js.to_string txt in - State_file.create_file ~filename:file_id ~content - >>= - (* get new contact map *) - (fun r -> State_project.sync () >>= - fun r' -> Lwt.return (Api_common.result_combine [r; r']))) - >>= - (fun _ -> Lwt.return_unit) - ) - ) +let create_file ?(text = Lwt.return (Js.string "")) (file_id : string) : unit = + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ + ( text >>= fun txt -> + let content = Js.to_string txt in + State_file.create_file ~filename:file_id ~content + >>= (* get new contact map *) + fun r -> + State_project.sync () >>= fun r' -> + Lwt.return (Api_common.result_combine [ r; r' ]) ) + >>= fun _ -> Lwt.return_unit) let set_file (file_id : string) : unit = let () = Common.debug (Js.string (Format.sprintf "set_file:%s" file_id)) in - Common.async - __LOC__ - (fun () -> - State_error.wrap - ~append:true - __LOC__ - ((State_file.select_file file_id None) - >>= (fun r -> State_project.sync () >>= - fun r' -> Lwt.return (Api_common.result_combine [r; r']))) (* get new contact map *) - >>= (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + State_error.wrap ~append:true __LOC__ + ( State_file.select_file file_id None >>= fun r -> + State_project.sync () >>= fun r' -> + Lwt.return (Api_common.result_combine [ r; r' ]) ) + (* get new contact map *) + >>= fun _ -> Lwt.return_unit) let close_file () : unit = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (State_file.remove_file () - >>= (fun r -> State_project.sync () >>= - fun r' -> Lwt.return (Api_common.result_combine [r; r']))) (* get new contact map *) - >>= (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ + ( State_file.remove_file () >>= fun r -> + State_project.sync () >>= fun r' -> + Lwt.return (Api_common.result_combine [ r; r' ]) ) + (* get new contact map *) + >>= fun _ -> Lwt.return_unit) let set_file_compile rank (compile : bool) : unit = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (State_file.set_compile - rank - compile - >>= - (fun r -> State_project.sync () >>= - fun r' -> Lwt.return (Api_common.result_combine [r; r']))) (* get new contact map *) - >>= - (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ + ( State_file.set_compile rank compile >>= fun r -> + State_project.sync () >>= fun r' -> + Lwt.return (Api_common.result_combine [ r; r' ]) ) + (* get new contact map *) + >>= fun _ -> Lwt.return_unit) let order_files (filenames : string list) : unit = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (State_file.order_files filenames - >>= (fun r -> State_project.sync () >>= - fun r' -> Lwt.return (Api_common.result_combine [r; r']))) (* get new contact map *) - >>= (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ + ( State_file.order_files filenames >>= fun r -> + State_project.sync () >>= fun r' -> + Lwt.return (Api_common.result_combine [ r; r' ]) ) + (* get new contact map *) + >>= fun _ -> Lwt.return_unit) let export_current_file () = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (State_file.get_file ()) >>= - (Result_util.fold - ~ok:(fun (data,filename) -> + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ (State_file.get_file ()) + >>= Result_util.fold + ~ok:(fun (data, filename) -> let () = - Common.saveFile - ~data:(Js.string data) - ~mime:"application/octet-stream" - ~filename in + Common.saveFile ~data:(Js.string data) + ~mime:"application/octet-stream" ~filename + in Lwt.return_unit) - ~error:(fun _ -> Lwt.return_unit) - ) - ) + ~error:(fun _ -> Lwt.return_unit)) diff --git a/gui/modal_preferences.ml b/gui/modal_preferences.ml index 810b7ec27b..cfcd482550 100644 --- a/gui/modal_preferences.ml +++ b/gui/modal_preferences.ml @@ -7,46 +7,56 @@ (******************************************************************************) module Html = Tyxml_js.Html5 + let configuration_seed_input_id = "simulation_seed_input" let preferences_modal_id = "preferences_modal" let settings_client_id_input_id = "settings-client-id-input" - -let preferences_button = - Html.a [ Html.txt "Preferences" ] +let preferences_button = Html.a [ Html.txt "Preferences" ] let option_seed_input = - Html.input ~a:[ - Html.a_id configuration_seed_input_id; - Html.a_input_type `Number; - Html.a_class ["form-control"]; - ] () -let option_withtrace = - Html.input ~a:[ Html.a_input_type `Checkbox ] () -let option_withdeadrules = - Html.input ~a:[ Html.a_input_type `Checkbox ] () -let option_withdeadagents = - Html.input ~a:[ Html.a_input_type `Checkbox ] () -let option_withirreversible = - Html.input ~a:[ Html.a_input_type `Checkbox ] () + Html.input + ~a: + [ + Html.a_id configuration_seed_input_id; + Html.a_input_type `Number; + Html.a_class [ "form-control" ]; + ] + () + +let option_withtrace = Html.input ~a:[ Html.a_input_type `Checkbox ] () +let option_withdeadrules = Html.input ~a:[ Html.a_input_type `Checkbox ] () +let option_withdeadagents = Html.input ~a:[ Html.a_input_type `Checkbox ] () +let option_withirreversible = Html.input ~a:[ Html.a_input_type `Checkbox ] () + let decrease_font = - Html.button ~a:[ - Html.a_button_type `Button; - Html.a_class [ "btn"; "btn-default"; "btn-sm" ] - ] [Html.txt "-"] + Html.button + ~a: + [ + Html.a_button_type `Button; + Html.a_class [ "btn"; "btn-default"; "btn-sm" ]; + ] + [ Html.txt "-" ] + let increase_font = - Html.button ~a:[ - Html.a_button_type `Button; - Html.a_class [ "btn"; "btn-default"; "btn-lg" ] - ] [Html.txt "+"] + Html.button + ~a: + [ + Html.a_button_type `Button; + Html.a_class [ "btn"; "btn-default"; "btn-lg" ]; + ] + [ Html.txt "+" ] let settings_client_id_input = Html.input - ~a:[ Html.a_id settings_client_id_input_id ; - Html.a_input_type `Text ; - Html.a_class [ "form-control" ]; - Html.a_placeholder "client id" ; - Html.a_size 40; - ] () + ~a: + [ + Html.a_id settings_client_id_input_id; + Html.a_input_type `Text; + Html.a_class [ "form-control" ]; + Html.a_placeholder "client id"; + Html.a_size 40; + ] + () let settings_client_id_input_dom = Tyxml_js.To_dom.of_input settings_client_id_input @@ -54,144 +64,193 @@ let settings_client_id_input_dom = let option_http_synch = Html.input ~a:[ Html.a_input_type `Checkbox ] () let dropdown (model : State_runtime.model) = - let current_id = State_runtime.spec_id model.State_runtime.model_current in - (List.map - (fun (spec : State_runtime.spec) -> - let spec_id = State_runtime.spec_id spec in - Html.option - ~a:(Html.a_value spec_id :: - if current_id = spec_id then [Html.a_selected ()] else []) - (Html.txt (State_runtime.spec_label spec))) - model.State_runtime.model_runtimes) - -let backend_options, backend_handle = ReactiveData.RList.create [] + let current_id = State_runtime.spec_id model.State_runtime.model_current in + List.map + (fun (spec : State_runtime.spec) -> + let spec_id = State_runtime.spec_id spec in + Html.option + ~a: + (Html.a_value spec_id + :: + (if current_id = spec_id then + [ Html.a_selected () ] + else + [])) + (Html.txt (State_runtime.spec_label spec))) + model.State_runtime.model_runtimes + +let backend_options = + ReactiveData.RList.from_signal + (React.S.map (fun list_t -> dropdown list_t) State_runtime.model) + let backend_select = - Tyxml_js.R.Html.select ~a:[Html.a_class ["form-control"]] backend_options + Tyxml_js.R.Html.select ~a:[ Html.a_class [ "form-control" ] ] backend_options let%html bodies = {|

    Application

    -
    |}[decrease_font; increase_font]{|
    +
    |} + [ decrease_font; increase_font ] + {|
    -
    |}[backend_select]{|
    +
    |} + [ backend_select ] + {|

    Project

    - -
    |}[option_seed_input]{|
    + +
    |} + [ option_seed_input ] + {|

    HTTPS backend

    - -
    |}[settings_client_id_input]{|
    + +
    |} + [ settings_client_id_input ] + {|

    Static analyses

    |} let set_button = Html.button - ~a:[ Html.a_button_type `Submit; - Html.a_class [ "btn"; "btn-primary" ] ] + ~a:[ Html.a_button_type `Submit; Html.a_class [ "btn"; "btn-primary" ] ] [ Html.txt "Set" ] let save_button = Html.button - ~a:[ Html.a_button_type `Button; - Html.a_class [ "btn"; "btn-default" ] ] + ~a:[ Html.a_button_type `Button; Html.a_class [ "btn"; "btn-default" ] ] [ Html.txt "Save as default" ] let modal = - let head = Html.div + let head = + Html.div ~a:[ Html.a_class [ "modal-header" ] ] - [ Html.button - ~a:[ Html.a_button_type `Button; - Html.a_class [ "close" ]; - Html.a_user_data "dismiss" "modal" ] + [ + Html.button + ~a: + [ + Html.a_button_type `Button; + Html.a_class [ "close" ]; + Html.a_user_data "dismiss" "modal"; + ] [ Html.entity "times" ]; - Html.h4 ~a:[ Html.a_class ["modal-title"] ] [ Html.txt "Preferences" ] - ] in - let body = Html.div - ~a:[ Html.a_class [ "modal-body" ] ] - bodies in - let foot = Html.div + Html.h4 ~a:[ Html.a_class [ "modal-title" ] ] [ Html.txt "Preferences" ]; + ] + in + let body = Html.div ~a:[ Html.a_class [ "modal-body" ] ] bodies in + let foot = + Html.div ~a:[ Html.a_class [ "modal-footer" ] ] - [ set_button; save_button; + [ + set_button; + save_button; Html.button - ~a:[ Html.a_button_type `Button; - Html.a_class [ "btn"; "btn-default" ]; - Html.a_user_data "dismiss" "modal" ] - [ Html.txt "Close" ] ] in + ~a: + [ + Html.a_button_type `Button; + Html.a_class [ "btn"; "btn-default" ]; + Html.a_user_data "dismiss" "modal"; + ] + [ Html.txt "Close" ]; + ] + in Html.form ~a:[ Html.a_class [ "modal-content"; "form-horizontal" ] ] - [head; body; foot] - -let content () = [ - preferences_button; - Html.div - ~a:[ Html.a_class [ "modal"; "fade" ]; - Html.a_id preferences_modal_id; - Html.a_role [ "dialog" ]; - Html.a_tabindex (-1)] - [ Html.div - ~a:[ Html.a_class [ "modal-dialog" ]; Html.a_role [ "document" ] ] - [ modal ] ] -] + [ head; body; foot ] + +let content () = + [ + preferences_button; + Html.div + ~a: + [ + Html.a_class [ "modal"; "fade" ]; + Html.a_id preferences_modal_id; + Html.a_role [ "dialog" ]; + Html.a_tabindex (-1); + ] + [ + Html.div + ~a:[ Html.a_class [ "modal-dialog" ]; Html.a_role [ "document" ] ] + [ modal ]; + ]; + ] let set_action () = let settings_client_id = Js.to_string settings_client_id_input_dom##.value in let () = State_settings.set_client_id settings_client_id in let synch_checkbox_dom = Tyxml_js.To_dom.of_input option_http_synch in - let is_checked = Js.to_bool (synch_checkbox_dom##.checked) in + let is_checked = Js.to_bool synch_checkbox_dom##.checked in let () = State_settings.set_synch is_checked in let input = Tyxml_js.To_dom.of_input option_seed_input in let value : string = Js.to_string input##.value in - let model_seed = - try Some (int_of_string value) with Failure _ -> None in + let model_seed = try Some (int_of_string value) with Failure _ -> None in let () = State_project.set_seed model_seed in - let () = State_project.set_store_trace - (Js.to_bool (Tyxml_js.To_dom.of_input option_withtrace)##.checked) in - let () = State_project.set_show_dead_rules - (Js.to_bool (Tyxml_js.To_dom.of_input option_withdeadrules)##.checked) in - let () = State_project.set_show_dead_agents - (Js.to_bool (Tyxml_js.To_dom.of_input option_withdeadagents)##.checked) in - let () = State_project.set_show_non_weakly_reversible_transitions - (Js.to_bool (Tyxml_js.To_dom.of_input option_withirreversible)##.checked) in + let () = + State_project.set_store_trace + (Js.to_bool (Tyxml_js.To_dom.of_input option_withtrace)##.checked) + in + let () = + State_project.set_show_dead_rules + (Js.to_bool (Tyxml_js.To_dom.of_input option_withdeadrules)##.checked) + in + let () = + State_project.set_show_dead_agents + (Js.to_bool (Tyxml_js.To_dom.of_input option_withdeadagents)##.checked) + in + let () = + State_project.set_show_non_weakly_reversible_transitions + (Js.to_bool (Tyxml_js.To_dom.of_input option_withirreversible)##.checked) + in let () = Panel_projects_controller.set_manager - (Js.to_string (Tyxml_js.To_dom.of_select backend_select)##.value) in + (Js.to_string (Tyxml_js.To_dom.of_select backend_select)##.value) + in () let set_and_save_action () = @@ -204,86 +263,94 @@ let set_and_save_action () = let onload () = let () = - (Tyxml_js.To_dom.of_form modal)##.onsubmit := - Dom_html.handler - (fun (_ : _ Js.t) -> + (Tyxml_js.To_dom.of_form modal)##.onsubmit + := Dom_html.handler (fun (_ : _ Js.t) -> let () = - Common.modal ~id:("#"^preferences_modal_id) ~action:"hide" in + Common.modal ~id:("#" ^ preferences_modal_id) ~action:"hide" + in let () = set_action () in - Js._false) in + Js._false) + in let () = - (Tyxml_js.To_dom.of_button save_button)##.onclick := - Dom_html.handler - (fun _ -> let () = set_and_save_action () in Js._false) in + (Tyxml_js.To_dom.of_button save_button)##.onclick + := Dom_html.handler (fun _ -> + let () = set_and_save_action () in + Js._false) + in let () = - (Tyxml_js.To_dom.of_a preferences_button)##.onclick := - Dom_html.handler - (fun _ -> + (Tyxml_js.To_dom.of_a preferences_button)##.onclick + := Dom_html.handler (fun _ -> let sp = React.S.value State_project.model in let () = - settings_client_id_input_dom##.value := - Js.string (State_settings.get_client_id ()) in + settings_client_id_input_dom##.value + := Js.string (State_settings.get_client_id ()) + in let input = Tyxml_js.To_dom.of_input option_seed_input in - let () = input##.value := Js.string - (match sp.State_project.model_parameters.State_project.seed with - | None -> "" - | Some model_seed -> string_of_int model_seed) in + let () = + input##.value := + Js.string + (match + sp.State_project.model_parameters.State_project.seed + with + | None -> "" + | Some model_seed -> string_of_int model_seed) + in let () = - (Tyxml_js.To_dom.of_input option_withtrace)##.checked := - Js.bool - sp.State_project.model_parameters.State_project.store_trace in + (Tyxml_js.To_dom.of_input option_withtrace)##.checked + := Js.bool + sp.State_project.model_parameters.State_project.store_trace + in let () = - (Tyxml_js.To_dom.of_input option_withdeadagents)##.checked := - Js.bool - sp.State_project.model_parameters.State_project.show_dead_agents + (Tyxml_js.To_dom.of_input option_withdeadagents)##.checked + := Js.bool + sp.State_project.model_parameters + .State_project.show_dead_agents in let () = - (Tyxml_js.To_dom.of_input option_withdeadrules)##.checked := - Js.bool - sp.State_project.model_parameters.State_project.show_dead_rules + (Tyxml_js.To_dom.of_input option_withdeadrules)##.checked + := Js.bool + sp.State_project.model_parameters + .State_project.show_dead_rules in let () = - (Tyxml_js.To_dom.of_input option_withirreversible)##.checked := - Js.bool - sp.State_project.model_parameters. - State_project.show_non_weakly_reversible_transitions in + (Tyxml_js.To_dom.of_input option_withirreversible)##.checked + := Js.bool + sp.State_project.model_parameters + .State_project.show_non_weakly_reversible_transitions + in let () = - (Tyxml_js.To_dom.of_input option_http_synch)##.checked := - Js.bool (React.S.value State_settings.synch) in + (Tyxml_js.To_dom.of_input option_http_synch)##.checked + := Js.bool (React.S.value State_settings.synch) + in let () = - (Tyxml_js.To_dom.of_select backend_select)##.value := - Js.string - (State_runtime.spec_id - (React.S.value State_runtime.model) - .State_runtime.model_current) in + (Tyxml_js.To_dom.of_select backend_select)##.value + := Js.string + (State_runtime.spec_id + (React.S.value State_runtime.model) + .State_runtime.model_current) + in let () = - Common.modal ~id:("#"^preferences_modal_id) ~action:"show" in - - Js._false) in + Common.modal ~id:("#" ^ preferences_modal_id) ~action:"show" + in - let _ = - React.S.bind - State_runtime.model - (fun list_t -> - let () = - ReactiveData.RList.set backend_handle (dropdown list_t) in - React.S.const ()) in + Js._false) + in let () = State_settings.updateFontSize ~delta:0. in let () = - (Tyxml_js.To_dom.of_button increase_font)##.onclick := - Dom_html.handler - (fun _ -> + (Tyxml_js.To_dom.of_button increase_font)##.onclick + := Dom_html.handler (fun _ -> let () = State_settings.updateFontSize ~delta:0.2 in - Js._false) in + Js._false) + in let () = - (Tyxml_js.To_dom.of_button decrease_font)##.onclick := - Dom_html.handler - (fun _ -> + (Tyxml_js.To_dom.of_button decrease_font)##.onclick + := Dom_html.handler (fun _ -> let () = State_settings.updateFontSize ~delta:(-0.2) in - Js._false) in + Js._false) + in () diff --git a/gui/panel_projects.ml b/gui/panel_projects.ml index 7d868a683d..560b94bd57 100644 --- a/gui/panel_projects.ml +++ b/gui/panel_projects.ml @@ -12,106 +12,132 @@ let project_id_modal_id = "menu-editor-project-id-modal" let project_id_input = Html.input - ~a:[ Html.a_input_type `Text ; - Html.a_class [ "form-control" ]; - Html.a_placeholder "project new" ; - Html.a_size 40; - ] () + ~a: + [ + Html.a_input_type `Text; + Html.a_class [ "form-control" ]; + Html.a_placeholder "project new"; + Html.a_size 40; + ] + () -let li_new = - Html.li [ Html.a [ Html.cdata "New project" ]] - -let li_prefs = - Html.li (Modal_preferences.content ()) - -let project_id_input_dom = - Tyxml_js.To_dom.of_input project_id_input +let li_new = Html.li [ Html.a [ Html.cdata "New project" ] ] +let li_prefs = Html.li (Modal_preferences.content ()) +let project_id_input_dom = Tyxml_js.To_dom.of_input project_id_input let content () = Html.div - [Tyxml_js.R.Html5.ul - ~a:[Html.a_class [ "nav"; "nav-tabs"; "nav-justified"]] - (ReactiveData.RList.from_signal - (React.S.map - (fun model -> + [ + Tyxml_js.R.Html5.ul + ~a:[ Html.a_class [ "nav"; "nav-tabs"; "nav-justified" ] ] + (ReactiveData.RList.from_signal + (React.S.map + (fun model -> let acc = List.rev_map - (fun {State_project.model_project_id; - State_project.model_project_is_computing} -> - let li_class = - if match model.State_project.model_current_id with - | Some current_project_id -> - current_project_id = model_project_id - | None -> false then - [ "active" ] - else - [] in - let span_close = Html.button - ~a:[Html.a_class ["close"]] [ Html.entity "times" ] in - let () = (Tyxml_js.To_dom.of_button span_close)##.onclick := - Dom.handler - (fun event -> - let () = Panel_projects_controller.close_project - model_project_id in - let () = Dom_html.stopPropagation event in - Js._false) in - let computing = - let classes = - React.S.map - (fun b -> - if b then ["glyphicon";"glyphicon-refresh"] - else ["glyphicon";"glyphicon-ok"]) - model_project_is_computing in - Html.span ~a:[Tyxml_js.R.Html5.a_class classes] [] in - let a_project = - Html.a - [ computing; Html.cdata (" "^model_project_id); span_close] in - let () = (Tyxml_js.To_dom.of_a a_project)##.onclick := - Dom.handler - (fun _ -> - let () = Panel_projects_controller.set_project - model_project_id in - Js._true) in - Html.li ~a:[ Html.a_class li_class ] [a_project]) - model.State_project.model_catalog in - List.rev_append acc [li_new; li_prefs]) - State_project.model)); - Ui_common.create_modal - ~id:project_id_modal_id - ~title_label:"New Project" - ~body:[[%html - {|
    |}[project_id_input]{|
    |}] ; - ] - ~submit_label:"Create Project" - ~submit: - (Dom.handler - (fun _ -> + (fun { + State_project.model_project_id; + State_project.model_project_is_computing; + } -> + let li_class = + if + match model.State_project.model_current_id with + | Some current_project_id -> + current_project_id = model_project_id + | None -> false + then + [ "active" ] + else + [] + in + let span_close = + Html.button + ~a:[ Html.a_class [ "close" ] ] + [ Html.entity "times" ] + in + let () = + (Tyxml_js.To_dom.of_button span_close)##.onclick + := Dom.handler (fun event -> + let () = + Panel_projects_controller.close_project + model_project_id + in + let () = Dom_html.stopPropagation event in + Js._false) + in + let computing = + let classes = + React.S.map + (fun b -> + if b then + [ "glyphicon"; "glyphicon-refresh" ] + else + [ "glyphicon"; "glyphicon-ok" ]) + model_project_is_computing + in + Html.span ~a:[ Tyxml_js.R.Html5.a_class classes ] [] + in + let a_project = + Html.a + [ + computing; + Html.cdata (" " ^ model_project_id); + span_close; + ] + in + let () = + (Tyxml_js.To_dom.of_a a_project)##.onclick + := Dom.handler (fun _ -> + let () = + Panel_projects_controller.set_project + model_project_id + in + Js._true) + in + Html.li ~a:[ Html.a_class li_class ] [ a_project ]) + model.State_project.model_catalog + in + List.rev_append acc [ li_new; li_prefs ]) + State_project.model)); + Ui_common.create_modal ~id:project_id_modal_id ~title_label:"New Project" + ~body: + [ + [%html + {|
    |} [ project_id_input ] {|
    |}]; + ] + ~submit_label:"Create Project" + ~submit: + (Dom.handler (fun _ -> let settings_client_id : string = - Js.to_string project_id_input_dom##.value in + Js.to_string project_id_input_dom##.value + in let () = - Panel_projects_controller.create_project settings_client_id in + Panel_projects_controller.create_project settings_client_id + in let () = - Common.modal - ~id:("#"^project_id_modal_id) ~action:"hide" in - Js._false)) + Common.modal ~id:("#" ^ project_id_modal_id) ~action:"hide" + in + Js._false)); ] let onload () = let () = Modal_preferences.onload () in let () = Common.jquery_on - ("#"^project_id_modal_id) + ("#" ^ project_id_modal_id) "shown.bs.modal" - (Dom_html.handler - (fun _ -> + (Dom_html.handler (fun _ -> let () = project_id_input_dom##focus in - Js._false)) in - let () = (Tyxml_js.To_dom.of_span li_new)##.onclick := - Dom.handler - (fun _ -> + Js._false)) + in + let () = + (Tyxml_js.To_dom.of_span li_new)##.onclick + := Dom.handler (fun _ -> let () = - Common.modal ~id:("#"^project_id_modal_id) ~action:"show" in - Js._false) in + Common.modal ~id:("#" ^ project_id_modal_id) ~action:"show" + in + Js._false) + in () let onresize () = () diff --git a/gui/panel_projects_controller.ml b/gui/panel_projects_controller.ml index ad5d938d8e..02e7d68675 100644 --- a/gui/panel_projects_controller.ml +++ b/gui/panel_projects_controller.ml @@ -12,44 +12,29 @@ let refresh r = let r' = State_file.sync ~reset:true () in let r'' = State_simulation.refresh () in r' >>= fun r' -> - r'' >>= fun r'' -> - Lwt.return (Api_common.result_combine [r; r'; r'']) + r'' >>= fun r'' -> Lwt.return (Api_common.result_combine [ r; r'; r'' ]) let create_project (project_id : string) : unit = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (State_project.create_project project_id >>= refresh) >>= - fun _ -> Lwt.return_unit) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ + (State_project.create_project project_id >>= refresh) + >>= fun _ -> Lwt.return_unit) let set_project (project_id : string) : unit = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (State_project.set_project project_id >>= refresh) >>= - fun _ -> Lwt.return_unit) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ (State_project.set_project project_id >>= refresh) + >>= fun _ -> Lwt.return_unit) let close_project project_id : unit = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (State_project.remove_project project_id >>= refresh) >>= - fun _ -> Lwt.return_unit) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ + (State_project.remove_project project_id >>= refresh) + >>= fun _ -> Lwt.return_unit) let set_manager (runtime_id : string) : unit = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - (Api_common.result_bind_lwt - ~ok:(fun () -> Lwt.return (Result_util.ok ())) - (State_runtime.create_spec ~load:true runtime_id)) >>= - (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ + (Api_common.result_bind_lwt + ~ok:(fun () -> Lwt.return (Result_util.ok ())) + (State_runtime.create_spec ~load:true runtime_id)) + >>= fun _ -> Lwt.return_unit) diff --git a/gui/panel_projects_controller.mli b/gui/panel_projects_controller.mli index f9f7473597..788ad5a710 100644 --- a/gui/panel_projects_controller.mli +++ b/gui/panel_projects_controller.mli @@ -9,5 +9,4 @@ val create_project : string -> unit val set_project : string -> unit val close_project : string -> unit - val set_manager : string -> unit diff --git a/gui/panel_settings.ml b/gui/panel_settings.ml index f3c5df0068..b7723450b5 100644 --- a/gui/panel_settings.ml +++ b/gui/panel_settings.ml @@ -7,181 +7,207 @@ (******************************************************************************) module Html = Tyxml_js.Html5 - open Lwt.Infix open List_util.Infix -let visible_on_states - ?(a_class=[]) +let visible_on_states ?(a_class = []) (state : State_simulation.model_state list) : string list React.signal = - let hidden_class = ["hidden"] in - let visible_class = ["visible"] in - React.S.bind - State_simulation.model - (fun model -> - let current_state = State_simulation.model_simulation_state model in - React.S.const - (if List.mem current_state state then - a_class@visible_class - else - a_class@hidden_class)) + let hidden_class = [ "hidden" ] in + let visible_class = [ "visible" ] in + React.S.bind State_simulation.model (fun model -> + let current_state = State_simulation.model_simulation_state model in + React.S.const + (if List.mem current_state state then + a_class @ visible_class + else + a_class @ hidden_class)) module FormPerturbation : Ui_common.Div = struct let id = "panel_settings_perturbation" + let input = Html.input - ~a:[Html.a_input_type `Text; - Html.a_class ["form-control"]; - Html.a_placeholder "Simulation Perturbation";] + ~a: + [ + Html.a_input_type `Text; + Html.a_class [ "form-control" ]; + Html.a_placeholder "Simulation Perturbation"; + ] () + let button = Html.button - ~a:[ Html.a_button_type `Submit - ; Html.a_class ["btn"; "btn-default" ] ] + ~a:[ Html.a_button_type `Submit; Html.a_class [ "btn"; "btn-default" ] ] [ Html.cdata "intervention" ] - let form = Html.form ~a: - [Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "form-horizontal" ] - [ State_simulation.PAUSED ; ])] - [ Html.div ~a:[ Html.a_class [ "form-group" ]] - [ Html.div ~a:[ Html.a_class ["col-md-10"; "col-xs-9"]] [input]; - Html.div ~a:[ Html.a_class ["col-md-2"; "col-xs-3"]] [button] ] ] + + let form = + Html.form + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states ~a_class:[ "form-horizontal" ] + [ State_simulation.PAUSED ]); + ] + [ + Html.div + ~a:[ Html.a_class [ "form-group" ] ] + [ + Html.div ~a:[ Html.a_class [ "col-md-10"; "col-xs-9" ] ] [ input ]; + Html.div ~a:[ Html.a_class [ "col-md-2"; "col-xs-3" ] ] [ button ]; + ]; + ] let content () = [ form ] - let onload () : unit = - let form_dom = Tyxml_js.To_dom.of_form form in - let input_dom = Tyxml_js.To_dom.of_input input in - let handler = - (fun _ -> - let model_perturbation : string = Js.to_string input_dom##.value in - let () = - State_perturbation.set_model_intervention model_perturbation in - Js._true) - in - - let () = form_dom##.onsubmit := - Dom.handler (fun _ -> - let () = Panel_settings_controller.intervene_simulation () in - Js._false) in - let () = input_dom##.onchange := Dom.handler handler in - () + let onload () : unit = + let form_dom = Tyxml_js.To_dom.of_form form in + let input_dom = Tyxml_js.To_dom.of_input input in + let handler _ = + let model_perturbation : string = Js.to_string input_dom##.value in + let () = State_perturbation.set_model_intervention model_perturbation in + Js._true + in + + let () = + form_dom##.onsubmit := + Dom.handler (fun _ -> + let () = Panel_settings_controller.intervene_simulation () in + Js._false) + in + let () = input_dom##.onchange := Dom.handler handler in + () end let signal_change input_dom signal_handler = input_dom##.onchange := - Dom_html.handler - (fun _ -> let () = signal_handler (Js.to_string (input_dom##.value)) in + Dom_html.handler (fun _ -> + let () = signal_handler (Js.to_string input_dom##.value) in Js._true) module InputPauseCondition : Ui_common.Div = struct let id = "panel_settings_pause_condition" + let input = Html.input - ~a:[Html.a_id id ; - Html.a_input_type `Text; - Html.a_class ["form-control"]; - Html.a_placeholder "[T] > 100" ; + ~a: + [ + Html.a_id id; + Html.a_input_type `Text; + Html.a_class [ "form-control" ]; + Html.a_placeholder "[T] > 100"; Tyxml_js.R.Html.a_value (React.S.map (fun m -> - m.State_project.model_parameters.State_project.pause_condition) - State_project.model) ] - () - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [input] + m.State_project.model_parameters.State_project.pause_condition) + State_project.model); + ] + () + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ input ] let dom = Tyxml_js.To_dom.of_input input let onload () = - let () = signal_change dom - (fun value -> - let v' = if value = "" then "[false]" else value in - State_project.set_pause_condition v') in + let () = + signal_change dom (fun value -> + let v' = + if value = "" then + "[false]" + else + value + in + State_project.set_pause_condition v') + in () end module InputPlotPeriod : Ui_common.Div = struct let id = "panel_settings_plot_period" -let format_float_string value = - let n = string_of_float value in - let length = String.length n in - if length > 0 && String.get n (length - 1) = '.' then - n^"0" - else - n - -let input = - Html.input - ~a:[Html.a_input_type `Number; - Html.a_id id; - Html.a_class [ "form-control"]; - Html.a_placeholder "time units"; - Html.a_input_min (`Number 0); - Tyxml_js.R.Html.a_value - (React.S.map - (fun m -> - format_float_string - m.State_project.model_parameters.State_project.plot_period) - State_project.model) ] - () - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [input] + + let format_float_string value = + let n = string_of_float value in + let length = String.length n in + if length > 0 && String.get n (length - 1) = '.' then + n ^ "0" + else + n + + let input = + Html.input + ~a: + [ + Html.a_input_type `Number; + Html.a_id id; + Html.a_class [ "form-control" ]; + Html.a_placeholder "time units"; + Html.a_input_min (`Number 0); + Tyxml_js.R.Html.a_value + (React.S.map + (fun m -> + format_float_string + m.State_project.model_parameters.State_project.plot_period) + State_project.model); + ] + () + + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ input ] let onload () = let input_dom = Tyxml_js.To_dom.of_input input in - let () = signal_change input_dom - (fun value -> - let reset_value () = - let old_value = - (React.S.value State_project.model). - State_project.model_parameters.State_project.plot_period in - input_dom##.value := Js.string (string_of_float old_value) in - try - let new_value = (float_of_string value) in - if new_value < 0. then reset_value () - else State_project.set_plot_period new_value - with | Not_found | Failure _ -> reset_value ()) in + let () = + signal_change input_dom (fun value -> + let reset_value () = + let old_value = + (React.S.value State_project.model).State_project.model_parameters + .State_project.plot_period + in + input_dom##.value := Js.string (string_of_float old_value) + in + try + let new_value = float_of_string value in + if new_value < 0. then + reset_value () + else + State_project.set_plot_period new_value + with Not_found | Failure _ -> reset_value ()) + in () - end module DivErrorMessage : Ui_common.Div = struct - let id = "configuration_error_div" let message_nav_inc_id = "panel_settings_message_nav_inc_id" let message_nav_dec_id = "panel_settings_message_nav_dec_id" let message_file_label_id = "panel_settings_message_file_label" let error_index, set_error_index = React.S.create None - let _ = + let dont_gc_me = React.S.l1 (function | [] -> () - | _::_ -> - match (React.S.value error_index) with + | _ :: _ -> + (match React.S.value error_index with | None -> set_error_index (Some 0) - | Some _ -> ()) + | Some _ -> ())) State_error.errors - (* if there are less or no errors the index needs to be updated *) let sanitize_index (index : int option) errors : int option = - match (index,errors) with + let () = ignore dont_gc_me in + match index, errors with | None, [] -> None - | None, _::_ -> Some 0 + | None, _ :: _ -> Some 0 | Some _, [] -> None | Some index, error -> let length = List.length error in - if index > length then + if index > length then ( let () = set_error_index (Some 0) in Some 0 - else - (if 0 > index then - let index = Some ((List.length error) - 1) in - let () = set_error_index index in - index - else - Some index) + ) else if 0 > index then ( + let index = Some (List.length error - 1) in + let () = set_error_index index in + index + ) else + Some index let get_message (index : int option) errors : Api_types_t.message option = Option_util.bind @@ -190,146 +216,126 @@ module DivErrorMessage : Ui_common.Div = struct let mesage_nav_text = React.S.l2 - (fun index error -> - match (index,error) with - | (None, []) -> "" - | (Some _,[]) -> "" - | (None, _::_) -> "" - | (Some index,(_ :: _ as errors)) -> - Format.sprintf - "%d/%d" - (index+1) - (List.length errors) - ) - error_index - State_error.errors - - let a_class = Tyxml_js.R.Html.a_class - (React.S.bind - State_error.errors - (fun error -> - React.S.const - (match error with - | [] | [ _ ] -> [ "hide" ; ] - | _::_::_ -> [ "error-span"; "clickable"] - ) - ) - ) - - let message_nav_dec = - Html.span - ~a:[ Html.a_id message_nav_dec_id ; a_class ; ] - [ Html.txt " « " ] - let message_nav_inc = - Html.span - ~a:[ Html.a_id message_nav_inc_id ; a_class ; ] - [ Html.txt " » " ] - let message_nav = - [ message_nav_dec ; - Tyxml_js.R.Html.txt mesage_nav_text ; - message_nav_inc ; ] + (fun index error -> + match index, error with + | None, [] -> "" + | Some _, [] -> "" + | None, _ :: _ -> "" + | Some index, (_ :: _ as errors) -> + Format.sprintf "%d/%d" (index + 1) (List.length errors)) + error_index State_error.errors + + let a_class = + Tyxml_js.R.Html.a_class + (React.S.bind State_error.errors (fun error -> + React.S.const + (match error with + | [] | [ _ ] -> [ "hide" ] + | _ :: _ :: _ -> [ "error-span"; "clickable" ]))) + + let message_nav_dec = + Html.span ~a:[ Html.a_id message_nav_dec_id; a_class ] [ Html.txt " « " ] + + let message_nav_inc = + Html.span ~a:[ Html.a_id message_nav_inc_id; a_class ] [ Html.txt " » " ] + + let message_nav = + [ message_nav_dec; Tyxml_js.R.Html.txt mesage_nav_text; message_nav_inc ] let file_label_text = React.S.l2 - (fun index error -> - let range = - Option_util.bind - (fun message -> message.Result_util.range) - (get_message index error) - in - match range with - | None -> "" - | Some range -> Format.sprintf "[%s]" range.Locality.file) - error_index - State_error.errors + (fun index error -> + let range = + Option_util.bind + (fun message -> message.Result_util.range) + (get_message index error) + in + match range with + | None -> "" + | Some range -> Format.sprintf "[%s]" range.Loc.file) + error_index State_error.errors let file_label = Html.span - ~a:[Html.a_id message_file_label_id; - Html.a_class [ "error-span" ; "clickable" ] ; - ] - [Tyxml_js.R.Html.txt file_label_text] + ~a: + [ + Html.a_id message_file_label_id; + Html.a_class [ "error-span"; "clickable" ]; + ] + [ Tyxml_js.R.Html.txt file_label_text ] let error_message_text = React.S.l2 - (fun index error -> - match get_message index error with - | None -> "" - | Some message -> Format.sprintf " %s " message.Result_util.text) - error_index - State_error.errors + (fun index error -> + match get_message index error with + | None -> "" + | Some message -> Format.sprintf " %s " message.Result_util.text) + error_index State_error.errors let error_message = Html.span - ~a:[Html.a_id id ; - Html.a_class [ "error-span" ] ; - ] - [Tyxml_js.R.Html.txt error_message_text] + ~a:[ Html.a_id id; Html.a_class [ "error-span" ] ] + [ Tyxml_js.R.Html.txt error_message_text ] let alert_messages = Html.div - ~a:[Html.a_id id; - + ~a: + [ + Html.a_id id; Tyxml_js.R.Html.a_class - (React.S.bind - State_error.errors - (fun error -> - React.S.const - (match error with - | [] -> [ "alert-sm" ; "alert" ; ] - | _ :: _ -> [ "alert-sm" ; "alert" ; "alert-danger" ; ] - ) - ) - ); - ] - (message_nav@ - [ file_label ; - error_message ; - ]) + (React.S.bind State_error.errors (fun error -> + React.S.const + (match error with + | [] -> [ "alert-sm"; "alert" ] + | _ :: _ -> [ "alert-sm"; "alert"; "alert-danger" ]))); + ] + (message_nav @ [ file_label; error_message ]) let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ alert_messages ] let file_click_handler () = let dom = Tyxml_js.To_dom.of_span file_label in - let () = dom##.onclick := - Dom.handler - (fun _ -> - let () = Common.debug (Js.string "file_click_handler") in - let message : Api_types_t.message option = - get_message - (React.S.value error_index) - (React.S.value State_error.errors) - in - let range = - Option_util.bind - (fun message -> message.Result_util.range) - message - in - let () = match range with - | Some range -> Panel_settings_controller.focus_range range - | None -> () - in - Js._true) + let () = + dom##.onclick := + Dom.handler (fun _ -> + let () = Common.debug (Js.string "file_click_handler") in + let message : Api_types_t.message option = + get_message + (React.S.value error_index) + (React.S.value State_error.errors) + in + let range = + Option_util.bind + (fun message -> message.Result_util.range) + message + in + let () = + match range with + | Some range -> Panel_settings_controller.focus_range range + | None -> () + in + Js._true) in () let index_click_handler dom delta = - let () = dom##.onclick := Dom.handler - (fun _ -> - let () = Common.debug (Js.string "index_click_handler") in - let index : int option = - sanitize_index - (React.S.value error_index) - (React.S.value State_error.errors) - in - let index = Option_util.map delta index in - let index : int option = - sanitize_index - index - (React.S.value State_error.errors) in - let () = set_error_index index in - Js._true) in + let () = + dom##.onclick := + Dom.handler (fun _ -> + let () = Common.debug (Js.string "index_click_handler") in + let index : int option = + sanitize_index + (React.S.value error_index) + (React.S.value State_error.errors) + in + let index = Option_util.map delta index in + let index : int option = + sanitize_index index (React.S.value State_error.errors) + in + let () = set_error_index index in + Js._true) + in () let inc_click_handler () = @@ -351,33 +357,36 @@ end module ButtonStart : Ui_common.Div = struct let id = "panel_settings_start_button" + let button = Html.button - ~a:([ Html.a_id id ; - Html.Unsafe.string_attrib "type" "button" ; - Html.a_class [ "btn" ; "btn-default" ; ]; - (Tyxml_js.R.filter_attrib - (Html.a_disabled ()) - (React.S.map (function - | { State_file.current = Some { State_file.out_of_sync; _ }; _ } -> - out_of_sync - | _ -> false) - State_file.model) - ); - - ] - ) + ~a: + [ + Html.a_id id; + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "btn"; "btn-default" ]; + Tyxml_js.R.filter_attrib (Html.a_disabled ()) + (React.S.map + (function + | { + State_file.current = Some { State_file.out_of_sync; _ }; + _; + } -> + out_of_sync + | _ -> false) + State_file.model); + ] [ Html.cdata "start" ] - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [button] + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ button ] let onload () = let start_button_dom = Tyxml_js.To_dom.of_button button in - let () = start_button_dom##.onclick := - Dom.handler - (fun _ -> - let () = Panel_settings_controller.start_simulation () in - Js._true) + let () = + start_button_dom##.onclick := + Dom.handler (fun _ -> + let () = Panel_settings_controller.start_simulation () in + Js._true) in () @@ -385,341 +394,400 @@ end module ButtonClear : Ui_common.Div = struct let id = "panel_settings_clear_button" + let button = - Html.button - ~a:[ Html.a_id id - ; Html.Unsafe.string_attrib "type" "button" - ; Html.a_class ["btn" ; - "btn-default" ; ] ] - [ Html.cdata "clear" ] + Html.button + ~a: + [ + Html.a_id id; + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "btn"; "btn-default" ]; + ] + [ Html.cdata "clear" ] - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [button] + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ button ] let onload () = let dom = Tyxml_js.To_dom.of_button button in - let () = dom##.onclick := - Dom.handler - (fun _ -> - let () = Panel_settings_controller.stop_simulation () in - Js._true) + let () = + dom##.onclick := + Dom.handler (fun _ -> + let () = Panel_settings_controller.stop_simulation () in + Js._true) in () - end module ButtonPause : Ui_common.Div = struct let id = "panel_settings_pause_button" + let button = - Html.button - ~a:[ Html.a_id id - ; Html.Unsafe.string_attrib "type" "button" - ; Html.a_class ["btn" ; - "btn-default" ; ] ] - [ Html.cdata "pause" ] + Html.button + ~a: + [ + Html.a_id id; + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "btn"; "btn-default" ]; + ] + [ Html.cdata "pause" ] - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [button] + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ button ] let onload () = let button_dom = Tyxml_js.To_dom.of_button button in - let () = button_dom##.onclick := - Dom.handler - (fun _ -> - let () = Panel_settings_controller.pause_simulation () in - Js._true) - in + let () = + button_dom##.onclick := + Dom.handler (fun _ -> + let () = Panel_settings_controller.pause_simulation () in + Js._true) + in () - end module ButtonTrace : Ui_common.Div = struct let id = "panel_settings_get_trace_button" + let button = - Html.button - ~a:[ Html.a_id id - ; Html.Unsafe.string_attrib "type" "button" - ; Tyxml_js.R.Html5.a_class - (React.S.map (fun model -> - (if model.State_project.model_parameters.State_project.store_trace - then [] else ["disabled"]) - @ ["btn" ; "btn-default" ; ]) - State_project.model)] - [ Html.cdata "get trace" ] - - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [button] + Html.button + ~a: + [ + Html.a_id id; + Html.Unsafe.string_attrib "type" "button"; + Tyxml_js.R.Html5.a_class + (React.S.map + (fun model -> + (if + model.State_project.model_parameters + .State_project.store_trace + then + [] + else + [ "disabled" ]) + @ [ "btn"; "btn-default" ]) + State_project.model); + ] + [ Html.cdata "get trace" ] + + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ button ] let onload () = let button_dom = Tyxml_js.To_dom.of_button button in - let () = button_dom##.onclick := - Dom.handler - (fun _ -> - let () = Panel_settings_controller.simulation_trace () in - Js._true) + let () = + button_dom##.onclick := + Dom.handler (fun _ -> + let () = Panel_settings_controller.simulation_trace () in + Js._true) in () end module ButtonOutputs : Ui_common.Div = struct let id = "panel_settings_outputs_button" + let button = - Html.button - ~a:[ Html.a_id id - ; Html.Unsafe.string_attrib "type" "button" - ; Html.a_class ["btn" ; "btn-default" ; ] ] - [ Html.cdata "All outputs" ] + Html.button + ~a: + [ + Html.a_id id; + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "btn"; "btn-default" ]; + ] + [ Html.cdata "All outputs" ] - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [button] + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ button ] let onload () = let button_dom = Tyxml_js.To_dom.of_button button in - let () = button_dom##.onclick := - Dom.handler - (fun _ -> - let () = Panel_settings_controller.simulation_outputs () in - Js._true) + let () = + button_dom##.onclick := + Dom.handler (fun _ -> + let () = Panel_settings_controller.simulation_outputs () in + Js._true) in () end module ButtonContinue : Ui_common.Div = struct let id = "panel_settings_continue_button" + let button = - Html.button - ~a:[ Html.a_id id - ; Html.Unsafe.string_attrib "type" "button" - ; Html.a_class ["btn" ; - "btn-default" ; ] ] - [ Html.cdata "continue" ] + Html.button + ~a: + [ + Html.a_id id; + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "btn"; "btn-default" ]; + ] + [ Html.cdata "continue" ] - let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [button] + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = [ button ] let onload () = let button_dom = Tyxml_js.To_dom.of_button button in - let () = button_dom##.onclick := - Dom.handler - (fun _ -> - let () = Panel_settings_controller.continue_simulation () in - Js._true) + let () = + button_dom##.onclick := + Dom.handler (fun _ -> + let () = Panel_settings_controller.continue_simulation () in + Js._true) in () end module DivStatusIndicator : Ui_common.Div = struct let id = "setting_status_indicator" + let content () : [> Html_types.div ] Tyxml_js.Html.elt list = let debug = Html.div - [ Tyxml_js.R.Html.txt - (React.S.bind - State_simulation.model - (fun model -> - let label = - State_simulation.model_state_to_string - (State_simulation.model_simulation_state model) in - React.S.const label - ) - ) + [ + Tyxml_js.R.Html.txt + (React.S.bind State_simulation.model (fun model -> + let label = + State_simulation.model_state_to_string + (State_simulation.model_simulation_state model) + in + React.S.const label)); ] in - [ Html.div - ~a:[ Html.a_id id ] - (Ui_common.level ~debug ()) ] + [ Html.div ~a:[ Html.a_id id ] (Ui_common.level ~debug ()) ] let onload () = () end module RunningPanelLayout : Ui_common.Div = struct let id = "settings_runetime_layout" - let progress_bar - (percent_signal : int Tyxml_js.R.Html.wrap) + + let progress_bar (percent_signal : int Tyxml_js.R.Html.wrap) (value_signal : string React.signal) = Html.div - ~a:[ Html.Unsafe.string_attrib "role" "progressbar" ; - Tyxml_js.R.Html.Unsafe.int_attrib "aria-valuenow" percent_signal ; - Html.Unsafe.int_attrib "aria-valuemin" 0 ; - Html.Unsafe.int_attrib "aria-valuemax" 100 ; - Tyxml_js.R.Html.Unsafe.string_attrib - "style" - (React.S.map - (fun s -> Format.sprintf "width: %d%%;" s) - percent_signal) ; - Html.a_class ["progress-bar"] ] - [ Tyxml_js.R.Html.txt - (React.S.bind - value_signal - (fun value -> React.S.const value) - ) - ] + ~a: + [ + Html.Unsafe.string_attrib "role" "progressbar"; + Tyxml_js.R.Html.Unsafe.int_attrib "aria-valuenow" percent_signal; + Html.Unsafe.int_attrib "aria-valuemin" 0; + Html.Unsafe.int_attrib "aria-valuemax" 100; + Tyxml_js.R.Html.Unsafe.string_attrib "style" + (React.S.map + (fun s -> Format.sprintf "width: %d%%;" s) + percent_signal); + Html.a_class [ "progress-bar" ]; + ] + [ + Tyxml_js.R.Html.txt + (React.S.bind value_signal (fun value -> React.S.const value)); + ] - let time_progress_bar () = + let time_progress_bar () = progress_bar (React.S.map (fun model -> - let simulation_info = State_simulation.model_simulation_info model in - let time_percent : int option = - Option_util.bind - (fun (status : Api_types_j.simulation_info) -> - status.Api_types_j.simulation_info_progress.Api_types_j.simulation_progress_time_percentage ) - simulation_info - in - let time_percent : int = Option_util.unsome 100 time_percent in - time_percent - ) + let simulation_info = State_simulation.model_simulation_info model in + let time_percent : int option = + Option_util.bind + (fun (status : Api_types_j.simulation_info) -> + status.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_time_percentage) + simulation_info + in + let time_percent : int = Option_util.unsome 100 time_percent in + time_percent) State_simulation.model) - (React.S.map (fun model -> + (React.S.map + (fun model -> let simulation_info = State_simulation.model_simulation_info model in let time : float option = Option_util.map (fun (status : Api_types_j.simulation_info) -> - status.Api_types_j.simulation_info_progress.Api_types_j.simulation_progress_time) simulation_info in + status.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_time) + simulation_info + in let time : float = Option_util.unsome 0.0 time in - string_of_float time - ) - State_simulation.model) + string_of_float time) + State_simulation.model) let event_progress_bar () = progress_bar - (React.S.map (fun model -> + (React.S.map + (fun model -> let simulation_info = State_simulation.model_simulation_info model in let event_percentage : int option = Option_util.bind (fun (status : Api_types_j.simulation_info) -> - status.Api_types_j.simulation_info_progress.Api_types_j.simulation_progress_event_percentage) simulation_info in - let event_percentage : int = Option_util.unsome 100 event_percentage in - event_percentage - ) - State_simulation.model) - (React.S.map (fun model -> + status.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_event_percentage) + simulation_info + in + let event_percentage : int = + Option_util.unsome 100 event_percentage + in + event_percentage) + State_simulation.model) + (React.S.map + (fun model -> let simulation_info = State_simulation.model_simulation_info model in let event : int option = Option_util.map (fun (status : Api_types_j.simulation_info) -> - status.Api_types_j.simulation_info_progress.Api_types_j.simulation_progress_event) + status.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_event) simulation_info in let event : int = Option_util.unsome 0 event in - string_of_int event - ) - State_simulation.model) + string_of_int event) + State_simulation.model) let tracked_events state = let tracked_events : int option = Option_util.bind (fun (status : Api_types_j.simulation_info) -> - status.Api_types_j.simulation_info_progress.Api_types_j.simulation_progress_tracked_events) + status.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_tracked_events) state in match tracked_events with - None -> None - | Some tracked_events -> - if tracked_events > 0 then - Some tracked_events - else - None + | None -> None + | Some tracked_events -> + if tracked_events > 0 then + Some tracked_events + else + None let tracked_events_count () = Tyxml_js.R.Html.txt (React.S.map (fun model -> - let simulation_info = State_simulation.model_simulation_info model in - match tracked_events simulation_info with - | Some tracked_events -> string_of_int tracked_events - | None -> " " - ) + let simulation_info = State_simulation.model_simulation_info model in + match tracked_events simulation_info with + | Some tracked_events -> string_of_int tracked_events + | None -> " ") State_simulation.model) let tracked_events_label () = Tyxml_js.R.Html.txt (React.S.map (fun model -> - let simulation_info = State_simulation.model_simulation_info model in - match tracked_events simulation_info with - Some _ -> "tracked events" - | None -> " " - ) + let simulation_info = State_simulation.model_simulation_info model in + match tracked_events simulation_info with + | Some _ -> "tracked events" + | None -> " ") State_simulation.model) let efficiency_detail ~current_event t = - let all = float_of_int - (t.Counter.Efficiency.no_more_binary + - t.Counter.Efficiency.no_more_unary + - t.Counter.Efficiency.clashing_instance + - t.Counter.Efficiency.time_correction) in + let all = + float_of_int + (t.Counter.Efficiency.no_more_binary + + t.Counter.Efficiency.no_more_unary + + t.Counter.Efficiency.clashing_instance + + t.Counter.Efficiency.time_correction) + in let events = float_of_int current_event in Html.p - [ Html.txt - (Format.asprintf - "@[%.2f%% of event loops were productive.%t@]" + [ + Html.txt + (Format.asprintf "@[%.2f%% of event loops were productive.%t@]" (100. *. events /. (all +. events)) - (fun f -> if all > 0. then - Format.fprintf f "@ Null event cause:")) ] - :: - ((if t.Counter.Efficiency.no_more_unary > 0 then - Some (Html.p - [ Html.txt - (Format.asprintf - "Valid embedding but no longer unary when required: %.2f%%" - (100. *. (float_of_int t.Counter.Efficiency.no_more_unary) /. all) )]) - else None) - $$ - ((if t.Counter.Efficiency.no_more_binary > 0 then - Some (Html.p - [ Html.txt - (Format.asprintf - "Valid embedding but not binary when required: %.2f%%" - (100. *. (float_of_int t.Counter.Efficiency.no_more_binary) /. all)) ] ) - else None) - $$ - ((if t.Counter.Efficiency.clashing_instance > 0 then - Some (Html.p - [ Html.txt - (Format.asprintf - "Clashing instance: %.2f%%" - (100. *. (float_of_int t.Counter.Efficiency.clashing_instance) /. all))]) - else None) - $$ - ((if t.Counter.Efficiency.time_correction > 0 then - Some (Html.p - [ Html.txt - (Format.asprintf - "Perturbation interrupting time advance: %.2f%%" - (100. *. (float_of_int t.Counter.Efficiency.time_correction) /. all))]) - else None) - $$ [])))) + (fun f -> if all > 0. then Format.fprintf f "@ Null event cause:")); + ] + :: ((if t.Counter.Efficiency.no_more_unary > 0 then + Some + (Html.p + [ + Html.txt + (Format.asprintf + "Valid embedding but no longer unary when required: \ + %.2f%%" + (100. + *. float_of_int t.Counter.Efficiency.no_more_unary + /. all)); + ]) + else + None) + $$ ((if t.Counter.Efficiency.no_more_binary > 0 then + Some + (Html.p + [ + Html.txt + (Format.asprintf + "Valid embedding but not binary when required: %.2f%%" + (100. + *. float_of_int t.Counter.Efficiency.no_more_binary + /. all)); + ]) + else + None) + $$ ((if t.Counter.Efficiency.clashing_instance > 0 then + Some + (Html.p + [ + Html.txt + (Format.asprintf "Clashing instance: %.2f%%" + (100. + *. float_of_int + t.Counter.Efficiency.clashing_instance + /. all)); + ]) + else + None) + $$ ((if t.Counter.Efficiency.time_correction > 0 then + Some + (Html.p + [ + Html.txt + (Format.asprintf + "Perturbation interrupting time advance: %.2f%%" + (100. + *. float_of_int + t.Counter.Efficiency.time_correction + /. all)); + ]) + else + None) + $$ [])))) + + let dont_gc_me = ref [] let content () : Html_types.div_content Tyxml_js.Html.elt list = - let state_log , set_state_log = ReactiveData.RList.create [] in - let _ = Lwt_react.S.map_s - (fun _ -> - State_simulation.with_simulation_info - ~label:__LOC__ - ~ready: - (fun manager status -> - manager#simulation_efficiency >>= - (Api_common.result_bind_lwt - ~ok:(fun eff -> - let current_event = - status.Api_types_j.simulation_info_progress.Api_types_j.simulation_progress_event in - let () = - ReactiveData.RList.set - set_state_log - (efficiency_detail ~current_event eff) in - Lwt.return (Result_util.ok ())) - ) - ) - ~stopped:(fun _ -> - let () = ReactiveData.RList.set set_state_log [] in - Lwt.return (Result_util.ok ())) - () - ) - State_simulation.model in - - [ [%html {| -
    + let state_log, set_state_log = ReactiveData.RList.create [] in + let () = + dont_gc_me := + [ + Lwt_react.S.map_s + (fun _ -> + State_simulation.with_simulation_info ~label:__LOC__ + ~ready:(fun manager status -> + manager#simulation_efficiency + >>= Api_common.result_bind_lwt ~ok:(fun eff -> + let current_event = + status.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_event + in + let () = + ReactiveData.RList.set set_state_log + (efficiency_detail ~current_event eff) + in + Lwt.return (Result_util.ok ()))) + ~stopped:(fun _ -> + let () = ReactiveData.RList.set set_state_log [] in + Lwt.return (Result_util.ok ())) + ()) + State_simulation.model; + ] + in + + [ + [%html + {| +
    - |}[ event_progress_bar () ]{| + |} + [ event_progress_bar () ] + {|
    events
    @@ -727,137 +795,180 @@ module RunningPanelLayout : Ui_common.Div = struct
    - |}[ time_progress_bar () ]{| + |} + [ time_progress_bar () ] + {|
    time
    - |}[ tracked_events_count () ]{| + |} + [ tracked_events_count () ] + {|
    - |}[ tracked_events_label () ]{| + |} + [ tracked_events_label () ] + {|
    -|}[ Tyxml_js.R.Html.div state_log ]{| +|} + [ Tyxml_js.R.Html.div state_log ] + {|
    - |}] ] + |}]; + ] let onload () = () - end let stopped_body () : [> Html_types.div ] Tyxml_js.Html5.elt = let stopped_row = Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "form-group"; "form-group-sm" ] - [ State_simulation.STOPPED ; ]) ] - [%html {| - -
    |}(InputPlotPeriod.content ()){|
    |}] in - let paused_row = FormPerturbation.content () in - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "panel-body" ; "panel-controls" ] - [ State_simulation.STOPPED ; - State_simulation.PAUSED ;]) ] - ([%html {| + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states + ~a_class:[ "form-group"; "form-group-sm" ] + [ State_simulation.STOPPED ]); + ] + [%html + {| + +
    |} + (InputPlotPeriod.content ()) + {|
    |}] + in + let paused_row = FormPerturbation.content () in + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states + ~a_class:[ "panel-body"; "panel-controls" ] + [ State_simulation.STOPPED; State_simulation.PAUSED ]); + ] + ([%html + {|
    - -
    |}(InputPauseCondition.content ()){|
    -
    |}(DivErrorMessage.content ()){|
    + +
    |} + (InputPauseCondition.content ()) + {|
    +
    |} + (DivErrorMessage.content ()) + {|
    |} - [stopped_row] - {||}]::paused_row) + [ stopped_row ] {||}] + :: paused_row) - let initializing_body () : [> Html_types.div ] Tyxml_js.Html5.elt = - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "panel-body" ; "panel-controls" ] - [ State_simulation.INITALIZING ; ]) ] - [ Html.entity "nbsp" ] +let initializing_body () : [> Html_types.div ] Tyxml_js.Html5.elt = + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states + ~a_class:[ "panel-body"; "panel-controls" ] + [ State_simulation.INITALIZING ]); + ] + [ Html.entity "nbsp" ] + +let running_body () = + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states + ~a_class:[ "panel-body"; "panel-controls" ] + [ State_simulation.RUNNING ]); + ] + (RunningPanelLayout.content ()) - let running_body () = - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "panel-body" ; "panel-controls" ] - [ State_simulation.RUNNING ; ]) ] - (RunningPanelLayout.content ()) let footer () = - [%html {| + [%html + {|
    - |}[ Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "col-md-2"; "col-xs-4" ] - [ State_simulation.STOPPED ; ]) ] - (ButtonStart.content ()); - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "col-md-2"; "col-xs-3" ] - [ State_simulation.PAUSED ; ]) ] - (ButtonContinue.content ()); - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "col-md-2"; "col-xs-3" ] - [ State_simulation.PAUSED ; ]) ] - (ButtonOutputs.content ()); - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "col-md-2"; "col-xs-3" ] - [ State_simulation.PAUSED ; ]) ] - (ButtonTrace.content ()); - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "col-md-2"; "col-xs-4" ] - [ State_simulation.RUNNING ; ]) ] - (ButtonPause.content ()); - Html.div - ~a:[ Tyxml_js.R.Html.a_class - (visible_on_states - ~a_class:[ "col-xs-2"; "col-sm-1" ] - [ State_simulation.PAUSED ; - State_simulation.RUNNING ; ]) ] - (ButtonClear.content ()); - Html.div - ~a:[ Html.a_class [ "col-md-1"; "col-xs-3" ] ] - ((DivStatusIndicator.content ()) - @ - [ Html.entity "nbsp" ; ]) ]{| + |} + [ + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states ~a_class:[ "col-md-2"; "col-xs-4" ] + [ State_simulation.STOPPED ]); + ] + (ButtonStart.content ()); + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states ~a_class:[ "col-md-2"; "col-xs-3" ] + [ State_simulation.PAUSED ]); + ] + (ButtonContinue.content ()); + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states ~a_class:[ "col-md-2"; "col-xs-3" ] + [ State_simulation.PAUSED ]); + ] + (ButtonOutputs.content ()); + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states ~a_class:[ "col-md-2"; "col-xs-3" ] + [ State_simulation.PAUSED ]); + ] + (ButtonTrace.content ()); + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states ~a_class:[ "col-md-2"; "col-xs-4" ] + [ State_simulation.RUNNING ]); + ] + (ButtonPause.content ()); + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (visible_on_states ~a_class:[ "col-xs-2"; "col-sm-1" ] + [ State_simulation.PAUSED; State_simulation.RUNNING ]); + ] + (ButtonClear.content ()); + Html.div + ~a:[ Html.a_class [ "col-md-1"; "col-xs-3" ] ] + (DivStatusIndicator.content () @ [ Html.entity "nbsp" ]); + ] + {|
    |}] + let content () = Html.div - ~a:[ Tyxml_js.R.Html.a_class - (React.S.bind - State_project.model - (fun model -> - match model.State_project.model_current_id with - | None -> React.S.const [ "hide" ] - | Some _ -> React.S.const [ "panel"; "panel-default" ] - ) - ) - ] - [(stopped_body ()); - (initializing_body ()); - (running_body ()); - (footer ()); ] + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.bind State_project.model (fun model -> + match model.State_project.model_current_id with + | None -> React.S.const [ "hide" ] + | Some _ -> React.S.const [ "panel"; "panel-default" ])); + ] + [ stopped_body (); initializing_body (); running_body (); footer () ] let onload () : unit = let () = FormPerturbation.onload () in @@ -870,6 +981,7 @@ let onload () : unit = let () = ButtonTrace.onload () in let () = ButtonOutputs.onload () in let () = ButtonClear.onload () in - let () = DivStatusIndicator.onload() in + let () = DivStatusIndicator.onload () in () + let onresize () : unit = () diff --git a/gui/panel_settings_controller.ml b/gui/panel_settings_controller.ml index f947c98b8a..1d849f7ffd 100644 --- a/gui/panel_settings_controller.ml +++ b/gui/panel_settings_controller.ml @@ -8,120 +8,93 @@ open Lwt.Infix -let create_simulation_parameter param : - Api_types_j.simulation_parameter = { - Api_types_j.simulation_plot_period = param.State_project.plot_period ; - Api_types_j.simulation_pause_condition = param.State_project.pause_condition ; - Api_types_j.simulation_seed = param.State_project.seed; - Api_types_j.simulation_store_trace = param.State_project.store_trace ; -} +let create_simulation_parameter param : Api_types_j.simulation_parameter = + { + Api_types_j.simulation_plot_period = param.State_project.plot_period; + Api_types_j.simulation_pause_condition = param.State_project.pause_condition; + Api_types_j.simulation_seed = param.State_project.seed; + Api_types_j.simulation_store_trace = param.State_project.store_trace; + } let continue_simulation () = - Common.async - __LOC__ - (fun () -> - let pause_condition = - let open State_project in - (React.S.value model).model_parameters.pause_condition in - State_error.wrap - __LOC__ - (State_simulation.continue_simulation pause_condition) - >>= (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + let pause_condition = + let open State_project in + (React.S.value model).model_parameters.pause_condition + in + State_error.wrap __LOC__ + (State_simulation.continue_simulation pause_condition) + >>= fun _ -> Lwt.return_unit) let pause_simulation () = - Common.async - __LOC__ - (fun () -> - State_error.wrap __LOC__ (State_simulation.pause_simulation ()) - >>= (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ (State_simulation.pause_simulation ()) + >>= fun _ -> Lwt.return_unit) let stop_simulation () = - Common.async - __LOC__ - (fun () -> - let () = Common.debug (Js.string "subpanel_editor_controller.stop") in - State_error.wrap __LOC__ (State_simulation.stop_simulation ()) - >>= (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + let () = Common.debug (Js.string "subpanel_editor_controller.stop") in + State_error.wrap __LOC__ (State_simulation.stop_simulation ()) + >>= fun _ -> Lwt.return_unit) let start_simulation () = - Common.async - __LOC__ - (fun () -> - let simulation_parameter = - create_simulation_parameter - (React.S.value State_project.model).State_project.model_parameters in - State_error.wrap - __LOC__ (State_simulation.start_simulation simulation_parameter) - >>= (fun _ -> Lwt.return_unit) - ) + Common.async __LOC__ (fun () -> + let simulation_parameter = + create_simulation_parameter + (React.S.value State_project.model).State_project.model_parameters + in + State_error.wrap __LOC__ + (State_simulation.start_simulation simulation_parameter) + >>= fun _ -> Lwt.return_unit) let intervene_simulation () = - Common.async - __LOC__ - (fun () -> + Common.async __LOC__ (fun () -> let model_perturbation = - React.S.value State_perturbation.model_intervention in - State_error.wrap - __LOC__ (State_simulation.intervene_simulation model_perturbation) >>= - Result_util.fold - ~ok:(fun text -> - let () = State_error.add_error __LOC__ [{ - Result_util.severity = Logs.Info; - Result_util.range = None; - Result_util.text; - }] in - Lwt.return_unit) - ~error:(fun _ -> Lwt.return_unit)) + React.S.value State_perturbation.model_intervention + in + State_error.wrap __LOC__ + (State_simulation.intervene_simulation model_perturbation) + >>= Result_util.fold + ~ok:(fun text -> + let () = + State_error.add_error __LOC__ + [ + { + Result_util.severity = Logs.Info; + Result_util.range = None; + Result_util.text; + }; + ] + in + Lwt.return_unit) + ~error:(fun _ -> Lwt.return_unit)) -let focus_range (range : Locality.t) : unit = - let file_id = range.Locality.file in - let line = range.Locality.from_position.Locality.line in - Common.async - __LOC__ - (fun () -> - State_error.wrap - ~append:true - __LOC__ - (State_file.select_file file_id (Some line)) - >>= (fun _ -> Lwt.return_unit) - ) +let focus_range (range : Loc.t) : unit = + let file_id = range.Loc.file in + let line = range.Loc.from_position.Loc.line in + Common.async __LOC__ (fun () -> + State_error.wrap ~append:true __LOC__ + (State_file.select_file file_id (Some line)) + >>= fun _ -> Lwt.return_unit) let simulation_trace () = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - State_error.wrap - __LOC__ - manager#simulation_raw_trace >>= - (Api_common.result_bind_lwt - ~ok:(fun data_string -> - let data = Js.string data_string in - let () = - Common.saveFile - ~data ~mime:"application/octet-stream" - ~filename:"trace.json" in - Lwt.return (Result_util.ok ())) - ) - ) + State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_error.wrap __LOC__ manager#simulation_raw_trace + >>= Api_common.result_bind_lwt ~ok:(fun data_string -> + let data = Js.string data_string in + let () = + Common.saveFile ~data ~mime:"application/octet-stream" + ~filename:"trace.json" + in + Lwt.return (Result_util.ok ()))) let simulation_outputs () = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - State_error.wrap - __LOC__ - manager#simulation_outputs_zip >>= - (Api_common.result_bind_lwt - ~ok:(fun data_bigstring -> - let data = - Typed_array.Bigstring.to_arrayBuffer data_bigstring in - let () = - Common.saveFile - ~data ~mime:"application/zip" - ~filename:"simulation_outputs.zip" in - Lwt.return (Result_util.ok ())) - ) - ) + State_simulation.when_ready ~label:__LOC__ (fun manager -> + State_error.wrap __LOC__ manager#simulation_outputs_zip + >>= Api_common.result_bind_lwt ~ok:(fun data_bigstring -> + let data = Typed_array.Bigstring.to_arrayBuffer data_bigstring in + let () = + Common.saveFile ~data ~mime:"application/zip" + ~filename:"simulation_outputs.zip" + in + Lwt.return (Result_util.ok ()))) diff --git a/gui/panel_settings_controller.mli b/gui/panel_settings_controller.mli index afc31c3994..615ec0c3a2 100644 --- a/gui/panel_settings_controller.mli +++ b/gui/panel_settings_controller.mli @@ -13,4 +13,4 @@ val start_simulation : unit -> unit val intervene_simulation : unit -> unit val simulation_trace : unit -> unit val simulation_outputs : unit -> unit -val focus_range : Locality.range -> unit +val focus_range : Loc.t -> unit diff --git a/gui/panel_tab.ml b/gui/panel_tab.ml index 6bcc870787..36aba0b845 100644 --- a/gui/panel_tab.ml +++ b/gui/panel_tab.ml @@ -13,38 +13,40 @@ let navtabs () = Some (React.S.map (fun s -> - if s.State_project.model_parameters.State_project.store_trace - then [] else ["disabled"]) - State_project.model) in - Tyxml_js.To_dom.of_ul @@ - Ui_common.navtabs nav_tab_id - ([ "editor", None, (Tab_editor.navli ()) - ; "log", None, (Tab_log.navli ()) - ; "plot", None, (Tab_plot.navli ()) - ; "DIN", None, (Tab_flux.navli ()) - ; "snapshot", None, (Tab_snapshot.navli ()) - ; "outputs", None, (Tab_outputs.navli ()) - ; "stories", story_class, (Tab_stories.navli ()) - ; "about", None, (Tab_about.navli ()) - ]) + if s.State_project.model_parameters.State_project.store_trace then + [] + else + [ "disabled" ]) + State_project.model) + in + Tyxml_js.To_dom.of_ul + @@ Ui_common.navtabs nav_tab_id + [ + "editor", None, Tab_editor.navli (); + "log", None, Tab_log.navli (); + "plot", None, Tab_plot.navli (); + "DIN", None, Tab_flux.navli (); + "snapshot", None, Tab_snapshot.navli (); + "outputs", None, Tab_outputs.navli (); + "stories", story_class, Tab_stories.navli (); + "about", None, Tab_about.navli (); + ] -let navcontents_id : string = - "navcontents" +let navcontents_id : string = "navcontents" let navcontents () = - Tyxml_js.To_dom.of_div @@ - Ui_common.navcontent - ~id:navcontents_id - [] - ([ "editor", ["row"], (Tab_editor.content ()) - ; "log", [], (Tab_log.content ()) - ; "plot", [], (Tab_plot.content ()) - ; "DIN", [], (Tab_flux.content ()) - ; "snapshot", [], (Tab_snapshot.content ()) - ; "outputs", [], (Tab_outputs.content ()) - ; "stories", ["row"], (Tab_stories.content ()) - ; "about", ["panel-scroll"], (Tab_about.content ()) - ]) + Tyxml_js.To_dom.of_div + @@ Ui_common.navcontent ~id:navcontents_id [] + [ + "editor", [ "row" ], Tab_editor.content (); + "log", [], Tab_log.content (); + "plot", [], Tab_plot.content (); + "DIN", [], Tab_flux.content (); + "snapshot", [], Tab_snapshot.content (); + "outputs", [], Tab_outputs.content (); + "stories", [ "row" ], Tab_stories.content (); + "about", [ "panel-scroll" ], Tab_about.content (); + ] let onload () = let () = Tab_editor.onload () in diff --git a/gui/panel_tab.mli b/gui/panel_tab.mli index 87d325e23c..8c794fafed 100644 --- a/gui/panel_tab.mli +++ b/gui/panel_tab.mli @@ -1,4 +1,4 @@ -val navtabs: unit -> Js_of_ocaml.Dom_html.uListElement Js.t -val navcontents: unit -> Dom_html.divElement Js.t -val onresize: unit -> unit -val onload: unit -> unit +val navtabs : unit -> Js_of_ocaml.Dom_html.uListElement Js.t +val navcontents : unit -> Dom_html.divElement Js.t +val onresize : unit -> unit +val onload : unit -> unit diff --git a/gui/rest_api.ml b/gui/rest_api.ml index 68210409ff..4ceee843d5 100644 --- a/gui/rest_api.ml +++ b/gui/rest_api.ml @@ -16,15 +16,10 @@ let request_up v = incr v let request_down v = decr v let is_computing v = !v <> 0 -let send - ?(timeout : float option) - request_count - (url : string) - (meth : Common.meth) - ?(data : string option) - (hydrate : string -> 'a) - : 'a Api.result Lwt.t = - let reply,feeder = Lwt.task () in +let send ?(timeout : float option) request_count (url : string) + (meth : Common.meth) ?(data : string option) (hydrate : string -> 'a) : + 'a Api.result Lwt.t = + let reply, feeder = Lwt.task () in let handler status response_text = let result_code : Result_util.status option = match status with @@ -35,22 +30,25 @@ let send | 404 -> Some `Not_found | 408 -> Some `Request_timeout | 409 -> Some `Conflict - | _ -> None in + | _ -> None + in let result = match result_code with - | None -> - Api_common.result_error_exception (BadResponseCode status) + | None -> Api_common.result_error_exception (BadResponseCode status) | Some result_code -> - if (400 <= status) && (status < 500) then - Api_common.result_messages - ~result_code + if 400 <= status && status < 500 then + Api_common.result_messages ~result_code (Yojson.Basic.read_list Result_util.read_message - (Yojson.Safe.init_lexer ()) (Lexing.from_string response_text)) - else + (Yojson.Safe.init_lexer ()) + (Lexing.from_string response_text)) + else ( let response = hydrate response_text in - Result_util.ok response in + Result_util.ok response + ) + in let () = request_down request_count in - let () = Lwt.wakeup feeder result in () + let () = Lwt.wakeup feeder result in + () in let () = request_up request_count in let () = Common.ajax_request ~url ~meth ?timeout ?data ~handler in @@ -60,603 +58,467 @@ let kasa_error l = Lwt.return_error (List.fold_left (fun acc m -> - Exception_without_parameter.add_uncaught_error - (Exception_without_parameter.build_uncaught_exception - ~file_name:"rest_api" ~message:m.Result_util.text Exit) - acc) + Exception_without_parameter.add_uncaught_error + (Exception_without_parameter.build_uncaught_exception + ~file_name:"rest_api" ~message:m.Result_util.text Exit) + acc) Exception_without_parameter.empty_error_handler l) -class manager - ~(timeout:float option) - ~url ~project_id : Api.rest_manager = +class manager ~(timeout : float option) ~url ~project_id : Api.rest_manager = let request_count = ref 0 in - object(self) - method private message : - Mpi_message_j.request -> Mpi_message_j.response Lwt.t = - function - | `ProjectLoad _ -> - Lwt.return (Api_common.result_error_msg - ~result_code:`Bad_request - "low level project_load mustn't be used over HTTP") - | `SimulationContinue pause_condition -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/continue" - url project_id) - `PUT - ~data:(Yojson.Safe.to_string (`String pause_condition)) - (fun _ -> (`SimulationContinue)) - | `SimulationDelete -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation" - url - project_id) - `DELETE - (fun _ -> (`SimulationDelete)) - | `SimulationDetailFileLine file_line_id -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/filelines/%s" - url - project_id - file_line_id) - `GET - (fun result -> - let lines = - Yojson.Safe.read_list - Yojson.Safe.read_string - (Yojson.Safe.init_lexer ()) (Lexing.from_string result) in - (`SimulationDetailFileLine lines)) - | `SimulationDetailDIN flux_map_id -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/DIN/%s" - url - project_id - flux_map_id) - `GET - (fun result -> - (`SimulationDetailDIN (Mpi_message_j.din_of_string result))) - | `SimulationDetailLogMessage -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/logmessages" - url - project_id) - `GET - (fun result -> - (`SimulationDetailLogMessage - (Mpi_message_j.log_message_of_string result))) - | `SimulationDetailPlot plot_limit -> - let args = - String.concat - "&" - (List.map - (fun (key,value) -> Format.sprintf "%s=%s" key value) - ((match plot_limit.Api_types_j.plot_limit_offset with - | None -> [] - | Some plot_limit_offset -> [("plot_limit_offset",string_of_int plot_limit_offset)]) - @ - (match plot_limit.Api_types_j.plot_limit_points with + object (self) + method private message + : Mpi_message_j.request -> Mpi_message_j.response Lwt.t = + function + | `ProjectLoad _ -> + Lwt.return + (Api_common.result_error_msg ~result_code:`Bad_request + "low level project_load mustn't be used over HTTP") + | `SimulationContinue pause_condition -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/continue" url project_id) + `PUT + ~data:(Yojson.Safe.to_string (`String pause_condition)) + (fun _ -> `SimulationContinue) + | `SimulationDelete -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation" url project_id) `DELETE + (fun _ -> `SimulationDelete) + | `SimulationDetailFileLine file_line_id -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/filelines/%s" url + project_id file_line_id) `GET (fun result -> + let lines = + Yojson.Safe.read_list Yojson.Safe.read_string + (Yojson.Safe.init_lexer ()) + (Lexing.from_string result) + in + `SimulationDetailFileLine lines) + | `SimulationDetailDIN flux_map_id -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/DIN/%s" url project_id + flux_map_id) `GET (fun result -> + `SimulationDetailDIN (Mpi_message_j.din_of_string result)) + | `SimulationDetailLogMessage -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/logmessages" url + project_id) `GET (fun result -> + `SimulationDetailLogMessage + (Mpi_message_j.log_message_of_string result)) + | `SimulationDetailPlot plot_limit -> + let args = + String.concat "&" + (List.map + (fun (key, value) -> Format.sprintf "%s=%s" key value) + ((match plot_limit.Api_types_j.plot_limit_offset with + | None -> [] + | Some plot_limit_offset -> + [ "plot_limit_offset", string_of_int plot_limit_offset ]) + @ + match plot_limit.Api_types_j.plot_limit_points with | None -> [] - | Some plot_limit_points -> [("plot_limit_points",string_of_int plot_limit_points)]) - )) in - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/plot" - url - project_id) - `GET - ~data:args - (fun result -> - (`SimulationDetailPlot (Mpi_message_j.plot_of_string result))) - | `SimulationDetailSnapshot snapshot_id -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/snapshots/%s" - url - project_id - snapshot_id) - `GET - (fun result -> - (`SimulationDetailSnapshot - (Mpi_message_j.snapshot_detail_of_string result))) - | `SimulationInfo -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation" - url - project_id) - `GET - (fun result -> - (`SimulationInfo (Mpi_message_j.simulation_info_of_string result))) - | `SimulationEfficiency -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/efficiency" - url - project_id) - `GET - (fun result -> - (`SimulationEfficiency - (Mpi_message_j.simulation_efficiency_of_string result))) - | `SimulationTrace -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/trace" - url - project_id) - `GET - (fun s -> (`SimulationTrace s)) - | `SimulationOutputsZip -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/outputs" - url - project_id) - `GET - (fun s -> (`SimulationOutputsZip s)) - | `SimulationCatalogFileLine -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/filelines" - url - project_id) - `GET - (fun result -> - (`SimulationCatalogFileLine - (Mpi_message_j.file_line_catalog_of_string result))) - | `SimulationCatalogDIN -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/DIN" - url - project_id) - `GET - (fun result -> - (`SimulationCatalogDIN - (Mpi_message_j.din_catalog_of_string result))) - | `SimulationCatalogSnapshot -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/snapshots" - url - project_id) - `GET - (fun result -> - (`SimulationCatalogSnapshot - (Mpi_message_j.snapshot_catalog_of_string result))) - | `SimulationPause -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/pause" - url - project_id) - `PUT - (fun _ -> `SimulationPause) - | `SimulationParameter -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/parameter" - url - project_id) - `GET - (fun result -> - (`SimulationParameter - (Mpi_message_j.simulation_parameter_of_string result))) - | `SimulationIntervention simulation_intervention -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation/intervention" - url - project_id) - `PUT - ~data:(Api_types_j.string_of_simulation_intervention - simulation_intervention) - (fun result -> - `SimulationIntervention - (Yojson.Safe.read_string - (Yojson.Safe.init_lexer ()) (Lexing.from_string result))) - | `SimulationStart simulation_parameter -> - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/simulation" - url - project_id) - `POST - ~data:(Api_types_j.string_of_simulation_parameter simulation_parameter) - (fun result -> - (`SimulationStart - (Mpi_message_j.simulation_artifact_of_string result))) - - inherit Mpi_api.manager_base () - - method private rest_message = function - | `EnvironmentInfo -> - send - ?timeout request_count - (Format.sprintf "%s/v2" url) - `GET - (fun result -> - (`EnvironmentInfo (Mpi_message_j.environment_info_of_string result))) - | `ProjectCatalog -> - send - ?timeout request_count - (Format.sprintf "%s/v2/projects" url) - `GET - (fun result -> - let projects = - Yojson.Safe.read_list - Yojson.Safe.read_string - (Yojson.Safe.init_lexer ()) (Lexing.from_string result) in - `ProjectCatalog projects) - | `ProjectCreate project_parameter -> - send - ?timeout request_count - (Format.sprintf "%s/v2/projects" url) - `POST - ~data:(Api_types_j.string_of_project_parameter project_parameter) - (fun _ -> `ProjectCreate) - | `ProjectDelete project_id -> - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s" url project_id) - `DELETE - (fun _ -> `ProjectDelete) - - method environment_info () : - Api_types_j.environment_info Api.result Lwt.t = - self#rest_message `EnvironmentInfo >>= - Api_common.result_bind_lwt - ~ok:(function - | `EnvironmentInfo - (result : Mpi_message_t.environment_info) -> - Lwt.return (Result_util.ok result) - | response -> - Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method project_delete project_id: unit Api.result Lwt.t = - self#rest_message (`ProjectDelete project_id) >>= - Api_common.result_bind_lwt - ~ok:(function - | `ProjectDelete -> - Lwt.return (Result_util.ok ()) + | Some plot_limit_points -> + [ "plot_limit_points", string_of_int plot_limit_points ])) + in + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/plot" url project_id) + `GET ~data:args (fun result -> + `SimulationDetailPlot (Mpi_message_j.plot_of_string result)) + | `SimulationDetailSnapshot snapshot_id -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/snapshots/%s" url + project_id snapshot_id) `GET (fun result -> + `SimulationDetailSnapshot + (Mpi_message_j.snapshot_detail_of_string result)) + | `SimulationInfo -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation" url project_id) `GET + (fun result -> + `SimulationInfo (Mpi_message_j.simulation_info_of_string result)) + | `SimulationEfficiency -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/efficiency" url + project_id) `GET (fun result -> + `SimulationEfficiency + (Mpi_message_j.simulation_efficiency_of_string result)) + | `SimulationTrace -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/trace" url project_id) + `GET (fun s -> `SimulationTrace s) + | `SimulationOutputsZip -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/outputs" url project_id) + `GET (fun s -> `SimulationOutputsZip s) + | `SimulationCatalogFileLine -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/filelines" url + project_id) `GET (fun result -> + `SimulationCatalogFileLine + (Mpi_message_j.file_line_catalog_of_string result)) + | `SimulationCatalogDIN -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/DIN" url project_id) + `GET (fun result -> + `SimulationCatalogDIN (Mpi_message_j.din_catalog_of_string result)) + | `SimulationCatalogSnapshot -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/snapshots" url + project_id) `GET (fun result -> + `SimulationCatalogSnapshot + (Mpi_message_j.snapshot_catalog_of_string result)) + | `SimulationPause -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/pause" url project_id) + `PUT (fun _ -> `SimulationPause) + | `SimulationParameter -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/parameter" url + project_id) `GET (fun result -> + `SimulationParameter + (Mpi_message_j.simulation_parameter_of_string result)) + | `SimulationIntervention simulation_intervention -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation/intervention" url + project_id) `PUT + ~data: + (Api_types_j.string_of_simulation_intervention + simulation_intervention) (fun result -> + `SimulationIntervention + (Yojson.Safe.read_string + (Yojson.Safe.init_lexer ()) + (Lexing.from_string result))) + | `SimulationStart simulation_parameter -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/simulation" url project_id) `POST + ~data: + (Api_types_j.string_of_simulation_parameter simulation_parameter) + (fun result -> + `SimulationStart + (Mpi_message_j.simulation_artifact_of_string result)) + + inherit Mpi_api.manager_base () + + method private rest_message = + function + | `EnvironmentInfo -> + send ?timeout request_count (Format.sprintf "%s/v2" url) `GET + (fun result -> + `EnvironmentInfo (Mpi_message_j.environment_info_of_string result)) + | `ProjectCatalog -> + send ?timeout request_count (Format.sprintf "%s/v2/projects" url) `GET + (fun result -> + let projects = + Yojson.Safe.read_list Yojson.Safe.read_string + (Yojson.Safe.init_lexer ()) + (Lexing.from_string result) + in + `ProjectCatalog projects) + | `ProjectCreate project_parameter -> + send ?timeout request_count (Format.sprintf "%s/v2/projects" url) `POST + ~data:(Api_types_j.string_of_project_parameter project_parameter) + (fun _ -> `ProjectCreate) + | `ProjectDelete project_id -> + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s" url project_id) `DELETE (fun _ -> + `ProjectDelete) + + method environment_info () : Api_types_j.environment_info Api.result Lwt.t = + self#rest_message `EnvironmentInfo + >>= Api_common.result_bind_lwt ~ok:(function + | `EnvironmentInfo (result : Mpi_message_t.environment_info) -> + Lwt.return (Result_util.ok result) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response)) + (Api_common.result_error_exception (BadResponse response))) - ) + method project_delete project_id : unit Api.result Lwt.t = + self#rest_message (`ProjectDelete project_id) + >>= Api_common.result_bind_lwt ~ok:(function + | `ProjectDelete -> Lwt.return (Result_util.ok ()) + | response -> + Lwt.return + (Api_common.result_error_exception (BadResponse response))) method project_catalog : string list Api.result Lwt.t = - self#rest_message `ProjectCatalog >>= - Api_common.result_bind_lwt - ~ok:(function - | `ProjectCatalog result -> - Lwt.return (Result_util.ok result) + self#rest_message `ProjectCatalog + >>= Api_common.result_bind_lwt ~ok:(function + | `ProjectCatalog result -> Lwt.return (Result_util.ok result) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) - - method project_create - (project_parameter : Api_types_j.project_parameter) : unit Api.result Lwt.t = - self#rest_message (`ProjectCreate project_parameter) >>= - Api_common.result_bind_lwt - ~ok:(function - | `ProjectCreate -> - Lwt.return (Result_util.ok ()) + (Api_common.result_error_exception (BadResponse response))) + + method project_create (project_parameter : Api_types_j.project_parameter) + : unit Api.result Lwt.t = + self#rest_message (`ProjectCreate project_parameter) + >>= Api_common.result_bind_lwt ~ok:(function + | `ProjectCreate -> Lwt.return (Result_util.ok ()) | response -> Lwt.return - (Api_common.result_error_exception - (BadResponse response))) + (Api_common.result_error_exception (BadResponse response))) method secret_project_parse = - Lwt.return (Api_common.result_error_msg - ~result_code:`Bad_request - "low level project_parse mustn't be used over HTTP") + Lwt.return + (Api_common.result_error_msg ~result_code:`Bad_request + "low level project_parse mustn't be used over HTTP") method secret_get_pos_of_rules_and_vars = - Lwt.return (Api_common.result_error_msg - ~result_code:`Bad_request - "low level get_pos_of_rules_and_vars mustn't be used over HTTP") + Lwt.return + (Api_common.result_error_msg ~result_code:`Bad_request + "low level get_pos_of_rules_and_vars mustn't be used over HTTP") method project_parse ~patternSharing overwrite = - send - ?timeout request_count + send ?timeout request_count (Format.asprintf "%s/v2/projects/%s/parse/%s%t" url project_id (match patternSharing with - | Pattern.No_sharing -> "no_sharing" - | Pattern.Compatible_patterns -> "compatible_patterns" - | Pattern.Max_sharing -> "max_sharing") - (fun f -> match overwrite with - | [] -> () - | l -> Format.fprintf f "?%a" - (Pp.list - (fun f -> Format.pp_print_string f "&") - (fun f (vr,va) -> - Format.fprintf f "%s=%a" vr Nbr.print va)) - l)) + | Pattern.No_sharing -> "no_sharing" + | Pattern.Compatible_patterns -> "compatible_patterns" + | Pattern.Max_sharing -> "max_sharing") + (fun f -> + match overwrite with + | [] -> () + | l -> + Format.fprintf f "?%a" + (Pp.list + (fun f -> Format.pp_print_string f "&") + (fun f (vr, va) -> Format.fprintf f "%s=%a" vr Nbr.print va)) + l)) + `POST + (JsonUtil.read_of_string Yojson.Basic.read_null) + + method terminate = Lwt.ignore_result (self#project_delete project_id) + method is_running = true (*TODO*) + + method file_catalog = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/files" url project_id) + `GET + (JsonUtil.read_of_string + (Yojson.Basic.read_list Kfiles.read_catalog_item)) + + method file_create pos id content = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/files/%s/position/%i" url project_id + id pos) + `PUT + ~data:(Yojson.Basic.to_string (`String content)) + (JsonUtil.read_of_string Yojson.Basic.read_null) + + method file_get id = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/files/%s" url project_id id) + `GET + (JsonUtil.read_of_string + (JsonUtil.read_compact_pair Yojson.Basic.read_string + Yojson.Basic.read_int)) + + method file_update id content = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/files/%s" url project_id id) + `POST + ~data:(Yojson.Basic.to_string (`String content)) + (JsonUtil.read_of_string Yojson.Basic.read_null) + + method file_move pos id = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/files/%s/position/%i" url project_id + id pos) `POST (JsonUtil.read_of_string Yojson.Basic.read_null) - method terminate = - Lwt.ignore_result (self#project_delete project_id) - - method is_running = true (*TODO*) - - method file_catalog = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/files" url project_id) - `GET - (JsonUtil.read_of_string - (Yojson.Basic.read_list Kfiles.read_catalog_item)) - - method file_create pos id content = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/files/%s/position/%i" url project_id id pos) - `PUT ~data:(Yojson.Basic.to_string (`String content)) - (JsonUtil.read_of_string Yojson.Basic.read_null) - - method file_get id = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/files/%s" url project_id id) - `GET - (JsonUtil.read_of_string - (JsonUtil.read_compact_pair - Yojson.Basic.read_string Yojson.Basic.read_int)) - - method file_update id content = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/files/%s" url project_id id) - `POST ~data:(Yojson.Basic.to_string (`String content)) - (JsonUtil.read_of_string Yojson.Basic.read_null) - - method file_move pos id = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/files/%s/position/%i" url project_id id pos) - `POST - (JsonUtil.read_of_string Yojson.Basic.read_null) - - method file_delete id = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/files/%s" url project_id id) - `DELETE - (JsonUtil.read_of_string Yojson.Basic.read_null) - - method project_overwrite file_id ast = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/overwrite/%s" url project_id file_id) - `POST ~data:(Yojson.Basic.to_string (Ast.compil_to_json ast)) - (JsonUtil.read_of_string Yojson.Basic.read_null) - - method init_static_analyser_raw data = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/analyses" url project_id) - `PUT ~data - (fun x -> - match Yojson.Basic.from_string x with - | `Null -> () - | x -> - raise - (Yojson.Basic.Util.Type_error ("Not a KaSa INIT response: ", x))) - - method init_static_analyser compil = - self#init_static_analyser_raw - (Yojson.Basic.to_string (Ast.compil_to_json compil)) - - method get_contact_map accuracy = - send - ?timeout request_count - (match accuracy with - | Some accuracy -> - Format.sprintf "%s/v2/projects/%s/analyses/contact_map?accuracy=%s" - url project_id (Public_data.accuracy_to_string accuracy) - | None -> - Format.sprintf "%s/v2/projects/%s/analyses/contact_map" url project_id) - `GET - (fun x -> Yojson.Basic.from_string x) - - method get_influence_map_raw accuracy = - send - ?timeout request_count - (match accuracy with - | Some accuracy -> - Format.sprintf "%s/v2/projects/%s/analyses/influence_map?accuracy=%s" - url project_id (Public_data.accuracy_to_string accuracy) - | None -> Format.sprintf "%s/v2/analyses/influence_map" url) - `GET - (fun x -> x) - - method get_local_influence_map ?fwd ?bwd ?origin ~total accuracy = - send - ?timeout request_count - (let s = - match accuracy with - | Some accuracy -> - "&accuracy="^(Public_data.accuracy_to_string accuracy) - | None -> "" - in - Format.sprintf - "%s/v2/projects/%s/analyses/influence_map?total=%i%s%s%s%s" - url project_id total - ( - match origin with - | Some (Public_data.Rule i) -> "&origin=_rule_"^(string_of_int i) - | Some (Public_data.Var i) -> "&origin=_var_"^(string_of_int i) + method file_delete id = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/files/%s" url project_id id) + `DELETE + (JsonUtil.read_of_string Yojson.Basic.read_null) + + method project_overwrite file_id ast = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/overwrite/%s" url project_id file_id) + `POST + ~data:(Yojson.Basic.to_string (Ast.compil_to_json ast)) + (JsonUtil.read_of_string Yojson.Basic.read_null) + + method init_static_analyser_raw data = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/analyses" url project_id) `PUT ~data + (fun x -> + match Yojson.Basic.from_string x with + | `Null -> () + | x -> + raise + (Yojson.Basic.Util.Type_error ("Not a KaSa INIT response: ", x))) + + method init_static_analyser compil = + self#init_static_analyser_raw + (Yojson.Basic.to_string (Ast.compil_to_json compil)) + + method get_contact_map accuracy = + send ?timeout request_count + (match accuracy with + | Some accuracy -> + Format.sprintf "%s/v2/projects/%s/analyses/contact_map?accuracy=%s" + url project_id + (Public_data.accuracy_to_string accuracy) + | None -> + Format.sprintf "%s/v2/projects/%s/analyses/contact_map" url project_id) + `GET + (fun x -> Yojson.Basic.from_string x) + + method get_influence_map_raw accuracy = + send ?timeout request_count + (match accuracy with + | Some accuracy -> + Format.sprintf "%s/v2/projects/%s/analyses/influence_map?accuracy=%s" + url project_id + (Public_data.accuracy_to_string accuracy) + | None -> Format.sprintf "%s/v2/analyses/influence_map" url) + `GET + (fun x -> x) + + method get_local_influence_map ?fwd ?bwd ?origin ~total accuracy = + send ?timeout request_count + (let s = + match accuracy with + | Some accuracy -> + "&accuracy=" ^ Public_data.accuracy_to_string accuracy | None -> "" - ) s - (match fwd with None -> "" | Some i -> "&fwd="^string_of_int i) - (match bwd with None -> "" | Some i -> "&bwd="^string_of_int i) - ) - `GET - (fun x -> Public_data.local_influence_map_of_json (Yojson.Basic.from_string x)) - - method get_initial_node = - send - ?timeout request_count - ( - Format.sprintf - "%s/v2/projects/%s/analyses/influence_map/initial_node" - url - project_id - ) - `GET - (fun x -> - JsonUtil.to_option - Public_data.refined_influence_node_of_json - (Yojson.Basic.from_string x)) - - method get_next_node short_id_opt = - send - ?timeout request_count - ( - Format.sprintf - "%s/v2/projects/%s/analyses/influence_map/next_node%s" - url - project_id - ( - match short_id_opt with - | Some (Public_data.Rule i) -> "_rule_"^(string_of_int i) - | Some (Public_data.Var i) -> "_var_"^(string_of_int i) - | None -> "" - ) - ) - `GET - (fun x -> JsonUtil.to_option - Public_data.refined_influence_node_of_json - (Yojson.Basic.from_string x)) - - method get_previous_node short_id_opt = - send - ?timeout request_count - ( - Format.sprintf - "%s/v2/projects/%s/analyses/influence_map/previous_node%s" - url - project_id - ( - match short_id_opt with - | Some (Public_data.Rule i) -> "_rule_"^(string_of_int i) - | Some (Public_data.Var i) -> "_var_"^(string_of_int i) - | None -> "") - ) - `GET - (fun x -> JsonUtil.to_option - Public_data.refined_influence_node_of_json - (Yojson.Basic.from_string x)) - - method get_influence_map_node_at ~filename { Locality.line; Locality.chr } = - send - ?timeout request_count - ( - Format.sprintf - "%s/v2/projects/%s/analyses/influence_map/node_at?file=%s&line=%i&chr=%i" - url project_id filename line chr) - `GET - (fun x -> JsonUtil.to_option - Public_data.short_influence_node_of_json - (Yojson.Basic.from_string x)) - - method get_nodes_of_influence_map accuracy = - send - ?timeout request_count - (match accuracy with - | Some accuracy -> - Format.sprintf "%s/v2/projects/%s/analyses/all_nodes_of_influence_map?accuracy=%s" - url project_id (Public_data.accuracy_to_string accuracy) - | None -> Format.sprintf "%s/v2/analyses/all_nodes_of_influence_map" url) - `GET - (fun x -> Public_data.nodes_of_influence_map_of_json (Yojson.Basic.from_string x)) - - method get_dead_rules = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/analyses/dead_rules" url project_id) - `GET - (fun x -> Public_data.dead_rules_of_json (Yojson.Basic.from_string x)) - - method get_dead_agents = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/analyses/dead_agents" url project_id) - `GET - (fun x -> Public_data.json_to_dead_agents (Yojson.Basic.from_string x)) - - method get_non_weakly_reversible_transitions = - send - ?timeout request_count - (Format.sprintf - "%s/v2/projects/%s/analyses/non_weakly_reversible_transitions" - url project_id) - `GET - (fun x -> Public_data.separating_transitions_of_json (Yojson.Basic.from_string x)) - - method get_constraints_list = - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/analyses/constraints" url project_id) - `GET - (fun x -> Public_data.lemmas_list_of_json (Yojson.Basic.from_string x)) - - method get_potential_polymers accuracy_cm accuracy_scc = - let options = - match accuracy_cm, accuracy_scc with - | None, None -> "" - | Some a, None -> "?accuracy_cm="^(Public_data.accuracy_to_string a) - | None, Some a -> "?accuracy_scc="^(Public_data.accuracy_to_string a) - | Some a, Some b -> "?accuracy_cm="^(Public_data.accuracy_to_string a)^"&accuracy_scc="^(Public_data.accuracy_to_string b) - in - send - ?timeout request_count - (Format.sprintf "%s/v2/projects/%s/analyses/potential_polymers%s" url project_id options ) - `GET - (fun x -> Public_data.scc_of_json (Yojson.Basic.from_string x)) - - method is_computing = is_computing request_count - - method config_story_computation - {Api.causal; Api.weak; Api.strong } : (unit,string) Lwt_result.t = - let _dontcare = causal || weak || strong in - Lwt.return_error "KaStor in not available through HTTP" - - method raw_launch_story_computation (_:string) : (unit,string) Lwt_result.t = - Lwt.return_error "KaStor in not available through HTTP" - - method story_log : string list = [] - method story_is_computing = false - method story_progress : Story_json.progress_bar option = None - method story_list : - (Api.compression_modes * - unit Trace.Simulation_info.t list list * - Graph_loggers_sig.graph) Mods.IntMap.t = Mods.IntMap.empty -end + in + Format.sprintf + "%s/v2/projects/%s/analyses/influence_map?total=%i%s%s%s%s" url + project_id total + (match origin with + | Some (Public_data.Rule i) -> "&origin=_rule_" ^ string_of_int i + | Some (Public_data.Var i) -> "&origin=_var_" ^ string_of_int i + | None -> "") + s + (match fwd with + | None -> "" + | Some i -> "&fwd=" ^ string_of_int i) + (match bwd with + | None -> "" + | Some i -> "&bwd=" ^ string_of_int i)) + `GET + (fun x -> + Public_data.local_influence_map_of_json (Yojson.Basic.from_string x)) + + method get_initial_node = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/analyses/influence_map/initial_node" + url project_id) `GET (fun x -> + JsonUtil.to_option Public_data.refined_influence_node_of_json + (Yojson.Basic.from_string x)) + + method get_next_node short_id_opt = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/analyses/influence_map/next_node%s" + url project_id + (match short_id_opt with + | Some (Public_data.Rule i) -> "_rule_" ^ string_of_int i + | Some (Public_data.Var i) -> "_var_" ^ string_of_int i + | None -> "")) + `GET + (fun x -> + JsonUtil.to_option Public_data.refined_influence_node_of_json + (Yojson.Basic.from_string x)) + + method get_previous_node short_id_opt = + send ?timeout request_count + (Format.sprintf + "%s/v2/projects/%s/analyses/influence_map/previous_node%s" url + project_id + (match short_id_opt with + | Some (Public_data.Rule i) -> "_rule_" ^ string_of_int i + | Some (Public_data.Var i) -> "_var_" ^ string_of_int i + | None -> "")) + `GET + (fun x -> + JsonUtil.to_option Public_data.refined_influence_node_of_json + (Yojson.Basic.from_string x)) + + method get_influence_map_node_at ~filename { Loc.line; Loc.chr } = + send ?timeout request_count + (Format.sprintf + "%s/v2/projects/%s/analyses/influence_map/node_at?file=%s&line=%i&chr=%i" + url project_id filename line chr) `GET (fun x -> + JsonUtil.to_option Public_data.short_influence_node_of_json + (Yojson.Basic.from_string x)) + + method get_nodes_of_influence_map accuracy = + send ?timeout request_count + (match accuracy with + | Some accuracy -> + Format.sprintf + "%s/v2/projects/%s/analyses/all_nodes_of_influence_map?accuracy=%s" + url project_id + (Public_data.accuracy_to_string accuracy) + | None -> Format.sprintf "%s/v2/analyses/all_nodes_of_influence_map" url) + `GET + (fun x -> + Public_data.nodes_of_influence_map_of_json + (Yojson.Basic.from_string x)) + + method get_dead_rules = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/analyses/dead_rules" url project_id) + `GET (fun x -> + Public_data.dead_rules_of_json (Yojson.Basic.from_string x)) + + method get_dead_agents = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/analyses/dead_agents" url project_id) + `GET (fun x -> + Public_data.json_to_dead_agents (Yojson.Basic.from_string x)) + + method get_non_weakly_reversible_transitions = + send ?timeout request_count + (Format.sprintf + "%s/v2/projects/%s/analyses/non_weakly_reversible_transitions" url + project_id) `GET (fun x -> + Public_data.separating_transitions_of_json + (Yojson.Basic.from_string x)) + + method get_constraints_list = + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/analyses/constraints" url project_id) + `GET (fun x -> + Public_data.lemmas_list_of_json (Yojson.Basic.from_string x)) + + method get_potential_polymers accuracy_cm accuracy_scc = + let options = + match accuracy_cm, accuracy_scc with + | None, None -> "" + | Some a, None -> "?accuracy_cm=" ^ Public_data.accuracy_to_string a + | None, Some a -> "?accuracy_scc=" ^ Public_data.accuracy_to_string a + | Some a, Some b -> + "?accuracy_cm=" + ^ Public_data.accuracy_to_string a + ^ "&accuracy_scc=" + ^ Public_data.accuracy_to_string b + in + send ?timeout request_count + (Format.sprintf "%s/v2/projects/%s/analyses/potential_polymers%s" url + project_id options) `GET (fun x -> + Public_data.scc_of_json (Yojson.Basic.from_string x)) + + method is_computing = is_computing request_count + + method config_story_computation { Api.causal; Api.weak; Api.strong } + : (unit, string) Lwt_result.t = + let _dontcare = causal || weak || strong in + Lwt.return_error "KaStor in not available through HTTP" + + method raw_launch_story_computation (_ : string) + : (unit, string) Lwt_result.t = + Lwt.return_error "KaStor in not available through HTTP" + + method story_log : string list = [] + method story_is_computing = false + method story_progress : Story_json.progress_bar option = None + + method story_list + : (Api.compression_modes + * unit Trace.Simulation_info.t list list + * Graph_loggers_sig.graph) + Mods.IntMap.t = + Mods.IntMap.empty + end diff --git a/gui/state_error.ml b/gui/state_error.ml index 3d12e9bfb1..4d31bf40e3 100644 --- a/gui/state_error.ml +++ b/gui/state_error.ml @@ -8,51 +8,57 @@ open Lwt.Infix -type t = - { state_error_errors : Result_util.message list ; - _state_error_location : string } +type t = { + state_error_errors: Result_util.message list; + _state_error_location: string; +} + let state_error, set_state_error = React.S.create ([] : t list) let clear_errors location = - let () = Common.debug - (Js.string (Format.sprintf "Clear_errors %s " location)) in + let () = + Common.debug (Js.string (Format.sprintf "Clear_errors %s " location)) + in set_state_error [] let has_errors () = match React.S.value state_error with | [] -> false - | _::_ -> true + | _ :: _ -> true let add_error (location : string) (errors : Result_util.message list) = (* log location and errors if debugging is enabled *) - let () = Common.debug - (Js.string (Format.asprintf - "set_errors { location : \"%s\" , errors : [@[%a@]] }" - location - (Pp.list Pp.space Result_util.print_message) errors)) in + let () = + Common.debug + (Js.string + (Format.asprintf "set_errors { location : \"%s\" , errors : [@[%a@]] }" + location + (Pp.list Pp.space Result_util.print_message) + errors)) + in let current_state_error : t list = React.S.value state_error in let new_state_error : t list = - { state_error_errors = errors; - _state_error_location = location; }::current_state_error in + { state_error_errors = errors; _state_error_location = location } + :: current_state_error + in set_state_error new_state_error let errors : Result_util.message list React.signal = React.S.map (fun (state_error : t list) -> - List.fold_left - (fun acc value -> value.state_error_errors@acc) - [] - state_error) + List.fold_left + (fun acc value -> value.state_error_errors @ acc) + [] state_error) state_error -let wrap : 'a . ?append:bool -> string -> 'a Api.result Lwt.t -> 'a Api.result Lwt.t = - fun ?(append=false) loc r -> - r >>= - (let () = if not append then clear_errors loc in - Result_util.fold - ~ok:(fun r -> - Lwt.return (Result_util.ok r)) - ~error:(fun errors -> - let () = add_error loc errors in - Lwt.return (Api_common.result_messages errors) - )) +let wrap : + 'a. ?append:bool -> string -> 'a Api.result Lwt.t -> 'a Api.result Lwt.t = + fun ?(append = false) loc r -> + r + >>= + let () = if not append then clear_errors loc in + Result_util.fold + ~ok:(fun r -> Lwt.return (Result_util.ok r)) + ~error:(fun errors -> + let () = add_error loc errors in + Lwt.return (Api_common.result_messages errors)) diff --git a/gui/state_error.mli b/gui/state_error.mli index 2799fbef38..897648011b 100644 --- a/gui/state_error.mli +++ b/gui/state_error.mli @@ -21,7 +21,7 @@ val set_errors : append:bool -> string -> Api_types_j.errors -> unit @param location of error the macro __LOC__ is expected. @paramer errors to be saved *) -*) + *) val has_errors : unit -> bool (** Return true if errors are present. *) diff --git a/gui/state_file.ml b/gui/state_file.ml index 50bfc8155d..3df9547793 100644 --- a/gui/state_file.ml +++ b/gui/state_file.ml @@ -8,33 +8,35 @@ open Lwt.Infix -type slot = { local : string option ; name : string; } +type slot = { local: string option; name: string } +type active = { rank: int; cursor_pos: Loc.position; out_of_sync: bool } +type model = { current: active option; directory: slot Mods.IntMap.t } -type active = { rank : int; cursor_pos : Locality.position; out_of_sync : bool } - -type model = { current : active option ; directory : slot Mods.IntMap.t } - -let dummy_cursor_pos = { Locality.line = -1; Locality.chr = 0 } - -let blank_state = - { current = None ; directory = Mods.IntMap.empty } +let dummy_cursor_pos = { Loc.line = -1; Loc.chr = 0 } +let blank_state = { current = None; directory = Mods.IntMap.empty } let model, set_directory_state = React.S.create blank_state -type refresh = { filename : string ; content : string ; line : int option ; } -let refresh_file , set_refresh_file = React.E.create () +type refresh = { filename: string; content: string; line: int option } + +let refresh_file, set_refresh_file = React.E.create () let current_filename = React.S.map - (fun m -> Option_util.bind - (fun x -> Option_util.map - (fun { name; _ } -> name) (Mods.IntMap.find_option x.rank m.directory)) - m.current) model + (fun m -> + Option_util.bind + (fun x -> + Option_util.map + (fun { name; _ } -> name) + (Mods.IntMap.find_option x.rank m.directory)) + m.current) + model -let with_current_pos ?eq ?(on=React.S.const true) f default = - React.S.fmap - ?eq - (fun m -> Option_util.bind - (fun x -> Option_util.bind +let with_current_pos ?eq ?(on = React.S.const true) f default = + React.S.fmap ?eq + (fun m -> + Option_util.bind + (fun x -> + Option_util.bind (fun { name; _ } -> f name x.cursor_pos) (Mods.IntMap.find_option x.rank m.directory)) m.current) @@ -45,36 +47,32 @@ let with_current_file f = let state = React.S.value model in match state.current with | None -> - let error_msg : string = - "Attempt to fetch file with none selected." - in + let error_msg : string = "Attempt to fetch file with none selected." in Lwt.return (Api_common.result_error_msg error_msg) | Some active -> - match Mods.IntMap.find_option active.rank state.directory with + (match Mods.IntMap.find_option active.rank state.directory with | None -> let error_msg : string = - "Internal inconsistentcy: No file at selected rank." in + "Internal inconsistentcy: No file at selected rank." + in Lwt.return (Api_common.result_error_msg error_msg) - | Some x -> f state active x + | Some x -> f state active x) -let get_file () : (string*string) Api.result Lwt.t = +let get_file () : (string * string) Api.result Lwt.t = with_current_file (fun _state active -> function - | { local = None; name } -> - State_project.with_project ~label:"get_file" - (fun manager -> - manager#file_get name >>= - Api_common.result_bind_lwt - ~ok:(fun (text,rank') -> - if active.rank = rank' then - Lwt.return (Result_util.ok (text,name)) - else - let error_msg = "Inconsistency in rank while get_file." in - Lwt.return (Api_common.result_error_msg error_msg))) - | { local = Some text; name } -> - Lwt.return (Result_util.ok (text,name))) + | { local = None; name } -> + State_project.with_project ~label:"get_file" (fun manager -> + manager#file_get name + >>= Api_common.result_bind_lwt ~ok:(fun (text, rank') -> + if active.rank = rank' then + Lwt.return (Result_util.ok (text, name)) + else ( + let error_msg = "Inconsistency in rank while get_file." in + Lwt.return (Api_common.result_error_msg error_msg) + ))) + | { local = Some text; name } -> Lwt.return (Result_util.ok (text, name))) -let send_refresh - (line : int option) : unit Api.result Lwt.t = +let send_refresh (line : int option) : unit Api.result Lwt.t = (* only send refresh if there is a current file *) match (React.S.value model).current with | None -> Lwt.return (Result_util.ok ()) @@ -84,188 +82,222 @@ let send_refresh (Api_common.result_error_msg "File was not in sync. Switching may lead to data lost.") else - get_file () >>= - (Api_common.result_bind_lwt - ~ok:(fun (content,filename) -> - let () = Common.debug content in - let () = set_refresh_file { filename; content; line } in - Lwt.return (Result_util.ok ())) - ) + get_file () + >>= Api_common.result_bind_lwt ~ok:(fun (content, filename) -> + let () = Common.debug content in + let () = set_refresh_file { filename; content; line } in + Lwt.return (Result_util.ok ())) let update_directory ~reset current catalog = let state = React.S.value model in let directory = - List.fold_left (fun acc { Kfiles.position; id } -> - Mods.IntMap.add position { name=id; local = None } acc) - (if reset then Mods.IntMap.empty else state.directory) catalog in + List.fold_left + (fun acc { Kfiles.position; id } -> + Mods.IntMap.add position { name = id; local = None } acc) + (if reset then + Mods.IntMap.empty + else + state.directory) + catalog + in set_directory_state { current; directory } -let create_file - ~(filename:string) - ~(content:string) : - unit Api.result Lwt.t = - State_project.with_project ~label:"create_file" - (fun manager -> - manager#file_catalog >>= - Api_common.result_bind_lwt - ~ok:(fun catalog -> - let matching_file = - List.filter - (fun file_metadata -> filename = file_metadata.Kfiles.id) - catalog in - (match matching_file with +let create_file ~(filename : string) ~(content : string) : unit Api.result Lwt.t + = + State_project.with_project ~label:"create_file" (fun manager -> + manager#file_catalog + >>= Api_common.result_bind_lwt ~ok:(fun catalog -> + let matching_file = + List.filter + (fun file_metadata -> filename = file_metadata.Kfiles.id) + catalog + in + (match matching_file with | [] -> let max_pos = List.fold_left (fun acc { Kfiles.position; _ } -> max acc position) - 0 catalog in - manager#file_create (succ max_pos) filename content >>= - Api_common.result_bind_lwt - ~ok:(fun () -> - manager#file_catalog >>= - Api_common.result_bind_lwt - ~ok:(fun catalog' -> - Lwt.return - (Result_util.ok (catalog',succ max_pos)))) - | metadata::_ -> - manager#file_update filename content >>= - Api_common.result_bind_lwt - ~ok:(fun () -> - Lwt.return - (Result_util.ok (catalog,metadata.Kfiles.position)))) - >>= Api_common.result_bind_lwt - ~ok:(fun (catalog,current) -> - let () = - update_directory - ~reset:false - (Some {rank=current; cursor_pos=dummy_cursor_pos; out_of_sync=false}) - catalog in - send_refresh None) - )) + 0 catalog + in + manager#file_create (succ max_pos) filename content + >>= Api_common.result_bind_lwt ~ok:(fun () -> + manager#file_catalog + >>= Api_common.result_bind_lwt ~ok:(fun catalog' -> + Lwt.return + (Result_util.ok (catalog', succ max_pos)))) + | metadata :: _ -> + manager#file_update filename content + >>= Api_common.result_bind_lwt ~ok:(fun () -> + Lwt.return + (Result_util.ok (catalog, metadata.Kfiles.position)))) + >>= Api_common.result_bind_lwt ~ok:(fun (catalog, current) -> + let () = + update_directory ~reset:false + (Some + { + rank = current; + cursor_pos = dummy_cursor_pos; + out_of_sync = false; + }) + catalog + in + send_refresh None))) let rec choose_file choice = function | [] -> let error_msg : string = - Format.sprintf "Failed to switch file %s." choice in + Format.sprintf "Failed to switch file %s." choice + in Api_common.result_error_msg error_msg | { Kfiles.id; position } :: t -> - if choice = id then Result_util.ok position else choose_file choice t + if choice = id then + Result_util.ok position + else + choose_file choice t -let select_file (filename : string) (line : int option) : unit Api.result Lwt.t = - State_project.with_project ~label:"select_file" - (fun manager -> - manager#file_catalog >>= - Api_common.result_bind_lwt - ~ok:(fun catalog -> - Api_common.result_bind_lwt - ~ok:(fun rank -> - let () = - update_directory - ~reset:false - (Some {rank; cursor_pos=dummy_cursor_pos; out_of_sync = false}) - catalog in - send_refresh line) - (choose_file filename catalog))) +let select_file (filename : string) (line : int option) : unit Api.result Lwt.t + = + State_project.with_project ~label:"select_file" (fun manager -> + manager#file_catalog + >>= Api_common.result_bind_lwt ~ok:(fun catalog -> + Api_common.result_bind_lwt + ~ok:(fun rank -> + let () = + update_directory ~reset:false + (Some + { + rank; + cursor_pos = dummy_cursor_pos; + out_of_sync = false; + }) + catalog + in + send_refresh line) + (choose_file filename catalog))) let set_content (content : string) : unit Api.result Lwt.t = with_current_file (fun state active -> function - | { local = Some _; name } -> - let directory = - Mods.IntMap.add - active.rank { local = Some content; name } state.directory in - let () = set_directory_state { current = state.current; directory } in - Lwt.return (Result_util.ok ()) - | { local = None; name } -> - let () = set_directory_state { + | { local = Some _; name } -> + let directory = + Mods.IntMap.add active.rank + { local = Some content; name } + state.directory + in + let () = set_directory_state { current = state.current; directory } in + Lwt.return (Result_util.ok ()) + | { local = None; name } -> + let () = + set_directory_state + { current = - Some {rank = active.rank; cursor_pos = active.cursor_pos; out_of_sync=false}; - directory = state.directory - } in - State_project.with_project ~label:"set_content" - (fun manager -> manager#file_update name content)) + Some + { + rank = active.rank; + cursor_pos = active.cursor_pos; + out_of_sync = false; + }; + directory = state.directory; + } + in + State_project.with_project ~label:"set_content" (fun manager -> + manager#file_update name content)) let set_compile file_id (compile : bool) : unit Api.result Lwt.t = - let state = React.S.value model in - match Mods.IntMap.filter_one - (fun _ { name; _ } -> name = file_id) state.directory with + let state = React.S.value model in + match + Mods.IntMap.filter_one (fun _ { name; _ } -> name = file_id) state.directory + with | None -> - let error_msg = "Internal inconsistency: No file "^file_id in + let error_msg = "Internal inconsistency: No file " ^ file_id in Lwt.return (Api_common.result_error_msg error_msg) | Some (rank, { local = Some content; name }) -> - if compile then + if compile then ( let directory = - Mods.IntMap.add rank { local = None; name } state.directory in + Mods.IntMap.add rank { local = None; name } state.directory + in let () = set_directory_state { current = state.current; directory } in - State_project.with_project ~label:"set_compile" - (fun manager -> manager#file_create rank name content) - else Lwt.return (Result_util.ok ()) + State_project.with_project ~label:"set_compile" (fun manager -> + manager#file_create rank name content) + ) else + Lwt.return (Result_util.ok ()) | Some (rank, { local = None; name }) -> - if compile then Lwt.return (Result_util.ok ()) + if compile then + Lwt.return (Result_util.ok ()) else - State_project.with_project ~label:"set_compile" - (fun manager -> manager#file_get name >>= - Api_common.result_bind_lwt - ~ok:(fun (content,rank') -> - if rank = rank' then - let directory = Mods.IntMap.add - rank { local = Some content; name } state.directory in - let () = set_directory_state - { current = state.current; directory } in - State_project.with_project ~label:"set_compile'" - (fun manager -> manager#file_delete name) - else - let error_msg = "Inconsistency in rank while set_compile." in - Lwt.return (Api_common.result_error_msg error_msg))) + State_project.with_project ~label:"set_compile" (fun manager -> + manager#file_get name + >>= Api_common.result_bind_lwt ~ok:(fun (content, rank') -> + if rank = rank' then ( + let directory = + Mods.IntMap.add rank + { local = Some content; name } + state.directory + in + let () = + set_directory_state { current = state.current; directory } + in + State_project.with_project ~label:"set_compile'" + (fun manager -> manager#file_delete name) + ) else ( + let error_msg = + "Inconsistency in rank while set_compile." + in + Lwt.return (Api_common.result_error_msg error_msg) + ))) let remove_file () : unit Api.result Lwt.t = with_current_file (fun state active { local; name } -> let directory = Mods.IntMap.remove active.rank state.directory in let current = Option_util.map - (fun (rank,_) -> {rank; cursor_pos=dummy_cursor_pos; out_of_sync=false}) - (Mods.IntMap.root directory) in - let () = set_directory_state {current; directory} in + (fun (rank, _) -> + { rank; cursor_pos = dummy_cursor_pos; out_of_sync = false }) + (Mods.IntMap.root directory) + in + let () = set_directory_state { current; directory } in let x = send_refresh None in match local with | Some _ -> x | None -> - State_project.with_project ~label:"remove_file" - (fun manager -> - manager#file_delete name >>= fun y -> x >>= fun x -> - Lwt.return (Api_common.result_combine [x; y])) - ) + State_project.with_project ~label:"remove_file" (fun manager -> + manager#file_delete name >>= fun y -> + x >>= fun x -> Lwt.return (Api_common.result_combine [ x; y ]))) let do_a_move state file_id rank = - match Mods.IntMap.filter_one - (fun _ { name; _ } -> name = file_id) state.directory with + match + Mods.IntMap.filter_one (fun _ { name; _ } -> name = file_id) state.directory + with | None -> - let error_msg = "Internal inconsistency: No file "^file_id in + let error_msg = "Internal inconsistency: No file " ^ file_id in Lwt.return (Api_common.result_error_msg error_msg) | Some (rank', ({ local; _ } as x)) -> let directory = - Mods.IntMap.add rank x (Mods.IntMap.remove rank' state.directory) in + Mods.IntMap.add rank x (Mods.IntMap.remove rank' state.directory) + in let current = match state.current with - | Some { rank=pos; cursor_pos; out_of_sync } when pos=rank' -> + | Some { rank = pos; cursor_pos; out_of_sync } when pos = rank' -> Some { rank; cursor_pos; out_of_sync } - | x -> x in + | x -> x + in if local = None then - State_project.with_project ~label:"remove_file" - (fun manager -> manager#file_move rank file_id >>= - Api_common.result_bind_lwt - ~ok:(fun () -> Lwt.return (Result_util.ok { current; directory }))) - else Lwt.return (Result_util.ok { current; directory }) + State_project.with_project ~label:"remove_file" (fun manager -> + manager#file_move rank file_id + >>= Api_common.result_bind_lwt ~ok:(fun () -> + Lwt.return (Result_util.ok { current; directory }))) + else + Lwt.return (Result_util.ok { current; directory }) let rec set_position state file_id rank = match Mods.IntMap.find_option rank state.directory with | Some { name; _ } -> - if file_id = name then Lwt.return (Result_util.ok state) + if file_id = name then + Lwt.return (Result_util.ok state) else - set_position state name (succ rank) >>= - Api_common.result_bind_lwt - ~ok:(fun state' -> do_a_move state' file_id rank) - | None -> - do_a_move state file_id rank + set_position state name (succ rank) + >>= Api_common.result_bind_lwt ~ok:(fun state' -> + do_a_move state' file_id rank) + | None -> do_a_move state file_id rank let order_files (filenames : string list) : unit Api.result Lwt.t = let rec _order_file filenames state index : unit Api.result Lwt.t = @@ -273,10 +305,10 @@ let order_files (filenames : string list) : unit Api.result Lwt.t = | [] -> let () = set_directory_state state in Lwt.return (Result_util.ok ()) - | file_id::tail -> - (set_position state file_id index) >>= - Api_common.result_bind_lwt - ~ok:(fun state' -> _order_file tail state' (index + 1)) + | file_id :: tail -> + set_position state file_id index + >>= Api_common.result_bind_lwt ~ok:(fun state' -> + _order_file tail state' (index + 1)) in _order_file filenames (React.S.value model) 0 @@ -285,126 +317,137 @@ let cursor_activity ~line ~ch = match v.current with | None -> () | Some { rank; out_of_sync; _ } -> - set_directory_state { - current = Some { rank; cursor_pos={Locality.line = succ line; chr = ch}; out_of_sync }; - directory = v.directory; - } + set_directory_state + { + current = + Some + { + rank; + cursor_pos = { Loc.line = succ line; chr = ch }; + out_of_sync; + }; + directory = v.directory; + } let out_of_sync out_of_sync = let v = React.S.value model in match v.current with | None -> () | Some { rank; cursor_pos; _ } -> - set_directory_state { - current = Some { rank; cursor_pos; out_of_sync }; - directory = v.directory; - } + set_directory_state + { + current = Some { rank; cursor_pos; out_of_sync }; + directory = v.directory; + } -let sync ?(reset=false) () : unit Api.result Lwt.t = - State_project.with_project ~label:"select_file" - (fun manager -> - manager#file_catalog >>= - Api_common.result_bind_lwt - ~ok:(fun catalog -> - let cand = (React.S.value model).current in - let pos = - if reset || match cand with - | None -> true - | Some x -> - List.exists - (fun {Kfiles.position; _} -> x.rank=position) catalog - then - match catalog with - | [] -> None - | { Kfiles.position; _ } :: _ -> - Some { - rank=position; - cursor_pos=dummy_cursor_pos; - out_of_sync = false - } - else cand in - let () = update_directory ~reset pos catalog in - send_refresh None)) +let sync ?(reset = false) () : unit Api.result Lwt.t = + State_project.with_project ~label:"select_file" (fun manager -> + manager#file_catalog + >>= Api_common.result_bind_lwt ~ok:(fun catalog -> + let cand = (React.S.value model).current in + let pos = + if + reset + || + match cand with + | None -> true + | Some x -> + List.exists + (fun { Kfiles.position; _ } -> x.rank = position) + catalog + then ( + match catalog with + | [] -> None + | { Kfiles.position; _ } :: _ -> + Some + { + rank = position; + cursor_pos = dummy_cursor_pos; + out_of_sync = false; + } + ) else + cand + in + let () = update_directory ~reset pos catalog in + send_refresh None)) let load_default () : unit Lwt.t = - (create_file ~filename:"model.ka" ~content:"") >>= - (Result_util.fold - ~ok:(fun () -> Lwt.return_unit) - ~error:(fun errors -> - let msg = - Format.asprintf - "State_file.load_default : creating default file error@ @[%a@]" - (Pp.list Pp.space Result_util.print_message) errors in - let () = Common.debug (Js.string msg) in - Lwt.return_unit)) + create_file ~filename:"model.ka" ~content:"" + >>= Result_util.fold + ~ok:(fun () -> Lwt.return_unit) + ~error:(fun errors -> + let msg = + Format.asprintf + "State_file.load_default : creating default file error@ @[%a@]" + (Pp.list Pp.space Result_util.print_message) + errors + in + let () = Common.debug (Js.string msg) in + Lwt.return_unit) let load_models () : unit Lwt.t = let models = Common_state.url_args "model" in let rec add_models models load_file : unit Lwt.t = match models with | [] -> Lwt.return_unit - | model::models -> + | model :: models -> (* fetch model *) - Js_of_ocaml_lwt.XmlHttpRequest.get model >>= - (fun content -> - if content.Js_of_ocaml_lwt.XmlHttpRequest.code <> 200 then - Lwt.return - (Api_common.result_error_msg - (Format.sprintf "bad response code %d fetching url %s" - content.Js_of_ocaml_lwt.XmlHttpRequest.code model)) - else - match Url.url_of_string - content.Js_of_ocaml_lwt.XmlHttpRequest.url with - | None -> - Lwt.return - (Api_common.result_error_msg - (Format.sprintf "failed to retrieve url %s" model)) - | Some u -> - let filename = - List_util.last - (match u with - | (Url.Http h | Url.Https h) -> h.Url.hu_path - | Url.File f -> f.Url.fu_path) in - let filecontent : string = - content.Js_of_ocaml_lwt.XmlHttpRequest.content - in - Lwt.return (Result_util.ok (filename,filecontent)) - ) - >>= - (* add content *) - (Api_common.result_bind_lwt - ~ok:(fun (filename,content) -> - (create_file ~filename ~content) >>= - (Api_common.result_bind_lwt - ~ok:(fun () -> Lwt.return (Result_util.ok filename)) - ))) >>= - (* select model if needed *) - (Result_util.fold - ~ok:(fun filename -> - if load_file then - (select_file filename None) >>= - (Result_util.fold + Js_of_ocaml_lwt.XmlHttpRequest.get model + >>= (fun content -> + if content.Js_of_ocaml_lwt.XmlHttpRequest.code <> 200 then + Lwt.return + (Api_common.result_error_msg + (Format.sprintf "bad response code %d fetching url %s" + content.Js_of_ocaml_lwt.XmlHttpRequest.code model)) + else ( + match + Url.url_of_string content.Js_of_ocaml_lwt.XmlHttpRequest.url + with + | None -> + Lwt.return + (Api_common.result_error_msg + (Format.sprintf "failed to retrieve url %s" model)) + | Some u -> + let filename = + List_util.last + (match u with + | Url.Http h | Url.Https h -> h.Url.hu_path + | Url.File f -> f.Url.fu_path) + in + let filecontent : string = + content.Js_of_ocaml_lwt.XmlHttpRequest.content + in + Lwt.return (Result_util.ok (filename, filecontent)) + )) + >>= (* add content *) + Api_common.result_bind_lwt ~ok:(fun (filename, content) -> + create_file ~filename ~content + >>= Api_common.result_bind_lwt ~ok:(fun () -> + Lwt.return (Result_util.ok filename))) + >>= (* select model if needed *) + Result_util.fold + ~ok:(fun filename -> + if load_file then + select_file filename None + >>= Result_util.fold ~ok:(fun _ -> add_models models false) ~error:(fun _ -> add_models models load_file) - ) - else - add_models models load_file - ) - ~error:(fun errors -> - let msg = - Format.asprintf - "creating loading url %s error@ @[%a@]" - model - (Pp.list Pp.space Result_util.print_message) errors in - let () = Common.debug - (Js.string (Format.sprintf "State_file.load_model %s" msg)) in - add_models models load_file) - ) + else + add_models models load_file) + ~error:(fun errors -> + let msg = + Format.asprintf "creating loading url %s error@ @[%a@]" model + (Pp.list Pp.space Result_util.print_message) + errors + in + let () = + Common.debug + (Js.string (Format.sprintf "State_file.load_model %s" msg)) + in + add_models models load_file) in match models with - [] -> load_default () - |_::_ -> add_models models true + | [] -> load_default () + | _ :: _ -> add_models models true -let init () : unit Lwt.t = - Lwt.return_unit >>= - load_models +let init () : unit Lwt.t = Lwt.return_unit >>= load_models diff --git a/gui/state_file.mli b/gui/state_file.mli index 752f5827b9..84e19c017d 100644 --- a/gui/state_file.mli +++ b/gui/state_file.mli @@ -8,44 +8,52 @@ (* Create a file *) val create_file : filename:string -> content:string -> unit Api.result Lwt.t + (* Set current file to file with the specified name *) val select_file : string -> int option -> unit Api.result Lwt.t + (* Update content of current file *) val set_content : string -> unit Api.result Lwt.t + (* Update compile of the file of rank [k] *) val set_compile : string -> bool -> unit Api.result Lwt.t + (* Update the position of a file *) val order_files : string list -> unit Api.result Lwt.t + (* get current file *) val get_file : unit -> (string * string) Api.result Lwt.t + (* remove current file from project *) val remove_file : unit -> unit Api.result Lwt.t (* Get current file - the name is not specified to force the selection of the file before the fetch. *) -type refresh = { filename : string ; content : string ; line : int option ; } +type refresh = { filename: string; content: string; line: int option } + val refresh_file : refresh React.event (* Meta data of current file *) val cursor_activity : line:int -> ch:int -> unit val out_of_sync : bool -> unit -type slot = { local : string option ; name : string; } - -type active = { rank : int; cursor_pos : Locality.position; out_of_sync : bool } - -type model = { current : active option ; directory : slot Mods.IntMap.t } +type slot = { local: string option; name: string } +type active = { rank: int; cursor_pos: Loc.position; out_of_sync: bool } +type model = { current: active option; directory: slot Mods.IntMap.t } val model : model React.signal val current_filename : string option React.signal val with_current_pos : - ?eq:('a -> 'a -> bool) -> ?on:bool React.signal -> - (string -> Locality.position -> 'a option) -> - 'a -> 'a React.signal + ?eq:('a -> 'a -> bool) -> + ?on:bool React.signal -> + (string -> Loc.position -> 'a option) -> + 'a -> + 'a React.signal (* run on application init *) val init : unit -> unit Lwt.t + (* to synch state of application with runtime *) val sync : ?reset:bool -> unit -> unit Api.result Lwt.t diff --git a/gui/state_project.ml b/gui/state_project.ml index 09f1d4d371..d047cfddc1 100644 --- a/gui/state_project.ml +++ b/gui/state_project.ml @@ -8,115 +8,122 @@ open Lwt.Infix - let plotPeriodParamId = Js.string "kappappPlotPeriod" let pauseConditionParamId = Js.string "kappappPauseCondition" let seedParamId = Js.string "kappappDefaultSeed" let storeTraceParamId = Js.string "kappappStoreTrace" let showDeadRulesParamId = Js.string "kappappShowDeadRules" let showDeadAgentsParamId = Js.string "kappappShowDeadAgents" + let showIrreversibleTransitionsParamId = Js.string "kappappShowIrreversibleTransition" type parameters = { - plot_period : float; - pause_condition : string; - seed : int option; - store_trace : bool; - show_dead_rules : bool; - show_dead_agents : bool; - show_non_weakly_reversible_transitions : bool; + plot_period: float; + pause_condition: string; + seed: int option; + store_trace: bool; + show_dead_rules: bool; + show_dead_agents: bool; + show_non_weakly_reversible_transitions: bool; } type a_project = { - project_id : string; - project_is_computing : bool React.S.t; - project_watcher_cancel : bool ref; - project_manager : Api.concrete_manager; + project_id: string; + project_is_computing: bool React.S.t; + project_watcher_cancel: bool ref; + project_manager: Api.concrete_manager; } type state = { - project_current : a_project option; - project_catalog : a_project list; - project_version : int ; - default_parameters : parameters; - project_parameters : parameters Mods.StringMap.t; + project_current: a_project option; + project_catalog: a_project list; + project_version: int; + default_parameters: parameters; + project_parameters: parameters Mods.StringMap.t; } type project_model = { - model_project_id : string; - model_project_is_computing : bool React.S.t; + model_project_id: string; + model_project_is_computing: bool React.S.t; } type model = { - model_current_id : string option ; - model_catalog : project_model list ; - model_project_version : int ; - model_parameters : parameters ; + model_current_id: string option; + model_catalog: project_model list; + model_project_version: int; + model_parameters: parameters; } let project_equal a b = a.project_id = b.project_id + let catalog_equal x y = try List.for_all2 project_equal x y with Invalid_argument _ -> false + let state_equal a b = - Option_util.equal project_equal a.project_current b.project_current && - a.project_version = b.project_version && - a.default_parameters = b.default_parameters && - Mods.StringMap.equal - (fun x y -> compare x y = 0) - a.project_parameters b.project_parameters && - catalog_equal a.project_catalog b.project_catalog + Option_util.equal project_equal a.project_current b.project_current + && a.project_version = b.project_version + && a.default_parameters = b.default_parameters + && Mods.StringMap.equal + (fun x y -> compare x y = 0) + a.project_parameters b.project_parameters + && catalog_equal a.project_catalog b.project_catalog let model_equal a b = Option_util.equal - (fun x y -> String.compare x y = 0) a.model_current_id b.model_current_id && - (try - List.for_all2 - (fun x y -> x.model_project_id = y.model_project_id) - a.model_catalog b.model_catalog - with Invalid_argument _ -> false) && - a.model_project_version = b.model_project_version && - a.model_parameters = b.model_parameters - -let init_default_parameters = { - plot_period = 1.; - pause_condition = "[false]"; - seed = None; - store_trace = false; - show_dead_rules = true; - show_dead_agents = true; - show_non_weakly_reversible_transitions = false; -} + (fun x y -> String.compare x y = 0) + a.model_current_id b.model_current_id + && (try + List.for_all2 + (fun x y -> x.model_project_id = y.model_project_id) + a.model_catalog b.model_catalog + with Invalid_argument _ -> false) + && a.model_project_version = b.model_project_version + && a.model_parameters = b.model_parameters + +let init_default_parameters = + { + plot_period = 1.; + pause_condition = "[false]"; + seed = None; + store_trace = false; + show_dead_rules = true; + show_dead_agents = true; + show_non_weakly_reversible_transitions = false; + } -let init_state = { - project_current = None; - project_catalog = []; - project_version = -1; - default_parameters = init_default_parameters; - project_parameters = Mods.StringMap.empty; -} +let init_state = + { + project_current = None; + project_catalog = []; + project_version = -1; + default_parameters = init_default_parameters; + project_parameters = Mods.StringMap.empty; + } -let state , set_state = - React.S.create ~eq:state_equal init_state +let state, set_state = React.S.create ~eq:state_equal init_state let update_parameters handler = let st = React.S.value state in - let default_parameters,project_parameters = + let default_parameters, project_parameters = match st.project_current with - | None -> - handler st.default_parameters, st.project_parameters + | None -> handler st.default_parameters, st.project_parameters | Some proj -> - st.default_parameters, - Mods.StringMap.add proj.project_id - (handler (Mods.StringMap.find_default - st.default_parameters proj.project_id st.project_parameters)) - st.project_parameters in - set_state { - project_current = st.project_current; - project_catalog = st.project_catalog; - project_version = st.project_version; - default_parameters; project_parameters; - } + ( st.default_parameters, + Mods.StringMap.add proj.project_id + (handler + (Mods.StringMap.find_default st.default_parameters proj.project_id + st.project_parameters)) + st.project_parameters ) + in + set_state + { + project_current = st.project_current; + project_catalog = st.project_catalog; + project_version = st.project_version; + default_parameters; + project_parameters; + } let set_parameters_as_default () = let st = React.S.value state in @@ -124,71 +131,94 @@ let set_parameters_as_default () = match st.project_current with | None -> st.default_parameters | Some proj -> - Mods.StringMap.find_default - st.default_parameters proj.project_id st.project_parameters in - let () = Js.Optdef.iter - Dom_html.window##.localStorage - (fun ls -> - let () = ls##setItem - plotPeriodParamId (Js.string (string_of_float pa.plot_period)) in - let () = ls##setItem - pauseConditionParamId (Js.string pa.pause_condition) in - let () = - match pa.seed with - | None -> ls##removeItem seedParamId - | Some va -> - ls##setItem seedParamId (Js.string (string_of_int va)) in - let () = - if pa.store_trace then - ls##setItem storeTraceParamId (Js.string "true") - else ls##removeItem storeTraceParamId in - let () = - if pa.show_dead_rules then - ls##setItem showDeadRulesParamId (Js.string "true") - else ls##setItem showDeadRulesParamId (Js.string "false") in - let () = - if pa.show_dead_agents then - ls##setItem showDeadAgentsParamId (Js.string "true") - else ls##setItem showDeadAgentsParamId (Js.string "false") in - let () = - if pa.show_non_weakly_reversible_transitions then - ls##setItem showIrreversibleTransitionsParamId (Js.string "true") - else ls##removeItem showIrreversibleTransitionsParamId in - ()) in - set_state { - project_current = st.project_current; - project_catalog = st.project_catalog; - project_version = st.project_version; - project_parameters = st.project_parameters; - default_parameters = pa; - } + Mods.StringMap.find_default st.default_parameters proj.project_id + st.project_parameters + in + let () = + Js.Optdef.iter Dom_html.window##.localStorage (fun ls -> + let () = + ls##setItem plotPeriodParamId + (Js.string (string_of_float pa.plot_period)) + in + let () = + ls##setItem pauseConditionParamId (Js.string pa.pause_condition) + in + let () = + match pa.seed with + | None -> ls##removeItem seedParamId + | Some va -> ls##setItem seedParamId (Js.string (string_of_int va)) + in + let () = + if pa.store_trace then + ls##setItem storeTraceParamId (Js.string "true") + else + ls##removeItem storeTraceParamId + in + let () = + if pa.show_dead_rules then + ls##setItem showDeadRulesParamId (Js.string "true") + else + ls##setItem showDeadRulesParamId (Js.string "false") + in + let () = + if pa.show_dead_agents then + ls##setItem showDeadAgentsParamId (Js.string "true") + else + ls##setItem showDeadAgentsParamId (Js.string "false") + in + let () = + if pa.show_non_weakly_reversible_transitions then + ls##setItem showIrreversibleTransitionsParamId (Js.string "true") + else + ls##removeItem showIrreversibleTransitionsParamId + in + ()) + in + set_state + { + project_current = st.project_current; + project_catalog = st.project_catalog; + project_version = st.project_version; + project_parameters = st.project_parameters; + default_parameters = pa; + } let set_plot_period plot_period = update_parameters (fun param -> { param with plot_period }) + let set_pause_condition pause_condition = update_parameters (fun param -> { param with pause_condition }) -let set_seed seed = - update_parameters (fun param -> { param with seed }) + +let set_seed seed = update_parameters (fun param -> { param with seed }) + let set_store_trace store_trace = update_parameters (fun param -> { param with store_trace }) + let set_show_dead_rules show_dead_rules = update_parameters (fun param -> { param with show_dead_rules }) + let set_show_dead_agents show_dead_agents = update_parameters (fun param -> { param with show_dead_agents }) + let set_show_non_weakly_reversible_transitions show_non_weakly_reversible_transitions = - update_parameters - (fun param -> { param with show_non_weakly_reversible_transitions }) + update_parameters (fun param -> + { param with show_non_weakly_reversible_transitions }) let update_state me project_catalog default_parameters project_parameters = - me.project_manager#project_parse - ~patternSharing:Pattern.Compatible_patterns [] >>= fun out -> + me.project_manager#project_parse ~patternSharing:Pattern.Compatible_patterns + [] + >>= fun out -> let () = - set_state { - project_current = Some me; - project_catalog; default_parameters; project_parameters; - project_version = 1; - } in + set_state + { + project_current = Some me; + project_catalog; + default_parameters; + project_parameters; + project_version = 1; + } + in Lwt.return out let computing_watcher manager setter = @@ -196,69 +226,85 @@ let computing_watcher manager setter = let cancelled = ref false in let rec loop () = let () = setter manager#is_computing in - if !cancelled then Lwt.return_unit - else Js_of_ocaml_lwt.Lwt_js.sleep delay >>= loop in + if !cancelled then + Lwt.return_unit + else + Js_of_ocaml_lwt.Lwt_js.sleep delay >>= loop + in let () = Lwt.async loop in cancelled let add_project is_new project_id : unit Api.result Lwt.t = let state_va = React.S.value state in + (* TODO: Is it ok to get the value like this ? *) let catalog = state_va.project_catalog in (try - Lwt.return (Result_util.ok - (List.find (fun x -> x.project_id = project_id) catalog, - catalog, - state_va.project_parameters)) + Lwt.return + (Result_util.ok + ( List.find (fun x -> x.project_id = project_id) catalog, + catalog, + state_va.project_parameters )) with Not_found -> - State_runtime.create_manager ~is_new project_id >>= - Api_common.result_bind_lwt - ~ok:(fun project_manager -> - let project_is_computing, set_computes = React.S.create true in - let project_watcher_cancel = - computing_watcher project_manager (set_computes ?step:None) in - let me = { project_id; project_manager; - project_is_computing; project_watcher_cancel } in - let default_parameters = state_va.default_parameters in - let params = - Mods.StringMap.add - project_id default_parameters state_va.project_parameters in - Lwt.return - (Result_util.ok (me,me::catalog,params)))) >>= - Api_common.result_bind_lwt - ~ok:(fun (me,catalog,params) -> - update_state me catalog state_va.default_parameters params) + State_runtime.create_manager ~is_new project_id + >>= Api_common.result_bind_lwt ~ok:(fun project_manager -> + let project_is_computing, set_computes = React.S.create true in + let project_watcher_cancel = + computing_watcher project_manager (set_computes ?step:None) + in + let me = + { + project_id; + project_manager; + project_is_computing; + project_watcher_cancel; + } + in + let default_parameters = state_va.default_parameters in + let params = + Mods.StringMap.add project_id default_parameters + state_va.project_parameters + in + Lwt.return (Result_util.ok (me, me :: catalog, params)))) + >>= Api_common.result_bind_lwt ~ok:(fun (me, catalog, params) -> + update_state me catalog state_va.default_parameters params) let create_project project_id = add_project true project_id let set_project project_id = add_project false project_id -let dummy_model = { - model_current_id = None; - model_catalog = []; - model_project_version = -1; - model_parameters = init_default_parameters; -} +let dummy_model = + { + model_current_id = None; + model_catalog = []; + model_project_version = -1; + model_parameters = init_default_parameters; + } let model : model React.signal = - React.S.map - ~eq:model_equal + React.S.map ~eq:model_equal (fun state -> - let model_catalog = - List.map - (fun p -> { - model_project_id = p.project_id; - model_project_is_computing = p.project_is_computing; - }) - state.project_catalog in - let model_parameters = match state.project_current with - | None -> state.default_parameters - | Some proj -> Mods.StringMap.find_default - state.default_parameters proj.project_id state.project_parameters in - { model_current_id = - Option_util.map (fun x -> x.project_id) state.project_current; - model_catalog; - model_project_version = state.project_version ; - model_parameters; - }) + let model_catalog = + List.map + (fun p -> + { + model_project_id = p.project_id; + model_project_is_computing = p.project_is_computing; + }) + state.project_catalog + in + let model_parameters = + match state.project_current with + | None -> state.default_parameters + | Some proj -> + Mods.StringMap.find_default state.default_parameters proj.project_id + state.project_parameters + in + { + model_current_id = + Option_util.map (fun x -> x.project_id) state.project_current; + model_catalog; + model_project_version = state.project_version; + model_parameters; + }) state let sync () : unit Api.result Lwt.t = @@ -266,104 +312,109 @@ let sync () : unit Api.result Lwt.t = | None -> Lwt.return (Result_util.ok ()) | Some current -> current.project_manager#project_parse - ~patternSharing:Pattern.Compatible_patterns [] >>= fun out -> + ~patternSharing:Pattern.Compatible_patterns [] + >>= fun out -> let st = React.S.value state in - let () = - set_state { - st with project_version = succ st.project_version; - } in + let () = set_state { st with project_version = succ st.project_version } in Lwt.return out let remove_files manager = - manager#file_catalog >>= - (Api_common.result_bind_lwt - ~ok:(fun catalog -> - Lwt_list.iter_p - (fun m -> - manager#file_delete m.Kfiles.id>>= - (fun _ -> Lwt.return_unit)) - catalog >>= - (fun () -> Lwt.return (Result_util.ok ())))) + manager#file_catalog + >>= Api_common.result_bind_lwt ~ok:(fun catalog -> + Lwt_list.iter_p + (fun m -> + manager#file_delete m.Kfiles.id >>= fun _ -> Lwt.return_unit) + catalog + >>= fun () -> Lwt.return (Result_util.ok ())) let remove_project project_id = let state = React.S.value state in try let current = - List.find (fun x -> x.project_id = project_id) - state.project_catalog in - remove_files current.project_manager >>= - (fun out' -> - let () = current.project_watcher_cancel := true in - let project_catalog = - List.filter (fun x -> x.project_id <> current.project_id) - state.project_catalog in - let project_current = - if (match state.project_current with - | None -> false - | Some v -> v.project_id = current.project_id) then - match project_catalog with - | [] -> None - | h :: _ -> Some h - else state.project_current in - let () = - set_state { - project_current; project_catalog; - default_parameters = state.default_parameters; - project_parameters = - Mods.StringMap.remove project_id state.project_parameters; - project_version = -1; - } in - let () = current.project_manager#terminate in - sync () >>= fun out'' -> - Lwt.return (Api_common.result_combine [out';out''])) + List.find (fun x -> x.project_id = project_id) state.project_catalog + in + remove_files current.project_manager >>= fun out' -> + let () = current.project_watcher_cancel := true in + let project_catalog = + List.filter + (fun x -> x.project_id <> current.project_id) + state.project_catalog + in + let project_current = + if + match state.project_current with + | None -> false + | Some v -> v.project_id = current.project_id + then ( + match project_catalog with + | [] -> None + | h :: _ -> Some h + ) else + state.project_current + in + let () = + set_state + { + project_current; + project_catalog; + default_parameters = state.default_parameters; + project_parameters = + Mods.StringMap.remove project_id state.project_parameters; + project_version = -1; + } + in + let () = current.project_manager#terminate in + sync () >>= fun out'' -> + Lwt.return (Api_common.result_combine [ out'; out'' ]) with Not_found -> - Lwt.return (Api_common.result_error_msg - ("Project "^project_id^" does not exists")) + Lwt.return + (Api_common.result_error_msg + ("Project " ^ project_id ^ " does not exists")) let rec init_plot_period (arg : string list) : unit = match arg with | [] -> () - | h::t -> - try set_plot_period (float_of_string h) - with Failure _ -> - let msg = Format.sprintf "failed to parse init_plot_period '%s'" h in - let () = Common.debug (Js.string msg) in - init_plot_period t + | h :: t -> + (try set_plot_period (float_of_string h) + with Failure _ -> + let msg = Format.sprintf "failed to parse init_plot_period '%s'" h in + let () = Common.debug (Js.string msg) in + init_plot_period t) let init_pause_condition (arg : string list) : unit = match arg with | [] -> () - | h::_ -> set_pause_condition h + | h :: _ -> set_pause_condition h let rec init_model_seed (arg : string list) : unit = match arg with | [] -> () - | h::t -> - try set_plot_period (float_of_string h) - with Failure _ -> - let msg = Format.sprintf "failed to parse model_seed '%s'" h in - let () = Common.debug (Js.string msg) in - init_model_seed t + | h :: t -> + (try set_plot_period (float_of_string h) + with Failure _ -> + let msg = Format.sprintf "failed to parse model_seed '%s'" h in + let () = Common.debug (Js.string msg) in + init_model_seed t) let init_store_trace (arg : string list) : unit = match arg with | [] -> () - | h::_ -> set_store_trace (h <> "false") + | h :: _ -> set_store_trace (h <> "false") let init_show_dead_rules (arg : string list) : unit = match arg with | [] -> () - | h::_ -> set_show_dead_rules (h <> "false") + | h :: _ -> set_show_dead_rules (h <> "false") let init_show_dead_agents (arg : string list) : unit = match arg with | [] -> () - | h::_ -> set_show_dead_agents (h <> "false") + | h :: _ -> set_show_dead_agents (h <> "false") let init_show_non_weakly_reversible_transitions (arg : string list) : unit = match arg with | [] -> () - | h::_ -> set_show_non_weakly_reversible_transitions (h <> "false") + | h :: _ -> set_show_non_weakly_reversible_transitions (h <> "false") let init existing_projects : unit Lwt.t = let arg_plot_period = @@ -372,123 +423,149 @@ let init existing_projects : unit Lwt.t = Dom_html.window##.localStorage (fun () -> []) (fun st -> - Js.Opt.case - (st##getItem plotPeriodParamId) - (fun () -> []) (fun x -> [Js.to_string x])) in - Common_state.url_args ~default "plot_period" in + Js.Opt.case + (st##getItem plotPeriodParamId) + (fun () -> []) + (fun x -> [ Js.to_string x ])) + in + Common_state.url_args ~default "plot_period" + in let arg_pause_condition = let default = Js.Optdef.case Dom_html.window##.localStorage (fun () -> []) (fun st -> - Js.Opt.case - (st##getItem pauseConditionParamId) - (fun () -> []) (fun x -> [Js.to_string x])) in - Common_state.url_args ~default "pause_condition" in + Js.Opt.case + (st##getItem pauseConditionParamId) + (fun () -> []) + (fun x -> [ Js.to_string x ])) + in + Common_state.url_args ~default "pause_condition" + in let arg_model_seed = - let default = + let default = Js.Optdef.case Dom_html.window##.localStorage (fun () -> []) (fun st -> - Js.Opt.case - (st##getItem seedParamId) - (fun () -> []) (fun x -> [Js.to_string x])) in - Common_state.url_args ~default "model_seed" in + Js.Opt.case + (st##getItem seedParamId) + (fun () -> []) + (fun x -> [ Js.to_string x ])) + in + Common_state.url_args ~default "model_seed" + in let arg_store_trace = - let default = + let default = Js.Optdef.case Dom_html.window##.localStorage (fun () -> []) (fun st -> - Js.Opt.case - (st##getItem storeTraceParamId) - (fun () -> []) (fun x -> [Js.to_string x])) in - Common_state.url_args ~default "store_trace" in + Js.Opt.case + (st##getItem storeTraceParamId) + (fun () -> []) + (fun x -> [ Js.to_string x ])) + in + Common_state.url_args ~default "store_trace" + in let arg_show_dead_rules = - let default = + let default = Js.Optdef.case Dom_html.window##.localStorage (fun () -> []) (fun st -> - Js.Opt.case - (st##getItem showDeadRulesParamId) - (fun () -> []) (fun x -> [Js.to_string x])) in - Common_state.url_args ~default "show_dead_rules" in + Js.Opt.case + (st##getItem showDeadRulesParamId) + (fun () -> []) + (fun x -> [ Js.to_string x ])) + in + Common_state.url_args ~default "show_dead_rules" + in let arg_show_dead_agents = - let default = + let default = Js.Optdef.case Dom_html.window##.localStorage (fun () -> []) (fun st -> - Js.Opt.case - (st##getItem showDeadAgentsParamId) - (fun () -> []) (fun x -> [Js.to_string x])) in - Common_state.url_args ~default "show_dead_agents" in + Js.Opt.case + (st##getItem showDeadAgentsParamId) + (fun () -> []) + (fun x -> [ Js.to_string x ])) + in + Common_state.url_args ~default "show_dead_agents" + in let arg_show_irreversible_transitions = - let default = + let default = Js.Optdef.case Dom_html.window##.localStorage (fun () -> []) (fun st -> - Js.Opt.case - (st##getItem showIrreversibleTransitionsParamId) - (fun () -> []) (fun x -> [Js.to_string x])) in - Common_state.url_args ~default "show_non_weakly_reversible_transitions" in + Js.Opt.case + (st##getItem showIrreversibleTransitionsParamId) + (fun () -> []) + (fun x -> [ Js.to_string x ])) + in + Common_state.url_args ~default "show_non_weakly_reversible_transitions" + in let () = init_plot_period arg_plot_period in let () = init_pause_condition arg_pause_condition in let () = init_model_seed arg_model_seed in let () = init_store_trace arg_store_trace in let () = init_show_dead_rules arg_show_dead_rules in let () = init_show_dead_agents arg_show_dead_agents in - let () = init_show_non_weakly_reversible_transitions - arg_show_irreversible_transitions in + let () = + init_show_non_weakly_reversible_transitions + arg_show_irreversible_transitions + in - let projects = Common_state.url_args ~default:["default"] "project" in + let projects = Common_state.url_args ~default:[ "default" ] "project" in let rec add_projects projects : unit Lwt.t = match projects with | [] -> Lwt.return_unit - | project::projects -> + | project :: projects -> add_project (List.for_all (fun x -> x <> project) existing_projects) - project >>= - Result_util.fold - ~ok:(fun () -> add_projects projects) - ~error:(fun errors -> - let msg = - Format.asprintf - "creating project %s error @[%a@]" - project - (Pp.list Pp.space Result_util.print_message) errors in - let () = Common.debug - (Js.string (Format.sprintf "State_project.init 2 : %s" msg)) in - add_projects projects) + project + >>= Result_util.fold + ~ok:(fun () -> add_projects projects) + ~error:(fun errors -> + let msg = + Format.asprintf "creating project %s error @[%a@]" project + (Pp.list Pp.space Result_util.print_message) + errors + in + let () = + Common.debug + (Js.string (Format.sprintf "State_project.init 2 : %s" msg)) + in + add_projects projects) in add_projects existing_projects >>= fun () -> add_projects projects let with_project : - 'a . label:string -> - (Api.concrete_manager -> 'a Api.result Lwt.t) -> - 'a Api.result Lwt.t = - fun ~label handler -> - match (React.S.value state).project_current with - | None -> - let error_msg : string = - Format.sprintf - "Failed %s due to unavailable project." - label in - Lwt.return (Api_common.result_error_msg error_msg) - | Some current -> handler current.project_manager - -let on_project_change_async ?eq ~on ?(others_eq= (=)) init_others others default handler = + 'a. + label:string -> + (Api.concrete_manager -> 'a Api.result Lwt.t) -> + 'a Api.result Lwt.t = + fun ~label handler -> + match (React.S.value state).project_current with + | None -> + let error_msg : string = + Format.sprintf "Failed %s due to unavailable project." label + in + Lwt.return (Api_common.result_error_msg error_msg) + | Some current -> handler current.project_manager + +let on_project_change_async ?eq ~on ?(others_eq = ( = )) init_others others + default handler = let eq_pair = Mods.pair_equal state_equal others_eq in - React.S.hold - ?eq default + React.S.hold ?eq default (Lwt_react.E.map_p - (fun (st,oth) -> match st.project_current with - | None -> Lwt.return default - | Some current -> handler current.project_manager oth) + (fun (st, oth) -> + match st.project_current with + | None -> Lwt.return default + | Some current -> handler current.project_manager oth) (React.S.changes - (React.S.on ~eq:eq_pair on (init_state,init_others) + (React.S.on ~eq:eq_pair on (init_state, init_others) (React.S.Pair.pair ~eq:eq_pair state others)))) diff --git a/gui/state_project.mli b/gui/state_project.mli index 42cf3c8da8..03fcd699bf 100644 --- a/gui/state_project.mli +++ b/gui/state_project.mli @@ -7,31 +7,30 @@ (******************************************************************************) type parameters = { - plot_period : float; - pause_condition : string; - seed : int option; - store_trace : bool; - show_dead_rules : bool; - show_dead_agents : bool; - show_non_weakly_reversible_transitions : bool; + plot_period: float; + pause_condition: string; + seed: int option; + store_trace: bool; + show_dead_rules: bool; + show_dead_agents: bool; + show_non_weakly_reversible_transitions: bool; } type project_model = { - model_project_id : string; - model_project_is_computing : bool React.S.t; + model_project_id: string; + model_project_is_computing: bool React.S.t; } type model = { - model_current_id : string option ; - model_catalog : project_model list ; - model_project_version : int ; - model_parameters : parameters ; + model_current_id: string option; + model_catalog: project_model list; + model_project_version: int; + model_parameters: parameters; } val model_equal : model -> model -> bool val dummy_model : model val model : model React.signal - val set_plot_period : float -> unit val set_pause_condition : string -> unit val set_seed : int option -> unit @@ -39,26 +38,27 @@ val set_store_trace : bool -> unit val set_show_dead_rules : bool -> unit val set_show_dead_agents : bool -> unit val set_show_non_weakly_reversible_transitions : bool -> unit - val set_parameters_as_default : unit -> unit - val set_project : string -> unit Api.result Lwt.t - val create_project : string -> unit Api.result Lwt.t - val remove_project : string -> unit Api.result Lwt.t - val init : string list -> unit Lwt.t (* run on application init *) val sync : unit -> unit Api.result Lwt.t -(* to synch state of application with runtime *) +(* to sync state of application with runtime *) val with_project : - label:string -> (Api.concrete_manager -> 'a Api.result Lwt.t) -> + label:string -> + (Api.concrete_manager -> 'a Api.result Lwt.t) -> 'a Api.result Lwt.t val on_project_change_async : - ?eq:('a -> 'a -> bool) -> on:bool React.signal -> - ?others_eq:('b -> 'b -> bool) -> 'b -> 'b React.signal -> - 'a -> (Api.concrete_manager -> 'b -> 'a Lwt.t) -> 'a React.signal + ?eq:('a -> 'a -> bool) -> + on:bool React.signal -> + ?others_eq:('b -> 'b -> bool) -> + 'b -> + 'b React.signal -> + 'a -> + (Api.concrete_manager -> 'b -> 'a Lwt.t) -> + 'a React.signal diff --git a/gui/state_runtime.ml b/gui/state_runtime.ml index e4c97e7d94..e8c685a81e 100644 --- a/gui/state_runtime.ml +++ b/gui/state_runtime.ml @@ -8,44 +8,29 @@ open Lwt.Infix -type cli = { - url : string; - command : string; - args : string list -} - +type cli = { url: string; command: string; args: string list } type protocol = HTTP of string | CLI of cli -type remote = { label : string ; protocol : protocol ; } - +type remote = { label: string; protocol: protocol } type spec = WebWorker | Embedded | Remote of remote +type state = { state_current: spec; state_runtimes: spec list } +type model = { model_current: spec; model_runtimes: spec list } -type state = { - state_current : spec ; - state_runtimes : spec list ; -} - -type model = { model_current : spec ; model_runtimes : spec list ; } - -let spec_label : spec -> string = - function +let spec_label : spec -> string = function | WebWorker -> "WebWorker" | Embedded -> "Embedded" | Remote remote -> remote.label -let spec_id : spec -> string = - function +let spec_id : spec -> string = function | WebWorker -> "WebWorker" | Embedded -> "Embedded" - | Remote { label = _ ; protocol = HTTP http } -> http - | Remote { label = _ ; protocol = CLI cli } -> cli.url + | Remote { label = _; protocol = HTTP http } -> http + | Remote { label = _; protocol = CLI cli } -> cli.url -let read_spec : string -> spec option = - function +let read_spec : string -> spec option = function | "WebWorker" -> Some WebWorker | "Embedded" -> Some Embedded | url -> - let () = - Common.debug (Js.string (Format.sprintf "parse_remote: %s" url)) in + let () = Common.debug (Js.string (Format.sprintf "parse_remote: %s" url)) in let format_url url = let length = String.length url in if length > 0 && String.get url (length - 1) == '/' then @@ -55,44 +40,43 @@ let read_spec : string -> spec option = in let cleaned_url http = let cleaned = - Format.sprintf - "%s:%d/%s" - http.Url.hu_host - http.Url.hu_port + Format.sprintf "%s:%d/%s" http.Url.hu_host http.Url.hu_port http.Url.hu_path_string in let () = - Common.debug (Js.string (Format.sprintf "cleaned : %s" cleaned)) in + Common.debug (Js.string (Format.sprintf "cleaned : %s" cleaned)) + in format_url cleaned in - match Url.url_of_string url with + (match Url.url_of_string url with | None -> None | Some parsed -> let protocol : protocol = match parsed with - | Url.Http http -> HTTP ("http://"^(cleaned_url http)) - | Url.Https https -> HTTP ("https://"^(cleaned_url https)) - | Url.File file -> CLI { url = "file://"^file.Url.fu_path_string ; - command = file.Url.fu_path_string ; - args = [] } + | Url.Http http -> HTTP ("http://" ^ cleaned_url http) + | Url.Https https -> HTTP ("https://" ^ cleaned_url https) + | Url.File file -> + CLI + { + url = "file://" ^ file.Url.fu_path_string; + command = file.Url.fu_path_string; + args = []; + } in let label = try - (List.assoc "label" - (match parsed with - | Url.Http http -> http.Url.hu_arguments - | Url.Https https -> https.Url.hu_arguments - | Url.File file -> file.Url.fu_arguments - ) - ) + List.assoc "label" + (match parsed with + | Url.Http http -> http.Url.hu_arguments + | Url.Https https -> https.Url.hu_arguments + | Url.File file -> file.Url.fu_arguments) with Not_found -> - match parsed with - | Url.Http http -> http.Url.hu_host - | Url.Https https -> https.Url.hu_host - | Url.File file -> file.Url.fu_path_string + (match parsed with + | Url.Http http -> http.Url.hu_host + | Url.Https https -> https.Url.hu_host + | Url.File file -> file.Url.fu_path_string) in - Some (Remote { label = label; - protocol = protocol ; }) + Some (Remote { label; protocol })) class embedded () : Api.concrete_manager = let kasa_worker = Worker.create "KaSaWorker.js" in @@ -100,93 +84,113 @@ class embedded () : Api.concrete_manager = let kamoha_worker = Worker.create "KaMoHaWorker.js" in let kamoha_mailbox = Kamoha_client.new_mailbox () in let kastor_worker = Worker.create "KaStorWorker.js" in - let stor_state,update_stor_state = Kastor_client.init_state () in - object(self) + let stor_state, update_stor_state = Kastor_client.init_state () in + object (self) initializer - let () = kasa_worker##.onmessage := - (Dom.handler - (fun (response_message : string Worker.messageEvent Js.t) -> - let response_text : string = response_message##.data in - let () = Kasa_client.receive kasa_mailbox response_text in - Js._true - )) in - let () = kamoha_worker##.onmessage := - (Dom.handler - (fun (response_message : string Worker.messageEvent Js.t) -> - let response_text : string = response_message##.data in - let () = Kamoha_client.receive kamoha_mailbox response_text in - Js._true - )) in - let () = kastor_worker##.onmessage := - (Dom.handler - (fun (response_message : string Worker.messageEvent Js.t) -> - let response_text : string = response_message##.data in - let () = Kastor_client.receive update_stor_state response_text in - Js._true - )) in + let () = + kasa_worker##.onmessage := + Dom.handler + (fun (response_message : string Worker.messageEvent Js.t) -> + let response_text : string = response_message##.data in + let () = Kasa_client.receive kasa_mailbox response_text in + Js._true) + in + let () = + kamoha_worker##.onmessage := + Dom.handler + (fun (response_message : string Worker.messageEvent Js.t) -> + let response_text : string = response_message##.data in + let () = Kamoha_client.receive kamoha_mailbox response_text in + Js._true) + in + let () = + kastor_worker##.onmessage := + Dom.handler + (fun (response_message : string Worker.messageEvent Js.t) -> + let response_text : string = response_message##.data in + let () = Kastor_client.receive update_stor_state response_text in + Js._true) + in () - inherit Api_runtime.manager + + inherit + Api_runtime.manager (object - method min_run_duration () = 0.1 - method yield = Js_of_ocaml_lwt.Lwt_js.yield - method log ?exn (msg: string) = - let () = ignore(exn) in - let () = Common.debug (Js.string (Format.sprintf "embedded_manager#log: %s" msg)) - in - Lwt.return_unit - end : Kappa_facade.system_process) - inherit Kasa_client.new_uniform_client + method min_run_duration () = 0.1 + method yield = Js_of_ocaml_lwt.Lwt_js.yield + + method log ?exn (msg : string) = + let () = ignore exn in + let () = + Common.debug + (Js.string (Format.sprintf "embedded_manager#log: %s" msg)) + in + Lwt.return_unit + end + : Kappa_facade.system_process) + + inherit + Kasa_client.new_uniform_client ~is_running:(fun () -> true) - ~post:(fun message_text -> kasa_worker##postMessage(message_text)) + ~post:(fun message_text -> kasa_worker##postMessage message_text) kasa_mailbox - inherit Kamoha_client.new_client - ~post:(fun message_text -> kamoha_worker##postMessage(message_text)) + + inherit + Kamoha_client.new_client + ~post:(fun message_text -> kamoha_worker##postMessage message_text) kamoha_mailbox - inherit Kastor_client.new_client - ~post:(fun message_text -> kastor_worker##postMessage(message_text)) + + inherit + Kastor_client.new_client + ~post:(fun message_text -> kastor_worker##postMessage message_text) stor_state + method is_running = true + method terminate = let () = kasa_worker##terminate in - ()(*TODO*) - method is_computing = true (*TODO*) + () (*TODO*) + method is_computing = true (*TODO*) val mutable kasa_locator = [] method project_parse ~patternSharing overwrites = - self#secret_project_parse >>= - Api_common.result_bind_lwt - ~ok:(fun out -> - let load = - self#secret_simulation_load patternSharing out overwrites in - let init = self#init_static_analyser out in - let locators = - init >>= Result_util.fold - ~error:(fun e -> - let () = kasa_locator <- [] in - Lwt.return (Result_util.error e)) - ~ok:(fun () -> - self#secret_get_pos_of_rules_and_vars >>= Result_util.fold - ~ok:(fun infos -> - let () = kasa_locator <- infos in - Lwt.return (Result_util.ok ())) + self#secret_project_parse + >>= Api_common.result_bind_lwt ~ok:(fun out -> + let load = + self#secret_simulation_load patternSharing out overwrites + in + let init = self#init_static_analyser out in + let locators = + init + >>= Result_util.fold ~error:(fun e -> - let () = kasa_locator <- [] in - Lwt.return (Result_util.error e))) in - load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) + let () = kasa_locator <- [] in + Lwt.return (Result_util.error e)) + ~ok:(fun () -> + self#secret_get_pos_of_rules_and_vars + >>= Result_util.fold + ~ok:(fun infos -> + let () = kasa_locator <- infos in + Lwt.return (Result_util.ok ())) + ~error:(fun e -> + let () = kasa_locator <- [] in + Lwt.return (Result_util.error e))) + in + load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) method get_influence_map_node_at ~filename pos : _ Api.result Lwt.t = - List.find_opt (fun (_,x) -> Locality.is_included_in filename pos x) kasa_locator |> - Option_util.map fst |> Result_util.ok ?status:None |> Lwt.return - + List.find_opt + (fun (_, x) -> Loc.is_included_in filename pos x) + kasa_locator + |> Option_util.map fst + |> Result_util.ok ?status:None + |> Lwt.return end -let state , set_state = +let state, set_state = React.S.create - { - state_current = WebWorker ; - state_runtimes = [ WebWorker ; Embedded ; ] ; - } + { state_current = WebWorker; state_runtimes = [ WebWorker; Embedded ] } let create_manager ~is_new project_id = match (React.S.value state).state_current with @@ -197,58 +201,58 @@ let create_manager ~is_new project_id = | Embedded -> let () = State_settings.set_synch false in Lwt.return (Result_util.ok (new embedded () : Api.concrete_manager)) - | Remote { label = _ ; protocol = HTTP url } -> + | Remote { label = _; protocol = HTTP url } -> let version_url : string = Format.sprintf "%s/v2" url in - let () = Common.debug - (Js.string (Format.sprintf "set_runtime_url: %s" version_url)) in - (Js_of_ocaml_lwt.XmlHttpRequest.perform_raw - ~response_type:XmlHttpRequest.Text - version_url) >>= - (fun frame -> - let is_valid_server : bool = - frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 in - if is_valid_server then - let () = State_settings.set_synch true in - let manager = new Rest_api.manager - ~timeout:None ~url ~project_id in - (if is_new then - manager#project_create - { Api_types_j.project_parameter_project_id = project_id } - else Lwt.return (Result_util.ok ())) >>= - Api_common.result_bind_lwt - ~ok:(fun () -> Lwt.return (Result_util.ok - (manager :> Api.concrete_manager))) + let () = + Common.debug + (Js.string (Format.sprintf "set_runtime_url: %s" version_url)) + in + Js_of_ocaml_lwt.XmlHttpRequest.perform_raw + ~response_type:XmlHttpRequest.Text version_url + >>= fun frame -> + let is_valid_server : bool = + frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 + in + if is_valid_server then ( + let () = State_settings.set_synch true in + let manager = new Rest_api.manager ~timeout:None ~url ~project_id in + (if is_new then + manager#project_create + { Api_types_j.project_parameter_project_id = project_id } else + Lwt.return (Result_util.ok ())) + >>= Api_common.result_bind_lwt ~ok:(fun () -> + Lwt.return (Result_util.ok (manager :> Api.concrete_manager))) + ) else ( + let error_msg : string = + Format.sprintf "Bad Response %d from %s " + frame.Js_of_ocaml_lwt.XmlHttpRequest.code url + in + Lwt.return (Api_common.result_error_msg error_msg) + ) + | Remote { label; protocol = CLI cli } -> + let () = Common.debug (Js.string ("set_runtime_url: " ^ cli.url)) in + (try + let js_node_runtime = new JsNode.manager cli.command cli.args in + if js_node_runtime#is_running then ( + let () = Common.debug (Js.string "set_runtime_url:sucess") in + let () = State_settings.set_synch false in + Lwt.return (Result_util.ok (js_node_runtime :> Api.concrete_manager)) + ) else ( + let () = Common.debug (Js.string "set_runtime_url:failure") in let error_msg : string = - Format.sprintf "Bad Response %d from %s " - frame.Js_of_ocaml_lwt.XmlHttpRequest.code url in + Format.sprintf "Could not start cli runtime %s " label + in Lwt.return (Api_common.result_error_msg error_msg) - ) - - | Remote { label ; protocol = CLI cli } -> - let () = Common.debug (Js.string ("set_runtime_url: "^cli.url)) in - try - let js_node_runtime = new JsNode.manager cli.command cli.args in - if js_node_runtime#is_running then - let () = Common.debug (Js.string "set_runtime_url:sucess") in - let () = State_settings.set_synch false in - Lwt.return (Result_util.ok (js_node_runtime :> Api.concrete_manager)) - else - let () = Common.debug (Js.string "set_runtime_url:failure") in - let error_msg : string = - Format.sprintf "Could not start cli runtime %s " label - in - Lwt.return (Api_common.result_error_msg error_msg) - with Failure x -> - Lwt.return (Api_common.result_error_msg x) + ) + with Failure x -> Lwt.return (Api_common.result_error_msg x)) let set_spec runtime = let current_state = React.S.value state in set_state - { state_current = runtime; - state_runtimes = current_state.state_runtimes } + { state_current = runtime; state_runtimes = current_state.state_runtimes } -let create_spec ~load (id : string): unit Api.result = +let create_spec ~load (id : string) : unit Api.result = match read_spec id with | None -> let error_msg : string = @@ -260,15 +264,21 @@ let create_spec ~load (id : string): unit Api.result = let () = if not (List.mem runtime current_state.state_runtimes) then set_state - { state_current = current_state.state_current; - state_runtimes = runtime::current_state.state_runtimes } in + { + state_current = current_state.state_current; + state_runtimes = runtime :: current_state.state_runtimes; + } + in let () = if load then set_spec runtime in Result_util.ok () let model : model React.signal = React.S.map - (fun state -> { model_current = state.state_current ; - model_runtimes = state.state_runtimes ; }) + (fun state -> + { + model_current = state.state_current; + model_runtimes = state.state_runtimes; + }) state (* run on application init *) @@ -278,33 +288,35 @@ let init () = let rec add_urls urls load = match urls with | [] -> () - | url::urls -> - match create_spec ~load url with + | url :: urls -> + (match create_spec ~load url with | { Result_util.value = Result.Ok (); _ } -> add_urls urls false - | { Result_util.value = Result.Error _; _ } -> add_urls urls load + | { Result_util.value = Result.Error _; _ } -> add_urls urls load) in let () = add_urls hosts true in match (React.S.value state).state_current with - | Remote { protocol = CLI _ ; _ } | WebWorker | Embedded -> Lwt.return_nil - | Remote { label = _ ; protocol = HTTP url } -> + | Remote { protocol = CLI _; _ } | WebWorker | Embedded -> Lwt.return_nil + | Remote { label = _; protocol = HTTP url } -> let version_url : string = Format.sprintf "%s/v2" url in - let () = Common.debug - (Js.string (Format.sprintf "set_runtime_url: %s" version_url)) in - (Js_of_ocaml_lwt.XmlHttpRequest.perform_raw - ~response_type:XmlHttpRequest.Text - version_url) >>= - (fun frame -> - let is_valid_server : bool = - frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 in - if is_valid_server then - let () = State_settings.set_synch true in - let manager = new Rest_api.manager - ~timeout:None ~url ~project_id:"" in - manager#project_catalog >>= - Result_util.fold - ~ok:(fun projects -> Lwt.return projects) - ~error:(fun _ -> Lwt.return_nil) - else Lwt.return_nil) + let () = + Common.debug + (Js.string (Format.sprintf "set_runtime_url: %s" version_url)) + in + Js_of_ocaml_lwt.XmlHttpRequest.perform_raw + ~response_type:XmlHttpRequest.Text version_url + >>= fun frame -> + let is_valid_server : bool = + frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 + in + if is_valid_server then ( + let () = State_settings.set_synch true in + let manager = new Rest_api.manager ~timeout:None ~url ~project_id:"" in + manager#project_catalog + >>= Result_util.fold + ~ok:(fun projects -> Lwt.return projects) + ~error:(fun _ -> Lwt.return_nil) + ) else + Lwt.return_nil (* to sync state of application with runtime *) let sync () = Lwt.return_unit diff --git a/gui/state_settings.ml b/gui/state_settings.ml index 21e42bf88a..1d0b026596 100644 --- a/gui/state_settings.ml +++ b/gui/state_settings.ml @@ -10,7 +10,6 @@ let clientIdParamId = Js.string "kappappClientId" let _client_id : string ref = ref "" let get_client_id () : string = !_client_id let set_client_id (client_id : string) : unit = _client_id := client_id - let fontSizeParamId = Js.string "kappappFontSize" let currentFontSize = ref 1.4 @@ -18,35 +17,37 @@ let initFromStorage () = Js.Optdef.case Dom_html.window##.localStorage (fun () -> - let () = currentFontSize := 1.4 in - _client_id := (Common.guid ())) + let () = currentFontSize := 1.4 in + _client_id := Common.guid ()) (fun st -> - let () = currentFontSize := - Js.Opt.case (st##getItem fontSizeParamId) - (fun () -> 1.4) Js.parseFloat in - _client_id := - (Js.Opt.case (st##getItem clientIdParamId) Common.guid Js.to_string) - ) + let () = + currentFontSize := + Js.Opt.case + (st##getItem fontSizeParamId) + (fun () -> 1.4) + Js.parseFloat + in + _client_id := + Js.Opt.case (st##getItem clientIdParamId) Common.guid Js.to_string) let set_parameters_as_default () = let v' = string_of_float !currentFontSize in - let () = Js.Optdef.iter - Dom_html.window##.localStorage - (fun st -> st##setItem fontSizeParamId (Js.string v')) in - Js.Optdef.iter - Dom_html.window##.localStorage - (fun st -> st##setItem clientIdParamId (Js.string !_client_id)) + let () = + Js.Optdef.iter Dom_html.window##.localStorage (fun st -> + st##setItem fontSizeParamId (Js.string v')) + in + Js.Optdef.iter Dom_html.window##.localStorage (fun st -> + st##setItem clientIdParamId (Js.string !_client_id)) let updateFontSize ~delta = - let () = currentFontSize := - max 0.2 (min (!currentFontSize +. delta) 3.) in + let () = currentFontSize := max 0.2 (min (!currentFontSize +. delta) 3.) in let v' = string_of_float !currentFontSize in - let () = Dom_html.document##.body##.style##.fontSize := - Js.string (v'^"em") in + let () = + Dom_html.document##.body##.style##.fontSize := Js.string (v' ^ "em") + in () let synch, set_synch = React.S.create false - let agent_coloring = Js.Unsafe.obj [||] let init () : unit Lwt.t = @@ -55,10 +56,10 @@ let init () : unit Lwt.t = let synch = Common_state.url_args "synch" in let () = match client_ids with - | client_id::_ -> set_client_id client_id + | client_id :: _ -> set_client_id client_id | [] -> () in - let () = set_synch (["true"] = synch) in + let () = set_synch ([ "true" ] = synch) in Lwt.return_unit let sync () : unit Lwt.t = Lwt.return_unit diff --git a/gui/state_settings.mli b/gui/state_settings.mli index 00408aab95..baa9027c79 100644 --- a/gui/state_settings.mli +++ b/gui/state_settings.mli @@ -8,10 +8,8 @@ val get_client_id : unit -> string val set_client_id : string -> unit - val updateFontSize : delta:float -> unit val set_parameters_as_default : unit -> unit - val synch : bool React.signal val set_synch : ?step:React.step -> bool -> unit diff --git a/gui/state_simulation.ml b/gui/state_simulation.ml index 8e967da988..81ff293f3f 100644 --- a/gui/state_simulation.ml +++ b/gui/state_simulation.ml @@ -12,11 +12,12 @@ type simulation_state = | SIMULATION_STATE_STOPPED (* simulation is unavailable *) | SIMULATION_STATE_INITALIZING (* simulation is blocked on an operation *) | SIMULATION_STATE_READY of Api_types_j.simulation_info - (* the simulation is ready *) +(* the simulation is ready *) -type t = { simulation_state : simulation_state ; } +type t = { simulation_state: simulation_state } let t_simulation_state simulation = simulation.simulation_state + let t_simulation_info simulation : Api_types_j.simulation_info option = match simulation.simulation_state with | SIMULATION_STATE_STOPPED -> None @@ -24,275 +25,238 @@ let t_simulation_info simulation : Api_types_j.simulation_info option = | SIMULATION_STATE_READY simulation_info -> Some simulation_info type state = t - type model = state type model_state = STOPPED | INITALIZING | RUNNING | PAUSED -let model_state_to_string = - function STOPPED -> "Stopped" - | INITALIZING -> "Initalizing" - | RUNNING -> "Running" - | PAUSED -> "Paused" +let model_state_to_string = function + | STOPPED -> "Stopped" + | INITALIZING -> "Initalizing" + | RUNNING -> "Running" + | PAUSED -> "Paused" let dummy_model = { simulation_state = SIMULATION_STATE_STOPPED } -let model_simulation_info model : Api_types_j.simulation_info option= +let model_simulation_info model : Api_types_j.simulation_info option = t_simulation_info model + let model_simulation_state model : model_state = match t_simulation_state model with | SIMULATION_STATE_STOPPED -> STOPPED | SIMULATION_STATE_INITALIZING -> INITALIZING | SIMULATION_STATE_READY simulation_info -> - if simulation_info.Api_types_j.simulation_info_progress. - Api_types_j.simulation_progress_is_running then + if + simulation_info.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_is_running + then RUNNING else PAUSED let state, set_state = React.S.create dummy_model -let update_simulation_state - (simulation_state : simulation_state) : unit = +let update_simulation_state (simulation_state : simulation_state) : unit = let () = set_state { simulation_state } in () let model : model React.signal = state let with_simulation : - 'a . label:string -> - (Api.concrete_manager -> t -> 'a Api.result Lwt.t) -> - 'a Api.result Lwt.t = - fun ~label handler -> - let project_handler manager = - handler manager (React.S.value state) in - State_project.with_project ~label project_handler + 'a. + label:string -> + (Api.concrete_manager -> t -> 'a Api.result Lwt.t) -> + 'a Api.result Lwt.t = + fun ~label handler -> + let project_handler manager = handler manager (React.S.value state) in + State_project.with_project ~label project_handler let fail_lwt error_msg = Lwt.return (Api_common.result_error_msg error_msg) -let with_simulation_info - ~(label : string) - ?(stopped : Api.concrete_manager -> - 'a Api.result Lwt.t = - fun _ -> fail_lwt "Simulation stopped") - ?(initializing : Api.concrete_manager -> - 'a Api.result Lwt.t = - fun _ -> fail_lwt "Simulation initalizing") - ?(ready : Api.concrete_manager -> - Api_types_j.simulation_info -> - 'a Api.result Lwt.t = - fun _ _ -> fail_lwt "Simulation ready") - () = - with_simulation - ~label - (fun manager s -> - match s.simulation_state with - | SIMULATION_STATE_STOPPED -> stopped manager - | SIMULATION_STATE_INITALIZING -> initializing manager - | SIMULATION_STATE_READY simulation_info -> ready manager simulation_info) +let with_simulation_info ~(label : string) + ?(stopped : Api.concrete_manager -> 'a Api.result Lwt.t = + fun _ -> fail_lwt "Simulation stopped") + ?(initializing : Api.concrete_manager -> 'a Api.result Lwt.t = + fun _ -> fail_lwt "Simulation initalizing") + ?(ready : + Api.concrete_manager -> + Api_types_j.simulation_info -> + 'a Api.result Lwt.t = + fun _ _ -> fail_lwt "Simulation ready") () = + with_simulation ~label (fun manager s -> + match s.simulation_state with + | SIMULATION_STATE_STOPPED -> stopped manager + | SIMULATION_STATE_INITALIZING -> initializing manager + | SIMULATION_STATE_READY simulation_info -> ready manager simulation_info) -let when_ready - ~(label : string) +let when_ready ~(label : string) ?(handler : unit Api.result -> unit Lwt.t = fun _ -> Lwt.return_unit) (operation : Api.concrete_manager -> unit Api.result Lwt.t) : unit = - Common.async - __LOC__ - (fun () -> - with_simulation_info - ~label - ~stopped:(fun _-> Lwt.return (Result_util.ok ())) - ~initializing:(fun _ -> Lwt.return (Result_util.ok ())) - ~ready:(fun manager _ -> - (operation manager : unit Api.result Lwt.t) - ) - () >>= handler - ) + Common.async __LOC__ (fun () -> + with_simulation_info ~label + ~stopped:(fun _ -> Lwt.return (Result_util.ok ())) + ~initializing:(fun _ -> Lwt.return (Result_util.ok ())) + ~ready:(fun manager _ : unit Api.result Lwt.t -> operation manager) + () + >>= handler) (* to synch state of application with runtime *) let sleep_time = 1.0 + let rec sync () = match (React.S.value state).simulation_state with | SIMULATION_STATE_STOPPED | SIMULATION_STATE_INITALIZING -> Lwt.return (Result_util.ok ()) | SIMULATION_STATE_READY _ -> - State_project.with_project ~label:"sync" - (fun manager -> - (* get current directory *) - manager#simulation_info >>= - (Api_common.result_bind_lwt - ~ok:(fun simulation_info -> - let () = set_state - {simulation_state = - SIMULATION_STATE_READY simulation_info} in - if simulation_info.Api_types_t.simulation_info_progress - .Api_types_t.simulation_progress_is_running then + State_project.with_project ~label:"sync" (fun manager -> + (* get current directory *) + manager#simulation_info + >>= Api_common.result_bind_lwt ~ok:(fun simulation_info -> + let () = + set_state + { + simulation_state = SIMULATION_STATE_READY simulation_info; + } + in + if + simulation_info.Api_types_t.simulation_info_progress + .Api_types_t.simulation_progress_is_running + then Js_of_ocaml_lwt.Lwt_js.sleep sleep_time >>= sync - else Lwt.return (Result_util.ok ()) - ) - ) - ) + else + Lwt.return (Result_util.ok ()))) let refresh () = - State_project.with_project ~label:"sync" - (fun manager -> - (* get current directory *) - manager#simulation_info >>= - (Result_util.fold - ~ok:(fun simulation_info -> - let () = set_state - {simulation_state = - SIMULATION_STATE_READY simulation_info} in + State_project.with_project ~label:"sync" (fun manager -> + (* get current directory *) + manager#simulation_info + >>= Result_util.fold + ~ok:(fun simulation_info -> + let () = + set_state + { simulation_state = SIMULATION_STATE_READY simulation_info } + in sync ()) - ~error:(fun _ -> - let () = set_state - {simulation_state = SIMULATION_STATE_STOPPED} in - Lwt.return (Result_util.ok ()) - ))) + ~error:(fun _ -> + let () = + set_state { simulation_state = SIMULATION_STATE_STOPPED } + in + Lwt.return (Result_util.ok ()))) let init () : unit Lwt.t = Lwt.return_unit let continue_simulation (pause_condition : string) : unit Api.result Lwt.t = - with_simulation_info - ~label:"continue_simulation" - ~stopped: - (fun _ -> - let error_msg : string = - "Failed to continue simulation, simulation stopped" - in - Lwt.return (Api_common.result_error_msg error_msg)) - ~initializing: - (fun _ -> - let error_msg : string = - "Failed to continue simulation, simulation initializing" - in - Lwt.return (Api_common.result_error_msg error_msg)) - ~ready: - (fun manager _ -> - manager#simulation_continue pause_condition >>= - (Api_common.result_bind_lwt ~ok:sync)) + with_simulation_info ~label:"continue_simulation" + ~stopped:(fun _ -> + let error_msg : string = + "Failed to continue simulation, simulation stopped" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~initializing:(fun _ -> + let error_msg : string = + "Failed to continue simulation, simulation initializing" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~ready:(fun manager _ -> + manager#simulation_continue pause_condition + >>= Api_common.result_bind_lwt ~ok:sync) () let pause_simulation () : unit Api.result Lwt.t = - with_simulation_info - ~label:"pause_simulation" - ~stopped: - (fun _ -> - let error_msg : string = - "Failed to pause simulation, simulation stopped" - in - Lwt.return (Api_common.result_error_msg error_msg)) - ~initializing: - (fun _ -> - let error_msg : string = - "Failed to pause simulation, simulation initializing" - in - Lwt.return (Api_common.result_error_msg error_msg)) - ~ready: - (fun manager (_ : Api_types_j.simulation_info) -> - manager#simulation_pause) + with_simulation_info ~label:"pause_simulation" + ~stopped:(fun _ -> + let error_msg : string = + "Failed to pause simulation, simulation stopped" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~initializing:(fun _ -> + let error_msg : string = + "Failed to pause simulation, simulation initializing" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~ready:(fun manager (_ : Api_types_j.simulation_info) -> + manager#simulation_pause) () let stop_simulation () : unit Api.result Lwt.t = - with_simulation_info - ~label:"stop_simulation" - ~stopped: - (fun _ -> - let error_msg : string = - "Failed to pause simulation, simulation stopped" - in - Lwt.return (Api_common.result_error_msg error_msg)) - ~initializing: - (fun _ -> - let error_msg : string = - "Failed to stop simulation, simulation initializing" - in - Lwt.return (Api_common.result_error_msg error_msg)) - ~ready: - (fun manager (_ : Api_types_j.simulation_info) -> - manager#simulation_delete >>= - (Api_common.result_bind_lwt ~ok:(fun () -> + with_simulation_info ~label:"stop_simulation" + ~stopped:(fun _ -> + let error_msg : string = + "Failed to pause simulation, simulation stopped" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~initializing:(fun _ -> + let error_msg : string = + "Failed to stop simulation, simulation initializing" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~ready:(fun manager (_ : Api_types_j.simulation_info) -> + manager#simulation_delete + >>= Api_common.result_bind_lwt ~ok:(fun () -> let () = update_simulation_state SIMULATION_STATE_STOPPED in - Lwt.return (Result_util.ok ())))) + Lwt.return (Result_util.ok ()))) () -let start_simulation (simulation_parameter : Api_types_j.simulation_parameter) : unit Api.result Lwt.t = - with_simulation_info - ~label:"start_simulation" - ~stopped: - (fun manager -> - let on_error error_msgs : unit Api.result Lwt.t = - let () = - update_simulation_state SIMULATION_STATE_STOPPED in - (* turn the lights off *) - manager#simulation_delete >>= - (fun _ -> Lwt.return (Api_common.result_messages error_msgs)) - in - Lwt.catch - (fun () -> - (* set state to initalize *) - let () = - update_simulation_state SIMULATION_STATE_INITALIZING in - (manager#simulation_start simulation_parameter) - >>= - (Api_common.result_bind_lwt - ~ok:(fun _ -> manager#simulation_info)) - >>= - (Api_common.result_bind_lwt - ~ok:(fun simulation_status -> - let simulation_state = - SIMULATION_STATE_READY simulation_status in - let () = - update_simulation_state simulation_state in - Lwt.return (Result_util.ok ()) - ) - ) - >>= - (Result_util.fold +let start_simulation (simulation_parameter : Api_types_j.simulation_parameter) : + unit Api.result Lwt.t = + with_simulation_info ~label:"start_simulation" + ~stopped:(fun manager -> + let on_error error_msgs : unit Api.result Lwt.t = + let () = update_simulation_state SIMULATION_STATE_STOPPED in + (* turn the lights off *) + manager#simulation_delete >>= fun _ -> + Lwt.return (Api_common.result_messages error_msgs) + in + Lwt.catch + (fun () -> + (* set state to initalize *) + let () = update_simulation_state SIMULATION_STATE_INITALIZING in + manager#simulation_start simulation_parameter + >>= Api_common.result_bind_lwt ~ok:(fun _ -> manager#simulation_info) + >>= Api_common.result_bind_lwt ~ok:(fun simulation_status -> + let simulation_state = + SIMULATION_STATE_READY simulation_status + in + let () = update_simulation_state simulation_state in + Lwt.return (Result_util.ok ())) + >>= Result_util.fold ~ok:(fun _ -> Lwt.return (Result_util.ok ())) ~error:(fun error_msg -> - let () = - update_simulation_state SIMULATION_STATE_STOPPED in - on_error error_msg)) - >>= - (Api_common.result_bind_lwt ~ok:sync) - ) - (function - | Invalid_argument error -> - let msg = Format.sprintf "Runtime error %s" error in - on_error [(Api_common.error_msg msg)] - | Sys_error message -> on_error [(Api_common.error_msg message)] - | _ -> on_error [(Api_common.error_msg "Initialization error")]) - ) - ~initializing: - (fun _ -> - let error_msg : string = - "Failed to start simulation, simulation initializing" in - Lwt.return (Api_common.result_error_msg error_msg)) - ~ready: - (fun _ _ -> - let error_msg : string = - "Failed to start simulation, simulation running" in - Lwt.return (Api_common.result_error_msg error_msg)) + let () = update_simulation_state SIMULATION_STATE_STOPPED in + on_error error_msg) + >>= Api_common.result_bind_lwt ~ok:sync) + (function + | Invalid_argument error -> + let msg = Format.sprintf "Runtime error %s" error in + on_error [ Api_common.error_msg msg ] + | Sys_error message -> on_error [ Api_common.error_msg message ] + | _ -> on_error [ Api_common.error_msg "Initialization error" ])) + ~initializing:(fun _ -> + let error_msg : string = + "Failed to start simulation, simulation initializing" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~ready:(fun _ _ -> + let error_msg : string = + "Failed to start simulation, simulation running" + in + Lwt.return (Api_common.result_error_msg error_msg)) () let intervene_simulation (code : string) : string Api.result Lwt.t = - with_simulation_info - ~label:"perturb_simulation" - ~stopped: - (fun _ -> - let error_msg : string = - "Failed to start simulation, simulation running" in - Lwt.return (Api_common.result_error_msg error_msg)) - ~initializing: - (fun _ -> - let error_msg : string = - "Failed to start simulation, simulation initializing" in - Lwt.return (Api_common.result_error_msg error_msg)) - ~ready: - (fun manager _ -> - manager#simulation_intervention code >>= - (Api_common.result_bind_lwt - ~ok:(fun out -> sync () >>= - Api_common.result_bind_lwt - ~ok:(fun () -> - Lwt.return (Result_util.ok out))))) + with_simulation_info ~label:"perturb_simulation" + ~stopped:(fun _ -> + let error_msg : string = + "Failed to start simulation, simulation running" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~initializing:(fun _ -> + let error_msg : string = + "Failed to start simulation, simulation initializing" + in + Lwt.return (Api_common.result_error_msg error_msg)) + ~ready:(fun manager _ -> + manager#simulation_intervention code + >>= Api_common.result_bind_lwt ~ok:(fun out -> + sync () + >>= Api_common.result_bind_lwt ~ok:(fun () -> + Lwt.return (Result_util.ok out)))) () diff --git a/gui/state_simulation.mli b/gui/state_simulation.mli index e0ca7be118..ff5ff8651d 100644 --- a/gui/state_simulation.mli +++ b/gui/state_simulation.mli @@ -15,7 +15,9 @@ type model = t val dummy_model : model val model : model React.signal val model_simulation_info : model -> Api_types_j.simulation_info option + type model_state = STOPPED | INITALIZING | RUNNING | PAUSED + val model_state_to_string : model_state -> string val model_simulation_state : t -> model_state @@ -24,21 +26,24 @@ val init : unit -> unit Lwt.t val refresh : unit -> unit Api.result Lwt.t val with_simulation : - label:string -> (Api.concrete_manager -> t -> 'a Api.result Lwt.t) -> + label:string -> + (Api.concrete_manager -> t -> 'a Api.result Lwt.t) -> 'a Api.result Lwt.t val with_simulation_info : label:string -> ?stopped:(Api.concrete_manager -> 'a Api.result Lwt.t) -> ?initializing:(Api.concrete_manager -> 'a Api.result Lwt.t) -> - ?ready:(Api.concrete_manager -> - Api_types_j.simulation_info -> 'a Api.result Lwt.t) -> - unit -> 'a Api.result Lwt.t + ?ready: + (Api.concrete_manager -> Api_types_j.simulation_info -> 'a Api.result Lwt.t) -> + unit -> + 'a Api.result Lwt.t val when_ready : label:string -> ?handler:(unit Api.result -> unit Lwt.t) -> - (Api.concrete_manager -> unit Api.result Lwt.t) -> unit + (Api.concrete_manager -> unit Api.result Lwt.t) -> + unit val continue_simulation : string -> unit Api.result Lwt.t val pause_simulation : unit -> unit Api.result Lwt.t diff --git a/gui/state_ui.ml b/gui/state_ui.ml index bbf5d10663..e2dcc8ae0a 100644 --- a/gui/state_ui.ml +++ b/gui/state_ui.ml @@ -9,35 +9,24 @@ open Lwt.Infix let sync () : unit Lwt.t = - State_settings.sync () >>= - State_runtime.sync >>= - State_project.sync >>= - fun _ -> State_file.sync () >>= - fun _ -> Lwt.return_unit + State_settings.sync () >>= State_runtime.sync >>= State_project.sync + >>= fun _ -> + State_file.sync () >>= fun _ -> Lwt.return_unit let init () : unit Lwt.t = - Lwt.return_unit >>= - State_settings.init >>= - State_runtime.init >>= - State_project.init >>= - State_file.init >>= - State_simulation.init >>= - sync + Lwt.return_unit >>= State_settings.init >>= State_runtime.init + >>= State_project.init >>= State_file.init >>= State_simulation.init >>= sync - -let rec loop - (h : unit -> unit Lwt.t) - (t : float) - () - : unit Lwt.t = +let rec loop (h : unit -> unit Lwt.t) (t : float) () : unit Lwt.t = h () >>= (fun _ -> Js_of_ocaml_lwt.Lwt_js.sleep t) >>= loop h t let loop_sync () : unit Lwt.t = - if React.S.value State_settings.synch then + if React.S.value State_settings.synch then ( let () = Common.debug (Js.string "loop sync") in sync () - else Lwt.return_unit + ) else + Lwt.return_unit let onload () : unit = - Common.async - __LOC__ (fun () -> Lwt.return_unit >>= init >>= loop loop_sync 20.0) + Common.async __LOC__ (fun () -> + Lwt.return_unit >>= init >>= loop loop_sync 20.0) diff --git a/gui/subpanel_editor.ml b/gui/subpanel_editor.ml index d8de904f43..ad34dddb67 100644 --- a/gui/subpanel_editor.ml +++ b/gui/subpanel_editor.ml @@ -9,8 +9,8 @@ open Codemirror module Html = Tyxml_js.Html5 -let editor_full , set_editor_full = React.S.create (false : bool) -let filename , set_filename = React.S.create (None : string option) +let editor_full, set_editor_full = React.S.create (false : bool) +let filename, set_filename = React.S.create (None : string option) let move_cursor, set_move_cursor = React.E.create () let file_label = @@ -18,123 +18,130 @@ let file_label = (React.S.map (Option_util.unsome "") State_file.current_filename) let toggle_button_id = "toggle_button" + let toggle_button = Html.a - ~a:[ Html.a_id toggle_button_id - ; Html.Unsafe.string_attrib "role" "button" - ; Html.a_class ["btn";"btn-default";"pull-right"] - ] + ~a: + [ + Html.a_id toggle_button_id; + Html.Unsafe.string_attrib "role" "button"; + Html.a_class [ "btn"; "btn-default"; "pull-right" ]; + ] [ Html.cdata "toggle" ] let panel_heading_group_id = "panel_heading_group" + let panel_heading = - let menu_editor_file_content : - [> Html_types.div ] Tyxml_js.Html5.elt = - Html.div - ~a:[ Html.a_class [ "btn-group" ] ; - Html.Unsafe.string_attrib "role" "group" ; ] - Menu_editor_file.content + let menu_editor_file_content : [> Html_types.div ] Tyxml_js.Html5.elt = + Html.div + ~a: + [ + Html.a_class [ "btn-group" ]; Html.Unsafe.string_attrib "role" "group"; + ] + Menu_editor_file.content in - let buttons = - menu_editor_file_content :: - [toggle_button] in - [%html {|
    -
    |} buttons{|
    - + let buttons = menu_editor_file_content :: [ toggle_button ] in + [%html + {|
    +
    |} buttons + {|
    +
    |}] let codemirror_id = "code-mirror" let editor_panel_id = "editor-panel" let content () = - let textarea = - Html.textarea - ~a:[Html.a_id codemirror_id] - (Html.txt "") - in + let textarea = Html.textarea ~a:[ Html.a_id codemirror_id ] (Html.txt "") in Html.div - ~a:[Html.a_class ["flex-content";"panel";"panel-default"]] - [ Html.div - ~a:[Html.a_class ["panel-heading"]] - [ panel_heading ] ; + ~a:[ Html.a_class [ "flex-content"; "panel"; "panel-default" ] ] + [ + Html.div ~a:[ Html.a_class [ "panel-heading" ] ] [ panel_heading ]; Html.div - ~a:[ Tyxml_js.R.Html.a_class - (React.S.map - (fun model -> - match model.State_file.current with - | None -> ["no-panel-body" ; "flex-content" ] - | Some _ -> ["panel-body" ; "flex-content" ]) - State_file.model) ; - Html.a_id editor_panel_id - ] - [ textarea ] ; + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.map + (fun model -> + match model.State_file.current with + | None -> [ "no-panel-body"; "flex-content" ] + | Some _ -> [ "panel-body"; "flex-content" ]) + State_file.model); + Html.a_id editor_panel_id; + ] + [ textarea ]; ] let error_lint errors : Codemirror.lint Js.t Js.js_array Js.t = - let position p = - new%js Codemirror.position (p.Locality.line-1) (p.Locality.chr) in - let hydrate (error : Api_types_j.message) : lint Js.t option = + let position p = new%js Codemirror.position (p.Loc.line - 1) p.Loc.chr in + let hydrate (error : Api_types_j.message) : lint Js.t option = match error.Result_util.range with | None -> None | Some range -> - match React.S.value State_file.current_filename with + (match React.S.value State_file.current_filename with | None -> None | Some file_id -> - if range.Locality.file = file_id then - Some (Codemirror.create_lint - ~message:error.Result_util.text - (* This is a bit of a hack ... i am trying to keep - the code mirror code independent of the api code. - *) - ~severity:( match error.Result_util.severity with - | Logs.App -> Codemirror.Error - | Logs.Error -> Codemirror.Error - | Logs.Warning -> Codemirror.Warning - | Logs.Info -> Codemirror.Warning - | Logs.Debug -> Codemirror.Warning - ) - ~from:(position range.Locality.from_position) - ~to_:(position range.Locality.to_position)) + if range.Loc.file = file_id then + Some + (Codemirror.create_lint + ~message:error.Result_util.text + (* This is a bit of a hack ... i am trying to keep + the code mirror code independent of the api code. + *) + ~severity: + (match error.Result_util.severity with + | Logs.App -> Codemirror.Error + | Logs.Error -> Codemirror.Error + | Logs.Warning -> Codemirror.Warning + | Logs.Info -> Codemirror.Warning + | Logs.Debug -> Codemirror.Warning) + ~from:(position range.Loc.from_position) + ~to_:(position range.Loc.to_position)) else - None + None) in Js.array (Array.of_list (List.fold_left (fun acc value -> - match hydrate value with - | None -> acc - | Some value -> value::acc) - [] - errors)) - + match hydrate value with + | None -> acc + | Some value -> value :: acc) + [] errors)) -let setup_lint _ _ _ = - error_lint (React.S.value State_error.errors) +let setup_lint _ _ _ = error_lint (React.S.value State_error.errors) (* http://stackoverflow.com/questions/10575343/codemirror-is-it-possible-to-scroll-to-a-line-so-that-it-is-in-the-middle-of-w *) let jump_to_line (codemirror : codemirror Js.t) (line : int) : unit = let position : position Js.t = new%js Codemirror.position line 0 in let mode : Js.js_string Js.t Js.opt = Js.some (Js.string "local") in - let coords : Codemirror.dimension Js.t = codemirror##charCoords position mode in + let coords : Codemirror.dimension Js.t = + codemirror##charCoords position mode + in let top : int = coords##.top in let element : Dom_html.element Js.t = codemirror##getScrollerElement in - let middleHeight : int = element##.offsetHeight/2 in + let middleHeight : int = element##.offsetHeight / 2 in let scrollLine : int = top - middleHeight - 5 in let () = codemirror##scrollTo Js.null (Js.some scrollLine) in () +let dont_gc_me_events = ref [] +let dont_gc_me_signals = ref [] + let onload () : unit = let () = Menu_editor_file.onload () in - let lint_config = - Codemirror.create_lint_configuration () in + let lint_config = Codemirror.create_lint_configuration () in let () = lint_config##.getAnnotations := setup_lint in let () = lint_config##.lintOnChange := Js._false in let configuration = Codemirror.default_configuration in let gutter_options = - Js.string "breakpoints,CodeMirror-lint-markers,CodeMirror-linenumbers" in + Js.string "breakpoints,CodeMirror-lint-markers,CodeMirror-linenumbers" + in let gutter_option : Js.string_array Js.t = - gutter_options##split(Js.string ",") + gutter_options##split (Js.string ",") in let textarea : Dom_html.element Js.t = Ui_common.id_dom "code-mirror" in let () = @@ -145,45 +152,37 @@ let onload () : unit = configuration##.autofocus := Js._true; configuration##.gutters := gutter_option; configuration##.lint := lint_config; - configuration##.mode := (Js.string "Kappa") + configuration##.mode := Js.string "Kappa" in let codemirror : codemirror Js.t = - Codemirror.fromTextArea textarea configuration in - let () = codemirror##setValue(Js.string "") in - let _ = React.S.map (fun _ -> codemirror##performLint) State_error.errors in - let _ = Subpanel_editor_controller.with_file + Codemirror.fromTextArea textarea configuration + in + let () = codemirror##setValue (Js.string "") in + let _ = + Subpanel_editor_controller.with_file (Result_util.fold - ~ok:(fun (content,id) -> - let () = set_filename (Some id) in - let () = codemirror##setValue(Js.string content) in - Lwt.return (Result_util.ok ())) + ~ok:(fun (content, id) -> + let () = set_filename (Some id) in + let () = codemirror##setValue (Js.string content) in + Lwt.return (Result_util.ok ())) ~error:(fun _ -> - (* ignore if missing file *) - Lwt.return (Result_util.ok ()))) + (* ignore if missing file *) + Lwt.return (Result_util.ok ()))) + in + let () = + Codemirror.commands##.save := + fun _ -> Menu_editor_file_controller.export_current_file () in - let _ = React.E.map - (fun pos -> - if Some pos.Locality.file = React.S.value filename then - let beg = pos.Locality.from_position in - let first = - new%js Codemirror.position (beg.Locality.line-1) beg.Locality.chr in - let en = pos.Locality.from_position in - let last = - new%js Codemirror.position (en.Locality.line-1) en.Locality.chr in - codemirror##setSelection first last) move_cursor in - let () = Codemirror.commands##.save := - (fun _ -> Menu_editor_file_controller.export_current_file ()) in let timeout : Dom_html.timeout_id option ref = ref None in - let handler = fun codemirror change -> + let handler codemirror change = let () = State_file.out_of_sync true in - let () = match !timeout with - None -> () - | Some timeout -> - Dom_html.window ## clearTimeout (timeout) in + let () = + match !timeout with + | None -> () + | Some timeout -> Dom_html.window##clearTimeout timeout + in let delay : float = - if (((Js.str_array (change##.text ))##.length) > 1) - || - (State_error.has_errors ()) + if (Js.str_array change##.text)##.length > 1 || State_error.has_errors () then 1.0 *. 1000.0 else @@ -194,54 +193,83 @@ let onload () : unit = match React.S.value filename with | None -> () | Some filename -> - Subpanel_editor_controller.set_content - ~filename - ~filecontent:(Js.to_string codemirror##getValue) + Subpanel_editor_controller.set_content ~filename + ~filecontent:(Js.to_string codemirror##getValue) + in + let () = + timeout := + Some + (Dom_html.window##setTimeout + (Js.wrap_callback (fun _ -> handle_timeout ())) + delay) in - let () = timeout := Some - (Dom_html.window ## setTimeout - (Js.wrap_callback - (fun _ -> handle_timeout ())) delay) in () in - let () = codemirror##onChange(handler) in - let () = codemirror##onCursorActivity - (fun _codemirror -> - let pos = codemirror##getCursor in - let line = pos##.line in - let ch = pos##.ch in - State_file.cursor_activity ~line ~ch) in + let () = codemirror##onChange handler in + let () = + codemirror##onCursorActivity (fun _codemirror -> + let pos = codemirror##getCursor in + let line = pos##.line in + let ch = pos##.ch in + State_file.cursor_activity ~line ~ch) + in let toggle_button_dom : Dom_html.linkElement Js.t = Js.Unsafe.coerce - (Js.Opt.get (Ui_common.document##getElementById (Js.string toggle_button_id)) - (fun () -> assert false)) in + (Js.Opt.get + (Ui_common.document##getElementById (Js.string toggle_button_id)) + (fun () -> assert false)) + in let () = - toggle_button_dom##.onclick := - Dom.handler - (fun _ -> + toggle_button_dom##.onclick + := Dom.handler (fun _ -> let editor_full = React.S.value editor_full in let () = set_editor_full (not editor_full) in - Js._true) in - let _ = - React.S.map - (fun model -> - match model.State_file.current with - | None -> Common.hide_codemirror () - | Some _ -> Common.show_codemirror ()) - State_file.model + Js._true) in - let _ = - React.E.map - (fun refresh -> - let () = set_filename (Some refresh.State_file.filename) in - let cand = Js.string refresh.State_file.content in - if cand <> codemirror##getValue then - let () = codemirror##setValue cand in - let () = match refresh.State_file.line with - | None -> () - | Some line -> jump_to_line codemirror line in - ()) - State_file.refresh_file + let () = + dont_gc_me_signals := + [ + React.S.map (fun _ -> codemirror##performLint) State_error.errors; + React.S.map + (fun model -> + match model.State_file.current with + | None -> Common.hide_codemirror () + | Some _ -> Common.show_codemirror ()) + State_file.model; + ] + in + let () = + dont_gc_me_events := + [ + React.E.map + (fun pos -> + if Some pos.Loc.file = React.S.value filename then ( + let beg = pos.Loc.from_position in + let first = + new%js Codemirror.position (beg.Loc.line - 1) beg.Loc.chr + in + let en = pos.Loc.from_position in + let last = + new%js Codemirror.position (en.Loc.line - 1) en.Loc.chr + in + codemirror##setSelection first last + )) + move_cursor; + React.E.map + (fun refresh -> + let () = set_filename (Some refresh.State_file.filename) in + let cand = Js.string refresh.State_file.content in + if cand <> codemirror##getValue then ( + let () = codemirror##setValue cand in + let () = + match refresh.State_file.line with + | None -> () + | Some line -> jump_to_line codemirror line + in + () + )) + State_file.refresh_file; + ] in () diff --git a/gui/subpanel_editor.mli b/gui/subpanel_editor.mli index 8b5ca2b280..a3f5ee8733 100644 --- a/gui/subpanel_editor.mli +++ b/gui/subpanel_editor.mli @@ -7,6 +7,6 @@ (******************************************************************************) val editor_full : bool React.signal -val set_move_cursor : ?step:React.step -> Locality.t -> unit +val set_move_cursor : ?step:React.step -> Loc.t -> unit include Ui_common.Panel diff --git a/gui/subpanel_editor_controller.ml b/gui/subpanel_editor_controller.ml index e35cbb3670..77ad08ef64 100644 --- a/gui/subpanel_editor_controller.ml +++ b/gui/subpanel_editor_controller.ml @@ -8,28 +8,22 @@ open Lwt.Infix -let with_file (handler : (string * string) Api.result -> unit Api.result Lwt.t) = - Common.async - __LOC__ - (fun () -> - State_error.wrap - __LOC__ - ((State_file.get_file ()) >>= - handler) - >>= (fun _ -> Lwt.return_unit) - ) +let with_file (handler : (string * string) Api.result -> unit Api.result Lwt.t) + = + Common.async __LOC__ (fun () -> + State_error.wrap __LOC__ (State_file.get_file () >>= handler) >>= fun _ -> + Lwt.return_unit) let set_content ~(filename : string) ~(filecontent : string) : unit = with_file - (Api_common.result_bind_lwt - ~ok:(fun (_, current_filename) -> - if filename = current_filename then - (State_file.set_content filecontent >>= - (fun r -> State_project.sync () >>= - fun r' -> Lwt.return (Api_common.result_combine [r; r']))) - else - let msg = Format.sprintf - "file name mismatch %s %s" filename current_filename in - Lwt.return (Api_common.result_error_msg msg) - ) - ) + (Api_common.result_bind_lwt ~ok:(fun (_, current_filename) -> + if filename = current_filename then + State_file.set_content filecontent >>= fun r -> + State_project.sync () >>= fun r' -> + Lwt.return (Api_common.result_combine [ r; r' ]) + else ( + let msg = + Format.sprintf "file name mismatch %s %s" filename current_filename + in + Lwt.return (Api_common.result_error_msg msg) + ))) diff --git a/gui/tab_about.ml b/gui/tab_about.ml index f3e4a94f28..c4c9a6b386 100644 --- a/gui/tab_about.ml +++ b/gui/tab_about.ml @@ -10,7 +10,9 @@ module Html = Tyxml_js.Html5 let navli () = ReactiveData.RList.empty -let content () = [%html {| +let content () = + [%html + {|

    The Kappa Language

    Copyright 2010-2020 CNRS - Harvard Medical School - INRIA - IRIF

    Kappa Language software is distributed under the terms of the GNU Lesser General Public License Version 3. @@ -36,5 +38,4 @@ let content () = [%html {| |}] let onload () = () - let onresize () = () diff --git a/gui/tab_constraints.ml b/gui/tab_constraints.ml index 934135a3ba..628340d560 100644 --- a/gui/tab_constraints.ml +++ b/gui/tab_constraints.ml @@ -10,7 +10,6 @@ module Html = Tyxml_js.Html5 open Lwt.Infix let navli () = ReactiveData.RList.empty - let tab_is_active, set_tab_is_active = React.S.create false let tab_was_active = ref false @@ -23,88 +22,114 @@ let tab_was_active = ref false let content () = let constraints_div = - State_project.on_project_change_async ~on:tab_is_active - () (React.S.const ()) [] - (fun (manager : Api.concrete_manager) () -> - (manager#get_constraints_list >|= - Result_util.fold - ~ok:(fun constraints -> + State_project.on_project_change_async ~on:tab_is_active () + (React.S.const ()) [] (fun (manager : Api.concrete_manager) () -> + manager#get_constraints_list + >|= Result_util.fold + ~ok:(fun constraints -> List.fold_left - (fun panels (a,b) -> - (*match b with - | [] -> panels - | _ :: _ ->*) - let texts = - List.fold_left - (fun list lemma -> - let hyp = Public_data.get_hyp lemma in - let conclusion = Public_data.get_refinement lemma in - let list = - match conclusion with - | [site_graph] -> - Utility.print_site_graph site_graph - (Utility.print_newline list) - | _::_ | [] -> - let list = Utility.print_newline list in - let list = Utility.print_string " ]" list in - let list = - (snd - (List.fold_left - (fun (bool,list) a -> - let list = - if bool then - (Utility.print_string " v " list) - else - list - in - let list = - Utility.print_site_graph a list - in - true,list) - (false,list) - (List.rev conclusion) - )) in - let list = - Utility.print_string "[ " list in - list in - let list = Utility.print_string " => " list in - let list = Utility.print_site_graph hyp list in - list) - [] - (List.rev b) in - let title = Html.div - ~a:[Html.a_class [ "panel-heading" ]] [Html.txt a] in - let content = Html.div - ~a:[Html.a_class [ "panel-body"; "panel-pre" ]] texts in - Html.div - ~a:[Html.a_class [ "panel"; "panel-default" ]] [title;content] :: - panels) + (fun panels (a, b) -> + (*match b with + | [] -> panels + | _ :: _ ->*) + let texts = + List.fold_left + (fun list lemma -> + let hyp = Public_data.get_hyp lemma in + let conclusion = Public_data.get_refinement lemma in + let list = + match conclusion with + | [ site_graph ] -> + Utility.print_site_graph site_graph + (Utility.print_newline list) + | _ :: _ | [] -> + let list = Utility.print_newline list in + let list = Utility.print_string " ]" list in + let list = + snd + (List.fold_left + (fun (bool, list) a -> + let list = + if bool then + Utility.print_string " v " list + else + list + in + let list = + Utility.print_site_graph a list + in + true, list) + (false, list) (List.rev conclusion)) + in + let list = Utility.print_string "[ " list in + list + in + let list = Utility.print_string " => " list in + let list = Utility.print_site_graph hyp list in + list) + [] (List.rev b) + in + let title = + Html.div + ~a:[ Html.a_class [ "panel-heading" ] ] + [ Html.txt a ] + in + let content = + Html.div + ~a:[ Html.a_class [ "panel-body"; "panel-pre" ] ] + texts + in + Html.div + ~a:[ Html.a_class [ "panel"; "panel-default" ] ] + [ title; content ] + :: panels) [] constraints) - ~error:(fun r -> - let title = Html.div - ~a:[Html.a_class [ "panel-heading" ]] [Html.txt "KaSa has failed"] in - let content = Html.div - ~a:[Html.a_class [ "panel-body"; "panel-pre" ]] - (List.map - (fun m -> Html.p [Html.txt (Format.asprintf "@[%a@]" Result_util.print_message m)]) - r) in - let out = Html.div - ~a:[Html.a_class [ "panel"; "panel-danger" ]] [title;content] in - [out]))) in - [ Tyxml_js.R.Html5.div - ~a:[Html.a_class ["panel-scroll"]] - (ReactiveData.RList.from_signal constraints_div) + ~error:(fun r -> + let title = + Html.div + ~a:[ Html.a_class [ "panel-heading" ] ] + [ Html.txt "KaSa has failed" ] + in + let content = + Html.div + ~a:[ Html.a_class [ "panel-body"; "panel-pre" ] ] + (List.map + (fun m -> + Html.p + [ + Html.txt + (Format.asprintf "@[%a@]" + Result_util.print_message m); + ]) + r) + in + let out = + Html.div + ~a:[ Html.a_class [ "panel"; "panel-danger" ] ] + [ title; content ] + in + [ out ])) + in + [ + Tyxml_js.R.Html5.div + ~a:[ Html.a_class [ "panel-scroll" ] ] + (ReactiveData.RList.from_signal constraints_div); ] let parent_hide () = set_tab_is_active false let parent_shown () = set_tab_is_active !tab_was_active let onload () = - let () = Common.jquery_on - "#navconstraints" "hide.bs.tab" - (fun _ -> let () = tab_was_active := false in set_tab_is_active false) in - let () = Common.jquery_on - "#navconstraints" "shown.bs.tab" - (fun _ -> let () = tab_was_active := true in set_tab_is_active true) in + let () = + Common.jquery_on "#navconstraints" "hide.bs.tab" (fun _ -> + let () = tab_was_active := false in + set_tab_is_active false) + in + let () = + Common.jquery_on "#navconstraints" "shown.bs.tab" (fun _ -> + let () = tab_was_active := true in + set_tab_is_active true) + in () + let onresize () : unit = () diff --git a/gui/tab_contact_map.ml b/gui/tab_contact_map.ml index 816e4623b0..a3b3bb99af 100644 --- a/gui/tab_contact_map.ml +++ b/gui/tab_contact_map.ml @@ -11,46 +11,43 @@ module Html = Tyxml_js.Html5 let display_id = "contact-map-display" let export_id = "contact-export" - let navli () = ReactiveData.RList.empty - let tab_is_active, set_tab_is_active = React.S.create true let tab_was_active = ref true - let accuracy, set_accuracy = React.S.create (Some Public_data.Low) let extract_contact_map = function - | `Assoc [ "contact map", `Assoc [ "accuracy", acc; "map", contact ] ] -> - acc,contact - | `Assoc [ "contact map", `Assoc [ "map", contact; "accuracy", acc ] ] -> - acc,contact + | `Assoc [ ("contact map", `Assoc [ ("accuracy", acc); ("map", contact) ]) ] + -> + acc, contact + | `Assoc [ ("contact map", `Assoc [ ("map", contact); ("accuracy", acc) ]) ] + -> + acc, contact | _ -> failwith "Wrong ugly contact_map extractor" let contact_map_text = - State_project.on_project_change_async - ~on:tab_is_active None accuracy - (Result_util.error []) - (fun (manager : Api.concrete_manager) acc -> - manager#get_contact_map acc >|= - Result_util.map - (fun contact_json -> - let _,map_json = extract_contact_map contact_json in - Yojson.Basic.to_string map_json) - ) + State_project.on_project_change_async ~on:tab_is_active None accuracy + (Result_util.error []) (fun (manager : Api.concrete_manager) acc -> + manager#get_contact_map acc + >|= Result_util.map (fun contact_json -> + let _, map_json = extract_contact_map contact_json in + Yojson.Basic.to_string map_json)) -let configuration : Widget_export.configuration = { - Widget_export.id = export_id ; - Widget_export.handlers = - [ Widget_export.export_svg ~svg_div_id:display_id (); - Widget_export.export_png ~svg_div_id:display_id (); - Widget_export.export_json - ~serialize_json:(fun () -> - Result_util.fold (React.S.value contact_map_text) +let configuration : Widget_export.configuration = + { + Widget_export.id = export_id; + Widget_export.handlers = + [ + Widget_export.export_svg ~svg_div_id:display_id (); + Widget_export.export_png ~svg_div_id:display_id (); + Widget_export.export_json ~serialize_json:(fun () -> + Result_util.fold + (React.S.value contact_map_text) ~ok:(fun x -> x) - ~error:(fun _ -> "null")) - ]; - Widget_export.show = React.S.const true; -} + ~error:(fun _ -> "null")); + ]; + Widget_export.show = React.S.const true; + } let accuracy_chooser_id = "contact_map-accuracy" @@ -58,26 +55,48 @@ let accuracy_chooser = let option_gen x = Html.option ~a: - ((fun l -> if React.S.value accuracy = Some x - then Html.a_selected () :: l else l) + ((fun l -> + if React.S.value accuracy = Some x then + Html.a_selected () :: l + else + l) [ Html.a_value (Public_data.accuracy_to_string x) ]) - (Html.txt (Public_data.accuracy_to_string x)) in + (Html.txt (Public_data.accuracy_to_string x)) + in Html.select - ~a:[Html.a_class [ "form-control" ]; Html.a_id accuracy_chooser_id ] + ~a:[ Html.a_class [ "form-control" ]; Html.a_id accuracy_chooser_id ] (List.map option_gen Public_data.contact_map_accuracy_levels) let content () = let accuracy_form = - Html.form ~a:[ Html.a_class [ "form-horizontal" ]; - Html.a_id "contact_map_accuracy_form" ] - [ Html.div ~a:[ Html.a_class [ "form-group" ] ] - [ Html.label ~a:[ Html.a_class ["col-md-2"]; Html.a_label_for accuracy_chooser_id ] - [Html.txt "Accuracy"]; - Html.div ~a:[Html.a_class ["col-md-10"] ] [accuracy_chooser] ] - ] in - [ accuracy_form; - Html.div ~a:[ Html.a_id display_id; Html.a_class [ "flex-content" ] ] [ Html.entity "nbsp" ]; - Widget_export.content configuration ] + Html.form + ~a: + [ + Html.a_class [ "form-horizontal" ]; + Html.a_id "contact_map_accuracy_form"; + ] + [ + Html.div + ~a:[ Html.a_class [ "form-group" ] ] + [ + Html.label + ~a: + [ + Html.a_class [ "col-md-2" ]; + Html.a_label_for accuracy_chooser_id; + ] + [ Html.txt "Accuracy" ]; + Html.div ~a:[ Html.a_class [ "col-md-10" ] ] [ accuracy_chooser ]; + ]; + ] + in + [ + accuracy_form; + Html.div + ~a:[ Html.a_id display_id; Html.a_class [ "flex-content" ] ] + [ Html.entity "nbsp" ]; + Widget_export.content configuration; + ] let parent_hide () = set_tab_is_active false let parent_shown () = set_tab_is_active !tab_was_active @@ -85,29 +104,39 @@ let parent_shown () = set_tab_is_active !tab_was_active let contactmap : Js_contact.contact_map Js.t = Js_contact.create_contact_map display_id State_settings.agent_coloring +let dont_gc_me = ref [] + let onload () = let () = Widget_export.onload configuration in - let _ = - React.S.map - (Result_util.fold - ~error:(fun mh -> - let () = State_error.add_error - "tab_contact_map" mh in - contactmap##clearData) - ~ok:(fun data -> contactmap##setData (Js.string data))) - contact_map_text in - let () = (Tyxml_js.To_dom.of_select accuracy_chooser)##.onchange := - Dom_html.full_handler - (fun va _ -> + let () = + dont_gc_me := + [ + React.S.map + (Result_util.fold + ~error:(fun mh -> + let () = State_error.add_error "tab_contact_map" mh in + contactmap##clearData) + ~ok:(fun data -> contactmap##setData (Js.string data))) + contact_map_text; + ] + in + let () = + (Tyxml_js.To_dom.of_select accuracy_chooser)##.onchange + := Dom_html.full_handler (fun va _ -> let va = Js.to_string va##.value in let () = set_accuracy (Public_data.accuracy_of_string va) in - Js._true) in - let () = Common.jquery_on - "#navcontact_map" "hide.bs.tab" - (fun _ -> let () = tab_was_active := false in set_tab_is_active false) in - let () = Common.jquery_on - "#navcontact_map" "shown.bs.tab" - (fun _ -> let () = tab_was_active := true in set_tab_is_active true) in + Js._true) + in + let () = + Common.jquery_on "#navcontact_map" "hide.bs.tab" (fun _ -> + let () = tab_was_active := false in + set_tab_is_active false) + in + let () = + Common.jquery_on "#navcontact_map" "shown.bs.tab" (fun _ -> + let () = tab_was_active := true in + set_tab_is_active true) + in () -let onresize () : unit = - if React.S.value tab_is_active then contactmap##redraw + +let onresize () : unit = if React.S.value tab_is_active then contactmap##redraw diff --git a/gui/tab_contact_map.mli b/gui/tab_contact_map.mli index c8542b9cdb..5615e50639 100644 --- a/gui/tab_contact_map.mli +++ b/gui/tab_contact_map.mli @@ -7,4 +7,5 @@ (******************************************************************************) include Ui_common.SubTab + val contact_map_text : string Api.result React.S.t diff --git a/gui/tab_editor.ml b/gui/tab_editor.ml index b484cde987..bf412fc6ba 100644 --- a/gui/tab_editor.ml +++ b/gui/tab_editor.ml @@ -11,195 +11,216 @@ open Lwt.Infix let navli () = ReactiveData.RList.empty let rightsubpanel_id : string = "rightsubpanel" + let rightsubpanel () = Html.div - ~a:[ Tyxml_js.R.Html.a_class - (React.S.bind - Subpanel_editor.editor_full - (fun editor_full -> + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.bind Subpanel_editor.editor_full (fun editor_full -> + React.S.const + (if editor_full then + [ "hidden" ] + else + [ "col-md-6"; "hidden-xs"; "hidden-sm"; "flex-content" ]))); + ] + [ + Ui_common.navtabs "subnavtab" + [ + "contact_map", None, Tab_contact_map.navli (); + "influences", None, Tab_influences.navli (); + "constraints", None, Tab_constraints.navli (); + "polymers", None, Tab_polymers.navli (); + ]; + Ui_common.navcontent ~id:rightsubpanel_id [] + [ + "contact_map", [], Tab_contact_map.content (); + "influences", [], Tab_influences.content (); + "constraints", [], Tab_constraints.content (); + "polymers", [], Tab_polymers.content (); + ]; + ] + +let content () = + [ + Html.div + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.bind Subpanel_editor.editor_full (fun editor_full -> React.S.const (if editor_full then - ["hidden"] + [ "col-md-12"; "flex-content" ] else - ["col-md-6"; "hidden-xs"; "hidden-sm"; "flex-content"]) - ) - ) - ] - [Ui_common.navtabs "subnavtab" - [ "contact_map", None, (Tab_contact_map.navli ()) - ; "influences", None, (Tab_influences.navli ()) - ; "constraints", None, (Tab_constraints.navli ()) - ; "polymers", None, (Tab_polymers.navli ()) - ]; - Ui_common.navcontent - ~id:rightsubpanel_id - [] - [ "contact_map", [], (Tab_contact_map.content ()) - ; "influences", [], (Tab_influences.content ()) - ; "constraints", [], (Tab_constraints.content ()) - ; "polymers", [], (Tab_polymers.content ()) - ]] - -let content () = - [Html.div - ~a:[ - Tyxml_js.R.Html.a_class - (React.S.bind - Subpanel_editor.editor_full - (fun editor_full -> - React.S.const - (if editor_full then ["col-md-12";"flex-content"] - else ["col-md-6";"flex-content"]) - ) - ) - ] - [Subpanel_editor.content ()]; - (rightsubpanel ()) ] + [ "col-md-6"; "flex-content" ]))); + ] + [ Subpanel_editor.content () ]; + rightsubpanel (); + ] let childs_hide b = - if b then + if b then ( let () = Tab_contact_map.parent_hide () in let () = Tab_influences.parent_hide () in let () = Tab_constraints.parent_hide () in Tab_polymers.parent_hide () - else + ) else ( let () = Tab_contact_map.parent_shown () in let () = Tab_influences.parent_shown () in let () = Tab_constraints.parent_shown () in Tab_polymers.parent_shown () + ) let init_dead_rules () = React.S.l1 (fun model -> - State_error.wrap ~append:true "tab_editor_dead_rule" - (State_project.with_project - ~label:__LOC__ - (fun (manager : Api.concrete_manager) -> - if model.State_project.model_parameters. - State_project.show_dead_rules then - manager#get_dead_rules >|= - Result_util.fold - ~ok:(fun list -> + State_error.wrap ~append:true "tab_editor_dead_rule" + (State_project.with_project ~label:__LOC__ + (fun (manager : Api.concrete_manager) -> + if + model.State_project.model_parameters + .State_project.show_dead_rules + then + manager#get_dead_rules + >|= Result_util.fold + ~ok:(fun list -> let warnings = List.fold_left (fun acc rule -> - if rule.Public_data.rule_hidden - then acc - else - let text = - "Dead rule "^ - if rule.Public_data.rule_label <> "" - then (" '"^rule.Public_data.rule_label^"'") - else if rule.Public_data.rule_ast <> "" - then rule.Public_data.rule_ast - else string_of_int rule.Public_data.rule_id in - { - Result_util.severity = Logs.Warning; - Result_util.range = - Some rule.Public_data.rule_position; - Result_util.text; - } :: acc) [] list in + if rule.Public_data.rule_hidden then + acc + else ( + let text = + "Dead rule " + ^ + if rule.Public_data.rule_label <> "" then + " '" ^ rule.Public_data.rule_label ^ "'" + else if rule.Public_data.rule_ast <> "" then + rule.Public_data.rule_ast + else + string_of_int rule.Public_data.rule_id + in + { + Result_util.severity = Logs.Warning; + Result_util.range = + Some rule.Public_data.rule_position; + Result_util.text; + } + :: acc + )) + [] list + in List.rev warnings) - ~error:(fun mh -> mh) >|= - Api_common.result_messages ?result_code:None - else - Lwt.return (Result_util.ok ())) - )) + ~error:(fun mh -> mh) + >|= Api_common.result_messages ?result_code:None + else + Lwt.return (Result_util.ok ())))) State_project.model let init_dead_agents () = React.S.l1 (fun model -> - State_error.wrap ~append:true "tab_editor_dead_agent" - (State_project.with_project - ~label:__LOC__ - (fun (manager : Api.concrete_manager) -> - if model.State_project.model_parameters. - State_project.show_dead_agents then - manager#get_dead_agents >|= - Result_util.fold - ~ok:(fun list -> + State_error.wrap ~append:true "tab_editor_dead_agent" + (State_project.with_project ~label:__LOC__ + (fun (manager : Api.concrete_manager) -> + if + model.State_project.model_parameters + .State_project.show_dead_agents + then + manager#get_dead_agents + >|= Result_util.fold + ~ok:(fun list -> let warnings = List.fold_left (fun acc agent -> - let text = - "Dead agent "^ - if agent.Public_data.agent_ast <> "" - then agent.Public_data.agent_ast - else string_of_int agent.Public_data.agent_id in - List.fold_left - (fun acc range -> - { - Result_util.severity = Logs.Warning; - Result_util.range = Some range; - Result_util.text; - } :: acc) - acc agent.Public_data.agent_position) - [] list in + let text = + "Dead agent " + ^ + if agent.Public_data.agent_ast <> "" then + agent.Public_data.agent_ast + else + string_of_int agent.Public_data.agent_id + in + List.fold_left + (fun acc range -> + { + Result_util.severity = Logs.Warning; + Result_util.range = Some range; + Result_util.text; + } + :: acc) + acc agent.Public_data.agent_position) + [] list + in List.rev warnings) - ~error:(fun mh -> mh) >|= - Api_common.result_messages ?result_code:None - else - Lwt.return (Result_util.ok ())) - )) + ~error:(fun mh -> mh) + >|= Api_common.result_messages ?result_code:None + else + Lwt.return (Result_util.ok ())))) State_project.model let init_non_weakly_reversible_transitions () = React.S.l1 (fun model -> - State_error.wrap ~append:true "tab_editor_dead_rule" - (State_project.with_project - ~label:__LOC__ - (fun (manager : Api.concrete_manager) -> - if model.State_project.model_parameters. - State_project.show_non_weakly_reversible_transitions then - manager#get_non_weakly_reversible_transitions >|= - Result_util.fold - ~ok:(fun list -> - let warnings = - List.fold_left - (fun acc (rule,context_list) -> - if rule.Public_data.rule_hidden - then acc (* hint: reversible rule are always weakly reversible *) - else - let plural,skip,tab = - match context_list with - | [] | [_] -> "",""," " - | _::_ -> "s","\n","\t" - in - let text = - Format.asprintf - "Rule %s may induce non weakly reversible events in the following context%s:%s%a" - (if rule.Public_data.rule_label <> "" - then (" '"^rule.Public_data.rule_label^"'") - else if rule.Public_data.rule_ast <> "" - then rule.Public_data.rule_ast - else string_of_int rule.Public_data.rule_id) - plural - skip - ( Pp.list - (fun fmt -> Format.fprintf fmt "%s" skip) - (fun fmt (a,b) -> - Format.fprintf fmt "%s%s -> %s " tab a b) - ) - context_list - in - (* to do, add the potential contexts *) - { - Result_util.severity = Logs.Warning; - Result_util.range = - Some rule.Public_data.rule_position; - Result_util.text; - } :: acc) [] list in - List.rev warnings) - ~error:(fun mh -> mh) >|= - Api_common.result_messages ?result_code:None - else - Lwt.return (Result_util.ok ())) - ) - ) + State_error.wrap ~append:true "tab_editor_dead_rule" + (State_project.with_project ~label:__LOC__ + (fun (manager : Api.concrete_manager) -> + if + model.State_project.model_parameters + .State_project.show_non_weakly_reversible_transitions + then + manager#get_non_weakly_reversible_transitions + >|= Result_util.fold + ~ok:(fun list -> + let warnings = + List.fold_left + (fun acc (rule, context_list) -> + if rule.Public_data.rule_hidden then + acc + (* hint: reversible rule are always weakly reversible *) + else ( + let plural, skip, tab = + match context_list with + | [] | [ _ ] -> "", "", " " + | _ :: _ -> "s", "\n", "\t" + in + let text = + Format.asprintf + "Rule %s may induce non weakly reversible \ + events in the following context%s:%s%a" + (if rule.Public_data.rule_label <> "" then + " '" ^ rule.Public_data.rule_label ^ "'" + else if rule.Public_data.rule_ast <> "" then + rule.Public_data.rule_ast + else + string_of_int rule.Public_data.rule_id) + plural skip + (Pp.list + (fun fmt -> Format.fprintf fmt "%s" skip) + (fun fmt (a, b) -> + Format.fprintf fmt "%s%s -> %s " tab a b)) + context_list + in + (* to do, add the potential contexts *) + { + Result_util.severity = Logs.Warning; + Result_util.range = + Some rule.Public_data.rule_position; + Result_util.text; + } + :: acc + )) + [] list + in + List.rev warnings) + ~error:(fun mh -> mh) + >|= Api_common.result_messages ?result_code:None + else + Lwt.return (Result_util.ok ())))) State_project.model +let dont_gc_me = ref [] + let onload () = let () = Subpanel_editor.onload () in let _ = init_dead_rules () in @@ -209,11 +230,15 @@ let onload () = let () = Tab_influences.onload () in let () = Tab_constraints.onload () in let () = Tab_polymers.onload () in - let _ = React.S.map childs_hide Subpanel_editor.editor_full in - let () = Common.jquery_on - "#naveditor" "hide.bs.tab" (fun _ -> childs_hide true) in - let () = Common.jquery_on - "#naveditor" "shown.bs.tab" (fun _ -> childs_hide false) in + let () = + dont_gc_me := [ React.S.map childs_hide Subpanel_editor.editor_full ] + in + let () = + Common.jquery_on "#naveditor" "hide.bs.tab" (fun _ -> childs_hide true) + in + let () = + Common.jquery_on "#naveditor" "shown.bs.tab" (fun _ -> childs_hide false) + in () let onresize () : unit = diff --git a/gui/tab_flux.ml b/gui/tab_flux.ml index 05599c1714..d11c00b0aa 100644 --- a/gui/tab_flux.ml +++ b/gui/tab_flux.ml @@ -10,14 +10,13 @@ open Lwt.Infix module Html = Tyxml_js.Html5 let tab_is_active, set_tab_is_active = React.S.create false - let din_table, table_handle = ReactiveData.RList.create [] let din_header, set_din_header = React.S.create [] + let din = let thead = React.S.map (fun x -> Html.thead x) din_header in Tyxml_js.R.Html5.tablex - ~a:[Html.a_class - ["table"; "table-condensed";"table-bordered"]] + ~a:[ Html.a_class [ "table"; "table-condensed"; "table-bordered" ] ] ~thead din_table let fill_table din = @@ -25,140 +24,166 @@ let fill_table din = let all = din.din_data.din_kind = Primitives.PROBABILITY in let header = Html.tr - ((Html.th [Html.txt "affects"]) :: - Array.fold_right - (fun r acc -> Html.th [Html.txt r] :: acc) - din.din_rules []) in + (Html.th [ Html.txt "affects" ] + :: Array.fold_right + (fun r acc -> Html.th [ Html.txt r ] :: acc) + din.din_rules []) + in let body = Tools.array_fold_righti (fun i data acc -> - if all || din.din_data.din_hits.(i) > 0 then - Html.tr - (Html.th - [Html.txt (din.din_rules.(i)^" ("^ - string_of_int din.din_data.din_hits.(i)^ - " hits)")] :: - Array.fold_right - (fun v acc -> Html.td - ~a:[Html.a_class (if v > 0. then ["success"] - else if v < 0. then ["info"] - else [])] - [Html.txt (string_of_float v)] :: acc) - data []) - ::acc - else acc) din.din_data.din_fluxs [] in - let () = set_din_header [header] in - ReactiveData.RList.set table_handle [Html.tbody body] + if all || din.din_data.din_hits.(i) > 0 then + Html.tr + (Html.th + [ + Html.txt + (din.din_rules.(i) ^ " (" + ^ string_of_int din.din_data.din_hits.(i) + ^ " hits)"); + ] + :: Array.fold_right + (fun v acc -> + Html.td + ~a: + [ + Html.a_class + (if v > 0. then + [ "success" ] + else if v < 0. then + [ "info" ] + else + []); + ] + [ Html.txt (string_of_float v) ] + :: acc) + data []) + :: acc + else + acc) + din.din_data.din_fluxs [] + in + let () = set_din_header [ header ] in + ReactiveData.RList.set table_handle [ Html.tbody body ] -let update_din din_id: unit = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> manager#simulation_detail_din din_id >>= - (Result_util.fold - ~ok:(fun (din : Api_types_t.din) -> - let () = fill_table din in - Lwt.return (Result_util.ok ())) - ~error:(fun e -> - let () = ReactiveData.RList.set table_handle [] in - Lwt.return (Api_common.result_messages e )))) +let update_din din_id : unit = + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_detail_din din_id + >>= Result_util.fold + ~ok:(fun (din : Api_types_t.din) -> + let () = fill_table din in + Lwt.return (Result_util.ok ())) + ~error:(fun e -> + let () = ReactiveData.RList.set table_handle [] in + Lwt.return (Api_common.result_messages e))) let din_list, din_handle = ReactiveData.RList.create [] + let din_select = - Tyxml_js.R.Html5.select - ~a:[ Html.a_class ["form-control"] ] - din_list + Tyxml_js.R.Html5.select ~a:[ Html.a_class [ "form-control" ] ] din_list let select_din () = - let din_id = - Js.to_string ((Tyxml_js.To_dom.of_select din_select)##.value) in + let din_id = Js.to_string (Tyxml_js.To_dom.of_select din_select)##.value in update_din din_id -let _ = React.S.map +let dont_gc_me = + React.S.map (fun _ -> - State_simulation.with_simulation_info - ~label:__LOC__ - ~stopped:(fun _ -> - let () = ReactiveData.RList.set din_handle [] in - let () = ReactiveData.RList.set table_handle [] in - Lwt.return (Result_util.ok ())) - ~initializing:(fun _ -> - let () = ReactiveData.RList.set din_handle [] in - let () = ReactiveData.RList.set table_handle [] in - Lwt.return (Result_util.ok ())) - ~ready:(fun manager _ -> - manager#simulation_catalog_din >>= - (Api_common.result_bind_lwt - ~ok:(fun din_ids -> - let () = ReactiveData.RList.set - din_handle + State_simulation.with_simulation_info ~label:__LOC__ + ~stopped:(fun _ -> + let () = ReactiveData.RList.set din_handle [] in + let () = ReactiveData.RList.set table_handle [] in + Lwt.return (Result_util.ok ())) + ~initializing:(fun _ -> + let () = ReactiveData.RList.set din_handle [] in + let () = ReactiveData.RList.set table_handle [] in + Lwt.return (Result_util.ok ())) + ~ready:(fun manager _ -> + manager#simulation_catalog_din + >>= Api_common.result_bind_lwt ~ok:(fun din_ids -> + let () = + ReactiveData.RList.set din_handle (List.rev_map - (fun id -> Html.option - ~a:[ Html.a_value id ] - (Html.txt id)) - din_ids) in + (fun id -> + Html.option ~a:[ Html.a_value id ] (Html.txt id)) + din_ids) + in let () = select_din () in - Lwt.return (Result_util.ok ())) - ) - ) () - ) - (React.S.on - tab_is_active State_simulation.dummy_model State_simulation.model) + Lwt.return (Result_util.ok ()))) + ()) + (React.S.on tab_is_active State_simulation.dummy_model + State_simulation.model) let export_current_din to_string mime filename = - let din_id = - Js.to_string ((Tyxml_js.To_dom.of_select din_select)##.value) in - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> manager#simulation_detail_din din_id >>= - Api_common.result_bind_lwt - ~ok:(fun din -> let data = Js.string (to_string din) in + let din_id = Js.to_string (Tyxml_js.To_dom.of_select din_select)##.value in + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_detail_din din_id + >>= Api_common.result_bind_lwt ~ok:(fun din -> + let data = Js.string (to_string din) in let () = Common.saveFile ~data ~mime ~filename in - Lwt.return (Result_util.ok ()))) + Lwt.return (Result_util.ok ()))) -let export_configuration = { - Widget_export.id = "din-export"; - Widget_export.show = React.S.const true; - Widget_export.handlers = [ - { Widget_export.suffix = "json"; - Widget_export.label = "json"; - Widget_export.export = export_current_din - (Data.string_of_din ?len:None) - "application/json";}; - { Widget_export.suffix = "dot"; - Widget_export.label = "dot"; - Widget_export.export = export_current_din - (Format.asprintf "@[%a@]" (Data.print_dot_din ?uuid:None)) - "text/vnd.graphviz";}; - { Widget_export.suffix = "html"; - Widget_export.label = "html"; - Widget_export.export = export_current_din - (Format.asprintf "@[%a@]" (Data.print_html_din)) - "text/html";}; - ]; -} +let export_configuration = + { + Widget_export.id = "din-export"; + Widget_export.show = React.S.const true; + Widget_export.handlers = + [ + { + Widget_export.suffix = "json"; + Widget_export.label = "json"; + Widget_export.export = + export_current_din (Data.string_of_din ?len:None) "application/json"; + }; + { + Widget_export.suffix = "dot"; + Widget_export.label = "dot"; + Widget_export.export = + export_current_din + (Format.asprintf "@[%a@]" (Data.print_dot_din ?uuid:None)) + "text/vnd.graphviz"; + }; + { + Widget_export.suffix = "html"; + Widget_export.label = "html"; + Widget_export.export = + export_current_din + (Format.asprintf "@[%a@]" Data.print_html_din) + "text/html"; + }; + ]; + } -let content () = [ - Html.div ~a:[Html.a_class ["flex_content"; "table-responsive"]] - [Html.form [din_select]; din; - Widget_export.content export_configuration] -] +let content () = + [ + Html.div + ~a:[ Html.a_class [ "flex_content"; "table-responsive" ] ] + [ + Html.form [ din_select ]; + din; + Widget_export.content export_configuration; + ]; + ] let navli () = - Ui_common.badge - (fun state -> - match state with - | None -> 0 - | Some state -> - state.Api_types_j.simulation_info_output.Api_types_j.simulation_output_dins) + Ui_common.badge (fun state -> + match state with + | None -> 0 + | Some state -> + state.Api_types_j.simulation_info_output + .Api_types_j.simulation_output_dins) let onload () = + let () = ignore dont_gc_me in let () = - (Tyxml_js.To_dom.of_select din_select)##.onchange := - Dom.handler (fun _ -> let () = select_din () in Js._false) in + (Tyxml_js.To_dom.of_select din_select)##.onchange + := Dom.handler (fun _ -> + let () = select_din () in + Js._false) + in let () = Widget_export.onload export_configuration in - let () = Common.jquery_on "#navDIN" - "shown.bs.tab" (fun _ -> set_tab_is_active true) in - Common.jquery_on "#navDIN" - "hide.bs.tab" (fun _ -> set_tab_is_active false) + let () = + Common.jquery_on "#navDIN" "shown.bs.tab" (fun _ -> set_tab_is_active true) + in + Common.jquery_on "#navDIN" "hide.bs.tab" (fun _ -> set_tab_is_active false) let onresize () : unit = () diff --git a/gui/tab_influences.ml b/gui/tab_influences.ml index b1631ecae8..7072f21ce6 100644 --- a/gui/tab_influences.ml +++ b/gui/tab_influences.ml @@ -9,70 +9,68 @@ module Html = Tyxml_js.Html5 open Lwt.Infix -type model_graph = { - fwd : int option; - bwd : int option; - total : int; -} +type model_graph = { fwd: int option; bwd: int option; total: int } type influence_sphere = { - positive_on : - ((Public_data.rule,Public_data.var) Public_data.influence_node * - Public_data.location Public_data.pair list) list; - negative_on : - ((Public_data.rule,Public_data.var) Public_data.influence_node * - Public_data.location Public_data.pair list) list; - positive_by : - ((Public_data.rule,Public_data.var) Public_data.influence_node * - Public_data.location Public_data.pair list) list; - negative_by : - ((Public_data.rule,Public_data.var) Public_data.influence_node * - Public_data.location Public_data.pair list) list; + positive_on: + ((Public_data.rule, Public_data.var) Public_data.influence_node + * Public_data.location Public_data.pair list) + list; + negative_on: + ((Public_data.rule, Public_data.var) Public_data.influence_node + * Public_data.location Public_data.pair list) + list; + positive_by: + ((Public_data.rule, Public_data.var) Public_data.influence_node + * Public_data.location Public_data.pair list) + list; + negative_by: + ((Public_data.rule, Public_data.var) Public_data.influence_node + * Public_data.location Public_data.pair list) + list; } let empty_sphere = { positive_on = []; positive_by = []; negative_on = []; negative_by = [] } -type model_rendering = - | DrawGraph of model_graph - | DrawTabular of unit +type model_rendering = DrawGraph of model_graph | DrawTabular of unit type model = { - rendering : model_rendering; - accuracy : Public_data.accuracy_level option; - origin : (int,int) Public_data.influence_node option; - origin_label : string option; + rendering: model_rendering; + accuracy: Public_data.accuracy_level option; + origin: (int, int) Public_data.influence_node option; + origin_label: string option; } let navli () = ReactiveData.RList.empty - let tab_is_active, set_tab_is_active = React.S.create false let tab_was_active = ref false - let track_cursor, set_track_cursor = React.S.create false -let dummy_model = { - rendering = DrawTabular (); - accuracy = Some Public_data.Low; - origin = None; - origin_label = None; -} +let dummy_model = + { + rendering = DrawTabular (); + accuracy = Some Public_data.Low; + origin = None; + origin_label = None; + } let model, set_model = React.S.create dummy_model - let total_input_id = "total_input" let fwd_input_id = "fwd_input" let bwd_input_id = "bwd_input" let influence_node_label = function | Public_data.Rule r -> - if r.Public_data.rule_label = "" - then r.Public_data.rule_ast - else r.Public_data.rule_label + if r.Public_data.rule_label = "" then + r.Public_data.rule_ast + else + r.Public_data.rule_label | Public_data.Var r -> - if r.Public_data.var_label = "" - then r.Public_data.var_ast - else r.Public_data.var_label + if r.Public_data.var_label = "" then + r.Public_data.var_ast + else + r.Public_data.var_label let update_model_graph f = let m = React.S.value model in @@ -80,120 +78,155 @@ let update_model_graph f = | DrawTabular _ -> () | DrawGraph g -> set_model { m with rendering = DrawGraph (f g) } -let update_model f = - set_model (f (React.S.value model)) - +let update_model f = set_model (f (React.S.value model)) let display_id = "influence_map_display" + let influencemap = - Js_graphlogger.create_graph_logger - display_id - (fun x -> update_model - (fun m -> - let node = - (Public_data.refined_influence_node_of_json - (Yojson.Basic.from_string (Js.to_string x))) in - let () = - Subpanel_editor.set_move_cursor - (Public_data.position_of_refined_influence_node node) in - let origin = - Some (Public_data.short_node_of_refined_node node) in - let origin_label = Some (influence_node_label node) in - { m with origin; origin_label })) + Js_graphlogger.create_graph_logger display_id (fun x -> + update_model (fun m -> + let node = + Public_data.refined_influence_node_of_json + (Yojson.Basic.from_string (Js.to_string x)) + in + let () = + Subpanel_editor.set_move_cursor + (Public_data.position_of_refined_influence_node node) + in + let origin = Some (Public_data.short_node_of_refined_node node) in + let origin_label = Some (influence_node_label node) in + { m with origin; origin_label })) let total_input = - Html.input ~a:[ - Html.a_id total_input_id ; - Html.a_input_type `Number; - Html.a_value "1"; - Html.a_class ["form-control"]; - Html.a_size 1;] () + Html.input + ~a: + [ + Html.a_id total_input_id; + Html.a_input_type `Number; + Html.a_value "1"; + Html.a_class [ "form-control" ]; + Html.a_size 1; + ] + () let fwd_input = - Html.input ~a:[ Html.a_id fwd_input_id ; - Html.a_input_type `Number; - Html.a_class ["form-control"]; - Html.a_size 1;] () + Html.input + ~a: + [ + Html.a_id fwd_input_id; + Html.a_input_type `Number; + Html.a_class [ "form-control" ]; + Html.a_size 1; + ] + () let bwd_input = - Html.input ~a:[ Html.a_id bwd_input_id ; - Html.a_input_type `Number; - Html.a_class ["form-control"]; - Html.a_size 1;] () + Html.input + ~a: + [ + Html.a_id bwd_input_id; + Html.a_input_type `Number; + Html.a_class [ "form-control" ]; + Html.a_size 1; + ] + () let next_node = - Html.button ~a:[ - Html.a_button_type `Button; - Html.a_class ["form-control";"btn";"btn-default"]; - ] [ Html.txt "Next" ] + Html.button + ~a: + [ + Html.a_button_type `Button; + Html.a_class [ "form-control"; "btn"; "btn-default" ]; + ] + [ Html.txt "Next" ] let prev_node = - Html.button ~a:[ - Html.a_button_type `Button; - Html.a_class ["form-control";"btn";"btn-default"]; - ] [ Html.txt "Previous" ] + Html.button + ~a: + [ + Html.a_button_type `Button; + Html.a_class [ "form-control"; "btn"; "btn-default" ]; + ] + [ Html.txt "Previous" ] let recenter = - Html.button ~a:[ - Html.a_button_type `Button; - Html.a_class ["form-control";"btn";"btn-default"]; - ] [ Html.txt "Reset" ] + Html.button + ~a: + [ + Html.a_button_type `Button; + Html.a_class [ "form-control"; "btn"; "btn-default" ]; + ] + [ Html.txt "Reset" ] let track_cursor_switch = - Html.button ~a:[ - Html.a_button_type `Button; - Tyxml_js.R.Html5.a_class - (React.S.map (fun tc -> "form-control" :: "btn" :: "btn-default" :: - if tc then ["active"] else []) track_cursor); - Html.a_onclick - (fun _ -> - let () = set_track_cursor (not (React.S.value track_cursor)) - in true - ); - ] [ Html.txt "Track cursor" ] - -let export_config = { - Widget_export.id = "influence-export"; - Widget_export.handlers = - [ { - Widget_export.suffix = "json"; - Widget_export.label = "json"; - Widget_export.export = (fun filename -> - Lwt.ignore_result - (State_error.wrap "influence_map_export" - (State_project.with_project - ~label:__LOC__ - (fun manager -> - let { accuracy; _ } = React.S.value model in - manager#get_influence_map_raw accuracy >|= - Result_util.map - (fun influences_string -> - let data = Js.string influences_string in - let () = - Common.saveFile - ~data ~mime:"application/json" ~filename in - ()))) - >>= fun _ -> Lwt.return_unit)); - } ]; - Widget_export.show = React.S.const true; -} + Html.button + ~a: + [ + Html.a_button_type `Button; + Tyxml_js.R.Html5.a_class + (React.S.map + (fun tc -> + "form-control" :: "btn" :: "btn-default" + :: + (if tc then + [ "active" ] + else + [])) + track_cursor); + Html.a_onclick (fun _ -> + let () = set_track_cursor (not (React.S.value track_cursor)) in + true); + ] + [ Html.txt "Track cursor" ] + +let export_config = + { + Widget_export.id = "influence-export"; + Widget_export.handlers = + [ + { + Widget_export.suffix = "json"; + Widget_export.label = "json"; + Widget_export.export = + (fun filename -> + Lwt.ignore_result + ( State_error.wrap "influence_map_export" + (State_project.with_project ~label:__LOC__ (fun manager -> + let { accuracy; _ } = React.S.value model in + manager#get_influence_map_raw accuracy + >|= Result_util.map (fun influences_string -> + let data = Js.string influences_string in + let () = + Common.saveFile ~data + ~mime:"application/json" ~filename + in + ()))) + >>= fun _ -> Lwt.return_unit )); + }; + ]; + Widget_export.show = React.S.const true; + } let rendering_chooser_id = "influence-rendering" let rendering_chooser = let { rendering; _ } = React.S.value model in Html.select - ~a:[Html.a_class [ "form-control" ]; Html.a_id rendering_chooser_id ] + ~a:[ Html.a_class [ "form-control" ]; Html.a_id rendering_chooser_id ] [ Html.option - ~a:((fun l -> match rendering with - | DrawTabular _ -> Html.a_selected () :: l - | DrawGraph _ -> l) + ~a: + ((fun l -> + match rendering with + | DrawTabular _ -> Html.a_selected () :: l + | DrawGraph _ -> l) [ Html.a_value "tabular" ]) (Html.txt "Tabular"); Html.option - ~a:((fun l -> match rendering with - | DrawGraph _ -> Html.a_selected () :: l - | DrawTabular _ -> l) + ~a: + ((fun l -> + match rendering with + | DrawGraph _ -> Html.a_selected () :: l + | DrawTabular _ -> l) [ Html.a_value "graph" ]) (Html.txt "Graph"); ] @@ -205,87 +238,85 @@ let accuracy_chooser = let option_gen x = Html.option ~a: - ((fun l -> if accuracy = Some x then Html.a_selected () :: l else l) + ((fun l -> + if accuracy = Some x then + Html.a_selected () :: l + else + l) [ Html.a_value (Public_data.accuracy_to_string x) ]) - (Html.txt - (Public_data.accuracy_to_string x)) in + (Html.txt (Public_data.accuracy_to_string x)) + in Html.select - ~a:[Html.a_class [ "form-control" ]; Html.a_id accuracy_chooser_id ] + ~a:[ Html.a_class [ "form-control" ]; Html.a_id accuracy_chooser_id ] (List.map option_gen Public_data.influence_map_accuracy_levels) let is_center origin_short_opt node = match origin_short_opt with | None -> - begin - match node with - | Public_data.Rule r -> r.Public_data.rule_id = 0 - | Public_data.Var _ -> false - end - | Some origin -> - match origin, node with - | Public_data.Rule id, Public_data.Rule a -> - a.Public_data.rule_id = id - | Public_data.Var id, Public_data.Var a -> - a.Public_data.var_id = id + (match node with + | Public_data.Rule r -> r.Public_data.rule_id = 0 + | Public_data.Var _ -> false) + | Some origin -> + (match origin, node with + | Public_data.Rule id, Public_data.Rule a -> a.Public_data.rule_id = id + | Public_data.Var id, Public_data.Var a -> a.Public_data.var_id = id | Public_data.Var _, Public_data.Rule _ - | Public_data.Rule _, Public_data.Var _ -> false + | Public_data.Rule _, Public_data.Var _ -> + false) -let json_to_graph logger (_,_,_,_,origin,influence_map) = +let json_to_graph logger (_, _, _, _, origin, influence_map) = let origin_short_opt = - Option_util.map - Public_data.short_node_of_refined_node - origin + Option_util.map Public_data.short_node_of_refined_node origin in let () = Graph_loggers.print_graph_preamble logger "" in let nodes = influence_map.Public_data.nodes in let directives_of_node node = - let json = - Public_data.refined_influence_node_to_json node - in + let json = Public_data.refined_influence_node_to_json node in let label = influence_node_label node in - match node - with + match node with | Public_data.Rule r -> let pos = r.Public_data.rule_position in - let contextual_help = - (Locality.to_string pos)^" "^(r.Public_data.rule_ast) - in + let contextual_help = Loc.to_string pos ^ " " ^ r.Public_data.rule_ast in let fillcolor = - if is_center origin_short_opt node then !Config.center_color - else !Config.rule_color in + if is_center origin_short_opt node then + !Config.center_color + else + !Config.rule_color + in [ - Graph_loggers_sig.Label label; - Graph_loggers_sig.Shape !Config.rule_shape; - Graph_loggers_sig.FillColor fillcolor; - Graph_loggers_sig.Color fillcolor; - Graph_loggers_sig.Position [pos] ; - Graph_loggers_sig.OnClick json ; - Graph_loggers_sig.Contextual_help contextual_help - ] + Graph_loggers_sig.Label label; + Graph_loggers_sig.Shape !Config.rule_shape; + Graph_loggers_sig.FillColor fillcolor; + Graph_loggers_sig.Color fillcolor; + Graph_loggers_sig.Position [ pos ]; + Graph_loggers_sig.OnClick json; + Graph_loggers_sig.Contextual_help contextual_help; + ] | Public_data.Var r -> let pos = r.Public_data.var_position in - let contextual_help = - (Locality.to_string pos)^(r.Public_data.var_ast) - in + let contextual_help = Loc.to_string pos ^ r.Public_data.var_ast in let fillcolor = - if is_center origin_short_opt node then !Config.center_color - else !Config.variable_color in + if is_center origin_short_opt node then + !Config.center_color + else + !Config.variable_color + in [ Graph_loggers_sig.Label label; Graph_loggers_sig.Shape !Config.variable_shape; Graph_loggers_sig.FillColor fillcolor; Graph_loggers_sig.Color fillcolor; - Graph_loggers_sig.Position [pos] ; - Graph_loggers_sig.OnClick json ; - Graph_loggers_sig.Contextual_help contextual_help] + Graph_loggers_sig.Position [ pos ]; + Graph_loggers_sig.OnClick json; + Graph_loggers_sig.Contextual_help contextual_help; + ] in let max_rule_id = List.fold_left (fun biggest_id n -> - match n with - | Public_data.Rule r -> - max biggest_id (1+(r.Public_data.rule_id)) - | Public_data.Var _ -> biggest_id) + match n with + | Public_data.Rule r -> max biggest_id (1 + r.Public_data.rule_id) + | Public_data.Var _ -> biggest_id) (-1) nodes in let get_id_of_node_id node_id = @@ -294,442 +325,499 @@ let json_to_graph logger (_,_,_,_,origin,influence_map) = | Public_data.Var id -> id + max_rule_id in let get_id_of_node node = - get_id_of_node_id (Public_data.short_node_of_refined_node node) in + get_id_of_node_id (Public_data.short_node_of_refined_node node) + in let () = List.iter (fun node -> - let directives = - directives_of_node node - in - Graph_loggers.print_node - logger - ~directives - (string_of_int (get_id_of_node node)) - ) + let directives = directives_of_node node in + Graph_loggers.print_node logger ~directives + (string_of_int (get_id_of_node node))) nodes in - let print_maps ?directives:(directives=[]) logger map = + let print_maps ?(directives = []) logger map = Public_data.InfluenceNodeMap.iter (fun source map -> - let source_id = - string_of_int (get_id_of_node_id source) - in - Public_data.InfluenceNodeMap.iter - (fun target label_list -> - let target_id = - string_of_int (get_id_of_node_id target) - in - (*let label_string = "todo" - in*) - let label_string = - Public_data.string_of_label_list label_list - in - let directives = (Graph_loggers_sig.Label - label_string)::directives in - let () = - Graph_loggers.print_edge logger ~directives - source_id target_id in - ()) - map) + let source_id = string_of_int (get_id_of_node_id source) in + Public_data.InfluenceNodeMap.iter + (fun target label_list -> + let target_id = string_of_int (get_id_of_node_id target) in + (*let label_string = "todo" + in*) + let label_string = Public_data.string_of_label_list label_list in + let directives = + Graph_loggers_sig.Label label_string :: directives + in + let () = + Graph_loggers.print_edge logger ~directives source_id target_id + in + ()) + map) map in let directives = - [Graph_loggers_sig.Color !Config.wake_up_color; - Graph_loggers_sig.ArrowHead !Config.wake_up_arrow] - in - let () = - print_maps - ~directives - logger - influence_map.Public_data.positive + [ + Graph_loggers_sig.Color !Config.wake_up_color; + Graph_loggers_sig.ArrowHead !Config.wake_up_arrow; + ] in + let () = print_maps ~directives logger influence_map.Public_data.positive in let directives = - [Graph_loggers_sig.Color !Config.inhibition_color; - Graph_loggers_sig.ArrowHead !Config.inhibition_arrow] - in - let () = - print_maps - ~directives - logger - influence_map.Public_data.negative + [ + Graph_loggers_sig.Color !Config.inhibition_color; + Graph_loggers_sig.ArrowHead !Config.inhibition_arrow; + ] in + let () = print_maps ~directives logger influence_map.Public_data.negative in let () = Graph_loggers.print_graph_foot logger in () -let table_of_influences_json (_,_,_,_,origin,influence_map) = +let table_of_influences_json (_, _, _, _, origin, influence_map) = let namer = List.fold_left - (fun acc e -> Public_data.InfluenceNodeMap.add - (Public_data.short_node_of_refined_node e) e acc) - Public_data.InfluenceNodeMap.empty - influence_map.Public_data.nodes in + (fun acc e -> + Public_data.InfluenceNodeMap.add + (Public_data.short_node_of_refined_node e) + e acc) + Public_data.InfluenceNodeMap.empty influence_map.Public_data.nodes + in let origin_id_opt = - Option_util.map - Public_data.short_node_of_refined_node origin + Option_util.map Public_data.short_node_of_refined_node origin in match origin_id_opt with | None -> empty_sphere | Some origin_id -> - - let positive_on,positive_by = + let positive_on, positive_by = Public_data.InfluenceNodeMap.fold (fun src -> - Public_data.InfluenceNodeMap.fold - (fun dst data (on,by as acc) -> - if src = origin_id then - match Public_data.InfluenceNodeMap.find_option dst namer with - | None -> acc - | Some v -> ((v,data)::on,by) - else if dst = origin_id then - match Public_data.InfluenceNodeMap.find_option src namer with - | None -> acc - | Some v -> (on,(v,data)::by) - else acc)) - influence_map.Public_data.positive ([],[]) in - let negative_on,negative_by = + Public_data.InfluenceNodeMap.fold (fun dst data ((on, by) as acc) -> + if src = origin_id then ( + match Public_data.InfluenceNodeMap.find_option dst namer with + | None -> acc + | Some v -> (v, data) :: on, by + ) else if dst = origin_id then ( + match Public_data.InfluenceNodeMap.find_option src namer with + | None -> acc + | Some v -> on, (v, data) :: by + ) else + acc)) + influence_map.Public_data.positive ([], []) + in + let negative_on, negative_by = Public_data.InfluenceNodeMap.fold (fun src -> - Public_data.InfluenceNodeMap.fold - (fun dst data (on,by as acc) -> - if src = origin_id then - match Public_data.InfluenceNodeMap.find_option dst namer with - | None -> acc - | Some v -> ((v,data)::on,by) - else if dst = origin_id then - match Public_data.InfluenceNodeMap.find_option src namer with - | None -> acc - | Some v -> (on,(v,data)::by) - else acc)) - influence_map.Public_data.negative ([],[]) in + Public_data.InfluenceNodeMap.fold (fun dst data ((on, by) as acc) -> + if src = origin_id then ( + match Public_data.InfluenceNodeMap.find_option dst namer with + | None -> acc + | Some v -> (v, data) :: on, by + ) else if dst = origin_id then ( + match Public_data.InfluenceNodeMap.find_option src namer with + | None -> acc + | Some v -> on, (v, data) :: by + ) else + acc)) + influence_map.Public_data.negative ([], []) + in { positive_on; positive_by; negative_on; negative_by } let pop_cell = function - | [] -> (Html.td [],[]) - | ((node,_mappings),positive)::t -> - (Html.td ~a:[ - Html.a_onclick (fun _ -> - let () = - Subpanel_editor.set_move_cursor - (Public_data.position_of_refined_influence_node node) in - let origin = Some (Public_data.short_node_of_refined_node node) in - let origin_label = Some (influence_node_label node) in - let () = update_model (fun m -> { m with origin; origin_label }) in - true); - Html.a_class [if positive then "success" else "danger"] - ] - [Html.cdata (influence_node_label node)],t) + | [] -> Html.td [], [] + | ((node, _mappings), positive) :: t -> + ( Html.td + ~a: + [ + Html.a_onclick (fun _ -> + let () = + Subpanel_editor.set_move_cursor + (Public_data.position_of_refined_influence_node node) + in + let origin = + Some (Public_data.short_node_of_refined_node node) + in + let origin_label = Some (influence_node_label node) in + let () = + update_model (fun m -> { m with origin; origin_label }) + in + true); + Html.a_class + [ + (if positive then + "success" + else + "danger"); + ]; + ] + [ Html.cdata (influence_node_label node) ], + t ) let rec fill_table acc by on = if on = [] && by = [] then List.rev acc - else - let b,by' = pop_cell by in - let o,on' = pop_cell on in + else ( + let b, by' = pop_cell by in + let o, on' = pop_cell on in let line = Html.tr [ b; o ] in - fill_table (line::acc) by' on' + fill_table (line :: acc) by' on' + ) -let draw_table origin_label { positive_on; positive_by; negative_on; negative_by } = +let draw_table origin_label + { positive_on; positive_by; negative_on; negative_by } = let by = - List_util.rev_map_append (fun x -> (x,false)) negative_by - (List.rev_map (fun x -> (x,true)) positive_by) in + List_util.rev_map_append + (fun x -> x, false) + negative_by + (List.rev_map (fun x -> x, true) positive_by) + in let on = - List_util.rev_map_append (fun x -> (x,false)) negative_on - (List.rev_map (fun x -> (x,true)) positive_on) in + List_util.rev_map_append + (fun x -> x, false) + negative_on + (List.rev_map (fun x -> x, true) positive_on) + in let outs = fill_table [] by on in Html.tablex - ~a:[ Html.a_class ["table"]] - ~thead:(Html.thead [ - Html.tr - [Html.th ~a:[Html.a_colspan 2] - [Html.cdata (Option_util.unsome "origin" origin_label)]]; - Html.tr [ - Html.th [Html.cdata "is influenced by"]; - Html.th [Html.cdata "influences"]]; - ]) - [Html.tbody outs] + ~a:[ Html.a_class [ "table" ] ] + ~thead: + (Html.thead + [ + Html.tr + [ + Html.th + ~a:[ Html.a_colspan 2 ] + [ Html.cdata (Option_util.unsome "origin" origin_label) ]; + ]; + Html.tr + [ + Html.th [ Html.cdata "is influenced by" ]; + Html.th [ Html.cdata "influences" ]; + ]; + ]) + [ Html.tbody outs ] let influence_sphere = - State_project.on_project_change_async - ~on:tab_is_active dummy_model model (Result_util.ok empty_sphere) + State_project.on_project_change_async ~on:tab_is_active dummy_model model + (Result_util.ok empty_sphere) (fun manager { rendering; accuracy; origin; origin_label = _ } -> - match rendering with - | DrawTabular _ -> - manager#get_local_influence_map - ?fwd:None ?bwd:None ?origin ~total:1 accuracy >|= - Result_util.map - table_of_influences_json - | DrawGraph _ -> Lwt.return (Result_util.ok empty_sphere)) + match rendering with + | DrawTabular _ -> + manager#get_local_influence_map ?fwd:None ?bwd:None ?origin ~total:1 + accuracy + >|= Result_util.map table_of_influences_json + | DrawGraph _ -> Lwt.return (Result_util.ok empty_sphere)) let content () = let accuracy_form = - Html.form ~a:[ Html.a_class [ "form-horizontal" ] ] - [ Html.div + Html.form + ~a:[ Html.a_class [ "form-horizontal" ] ] + [ + Html.div ~a:[ Html.a_class [ "form-group" ] ] [ Html.label - ~a:[ Html.a_class ["col-md-2"]; - Html.a_label_for rendering_chooser_id ] - [Html.txt "Rendering"]; - Html.span ~a:[Html.a_class ["col-md-4"] ] [rendering_chooser]; + ~a: + [ + Html.a_class [ "col-md-2" ]; + Html.a_label_for rendering_chooser_id; + ] + [ Html.txt "Rendering" ]; + Html.span ~a:[ Html.a_class [ "col-md-4" ] ] [ rendering_chooser ]; Html.label - ~a:[ Html.a_class ["col-md-2"]; - Html.a_label_for accuracy_chooser_id ] - [Html.txt "Accuracy"]; - Html.span ~a:[Html.a_class ["col-md-2"] ] [accuracy_chooser] ]; - Html.div + ~a: + [ + Html.a_class [ "col-md-2" ]; + Html.a_label_for accuracy_chooser_id; + ] + [ Html.txt "Accuracy" ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ accuracy_chooser ]; + ]; + Html.div ~a:[ Html.a_class [ "form-group" ] ] - [ Html.label - ~a:[Html.a_class ["col-md-3"]; - Html.a_label_for total_input_id] - [Html.txt "Navigate"]; - Html.span ~a:[Html.a_class ["col-md-2"] ] [prev_node]; - Html.span ~a:[Html.a_class ["col-md-2"] ] [next_node]; - Html.span ~a:[Html.a_class ["col-md-2"] ] [recenter]; - Html.span ~a:[Html.a_class ["col-md-2"] ] [track_cursor_switch]; - ]] in + [ + Html.label + ~a: + [ Html.a_class [ "col-md-3" ]; Html.a_label_for total_input_id ] + [ Html.txt "Navigate" ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ prev_node ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ next_node ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ recenter ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ track_cursor_switch ]; + ]; + ] + in let graph_form = - Html.form ~a:[ Html.a_class [ "form-horizontal" ] ] - [ Html.div + Html.form + ~a:[ Html.a_class [ "form-horizontal" ] ] + [ + Html.div ~a:[ Html.a_class [ "form-group" ] ] [ - Html.label ~a:[Html.a_class ["col-md-3"]] - [Html.txt "Size Radius"]; - Html.span ~a:[Html.a_class ["col-md-2"]] [total_input]; - Html.label ~a:[Html.a_class ["col-md-1"]] [Html.txt "fwd"]; - Html.span ~a:[Html.a_class ["col-md-2"]] [fwd_input]; - Html.label ~a:[Html.a_class ["col-md-2"]] [Html.txt "bwd"]; - Html.span ~a:[Html.a_class ["col-md-2"]] [bwd_input]; - ]] in - [ accuracy_form; + Html.label + ~a:[ Html.a_class [ "col-md-3" ] ] + [ Html.txt "Size Radius" ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ total_input ]; + Html.label ~a:[ Html.a_class [ "col-md-1" ] ] [ Html.txt "fwd" ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ fwd_input ]; + Html.label ~a:[ Html.a_class [ "col-md-2" ] ] [ Html.txt "bwd" ]; + Html.span ~a:[ Html.a_class [ "col-md-2" ] ] [ bwd_input ]; + ]; + ] + in + [ + accuracy_form; Html.div - ~a:[ Tyxml_js.R.Html5.a_class - (React.S.map - (fun { rendering; _ } -> - match rendering with - | DrawGraph _ -> ["flex-content"] - | DrawTabular _ -> []) - model); - Tyxml_js.R.filter_attrib - (Html.a_hidden ()) - (React.S.map - (fun { rendering; _ } -> - match rendering with - | DrawGraph _ -> false - | DrawTabular _ -> true) - model) - ] - [ graph_form; - Html.div ~a:[Html.a_id display_id; Html.a_class ["flex-content"] ] []]; + ~a: + [ + Tyxml_js.R.Html5.a_class + (React.S.map + (fun { rendering; _ } -> + match rendering with + | DrawGraph _ -> [ "flex-content" ] + | DrawTabular _ -> []) + model); + Tyxml_js.R.filter_attrib (Html.a_hidden ()) + (React.S.map + (fun { rendering; _ } -> + match rendering with + | DrawGraph _ -> false + | DrawTabular _ -> true) + model); + ] + [ + graph_form; + Html.div ~a:[ Html.a_id display_id; Html.a_class [ "flex-content" ] ] []; + ]; Tyxml_js.R.Html5.div - ~a:[ Html.a_class ["panel-scroll"] ] + ~a:[ Html.a_class [ "panel-scroll" ] ] (ReactiveData.RList.from_signal (React.S.l2 (fun { rendering; origin_label; _ } sphere -> - match rendering with - | DrawGraph _ -> [] - | DrawTabular () -> - Result_util.fold - sphere - ~ok:(fun sphere -> [ draw_table origin_label sphere ]) - ~error:(fun error -> - List.map - (fun m -> Html.p [Html.txt (Format.asprintf "@[%a@]" Result_util.print_message m)]) - error)) + match rendering with + | DrawGraph _ -> [] + | DrawTabular () -> + Result_util.fold sphere + ~ok:(fun sphere -> [ draw_table origin_label sphere ]) + ~error:(fun error -> + List.map + (fun m -> + Html.p + [ + Html.txt + (Format.asprintf "@[%a@]" + Result_util.print_message m); + ]) + error)) model influence_sphere)); Widget_export.content export_config; ] -let _ = +let neither_gc_me = React.S.l2 (fun _ { rendering; accuracy; origin; origin_label = _ } -> - match rendering with - | DrawTabular _ -> Lwt.return (Result_util.ok ()) - | DrawGraph { fwd; bwd; total } -> - State_error.wrap ~append:true "influence_map" - (State_project.with_project - ~label:__LOC__ - (fun (manager : Api.concrete_manager) -> - ((manager#get_local_influence_map - ?fwd ?bwd ?origin ~total accuracy) >|= - Result_util.fold - ~ok:(fun influences -> - let buf = Buffer.create 1000 in - let fmt = Format.formatter_of_buffer buf in - let logger = - Loggers.open_logger_from_formatter - ~mode:Loggers.Js_Graph fmt in - let logger_graph = Graph_loggers_sig.extend_logger logger in - let () = json_to_graph logger_graph influences in - let graph = - Graph_loggers_sig.graph_of_logger logger_graph in - let graph_json = Graph_json.to_json graph in - let () = Loggers.flush_logger logger in - let () = Loggers.close_logger logger in - let () = - influencemap##setData - (Js.string (Yojson.Basic.to_string graph_json)) in - Result_util.ok ()) - ~error:(fun e -> - let () = influencemap##clearData in - Result_util.error e) - )))) + match rendering with + | DrawTabular _ -> Lwt.return (Result_util.ok ()) + | DrawGraph { fwd; bwd; total } -> + State_error.wrap ~append:true "influence_map" + (State_project.with_project ~label:__LOC__ + (fun (manager : Api.concrete_manager) -> + manager#get_local_influence_map ?fwd ?bwd ?origin ~total accuracy + >|= Result_util.fold + ~ok:(fun influences -> + let buf = Buffer.create 1000 in + let fmt = Format.formatter_of_buffer buf in + let logger = + Loggers.open_logger_from_formatter + ~mode:Loggers.Js_Graph fmt + in + let logger_graph = + Graph_loggers_sig.extend_logger logger + in + let () = json_to_graph logger_graph influences in + let graph = + Graph_loggers_sig.graph_of_logger logger_graph + in + let graph_json = Graph_json.to_json graph in + let () = Loggers.flush_logger logger in + let () = Loggers.close_logger logger in + let () = + influencemap##setData + (Js.string (Yojson.Basic.to_string graph_json)) + in + Result_util.ok ()) + ~error:(fun e -> + let () = influencemap##clearData in + Result_util.error e)))) (React.S.on ~eq:State_project.model_equal tab_is_active State_project.dummy_model State_project.model) model -let _ = +let nor_gc_me = State_file.with_current_pos - ~on:(React.S.Bool.(&&) tab_is_active track_cursor) + ~on:(React.S.Bool.( && ) tab_is_active track_cursor) (fun filename cursor_pos -> - Some - (State_project.with_project - ~label:__LOC__ - (fun (manager : Api.concrete_manager) -> - manager#get_influence_map_node_at ~filename cursor_pos >|= - Result_util.map - (fun origin' -> - update_model - (fun m -> + Some + (State_project.with_project ~label:__LOC__ + (fun (manager : Api.concrete_manager) -> + manager#get_influence_map_node_at ~filename cursor_pos + >|= Result_util.map (fun origin' -> + update_model (fun m -> { m with origin = origin'; origin_label = None }))))) (Lwt.return (Result_util.ok ())) let parent_hide () = set_tab_is_active false let parent_shown () = set_tab_is_active !tab_was_active +let dont_gc_me = ref [] let onload () = + let () = dont_gc_me := [ neither_gc_me; nor_gc_me ] in let () = Widget_export.onload export_config in - let () = (Tyxml_js.To_dom.of_select rendering_chooser)##.onchange := - Dom_html.full_handler - (fun va _ -> - let () = update_model (fun m -> - { m with - rendering = - if Js.to_string va##.value = "graph" then - DrawGraph { fwd = None; bwd = None; total = 1 } - else DrawTabular () }) in - Js._true) in - let () = (Tyxml_js.To_dom.of_select accuracy_chooser)##.onchange := - Dom_html.full_handler - (fun va _ -> + let () = + (Tyxml_js.To_dom.of_select rendering_chooser)##.onchange + := Dom_html.full_handler (fun va _ -> + let () = + update_model (fun m -> + { + m with + rendering = + (if Js.to_string va##.value = "graph" then + DrawGraph { fwd = None; bwd = None; total = 1 } + else + DrawTabular ()); + }) + in + Js._true) + in + let () = + (Tyxml_js.To_dom.of_select accuracy_chooser)##.onchange + := Dom_html.full_handler (fun va _ -> let accuracy = - Public_data.accuracy_of_string (Js.to_string va##.value) in + Public_data.accuracy_of_string (Js.to_string va##.value) + in let () = update_model (fun m -> { m with accuracy }) in - Js._true) in - let () = (Tyxml_js.To_dom.of_input total_input)##.onchange := - Dom_html.full_handler - (fun va _ -> - let va = Js.to_string va##.value in - try - let () = update_model_graph - (fun m -> { m with total = int_of_string va }) in - Js._true - with _ -> Js._false) + Js._true) + in + let () = + (Tyxml_js.To_dom.of_input total_input)##.onchange + := Dom_html.full_handler (fun va _ -> + let va = Js.to_string va##.value in + try + let () = + update_model_graph (fun m -> { m with total = int_of_string va }) + in + Js._true + with _ -> Js._false) in - let () = (Tyxml_js.To_dom.of_input fwd_input)##.onchange := - Dom_html.full_handler - (fun va _ -> + let () = + (Tyxml_js.To_dom.of_input fwd_input)##.onchange + := Dom_html.full_handler (fun va _ -> let va = Js.to_string va##.value in try let fwd = - if va = "" then None - else Some (int_of_string va) + if va = "" then + None + else + Some (int_of_string va) in let () = update_model_graph (fun m -> { m with fwd }) in Js._true with _ -> Js._false) in - let () = (Tyxml_js.To_dom.of_input bwd_input)##.onchange := - Dom_html.full_handler - (fun va _ -> - let va = Js.to_string va##.value in - try - let bwd = - if va = "" then None - else Some (int_of_string va) - in - let () = update_model_graph (fun m -> { m with bwd }) in - Js._true - with _ -> Js._false) in let () = - (Tyxml_js.To_dom.of_button recenter)##.onclick := - Dom_html.full_handler - (fun _ _ -> + (Tyxml_js.To_dom.of_input bwd_input)##.onchange + := Dom_html.full_handler (fun va _ -> + let va = Js.to_string va##.value in + try + let bwd = + if va = "" then + None + else + Some (int_of_string va) + in + let () = update_model_graph (fun m -> { m with bwd }) in + Js._true + with _ -> Js._false) + in + let () = + (Tyxml_js.To_dom.of_button recenter)##.onclick + := Dom_html.full_handler (fun _ _ -> let _ = State_error.wrap "influence_map_recenter" - (State_project.with_project - ~label:__LOC__ + (State_project.with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> - manager#get_initial_node >|= - Result_util.map - (fun origin_refined -> - let origin = - Option_util.map - Public_data.short_node_of_refined_node - origin_refined in - let origin_label = - Option_util.map - influence_node_label origin_refined in - update_model - (fun m -> { m with origin; origin_label })) - )) - in Js._true - ) + manager#get_initial_node + >|= Result_util.map (fun origin_refined -> + let origin = + Option_util.map + Public_data.short_node_of_refined_node + origin_refined + in + let origin_label = + Option_util.map influence_node_label + origin_refined + in + update_model (fun m -> + { m with origin; origin_label })))) + in + Js._true) in let () = - (Tyxml_js.To_dom.of_button next_node)##.onclick := - Dom_html.full_handler - (fun _ _ -> + (Tyxml_js.To_dom.of_button next_node)##.onclick + := Dom_html.full_handler (fun _ _ -> let { origin; _ } = React.S.value model in let _ = State_error.wrap "influence_map_next_node" - (State_project.with_project - ~label:__LOC__ + (State_project.with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> - manager#get_next_node origin >|= - Result_util.map - (fun origin_refined -> + manager#get_next_node origin + >|= Result_util.map (fun origin_refined -> let origin = Option_util.map Public_data.short_node_of_refined_node - origin_refined in + origin_refined + in let origin_label = - Option_util.map - influence_node_label origin_refined in + Option_util.map influence_node_label + origin_refined + in update_model (fun m -> - { m with origin; origin_label })) - )) - in Js._true - ) in + { m with origin; origin_label })))) + in + Js._true) + in let () = - (Tyxml_js.To_dom.of_button prev_node)##.onclick := - Dom_html.full_handler - (fun _ _ -> + (Tyxml_js.To_dom.of_button prev_node)##.onclick + := Dom_html.full_handler (fun _ _ -> let { origin; _ } = React.S.value model in let _ = State_error.wrap "influence_map_prev_node" - (State_project.with_project - ~label:__LOC__ + (State_project.with_project ~label:__LOC__ (fun (manager : Api.concrete_manager) -> - manager#get_previous_node origin >|= - Result_util.map - (fun origin_refined -> - let origin = - Option_util.map - Public_data.short_node_of_refined_node - origin_refined in - let origin_label = - Option_util.map - influence_node_label origin_refined in - update_model (fun m -> - { m with origin; origin_label })) - )) - in Js._true - ) in - let () = Common.jquery_on - "#navinfluences" "hide.bs.tab" - (fun _ -> let () = tab_was_active := false in set_tab_is_active false) in - let () = Common.jquery_on - "#navinfluences" "shown.bs.tab" - (fun _ -> let () = tab_was_active := true in set_tab_is_active true) in + manager#get_previous_node origin + >|= Result_util.map (fun origin_refined -> + let origin = + Option_util.map + Public_data.short_node_of_refined_node + origin_refined + in + let origin_label = + Option_util.map influence_node_label + origin_refined + in + update_model (fun m -> + { m with origin; origin_label })))) + in + Js._true) + in + let () = + Common.jquery_on "#navinfluences" "hide.bs.tab" (fun _ -> + let () = tab_was_active := false in + set_tab_is_active false) + in + let () = + Common.jquery_on "#navinfluences" "shown.bs.tab" (fun _ -> + let () = tab_was_active := true in + set_tab_is_active true) + in () + let onresize () : unit = () diff --git a/gui/tab_log.ml b/gui/tab_log.ml index d781844d9b..2e67352224 100644 --- a/gui/tab_log.ml +++ b/gui/tab_log.ml @@ -20,44 +20,52 @@ let line_count state = state.simulation_info_output.simulation_output_log_messages let navli () = - Ui_common.label_news tab_is_active (fun state -> (line_count state)) + Ui_common.label_news tab_is_active (fun state -> line_count state) + +let dont_gc_me = ref [] let content () = - let state_log , set_state_log = React.S.create ("" : string) in - let _ = Lwt_react.S.map_s - (fun _ -> - State_simulation.with_simulation_info - ~label:__LOC__ - ~ready: - (fun manager _ -> - manager#simulation_detail_log_message >>= - (Api_common.result_bind_lwt - ~ok:(fun (log_messages : Api_types_j.log_message) -> - let () = set_state_log log_messages in - Lwt.return (Result_util.ok ())) - ) - ) - ~stopped:(fun _ -> - let () = set_state_log "" in - Lwt.return (Result_util.ok ())) - () - ) - (React.S.on - tab_is_active State_simulation.dummy_model State_simulation.model) in - [ Html.div - ~a:[Html.a_class ["panel-pre" ; "panel-scroll"]] - [ Tyxml_js.R.Html.txt state_log ] - ] + let state_log, set_state_log = React.S.create ("" : string) in + let () = + dont_gc_me := + [ + Lwt_react.S.map_s + (fun _ -> + State_simulation.with_simulation_info ~label:__LOC__ + ~ready:(fun manager _ -> + manager#simulation_detail_log_message + >>= Api_common.result_bind_lwt + ~ok:(fun (log_messages : Api_types_j.log_message) -> + let () = set_state_log log_messages in + Lwt.return (Result_util.ok ()))) + ~stopped:(fun _ -> + let () = set_state_log "" in + Lwt.return (Result_util.ok ())) + ()) + (React.S.on tab_is_active State_simulation.dummy_model + State_simulation.model); + ] + in + [ + Html.div + ~a:[ Html.a_class [ "panel-pre"; "panel-scroll" ] ] + [ Tyxml_js.R.Html.txt state_log ]; + ] let parent_hide () = set_tab_is_active false let parent_shown () = set_tab_is_active !tab_was_active let onload () = - let () = Common.jquery_on - "#navlog" "hide.bs.tab" - (fun _ -> let () = tab_was_active := false in set_tab_is_active false) in - let () = Common.jquery_on - "#navlog" "shown.bs.tab" - (fun _ -> let () = tab_was_active := true in set_tab_is_active true) in + let () = + Common.jquery_on "#navlog" "hide.bs.tab" (fun _ -> + let () = tab_was_active := false in + set_tab_is_active false) + in + let () = + Common.jquery_on "#navlog" "shown.bs.tab" (fun _ -> + let () = tab_was_active := true in + set_tab_is_active true) + in () + let onresize () : unit = () diff --git a/gui/tab_outputs.ml b/gui/tab_outputs.ml index 0163957efc..b181d5a95c 100644 --- a/gui/tab_outputs.ml +++ b/gui/tab_outputs.ml @@ -9,143 +9,153 @@ module Html = Tyxml_js.Html5 open Lwt.Infix - let select_id = "output-select-id" - let tab_is_active, set_tab_is_active = React.S.create false - -let current_file, set_current_file = - React.S.create None +let current_file, set_current_file = React.S.create None let update_outputs key : unit = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - (manager#simulation_detail_file_line key) >>= - (Api_common.result_bind_lwt - ~ok:(fun lines -> - let () = set_current_file (Some (key,lines)) in - Lwt.return (Result_util.ok ()) - ) - ) - ) + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_detail_file_line key + >>= Api_common.result_bind_lwt ~ok:(fun lines -> + let () = set_current_file (Some (key, lines)) in + Lwt.return (Result_util.ok ()))) let file_count state = match state with | None -> 0 | Some state -> - state.Api_types_t.simulation_info_output.Api_types_t.simulation_output_file_lines + state.Api_types_t.simulation_info_output + .Api_types_t.simulation_output_file_lines -let navli () = - Ui_common.badge (fun state -> (file_count state)) +let navli () = Ui_common.badge (fun state -> file_count state) +let dont_gc_me = ref [] let xml () = let select file_line_ids = let lines = React.S.value current_file in let current_file_id : string = - match (file_line_ids,lines) with + match file_line_ids, lines with | [], _ -> assert false - | (file::_,None) | (_::_,Some (file,_)) -> file in + | file :: _, None | _ :: _, Some (file, _) -> file + in let file_options = List.map (fun key -> - Html.option - ~a:([ Html.a_value key]@ - (if key = current_file_id then [Html.a_selected ()] - else [])) - (Html.txt (Ui_common.option_label key))) - file_line_ids in + Html.option + ~a: + ([ Html.a_value key ] + @ + if key = current_file_id then + [ Html.a_selected () ] + else + []) + (Html.txt (Ui_common.option_label key))) + file_line_ids + in let () = update_outputs current_file_id in Tyxml_js.Html.select - ~a:[ Html.a_class ["form-control"] ; Html.a_id select_id ] - file_options in + ~a:[ Html.a_class [ "form-control" ]; Html.a_id select_id ] + file_options + in let file_select = Tyxml_js.R.Html.div - ~a:[ Html.a_class ["list-group-item"] ] + ~a:[ Html.a_class [ "list-group-item" ] ] (let list, handle = ReactiveData.RList.create [] in - let _ = React.S.map - (fun _ -> - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - manager#simulation_catalog_file_line >>= - (Api_common.result_bind_lwt - ~ok:(fun (file_line_ids : Api_types_j.file_line_catalog) -> - let () = ReactiveData.RList.set - handle - (match file_line_ids with - | [] -> [] - | key::[] -> - let () = update_outputs key in - [Html.h4 - [ Html.txt - (Ui_common.option_label key)]] - | _ :: _ :: _ -> [select file_line_ids]) - in - Lwt.return (Result_util.ok ()) - ) - ) - ) - ) - (React.S.on - tab_is_active State_simulation.dummy_model State_simulation.model) + let () = + dont_gc_me := + [ + React.S.map + (fun _ -> + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_catalog_file_line + >>= Api_common.result_bind_lwt + ~ok:(fun + (file_line_ids : Api_types_j.file_line_catalog) + -> + let () = + ReactiveData.RList.set handle + (match file_line_ids with + | [] -> [] + | key :: [] -> + let () = update_outputs key in + [ + Html.h4 + [ Html.txt (Ui_common.option_label key) ]; + ] + | _ :: _ :: _ -> [ select file_line_ids ]) + in + Lwt.return (Result_util.ok ())))) + (React.S.on tab_is_active State_simulation.dummy_model + State_simulation.model); + ] in - list - ) + list) in let file_content = - [Tyxml_js.R.Html.div - ~a:[Html.a_class ["panel-scroll";"flex-content"]] - (ReactiveData.RList.from_signal - (React.S.map - (function - | None -> [] - | Some (_,lines) -> - List.map (fun line -> Html.p [ Html.txt line ]) lines) - current_file))] in - [ [%html {|

    + [ + Tyxml_js.R.Html.div + ~a:[ Html.a_class [ "panel-scroll"; "flex-content" ] ] + (ReactiveData.RList.from_signal + (React.S.map + (function + | None -> [] + | Some (_, lines) -> + List.map (fun line -> Html.p [ Html.txt line ]) lines) + current_file)); + ] + in + [ + [%html + {|
    - |}[file_select]{| + |} + [ file_select ] + {|
    - |}file_content{| -
    |}] ] + |} + file_content + {| +
    |}]; + ] let select_outputs () : unit = - let select_dom = Ui_common.id_dom select_id in - let fileindex = Js.to_string (select_dom##.value) in + let select_dom = Ui_common.id_dom select_id in + let fileindex = Js.to_string select_dom##.value in update_outputs fileindex let content () = [ Ui_common.toggle_element (fun t -> file_count t > 0) (xml ()) ] let onload () = - let () = Common.jquery_on - "#navoutputs" "hide.bs.tab" - (fun _ -> set_tab_is_active false) in - let () = Common.jquery_on - "#navoutputs" "shown.bs.tab" - (fun _ -> set_tab_is_active true) in let () = - Common.jquery_on - (Format.sprintf "#%s" select_id) - ("change") - (fun _ -> let () = select_outputs () in Js._true) - in () - (* TODO - let select_dom : Dom_html.inputElement Js.t = - Js.Unsafe.coerce - ((Js.Opt.get - (Ui_common.document##getElementById - (Js.string select_id)) - (fun () -> assert false)) - : Dom_html.element Js.t) in - let () = select_dom##.onchange := Dom_html.handler -(fun _ -> - let () = select_outputs t - in Js._true) + Common.jquery_on "#navoutputs" "hide.bs.tab" (fun _ -> + set_tab_is_active false) + in + let () = + Common.jquery_on "#navoutputs" "shown.bs.tab" (fun _ -> + set_tab_is_active true) + in + let () = + Common.jquery_on (Format.sprintf "#%s" select_id) "change" (fun _ -> + let () = select_outputs () in + Js._true) in - *) + () +(* TODO + let select_dom : Dom_html.inputElement Js.t = + Js.Unsafe.coerce + ((Js.Opt.get + (Ui_common.document##getElementById + (Js.string select_id)) + (fun () -> assert false)) + : Dom_html.element Js.t) in + let () = select_dom##.onchange := Dom_html.handler + (fun _ -> + let () = select_outputs t + in Js._true) + in +*) let onresize () : unit = () diff --git a/gui/tab_plot.ml b/gui/tab_plot.ml index f98bf46d90..8953f4e536 100644 --- a/gui/tab_plot.ml +++ b/gui/tab_plot.ml @@ -12,133 +12,156 @@ open Lwt.Infix let div_display_id = "plot-main_div" let export_id = "plot-export" -type offset = { offset_current : int ; - offset_max : int ; } -let offset , set_offset = React.S.create (None : offset option) +type offset = { offset_current: int; offset_max: int } +let offset, set_offset = React.S.create (None : offset option) let default_point = 1000 -let point , set_points = React.S.create default_point +let point, set_points = React.S.create default_point let has_plot (state : Api_types_j.simulation_info option) : bool = match state with | None -> false | Some state -> - state.Api_types_j.simulation_info_output.Api_types_j.simulation_output_plot > 0 + state.Api_types_j.simulation_info_output.Api_types_j.simulation_output_plot + > 0 let export_json filename = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - (manager#simulation_detail_plot - { Api_types_j.plot_limit_offset = None ; - Api_types_j.plot_limit_points = None }) >>= - (Api_common.result_bind_lwt - ~ok:(fun (plot : Api_types_t.plot) -> + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_detail_plot + { + Api_types_j.plot_limit_offset = None; + Api_types_j.plot_limit_points = None; + } + >>= Api_common.result_bind_lwt ~ok:(fun (plot : Api_types_t.plot) -> let data = Js.string (Data.string_of_plot plot) in let () = - Common.saveFile ~data ~mime:"application/json" ~filename in - Lwt.return (Result_util.ok ())))) + Common.saveFile ~data ~mime:"application/json" ~filename + in + Lwt.return (Result_util.ok ()))) let export mime filename = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - (manager#simulation_detail_plot - { Api_types_j.plot_limit_offset = None ; - Api_types_j.plot_limit_points = None }) >>= - (Api_common.result_bind_lwt - ~ok:(fun (plot : Api_types_t.plot) -> + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_detail_plot + { + Api_types_j.plot_limit_offset = None; + Api_types_j.plot_limit_points = None; + } + >>= Api_common.result_bind_lwt ~ok:(fun (plot : Api_types_t.plot) -> let data = - Js.string (Data.export_plot ~is_tsv:(mime="text/tsv") plot) in + Js.string (Data.export_plot ~is_tsv:(mime = "text/tsv") plot) + in let () = Common.saveFile ~data ~mime ~filename in - Lwt.return (Result_util.ok ())))) + Lwt.return (Result_util.ok ()))) let configuration () : Widget_export.configuration = - { Widget_export.id = export_id - ; Widget_export.handlers = - [ Widget_export.export_svg ~svg_div_id:div_display_id () - ; Widget_export.export_png ~svg_div_id:div_display_id () - ; { Widget_export.suffix = "json" - ; Widget_export.label = "json" - ; Widget_export.export = export_json - } - ; { Widget_export.suffix = "csv" - ; Widget_export.label = "csv" - ; Widget_export.export = export "text/csv" - } - ; { Widget_export.suffix = "tsv" - ; Widget_export.label = "tsv" - ; Widget_export.export = export "text/tsv" - } + { + Widget_export.id = export_id; + Widget_export.handlers = + [ + Widget_export.export_svg ~svg_div_id:div_display_id (); + Widget_export.export_png ~svg_div_id:div_display_id (); + { + Widget_export.suffix = "json"; + Widget_export.label = "json"; + Widget_export.export = export_json; + }; + { + Widget_export.suffix = "csv"; + Widget_export.label = "csv"; + Widget_export.export = export "text/csv"; + }; + { + Widget_export.suffix = "tsv"; + Widget_export.label = "tsv"; + Widget_export.export = export "text/tsv"; + }; ]; show = React.S.map (fun model -> has_plot (State_simulation.model_simulation_info model)) - State_simulation.model + State_simulation.model; } let plot_points_input_id = "plot_points_input" + let plot_points_input = - Html.input ~a:[ Html.a_id plot_points_input_id ; - Html.a_input_type `Number; - Html.a_class ["form-control"]; - Html.a_size 5; - ] () + Html.input + ~a: + [ + Html.a_id plot_points_input_id; + Html.a_input_type `Number; + Html.a_class [ "form-control" ]; + Html.a_size 5; + ] + () let plot_offset_input_id = "plot_offset_input" + let plot_offset_input = - Html.input ~a:[ Tyxml_js.R.Html.a_class - (React.S.bind - offset - (function - | None -> React.S.const [ "hide" ] - | Some _ -> React.S.const []) - ); - Tyxml_js.R.Html.a_input_max - (React.S.bind - offset - (function - | None -> React.S.const (`Number 0) - | Some max_offset -> - React.S.const - (`Number max_offset.offset_max)) - ); - Html.a_id plot_offset_input_id ; - Html.a_input_type `Range ; - Html.a_input_min (`Number 0) ; - Html.a_placeholder "offset" ; - ] () + Html.input + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.bind offset (function + | None -> React.S.const [ "hide" ] + | Some _ -> React.S.const [])); + Tyxml_js.R.Html.a_input_max + (React.S.bind offset (function + | None -> React.S.const (`Number 0) + | Some max_offset -> React.S.const (`Number max_offset.offset_max))); + Html.a_id plot_offset_input_id; + Html.a_input_type `Range; + Html.a_input_min (`Number 0); + Html.a_placeholder "offset"; + ] + () let xml () = - let export_controls = - Widget_export.inline_content (configuration ()) - in - [%html {| -
    + let export_controls = Widget_export.inline_content (configuration ()) in + [%html + {| +
    -
    - |}export_controls{| + + |} + export_controls + {|
    - +
    Points - |}[plot_points_input]{| + |} + [ plot_points_input ] + {|
    - - |}[plot_offset_input]{| + + |} + [ plot_offset_input ] + {|
    |}] let content () : [> Html_types.div ] Html.elt list = - [Ui_common.toggle_element (fun s -> has_plot s ) (xml ()) ] + [ Ui_common.toggle_element (fun s -> has_plot s) (xml ()) ] -let simulation_info_offset_max (simulation_info : Api_types_j.simulation_info) : int = - let plot_size = simulation_info.Api_types_j.simulation_info_output.Api_types_j.simulation_output_plot in - max 0 (plot_size - (React.S.value point)) +let simulation_info_offset_max (simulation_info : Api_types_j.simulation_info) : + int = + let plot_size = + simulation_info.Api_types_j.simulation_info_output + .Api_types_j.simulation_output_plot + in + max 0 (plot_size - React.S.value point) let update_offset (update_offset_input : bool) : unit = let simulation_model = React.S.value State_simulation.model in @@ -146,69 +169,85 @@ let update_offset (update_offset_input : bool) : unit = match simulation_info with | None -> () | Some simulation_info -> - if simulation_info.Api_types_j.simulation_info_progress.Api_types_j.simulation_progress_is_running then + if + simulation_info.Api_types_j.simulation_info_progress + .Api_types_j.simulation_progress_is_running + then (* If it is running no slider because update causes jitters. *) set_offset None - else + else ( let offset_max = simulation_info_offset_max simulation_info in let old_offset = React.S.value offset in - let offset_current = match old_offset with + let offset_current = + match old_offset with | Some offset -> offset.offset_current - | None -> offset_max in + | None -> offset_max + in let () = - if update_offset_input then - let plot_offset_input_dom = Tyxml_js.To_dom.of_input plot_offset_input in + if update_offset_input then ( + let plot_offset_input_dom = + Tyxml_js.To_dom.of_input plot_offset_input + in let () = Common.debug (Js.string (string_of_int offset_current)) in - let () = plot_offset_input_dom##.value := Js.string (string_of_int offset_current) in + let () = + plot_offset_input_dom##.value + := Js.string (string_of_int offset_current) + in () - else + ) else () in let new_offset = if offset_max > 0 then - Some { offset_current = offset_current ; - offset_max = offset_max ; } + Some { offset_current; offset_max } else None - in set_offset new_offset + in + set_offset new_offset + ) let plot_parameter () : Api_types_j.plot_parameter = - let point = React.S.value point in { + let point = React.S.value point in + { Api_types_j.plot_limit_offset = - Option_util.map (fun x -> x.offset_current) (React.S.value offset) ; - Api_types_j.plot_limit_points = Some point ; + Option_util.map (fun x -> x.offset_current) (React.S.value offset); + Api_types_j.plot_limit_points = Some point; } let update_plot (js_plot : Js_plot.observable_plot Js.t) : unit = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> + State_simulation.when_ready ~label:__LOC__ (fun manager -> let () = update_offset true in - (manager#simulation_detail_plot (plot_parameter ())) >>= - (Api_common.result_bind_lwt - ~ok:(fun (plot : Api_types_t.plot) -> - let data = Js.string (Data.string_of_plot plot) in - let () = js_plot##setData(data) in - Lwt.return (Result_util.ok ()) - ) - ) - ) + manager#simulation_detail_plot (plot_parameter ()) + >>= Api_common.result_bind_lwt ~ok:(fun (plot : Api_types_t.plot) -> + let data = Js.string (Data.string_of_plot plot) in + let () = js_plot##setData data in + Lwt.return (Result_util.ok ()))) -let onload_plot_points_input - (js_plot : Js_plot.observable_plot Js.t) : unit = - let plot_points_input_dom : Dom_html.inputElement Js.t = Tyxml_js.To_dom.of_input plot_points_input in - let js_point : Js.js_string Js.t = Js.string (string_of_int (React.S.value point)) in +let onload_plot_points_input (js_plot : Js_plot.observable_plot Js.t) : unit = + let plot_points_input_dom : Dom_html.inputElement Js.t = + Tyxml_js.To_dom.of_input plot_points_input + in + let js_point : Js.js_string Js.t = + Js.string (string_of_int (React.S.value point)) + in let () = plot_points_input_dom##.value := js_point in - let () = plot_points_input_dom##.onkeypress := - Dom_html.handler - (fun ev -> - if ev##.keyCode = 13 then Js._false else Js._true) in - let () = plot_points_input_dom##.onchange := - Dom_html.handler - (fun _ -> - let plot_points_string : string = Js.to_string plot_points_input_dom##.value in + let () = + plot_points_input_dom##.onkeypress + := Dom_html.handler (fun ev -> + if ev##.keyCode = 13 then + Js._false + else + Js._true) + in + let () = + plot_points_input_dom##.onchange + := Dom_html.handler (fun _ -> + let plot_points_string : string = + Js.to_string plot_points_input_dom##.value + in let plot_points_option : int option = - try let plot_point = int_of_string plot_points_string in + try + let plot_point = int_of_string plot_points_string in if plot_point > 0 then Some plot_point else @@ -221,8 +260,11 @@ let onload_plot_points_input | None -> let plot_point : int = React.S.value point in let plot_point_string = string_of_int plot_point in - let () = plot_points_input_dom##.value := Js.string plot_point_string in - let () = set_points default_point in () + let () = + plot_points_input_dom##.value := Js.string plot_point_string + in + let () = set_points default_point in + () in let () = update_plot js_plot in Js._true) @@ -230,57 +272,64 @@ let onload_plot_points_input () let plot_ref = ref None -let tab_is_active,set_tab_is_active = React.S.create false +let tab_is_active, set_tab_is_active = React.S.create false +let dont_gc_me = ref [] let onload () = let plot_offset_input_dom = Tyxml_js.To_dom.of_input plot_offset_input in let () = Widget_export.onload (configuration ()) in let plot : Js_plot.observable_plot Js.t = - Js_plot.create_observable_plot div_display_id in + Js_plot.create_observable_plot div_display_id + in (* The elements size themselves using the div's if they are hidden it will default to size zero. so they need to be sized when shown. *) let () = onload_plot_points_input plot in let () = plot_ref := Some plot in - let () = Common.jquery_on - "#navplot" - "hide.bs.tab" - (fun _ -> set_tab_is_active false) in - let () = Common.jquery_on - "#navplot" - "shown.bs.tab" - (fun _ -> - let () = set_tab_is_active true in - let simulation_model = React.S.value State_simulation.model in - let simulation_info = State_simulation.model_simulation_info simulation_model in - if has_plot simulation_info then - update_plot plot - else - ()) + let () = + Common.jquery_on "#navplot" "hide.bs.tab" (fun _ -> set_tab_is_active false) + in + let () = + Common.jquery_on "#navplot" "shown.bs.tab" (fun _ -> + let () = set_tab_is_active true in + let simulation_model = React.S.value State_simulation.model in + let simulation_info = + State_simulation.model_simulation_info simulation_model + in + if has_plot simulation_info then + update_plot plot + else + ()) + in + let () = + dont_gc_me := + [ + React.S.l1 + (fun simulation_model -> + let simulation_info = + State_simulation.model_simulation_info simulation_model + in + if has_plot simulation_info then + update_plot plot + else + ()) + (React.S.on tab_is_active State_simulation.dummy_model + State_simulation.model); + ] in - let _ = - React.S.l1 - (fun simulation_model -> - let simulation_info = State_simulation.model_simulation_info simulation_model in - if has_plot simulation_info then - update_plot plot - else - ()) - (React.S.on - tab_is_active State_simulation.dummy_model State_simulation.model) in let () = - Ui_common.input_change - plot_offset_input_dom - (fun value -> - let () = try set_offset - (match React.S.value offset with - | None -> None - | Some offset -> Some { offset with offset_current = int_of_string value }) - with | Failure _ -> () - in - let () = update_plot plot in - () - ) + Ui_common.input_change plot_offset_input_dom (fun value -> + let () = + try + set_offset + (match React.S.value offset with + | None -> None + | Some offset -> + Some { offset with offset_current = int_of_string value }) + with Failure _ -> () + in + let () = update_plot plot in + ()) in () @@ -291,7 +340,7 @@ let plot_count = function state.simulation_info_output.simulation_output_plot let navli () = - Ui_common.label_news tab_is_active (fun state -> (plot_count state)) + Ui_common.label_news tab_is_active (fun state -> plot_count state) let onresize () = (* recalcuate size *) @@ -299,9 +348,9 @@ let onresize () = match !plot_ref with | None -> () | Some plot -> - (let model = React.S.value State_simulation.model in - match State_simulation.model_simulation_info model with - | None -> () - | Some _ -> update_plot plot) + let model = React.S.value State_simulation.model in + (match State_simulation.model_simulation_info model with + | None -> () + | Some _ -> update_plot plot) in () diff --git a/gui/tab_polymers.ml b/gui/tab_polymers.ml index 4506b5e399..576344bbb2 100644 --- a/gui/tab_polymers.ml +++ b/gui/tab_polymers.ml @@ -10,65 +10,80 @@ module Html = Tyxml_js.Html5 open Lwt.Infix let navli () = ReactiveData.RList.empty - let tab_is_active, set_tab_is_active = React.S.create false let tab_was_active = ref false +let site a = [ a, None, Some (Public_data.Bound_to 1), None ] -let site a = [a,None,Some (Public_data.Bound_to 1),None] - -let print_edge ((a,b),(c,d)) list = - Utility.print_newline (Utility.print_site_graph [a,site b;c,site d] list) +let print_edge ((a, b), (c, d)) list = + Utility.print_newline (Utility.print_site_graph [ a, site b; c, site d ] list) let content () = let scc = - State_project.on_project_change_async ~on:tab_is_active - () (React.S.const ()) [] - (fun (manager : Api.concrete_manager) () -> - manager#get_potential_polymers - (Some Public_data.High) (Some Public_data.High) - (*TODO: make these options tunable *) >|= - Result_util.fold - ~ok:(fun (_,_,scc) -> - let scc = List.rev_map List.rev scc in - let output = - if scc = [] || scc = [[]] - then - Utility.print_string "The size of biomolecular compounds is uniformly bounded." [] - else - let list = - List.fold_left - (fun list list_edges -> - let list = Utility.print_newline list in + State_project.on_project_change_async ~on:tab_is_active () + (React.S.const ()) [] (fun (manager : Api.concrete_manager) () -> + manager#get_potential_polymers (Some Public_data.High) + (Some Public_data.High) + (*TODO: make these options tunable *) + >|= Result_util.fold + ~ok:(fun (_, _, scc) -> + let scc = List.rev_map List.rev scc in + let output = + if scc = [] || scc = [ [] ] then + Utility.print_string + "The size of biomolecular compounds is uniformly bounded." + [] + else ( + let list = List.fold_left - (fun list ((a,b),(c,d)) -> - print_edge ((a,b),(c,d)) list - ) list list_edges) [] scc - in - let list = Utility.print_newline list in - let list = - Utility.print_string "The following bonds may form arbitrary long chains of agents:" list - in list - in - [Html.p output]) - ~error:(fun mh -> - List.map - (fun m -> Html.p [Html.txt (Format.asprintf "@[%a@]" Result_util.print_message m)]) - mh)) in - [ Tyxml_js.R.Html5.div - ~a:[Html.a_class ["panel-pre" ; "panel-scroll"]] - (ReactiveData.RList.from_signal scc) + (fun list list_edges -> + let list = Utility.print_newline list in + List.fold_left + (fun list ((a, b), (c, d)) -> + print_edge ((a, b), (c, d)) list) + list list_edges) + [] scc + in + let list = Utility.print_newline list in + let list = + Utility.print_string + "The following bonds may form arbitrary long chains of \ + agents:" + list + in + list + ) + in + [ Html.p output ]) + ~error:(fun mh -> + List.map + (fun m -> + Html.p + [ + Html.txt + (Format.asprintf "@[%a@]" Result_util.print_message m); + ]) + mh)) + in + [ + Tyxml_js.R.Html5.div + ~a:[ Html.a_class [ "panel-pre"; "panel-scroll" ] ] + (ReactiveData.RList.from_signal scc); ] - let parent_hide () = set_tab_is_active false let parent_shown () = set_tab_is_active !tab_was_active let onload () = - let () = Common.jquery_on - "#navpolymers" "hide.bs.tab" - (fun _ -> let () = tab_was_active := false in set_tab_is_active false) in - let () = Common.jquery_on - "#navpolymers" "shown.bs.tab" - (fun _ -> let () = tab_was_active := true in set_tab_is_active true) in + let () = + Common.jquery_on "#navpolymers" "hide.bs.tab" (fun _ -> + let () = tab_was_active := false in + set_tab_is_active false) + in + let () = + Common.jquery_on "#navpolymers" "shown.bs.tab" (fun _ -> + let () = tab_was_active := true in + set_tab_is_active true) + in () + let onresize () : unit = () diff --git a/gui/tab_polymers.mli b/gui/tab_polymers.mli index fd539936b2..66b7f5fa00 100644 --- a/gui/tab_polymers.mli +++ b/gui/tab_polymers.mli @@ -1,4 +1,4 @@ include Ui_common.Tab -val parent_shown: unit -> unit -val parent_hide: unit -> unit +val parent_shown : unit -> unit +val parent_hide : unit -> unit diff --git a/gui/tab_snapshot.ml b/gui/tab_snapshot.ml index 60d25d8148..7c961b2471 100644 --- a/gui/tab_snapshot.ml +++ b/gui/tab_snapshot.ml @@ -10,133 +10,120 @@ open Lwt.Infix module Html = Tyxml_js.Html5 let tab_is_active, set_tab_is_active = React.S.create false + let current_snapshot, set_current_snapshot = React.S.create (None : (string * Data.snapshot) option) type display_format = Kappa | Graph -let string_to_display_format = - function + +let string_to_display_format = function | "Kappa" -> Some Kappa | "Graph" -> Some Graph | _ -> None let display_format, set_display_format = React.S.create Kappa -let snapshot_count - (state : Api_types_j.simulation_info option) : - int = +let snapshot_count (state : Api_types_j.simulation_info option) : int = match state with | None -> 0 | Some state -> - state.Api_types_j.simulation_info_output.Api_types_j.simulation_output_snapshots + state.Api_types_j.simulation_info_output + .Api_types_j.simulation_output_snapshots let navli () = Ui_common.badge (fun state -> snapshot_count state) - let select_id = "snapshot-select-id" let display_id = "snapshot-map-display" -let configuration_template - id - additional_handlers : Widget_export.configuration = - let json_handler = Widget_export.export_json - ~serialize_json:(fun () -> - (match React.S.value current_snapshot with - | None -> "null" - | Some (_,s) -> Data.string_of_snapshot s - ) - ) +let configuration_template id additional_handlers : Widget_export.configuration + = + let json_handler = + Widget_export.export_json ~serialize_json:(fun () -> + match React.S.value current_snapshot with + | None -> "null" + | Some (_, s) -> Data.string_of_snapshot s) in let kappa_handler = - { Widget_export.suffix = "ka" - ; Widget_export.label = "kappa" - ; Widget_export.export = - fun (filename : string) -> + { + Widget_export.suffix = "ka"; + Widget_export.label = "kappa"; + Widget_export.export = + (fun (filename : string) -> let data = Js.string (match React.S.value current_snapshot with | None -> "" - | Some (_,s) -> Api_data.api_snapshot_kappa s) in - Common.saveFile - ~data - ~mime:"application/json" - ~filename:filename + | Some (_, s) -> Api_data.api_snapshot_kappa s) + in + Common.saveFile ~data ~mime:"application/json" ~filename); } in let dot_handler = - { Widget_export.suffix = "dot" - ; Widget_export.label = "dot" - ; Widget_export.export = - fun (filename : string) -> + { + Widget_export.suffix = "dot"; + Widget_export.label = "dot"; + Widget_export.export = + (fun (filename : string) -> let data = Js.string (match React.S.value current_snapshot with | None -> "" - | Some (_,s) -> Api_data.api_snapshot_dot s) in - Common.saveFile - ~data - ~mime:"text/vnd.graphviz" - ~filename:filename + | Some (_, s) -> Api_data.api_snapshot_dot s) + in + Common.saveFile ~data ~mime:"text/vnd.graphviz" ~filename); } in - let default_handlers = - [ json_handler ; - kappa_handler ; - dot_handler ;] - in - { Widget_export.id = id ; - Widget_export.handlers = default_handlers @ additional_handlers ; + let default_handlers = [ json_handler; kappa_handler; dot_handler ] in + { + Widget_export.id; + Widget_export.handlers = default_handlers @ additional_handlers; Widget_export.show = React.S.map (fun model -> - let simulation_info = State_simulation.model_simulation_info model in - snapshot_count simulation_info > 0) - State_simulation.model + let simulation_info = State_simulation.model_simulation_info model in + snapshot_count simulation_info > 0) + State_simulation.model; } (* Only allow the export of non-graphical data. *) let configuration_kappa () : Widget_export.configuration = - configuration_template - "snapshot_kappa" - [] + configuration_template "snapshot_kappa" [] (* The maps are rendered so allow the export of graphical data. *) let configuration_graph () : Widget_export.configuration = - configuration_template - "snapshot_graph" - [ Widget_export.export_svg ~svg_div_id:display_id () - ; Widget_export.export_png ~svg_div_id:display_id () ] + configuration_template "snapshot_graph" + [ + Widget_export.export_svg ~svg_div_id:display_id (); + Widget_export.export_png ~svg_div_id:display_id (); + ] let format_select_id = "format_select_id" -let render_snapshot_graph - (snapshot_js : Js_snapshot.snapshot Js.t) +let render_snapshot_graph (snapshot_js : Js_snapshot.snapshot Js.t) (snapshot : Data.snapshot) : unit = - let () = - Common.debug - (Js.string - (Data.string_of_snapshot snapshot)) - in + let () = Common.debug (Js.string (Data.string_of_snapshot snapshot)) in match React.S.value display_format with | Graph -> let json : string = Data.string_of_snapshot snapshot in let contact_map = - Result_util.fold (React.S.value Tab_contact_map.contact_map_text) + Result_util.fold + (React.S.value Tab_contact_map.contact_map_text) ~ok:(fun x -> x) - ~error:(fun _ -> "null") in + ~error:(fun _ -> "null") + in snapshot_js##setData ~contact_map:(Js.string contact_map) (Js.string json) | Kappa -> () let select_snapshot snapshot_js = - let index = Js.Opt.bind + let index = + Js.Opt.bind (Ui_common.document##getElementById (Js.string select_id)) (fun dom -> - let snapshot_select_dom : Dom_html.inputElement Js.t = - Js.Unsafe.coerce dom in - let fileindex = Js.to_string (snapshot_select_dom##.value) in - try Js.some (int_of_string fileindex) with - _ -> Js.null - ) + let snapshot_select_dom : Dom_html.inputElement Js.t = + Js.Unsafe.coerce dom + in + let fileindex = Js.to_string snapshot_select_dom##.value in + try Js.some (int_of_string fileindex) with _ -> Js.null) in let () = Common.debug index in let model = React.S.value State_simulation.model in @@ -145,171 +132,183 @@ let select_snapshot snapshot_js = | None -> () | Some state -> let index = Js.Opt.get index (fun _ -> 0) in - if snapshot_count (Some state) > 0 then + if snapshot_count (Some state) > 0 then ( let () = - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - manager#simulation_catalog_snapshot >>= - (Api_common.result_bind_lwt - ~ok:(fun snapshot_ids -> + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_catalog_snapshot + >>= Api_common.result_bind_lwt ~ok:(fun snapshot_ids -> try - let snapshot_id : string = - List.nth snapshot_ids index in - manager#simulation_detail_snapshot snapshot_id >>= - Api_common.result_bind_lwt - ~ok:(fun (snapshot : Data.snapshot) -> - let () = - set_current_snapshot - (Some (snapshot_id,snapshot)) in - let () = render_snapshot_graph - snapshot_js snapshot in - Lwt.return (Result_util.ok ())) + let snapshot_id : string = List.nth snapshot_ids index in + manager#simulation_detail_snapshot snapshot_id + >>= Api_common.result_bind_lwt + ~ok:(fun (snapshot : Data.snapshot) -> + let () = + set_current_snapshot + (Some (snapshot_id, snapshot)) + in + let () = + render_snapshot_graph snapshot_js snapshot + in + Lwt.return (Result_util.ok ())) with - | Failure f -> - Lwt.return (Api_common.result_error_msg f) + | Failure f -> Lwt.return (Api_common.result_error_msg f) | Invalid_argument f -> - Lwt.return (Api_common.result_error_msg f) - ) - ) - ) + Lwt.return (Api_common.result_error_msg f))) in () + ) let select (snapshots : Api_types_j.snapshot_id list) = List.mapi (fun i snapshot_id -> - Html.option - ~a:([ Html.a_value (string_of_int i)] - @ - if (match (React.S.value current_snapshot) with - | None -> false - | Some (filename,_) -> filename = snapshot_id) - then [Html.a_selected ()] - else []) - (Html.txt snapshot_id)) + Html.option + ~a: + ([ Html.a_value (string_of_int i) ] + @ + if + match React.S.value current_snapshot with + | None -> false + | Some (filename, _) -> filename = snapshot_id + then + [ Html.a_selected () ] + else + []) + (Html.txt snapshot_id)) snapshots let snapshot_class : - empty:(unit -> 'a) -> - single:(unit -> 'a) -> - multiple:(unit -> 'a) -> 'a React.signal = - fun - ~empty - ~single - ~multiple -> - React.S.map - (fun model -> - let simulation_info = State_simulation.model_simulation_info model in - match snapshot_count simulation_info with - | 0 -> empty () - | 1 -> single () - | _ -> multiple ()) - (React.S.on - tab_is_active State_simulation.dummy_model State_simulation.model) + empty:(unit -> 'a) -> + single:(unit -> 'a) -> + multiple:(unit -> 'a) -> + 'a React.signal = + fun ~empty ~single ~multiple -> + React.S.map + (fun model -> + let simulation_info = State_simulation.model_simulation_info model in + match snapshot_count simulation_info with + | 0 -> empty () + | 1 -> single () + | _ -> multiple ()) + (React.S.on tab_is_active State_simulation.dummy_model + State_simulation.model) let snapshot_js : Js_snapshot.snapshot Js.t = Js_snapshot.create_snapshot display_id State_settings.agent_coloring +let dont_gc_me = ref [] + let xml () = let list, handle = ReactiveData.RList.create [] in (* populate select *) - let _ = React.S.map - (fun _ -> - State_simulation.when_ready - ~label:__LOC__ - (fun manager -> - manager#simulation_catalog_snapshot >>= - (Api_common.result_bind_lwt - ~ok:(fun snapshot_ids -> - let () = ReactiveData.RList.set - handle (select snapshot_ids) in - let () = select_snapshot snapshot_js in - Lwt.return (Result_util.ok ())) - ) - ) - ) - (React.S.on - tab_is_active State_simulation.dummy_model State_simulation.model) in + let () = + dont_gc_me := + [ + React.S.map + (fun _ -> + State_simulation.when_ready ~label:__LOC__ (fun manager -> + manager#simulation_catalog_snapshot + >>= Api_common.result_bind_lwt ~ok:(fun snapshot_ids -> + let () = + ReactiveData.RList.set handle (select snapshot_ids) + in + let () = select_snapshot snapshot_js in + Lwt.return (Result_util.ok ())))) + (React.S.on tab_is_active State_simulation.dummy_model + State_simulation.model); + ] + in let snapshot_label = Html.h4 - ~a:[ Tyxml_js.R.Html.a_class - (snapshot_class - ~empty:(fun () -> ["hidden"]) - ~single:(fun _ -> ["oneliner"; "visible"]) - ~multiple:(fun _ -> ["hidden"])) - ] - [ Tyxml_js.R.Html.txt + ~a: + [ + Tyxml_js.R.Html.a_class + (snapshot_class + ~empty:(fun () -> [ "hidden" ]) + ~single:(fun _ -> [ "oneliner"; "visible" ]) + ~multiple:(fun _ -> [ "hidden" ])); + ] + [ + Tyxml_js.R.Html.txt (React.S.map (fun snapshot -> - match snapshot with - | None -> "" - | Some (snapshot_file,_) -> snapshot_file) - current_snapshot) + match snapshot with + | None -> "" + | Some (snapshot_file, _) -> snapshot_file) + current_snapshot); ] in let snapshot_select = Tyxml_js.R.Html.select - ~a:[ Tyxml_js.R.Html.a_class - (snapshot_class - ~empty:(fun () -> [ "hidden" ]) - ~single:(fun _ -> [ "hidden" ]) - ~multiple:(fun _ -> ["visible" ; "form-control"])) ; - Html.a_id select_id ] + ~a: + [ + Tyxml_js.R.Html.a_class + (snapshot_class + ~empty:(fun () -> [ "hidden" ]) + ~single:(fun _ -> [ "hidden" ]) + ~multiple:(fun _ -> [ "visible"; "form-control" ])); + Html.a_id select_id; + ] list in - let snapshot_chooser = Html.div [ snapshot_label ; snapshot_select ] - in + let snapshot_chooser = Html.div [ snapshot_label; snapshot_select ] in let toggle_controls ~kappa ~graph = Tyxml_js.R.Html.a_class (React.S.map (function | Kappa -> kappa - | Graph -> graph - ) - display_format) in + | Graph -> graph) + display_format) + in let export_controls = - [ Html.div - ~a:[ toggle_controls ~kappa:["visible"] ~graph:["hidden"] ; ] - [ Widget_export.content (configuration_kappa ()) ] ; + [ + Html.div + ~a:[ toggle_controls ~kappa:[ "visible" ] ~graph:[ "hidden" ] ] + [ Widget_export.content (configuration_kappa ()) ]; Html.div - ~a:[ toggle_controls ~kappa:["hidden"] ~graph:["visible"] ; ] - [ Widget_export.content (configuration_graph ()) ] ] + ~a:[ toggle_controls ~kappa:[ "hidden" ] ~graph:[ "visible" ] ] + [ Widget_export.content (configuration_graph ()) ]; + ] in let kappa_snapshot_display = Html.div - ~a:[ Tyxml_js.R.Html.a_class - (React.S.map - (fun display_format -> - "panel-scroll"::"kappa-code"::"flex-content":: - match display_format with - | Kappa -> ["visible"] - | Graph -> ["hidden"]) - display_format - ) - ] - [ Tyxml_js.R.Html.txt + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.map + (fun display_format -> + "panel-scroll" :: "kappa-code" :: "flex-content" + :: + (match display_format with + | Kappa -> [ "visible" ] + | Graph -> [ "hidden" ])) + display_format); + ] + [ + Tyxml_js.R.Html.txt (React.S.map (fun snapshot -> - match snapshot with - | None -> "" - | Some (_,snapshot) -> - Api_data.api_snapshot_kappa snapshot) - current_snapshot) + match snapshot with + | None -> "" + | Some (_, snapshot) -> Api_data.api_snapshot_kappa snapshot) + current_snapshot); ] in let kappa_graph_display = Html.div - ~a:[ Tyxml_js.R.Html.a_class - (React.S.map - (fun display_format -> - "flex-content":: - match display_format with - | Graph -> ["visible"] - | Kappa -> ["hidden"]) - display_format - ) ] - [%html {| + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.map + (fun display_format -> + "flex-content" + :: + (match display_format with + | Graph -> [ "visible" ] + | Kappa -> [ "hidden" ])) + display_format); + ] + [%html + {|
    @@ -317,81 +316,87 @@ let xml () = -
    |}] +
    |}] in let format_chooser = [%html - {| |} ] + {| |}] in - [%html {|
    + [%html + {|
    - |}[ format_chooser ]{| + |} + [ format_chooser ] + {|
    -
    |}[ snapshot_chooser ]{|
    +
    |} + [ snapshot_chooser ] + {|
    - |} [kappa_snapshot_display; kappa_graph_display] {| + |} + [ kappa_snapshot_display; kappa_graph_display ] + {|
    - |}export_controls{| + |} + export_controls + {|
    |}] let content () = - [Ui_common.toggle_element - (fun state -> snapshot_count state > 0) - (xml ()) ] + [ Ui_common.toggle_element (fun state -> snapshot_count state > 0) (xml ()) ] let onload () : unit = let snapshot_select_dom : Dom_html.inputElement Js.t = - Ui_common.id_dom select_id in + Ui_common.id_dom select_id + in let format_select_dom : Dom_html.inputElement Js.t = - Ui_common.id_dom format_select_id in + Ui_common.id_dom format_select_id + in let () = - snapshot_select_dom - ##. - onchange := Dom_html.handler - (fun _ -> - let () = Common.debug ("onchange") in - let () = select_snapshot snapshot_js in Js._true) + snapshot_select_dom##.onchange + := Dom_html.handler (fun _ -> + let () = Common.debug "onchange" in + let () = select_snapshot snapshot_js in + Js._true) in let update_format () = - let format_text : string = (Js.to_string format_select_dom##.value) in + let format_text : string = Js.to_string format_select_dom##.value in match string_to_display_format format_text with | Some format -> - let () = - set_display_format format in + let () = set_display_format format in (match React.S.value current_snapshot with | None -> () - | Some (_,snapshot) -> render_snapshot_graph - (snapshot_js : Js_snapshot.snapshot Js.t) - (snapshot : Data.snapshot)) + | Some (_, snapshot) -> + render_snapshot_graph + (snapshot_js : Js_snapshot.snapshot Js.t) + (snapshot : Data.snapshot)) | None -> assert false in (* get initial value for display format *) let () = update_format () in (* update value for display format *) let () = - format_select_dom - ##. - onchange := Dom_html.handler - (fun _ -> + format_select_dom##.onchange + := Dom_html.handler (fun _ -> let () = update_format () in - Js._true) in - let () = Common.jquery_on - "#navsnapshot" "hide.bs.tab" - (fun _ -> set_tab_is_active false) in + Js._true) + in let () = - Common.jquery_on - "#navsnapshot" "shown.bs.tab" - (fun _ -> - let () = set_tab_is_active true in - ()) in + Common.jquery_on "#navsnapshot" "hide.bs.tab" (fun _ -> + set_tab_is_active false) + in + let () = + Common.jquery_on "#navsnapshot" "shown.bs.tab" (fun _ -> + let () = set_tab_is_active true in + ()) + in let () = Widget_export.onload (configuration_kappa ()) in let () = Widget_export.onload (configuration_graph ()) in () -let onresize () : unit = - if React.S.value tab_is_active then snapshot_js##redraw +let onresize () : unit = if React.S.value tab_is_active then snapshot_js##redraw diff --git a/gui/tab_stories.ml b/gui/tab_stories.ml index 149a95f71c..6549cf67e3 100644 --- a/gui/tab_stories.ml +++ b/gui/tab_stories.ml @@ -11,35 +11,34 @@ open Lwt.Infix let tab_is_active, set_tab_is_active = React.S.create false let tab_was_active = ref false - - let navli () = ReactiveData.RList.empty +let none_checkbox = Html.input ~a:[ Html.a_input_type `Checkbox ] () -let none_checkbox = Html.input ~a:[Html.a_input_type `Checkbox] () -let weak_checkbox = Html.input ~a:[Html.a_input_type `Checkbox; Html.a_checked ()] () -let strong_checkbox = Html.input ~a:[Html.a_input_type `Checkbox] () +let weak_checkbox = + Html.input ~a:[ Html.a_input_type `Checkbox; Html.a_checked () ] () +let strong_checkbox = Html.input ~a:[ Html.a_input_type `Checkbox ] () let none_box = Tyxml_js.To_dom.of_input none_checkbox let weak_box = Tyxml_js.To_dom.of_input weak_checkbox let strong_box = Tyxml_js.To_dom.of_input strong_checkbox -let launch_button = Html.button - ~a:[Html.a_class ["btn"; "btn-default"]; Html.a_button_type `Submit] - [Html.txt "Launch"] +let launch_button = + Html.button + ~a:[ Html.a_class [ "btn"; "btn-default" ]; Html.a_button_type `Submit ] + [ Html.txt "Launch" ] let story_list, list_control = React.S.create [] let story_list_html = ReactiveData.RList.map - (fun (id,cm) -> - Html.option - ~a:[Html.a_value (string_of_int id)] - (Html.txt (Format.asprintf - "@[%i (%a)@]" - id Kastor_client.print_compression_modes cm))) + (fun (id, cm) -> + Html.option + ~a:[ Html.a_value (string_of_int id) ] + (Html.txt + (Format.asprintf "@[%i (%a)@]" id + Kastor_client.print_compression_modes cm))) (ReactiveData.RList.from_signal story_list) - let select_stories = Tyxml_js.R.Html5.select story_list_html let select_stories_dom = Tyxml_js.To_dom.of_select select_stories @@ -47,13 +46,23 @@ let%html setup_form = {|
    -
    -
    -
    +
    +
    +
    -
    |}[launch_button]{|
    +
    |} + [ launch_button ] + {|
    - |}[select_stories]{| + |} + [ select_stories ] + {|
    |} @@ -62,30 +71,41 @@ let current_info, set_info = React.S.create "" let story_log_html = ReactiveData.RList.map - (fun line -> Html.txt (line^"\n")) - (ReactiveData.RList.rev - (ReactiveData.RList.from_signal story_log)) + (fun line -> Html.txt (line ^ "\n")) + (ReactiveData.RList.rev (ReactiveData.RList.from_signal story_log)) -let log_div = Tyxml_js.R.Html5.div - ~a:[Html.a_class ["panel-pre"]] - story_log_html +let log_div = + Tyxml_js.R.Html5.div ~a:[ Html.a_class [ "panel-pre" ] ] story_log_html let log_panel = - [Ui_common.navtabs "storylognavtab" - [ "story_computation_log", None, ReactiveData.RList.empty; - "story_info_log", None, ReactiveData.RList.empty ]; - Ui_common.navcontent ["panel-scroll"] - [ "story_computation_log", [], [log_div]; - "story_info_log", ["panel-pre"], [Tyxml_js.R.Html5.txt current_info]]] + [ + Ui_common.navtabs "storylognavtab" + [ + "story_computation_log", None, ReactiveData.RList.empty; + "story_info_log", None, ReactiveData.RList.empty; + ]; + Ui_common.navcontent [ "panel-scroll" ] + [ + "story_computation_log", [], [ log_div ]; + "story_info_log", [ "panel-pre" ], [ Tyxml_js.R.Html5.txt current_info ]; + ]; + ] let graph_display_id = "story_graph_display" let story_graph = Js_story.create_story_rendering graph_display_id let content () = - [Html.div ~a:[Html.a_class ["col-md-5";"flex-content"]] (setup_form::log_panel); - Html.div - ~a:[Html.a_id graph_display_id; Html.a_class ["col-md-7";"flex-content"]] - [] + [ + Html.div + ~a:[ Html.a_class [ "col-md-5"; "flex-content" ] ] + (setup_form :: log_panel); + Html.div + ~a: + [ + Html.a_id graph_display_id; + Html.a_class [ "col-md-7"; "flex-content" ]; + ] + []; ] let lift_result = function @@ -93,13 +113,12 @@ let lift_result = function | Result.Error e -> Api_common.result_error_msg e let do_update_compression_level () = - State_project.with_project ~label:"Config compression" - (fun manager -> - let causal = Js.to_bool none_box##.checked in - let weak = Js.to_bool weak_box##.checked in - let strong = Js.to_bool strong_box##.checked in - manager#config_story_computation {Api.causal; Api.weak; Api.strong} >|= - lift_result) + State_project.with_project ~label:"Config compression" (fun manager -> + let causal = Js.to_bool none_box##.checked in + let weak = Js.to_bool weak_box##.checked in + let strong = Js.to_bool strong_box##.checked in + manager#config_story_computation { Api.causal; Api.weak; Api.strong } + >|= lift_result) let update_compression_level = Dom_html.handler (fun _ -> @@ -109,100 +128,108 @@ let update_compression_level = let set_a_story = let pred_id = ref max_int in fun () -> - let va = (Js.to_string select_stories_dom##.value) in - if va = "" then + let va = Js.to_string select_stories_dom##.value in + if va = "" then ( let () = pred_id := max_int in Lwt.return (Result_util.ok ()) - else + ) else ( let id = int_of_string va in - if !pred_id <> id then + if !pred_id <> id then ( let () = pred_id := id in - State_project.with_project ~label:"Launch stories" - (fun manager -> - match Mods.IntMap.find_option id manager#story_list with - | None -> Lwt.return (Result_util.ok ()) - | Some (_cm,d,v) -> - let () = set_info - (Format.asprintf "@[ids: @[%a@]@ t=@[%a@]@ event=@[%a@]@]" - (Pp.list - Pp.comma - (Pp.list Pp.comma (fun f d -> - Format.pp_print_int f - d.Trace.Simulation_info.story_id))) d - (Pp.list - Pp.comma - (Pp.list Pp.comma (fun f d -> - Format.pp_print_float f - d.Trace.Simulation_info.story_time))) d - (Pp.list - Pp.comma - (Pp.list Pp.comma (fun f d -> - Format.pp_print_int f - d.Trace.Simulation_info.story_event))) d) in - let () = - story_graph##setData - (Js.string - (Yojson.Basic.to_string (Graph_json.to_json v))) in - Lwt.return (Result_util.ok ())) - else + State_project.with_project ~label:"Launch stories" (fun manager -> + match Mods.IntMap.find_option id manager#story_list with + | None -> Lwt.return (Result_util.ok ()) + | Some (_cm, d, v) -> + let () = + set_info + (Format.asprintf "@[ids: @[%a@]@ t=@[%a@]@ event=@[%a@]@]" + (Pp.list Pp.comma + (Pp.list Pp.comma (fun f d -> + Format.pp_print_int f + d.Trace.Simulation_info.story_id))) + d + (Pp.list Pp.comma + (Pp.list Pp.comma (fun f d -> + Format.pp_print_float f + d.Trace.Simulation_info.story_time))) + d + (Pp.list Pp.comma + (Pp.list Pp.comma (fun f d -> + Format.pp_print_int f + d.Trace.Simulation_info.story_event))) + d) + in + let () = + story_graph##setData + (Js.string (Yojson.Basic.to_string (Graph_json.to_json v))) + in + Lwt.return (Result_util.ok ())) + ) else Lwt.return (Result_util.ok ()) + ) let rec inspect_stories () = - State_project.with_project ~label:"Stories list" - (fun manager -> - let () = - list_control - (Mods.IntMap.fold - (fun id (cm,_,_) acc -> (id,cm) :: acc - ) manager#story_list []) in - let () = log_control manager#story_log in - set_a_story ()) >>= fun _ -> - State_project.with_project ~label:"Stories computing" - (fun manager -> - Lwt.return (Result_util.ok manager#is_computing)) >>= - Result_util.fold - ~ok:(fun b -> if b && React.S.value tab_is_active - then Js_of_ocaml_lwt.Lwt_js.sleep 3. >>= inspect_stories - else Lwt.return_unit) - ~error:(fun _ -> Lwt.return_unit) + State_project.with_project ~label:"Stories list" (fun manager -> + let () = + list_control + (Mods.IntMap.fold + (fun id (cm, _, _) acc -> (id, cm) :: acc) + manager#story_list []) + in + let () = log_control manager#story_log in + set_a_story ()) + >>= fun _ -> + State_project.with_project ~label:"Stories computing" (fun manager -> + Lwt.return (Result_util.ok manager#is_computing)) + >>= Result_util.fold + ~ok:(fun b -> + if b && React.S.value tab_is_active then + Js_of_ocaml_lwt.Lwt_js.sleep 3. >>= inspect_stories + else + Lwt.return_unit) + ~error:(fun _ -> Lwt.return_unit) let parent_hide () = set_tab_is_active false let parent_shown () = set_tab_is_active !tab_was_active let onload () = - let () = Common.jquery_on - "#navstories" "hide.bs.tab" - (fun _ -> let () = tab_was_active := false in set_tab_is_active false) in - let () = Common.jquery_on - "#navstories" "shown.bs.tab" - (fun _ -> - let () = tab_was_active := true in - let () = set_tab_is_active true in - let _ = do_update_compression_level () in - Lwt.async inspect_stories - ) in + let () = + Common.jquery_on "#navstories" "hide.bs.tab" (fun _ -> + let () = tab_was_active := false in + set_tab_is_active false) + in + let () = + Common.jquery_on "#navstories" "shown.bs.tab" (fun _ -> + let () = tab_was_active := true in + let () = set_tab_is_active true in + let _ = do_update_compression_level () in + Lwt.async inspect_stories) + in let () = none_box##.onchange := update_compression_level in let () = weak_box##.onchange := update_compression_level in let () = strong_box##.onchange := update_compression_level in let () = - select_stories_dom##.onchange := - Dom_html.handler (fun _ -> - let _ = set_a_story () in Js._false) in + select_stories_dom##.onchange + := Dom_html.handler (fun _ -> + let _ = set_a_story () in + Js._false) + in let () = - (Tyxml_js.To_dom.of_button launch_button)##.onclick := - Dom_html.handler (fun _ -> - let _ = - State_project.with_project ~label:"Launch stories" - (fun manager -> - if manager#story_is_computing then - Lwt.return (Result_util.ok ()) - else - manager#simulation_raw_trace >>= - Api_common.result_bind_lwt - ~ok:(fun trace -> - manager#raw_launch_story_computation trace >|= - lift_result)) in - let () = Lwt.async inspect_stories in - Js._false) in + (Tyxml_js.To_dom.of_button launch_button)##.onclick + := Dom_html.handler (fun _ -> + let _ = + State_project.with_project ~label:"Launch stories" (fun manager -> + if manager#story_is_computing then + Lwt.return (Result_util.ok ()) + else + manager#simulation_raw_trace + >>= Api_common.result_bind_lwt ~ok:(fun trace -> + manager#raw_launch_story_computation trace + >|= lift_result)) + in + let () = Lwt.async inspect_stories in + Js._false) + in () + let onresize () : unit = () diff --git a/gui/ui_common.ml b/gui/ui_common.ml index fa7b11f870..52839a28ff 100644 --- a/gui/ui_common.ml +++ b/gui/ui_common.ml @@ -8,76 +8,82 @@ module Html = Tyxml_js.Html5 -let toggle_element - (projection : Api_types_j.simulation_info option -> bool) - (content : [< Html_types.div_content_fun ] Html.elt Html.list_wrap) = +let toggle_element (projection : Api_types_j.simulation_info option -> bool) + (content : [< Html_types.div_content_fun ] Html.elt Html.list_wrap) = Html.div - ~a:[Tyxml_js.R.Html.a_class - (React.S.bind - State_simulation.model - (fun model -> React.S.const - (if projection (State_simulation.t_simulation_info - model) then - ["show"] + ~a: + [ + Tyxml_js.R.Html.a_class + (React.S.bind State_simulation.model (fun model -> + React.S.const + (if projection (State_simulation.t_simulation_info model) then + [ "show" ] else - ["hidden"]) - ) - )] + [ "hidden" ]))); + ] content - let option_label label = if String.length label > 10 then - (String.sub label 0 7)^"..." + String.sub label 0 7 ^ "..." else label - -let export_controls - ~(export_select_id : string) - ~(export_filename_id : string) - ~(export_button_id : string) - ~(export_data_label : string) = - let export_formats : string list = - [export_data_label] - in +let export_controls ~(export_select_id : string) ~(export_filename_id : string) + ~(export_button_id : string) ~(export_data_label : string) = + let export_formats : string list = [ export_data_label ] in let export_filename = Html.input - ~a:[ Html.a_id export_filename_id ; - Html.a_input_type `Text; - Html.a_class ["form-control"]; - Html.a_placeholder "file name"] + ~a: + [ + Html.a_id export_filename_id; + Html.a_input_type `Text; + Html.a_class [ "form-control" ]; + Html.a_placeholder "file name"; + ] () in let export_button = Html.button - ~a:[ Html.a_id export_button_id - ; Html.Unsafe.string_attrib "role" "button" - ; Html.a_class ["btn";"btn-default";"pull-right"] - ] + ~a: + [ + Html.a_id export_button_id; + Html.Unsafe.string_attrib "role" "button"; + Html.a_class [ "btn"; "btn-default"; "pull-right" ]; + ] [ Html.cdata "export" ] in let export_formats_select = List.map (fun format -> - [%html {||}]) + [%html + {||}]) export_formats in - [%html {|
    + [%html + {|
    + id="|} + export_select_id + {|">|} + export_formats_select + {|
    @@ -87,206 +93,193 @@ let export_controls let document = Dom_html.window##.document let label_news tab_is_active counter = - let count = - React.S.map - (fun model -> - let simulation_info = - State_simulation.t_simulation_info model in - counter simulation_info) - State_simulation.model in - let bip = ref React.E.never in - let labels, set_labels = ReactiveData.RList.create [] in - let _ = - React.S.map - (fun tab_active -> - let () = React.E.stop !bip in + let last_value = + ref + (let simulation_info = + State_simulation.t_simulation_info + (React.S.value State_simulation.model) + in + counter simulation_info) + in + ReactiveData.RList.from_signal + (React.S.l2 + (fun tab_active model -> if tab_active then - ReactiveData.RList.set set_labels [] - else - bip := - React.E.map - (fun v -> - ReactiveData.RList.set - set_labels - (if v > 0 then - [ Html.txt " " ; - Html.span - ~a:[ Html.a_class ["label";"label-default"] ] - [ Html.txt "New" ; ] ] - else []) - ) - (React.S.changes count) - ) - tab_is_active in - labels - -let badge - (counter : Api_types_j.simulation_info option -> int) = - let badge, badge_handle = ReactiveData.RList.create [] in - let _ = React.S.map - (fun model -> - let simulation_info = - State_simulation.t_simulation_info model in - let count = counter simulation_info in - if count > 0 then - ReactiveData.RList.set - badge_handle - [ Html.txt " " ; + [] + else ( + let simulation_info = State_simulation.t_simulation_info model in + let v = counter simulation_info in + if v <> !last_value && v > 0 then ( + let () = last_value := v in + [ + Html.txt " "; Html.span - ~a:[ Html.a_class ["badge"] ; ] - [ Html.txt (string_of_int count) ; ] ; + ~a:[ Html.a_class [ "label"; "label-default" ] ] + [ Html.txt "New" ]; ] + ) else + [] + )) + tab_is_active State_simulation.model) + +let badge (counter : Api_types_j.simulation_info option -> int) = + ReactiveData.RList.from_signal + (React.S.map + (fun model -> + let simulation_info = State_simulation.t_simulation_info model in + let count = counter simulation_info in + if count > 0 then + [ + Html.txt " "; + Html.span + ~a:[ Html.a_class [ "badge" ] ] + [ Html.txt (string_of_int count) ]; + ] else - ReactiveData.RList.set badge_handle [] - ) - State_simulation.model in - badge + []) + State_simulation.model) let arguments (key : string) : string list = - List.map - snd - (List.filter - (fun (k,_) -> key = k) - Url.Current.arguments) + List.map snd (List.filter (fun (k, _) -> key = k) Url.Current.arguments) -let version - ?(test:'a option = None) - ~(prod:'a) - ~(dev:'a) - :'a = +let version ?(test : 'a option = None) ~(prod : 'a) ~(dev : 'a) : 'a = let version : string list = arguments "version" in - match (test,version) with - | (Some test,["test"]) -> test - | (_,["dev"]) -> dev + match test, version with + | Some test, [ "test" ] -> test + | _, [ "dev" ] -> dev | _ -> prod let navli label force_class decorations = let default_attributes = - [ Html.a_id ("nav"^label) - ; Html.a_role [ "presentation" ] ] + [ Html.a_id ("nav" ^ label); Html.a_role [ "presentation" ] ] in let attributes = match force_class with | None -> default_attributes - | Some l -> - (Tyxml_js.R.Html5.a_class l)::default_attributes + | Some l -> Tyxml_js.R.Html5.a_class l :: default_attributes in let text = ReactiveData.RList.concat - (ReactiveData.RList.singleton (Html.cdata label)) decorations in + (ReactiveData.RList.singleton (Html.cdata label)) + decorations + in Html.li ~a:attributes - [ Tyxml_js.R.Html.a ~a:[ Html.Unsafe.string_attrib "data-toggle" "tab" - ; Html.a_role ["tab"] - ; Html.Unsafe.string_attrib "aria-controls" label - ; Html.a_href ("#"^label) ] - text + [ + Tyxml_js.R.Html.a + ~a: + [ + Html.Unsafe.string_attrib "data-toggle" "tab"; + Html.a_role [ "tab" ]; + Html.Unsafe.string_attrib "aria-controls" label; + Html.a_href ("#" ^ label); + ] + text; ] let navtabs nav_tab_id = function | [] | (_, Some _, _) :: _ -> Common.toss "ui_common.navtabs : missing tabs" - | (ti,None,l) :: t -> + | (ti, None, l) :: t -> Html.ul - ~a:[ Html.a_id nav_tab_id - ; Html.a_class ["nav";"nav-tabs"] - ; Html.Unsafe.string_attrib "role" "tablist" ] - (navli ti (Some (React.S.const ["active"])) l :: - List.map (fun (t,a_class,li) -> navli t a_class li) t) + ~a: + [ + Html.a_id nav_tab_id; + Html.a_class [ "nav"; "nav-tabs" ]; + Html.Unsafe.string_attrib "role" "tablist"; + ] + (navli ti (Some (React.S.const [ "active" ])) l + :: List.map (fun (t, a_class, li) -> navli t a_class li) t) let onenavcontent label active classes content = Html.div - ~a:[ Html.a_id label - ; Html.a_class - (if active then - "flex-content" :: "tab-pane" :: "active" :: classes - else - "flex-content" :: "tab-pane" :: classes) - ; Html.Unsafe.string_attrib "role" "tabpanel" ] content + ~a: + [ + Html.a_id label; + Html.a_class + (if active then + "flex-content" :: "tab-pane" :: "active" :: classes + else + "flex-content" :: "tab-pane" :: classes); + Html.Unsafe.string_attrib "role" "tabpanel"; + ] + content let navcontent ?id classes = function | [] -> Common.toss "ui_common.navcontent : missing content" - | (t,cl,c) :: l -> + | (t, cl, c) :: l -> let id : [> `Id ] Html.attrib list = match id with | None -> [] | Some id -> [ Html.a_id id ] in Html.div - ~a:([ Html.a_class - (["panel-content";"tab-content";"flex-content"]@classes) ; ]@id) - (onenavcontent t true cl c :: - List.map (fun (t,cl,c) -> onenavcontent t false cl c) l) + ~a: + ([ + Html.a_class + ([ "panel-content"; "tab-content"; "flex-content" ] @ classes); + ] + @ id) + (onenavcontent t true cl c + :: List.map (fun (t, cl, c) -> onenavcontent t false cl c) l) -let level - ?debug - ?info - ?notice - ?warning - ?error - ?fatal - () : 'a list = +let level ?debug ?info ?notice ?warning ?error ?fatal () : 'a list = let level : string list = arguments "level" in let extract key value = match value with | None -> [] | Some value -> - if List.mem key level then - [value] - else - [] + if List.mem key level then + [ value ] + else + [] in - (extract "debug" debug)@ - (extract "info" info)@ - (extract "notice" notice)@ - (extract "warning" warning)@ - (extract "error" error)@ - (extract "fatal" fatal)@ - [] + extract "debug" debug @ extract "info" info @ extract "notice" notice + @ extract "warning" warning @ extract "error" error @ extract "fatal" fatal + @ [] -let features - ?(default=[]) - (options :(string * 'a) list) : 'a list = +let features ?(default = []) (options : (string * 'a) list) : 'a list = let features : string list = arguments "feature" in let matches : 'a list = - List.map - snd - (List.filter - (fun (feature,_) -> List.mem feature features) - options) + List.map snd + (List.filter (fun (feature, _) -> List.mem feature features) options) in match matches with | [] -> default - | _::_ -> matches + | _ :: _ -> matches let input_change input_dom signal_handler = input_dom##.onchange := - Dom_html.handler - (fun _ -> - let () = signal_handler (Js.to_string (input_dom##.value)) in - Js._true) + Dom_html.handler (fun _ -> + let () = signal_handler (Js.to_string input_dom##.value) in + Js._true) module type Menu = sig val content : - unit -> [> `Button | `Div | `Ul | `A of [> `PCDATA | `Span ]] Tyxml_js.Html5.elt list + unit -> + [> `Button | `Div | `Ul | `A of [> `PCDATA | `Span ] ] Tyxml_js.Html5.elt + list + val onload : unit -> unit -end;; +end module type Div = sig val id : string val content : unit -> Html_types.div_content_fun Tyxml_js.Html.elt list val onload : unit -> unit -end;; +end module type Tab = sig val navli : unit -> Html_types.flow5_without_interactive Tyxml_js.Html5.elt ReactiveData.RList.t + val content : unit -> Html_types.div_content_fun Tyxml_js.Html5.elt list val onload : unit -> unit val onresize : unit -> unit -end;; +end module type SubTab = sig include Tab + val parent_hide : unit -> unit val parent_shown : unit -> unit end @@ -295,63 +288,79 @@ module type Panel = sig val content : unit -> Html_types.div Tyxml_js.Html5.elt val onload : unit -> unit val onresize : unit -> unit -end;; +end let id_dom (id : string) : 'a Js.t = Js.Unsafe.coerce - ((Js.Opt.get (document##getElementById (Js.string id)) - (fun () -> - Common.toss - (Format.sprintf "ui_common.id_dom : could not find id %s" id))) - : Dom_html.element Js.t) + (Js.Opt.get + (document##getElementById (Js.string id)) + (fun () -> + Common.toss + (Format.sprintf "ui_common.id_dom : could not find id %s" id)) + : Dom_html.element Js.t) -let create_modal - ~(id : string) - ~(title_label : string) +let create_modal ~(id : string) ~(title_label : string) ~(body : [< Html_types.div_content_fun ] Html.elt Html.list_wrap) - ~(submit_label: string) - ~(submit: ('self Js.t, _ Js.t) Dom.event_listener) : - [> Html_types.div ] Html.elt = + ~(submit_label : string) ~(submit : ('self Js.t, _ Js.t) Dom.event_listener) + : [> Html_types.div ] Html.elt = let button = - Html.button - ~a:[ Html.a_button_type `Submit; - Html.a_class [ "btn" ; "btn-primary"; ] ] - [ Html.txt submit_label ] in + Html.button + ~a:[ Html.a_button_type `Submit; Html.a_class [ "btn"; "btn-primary" ] ] + [ Html.txt submit_label ] + in let form = Html.form ~a:[ Html.a_class [ "modal-content" ] ] - [ Html.div + [ + Html.div ~a:[ Html.a_class [ "modal-header" ] ] - [ Html.button - ~a:[ Html.Unsafe.string_attrib "type" "button" ; - Html.a_class [ "close" ] ; - Html.Unsafe.string_attrib "data-dismiss" "modal" ; - Html.Unsafe.string_attrib "aria-label" "Close" ; ] - [ Html.span + [ + Html.button + ~a: + [ + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "close" ]; + Html.Unsafe.string_attrib "data-dismiss" "modal"; + Html.Unsafe.string_attrib "aria-label" "Close"; + ] + [ + Html.span ~a:[ Html.Unsafe.string_attrib "aria-hidden" "true" ] - [ Html.entity "times" ] - ] ; - Html.h4 [ Html.cdata title_label ]] ; - Html.div ~a:[ Html.a_class [ "modal-body" ] ] body ; - Html.div ~a:[ Html.a_class [ "modal-footer" ] ] - ([ Html.button - ~a:[ Html.Unsafe.string_attrib "type" "button" ; - Html.a_class [ "btn" ; "btn-default" ] ; - Html.Unsafe.string_attrib "data-dismiss" "modal" ; - ] - [ Html.cdata "Cancel" ] ; - ]@[button]) - ] in - let () = - (Tyxml_js.To_dom.of_form form)##.onsubmit := submit in - Html.div - ~a:[ Html.a_class [ "modal" ; "fade" ] ; - Html.a_id id ; - Html.Unsafe.string_attrib "tabindex" "-1" ; - Html.Unsafe.string_attrib "role" "dialog" ; - ] - [ Html.div - ~a:[ Html.a_class [ "modal-dialog" ] ; - Html.Unsafe.string_attrib "role" "document" ; + [ Html.entity "times" ]; + ]; + Html.h4 [ Html.cdata title_label ]; + ]; + Html.div ~a:[ Html.a_class [ "modal-body" ] ] body; + Html.div + ~a:[ Html.a_class [ "modal-footer" ] ] + ([ + Html.button + ~a: + [ + Html.Unsafe.string_attrib "type" "button"; + Html.a_class [ "btn"; "btn-default" ]; + Html.Unsafe.string_attrib "data-dismiss" "modal"; + ] + [ Html.cdata "Cancel" ]; ] - [ form ] ] + @ [ button ]); + ] + in + let () = (Tyxml_js.To_dom.of_form form)##.onsubmit := submit in + Html.div + ~a: + [ + Html.a_class [ "modal"; "fade" ]; + Html.a_id id; + Html.Unsafe.string_attrib "tabindex" "-1"; + Html.Unsafe.string_attrib "role" "dialog"; + ] + [ + Html.div + ~a: + [ + Html.a_class [ "modal-dialog" ]; + Html.Unsafe.string_attrib "role" "document"; + ] + [ form ]; + ] diff --git a/gui/ui_common.mli b/gui/ui_common.mli index f65d3cfe60..fb9e9fbdcf 100644 --- a/gui/ui_common.mli +++ b/gui/ui_common.mli @@ -8,51 +8,53 @@ module Html = Tyxml_js.Html5 -val toggle_element: +val toggle_element : (Api_types_j.simulation_info option -> bool) -> - [< Html_types.div_content_fun ] Html.elt list -> - [> Html_types.div ] Html.elt - + [< Html_types.div_content_fun ] Html.elt list -> + [> Html_types.div ] Html.elt -val export_controls: +val export_controls : export_select_id:string -> export_filename_id:string -> export_button_id:string -> - export_data_label:string -> [> Html_types.div ] Html.elt - -val badge: - (Api_types_j.simulation_info option -> int) -> -[> `PCDATA | `Span ] Html.elt Tyxml_js.Wrap.tlist - -val arguments: string -> string list + export_data_label:string -> + [> Html_types.div ] Html.elt -val version: - ?test:'a option -> prod:'a -> dev:'a -> 'a +val badge : + (Api_types_j.simulation_info option -> int) -> + [> `PCDATA | `Span ] Html.elt Tyxml_js.Wrap.tlist +val arguments : string -> string list +val version : ?test:'a option -> prod:'a -> dev:'a -> 'a module type Menu = sig val content : - unit -> [> `Button | `Div | `Ul | `A of [> `PCDATA | `Span ]] Tyxml_js.Html5.elt list + unit -> + [> `Button | `Div | `Ul | `A of [> `PCDATA | `Span ] ] Tyxml_js.Html5.elt + list + val onload : unit -> unit -end;; +end module type Div = sig val id : string val content : unit -> Html_types.div_content_fun Tyxml_js.Html.elt list val onload : unit -> unit -end;; +end module type Tab = sig val navli : unit -> Html_types.flow5_without_interactive Tyxml_js.Html5.elt ReactiveData.RList.t + val content : unit -> Html_types.div_content_fun Tyxml_js.Html5.elt list val onload : unit -> unit val onresize : unit -> unit -end;; +end module type SubTab = sig include Tab + val parent_hide : unit -> unit val parent_shown : unit -> unit end @@ -63,21 +65,28 @@ module type Panel = sig val onresize : unit -> unit end -val id_dom: string -> 'a Js.t -val document: Dom_html.document Js.t -val navtabs: +val id_dom : string -> 'a Js.t +val document : Dom_html.document Js.t + +val navtabs : string -> - (string * Html_types.nmtokens Tyxml_js.Wrap.t option * - Html_types.flow5_without_interactive Html.elt Tyxml_js.Wrap.tlist) - list -> + (string + * Html_types.nmtokens Tyxml_js.Wrap.t option + * Html_types.flow5_without_interactive Html.elt Tyxml_js.Wrap.tlist) + list -> [> Html_types.ul ] Html.elt -val level: + +val level : ?debug:'a -> ?info:'a -> ?notice:'a -> - ?warning:'a -> ?error:'a -> ?fatal:'a -> unit -> 'a list + ?warning:'a -> + ?error:'a -> + ?fatal:'a -> + unit -> + 'a list -val create_modal: +val create_modal : id:string -> title_label:string -> body:[< Html_types.div_content_fun ] Html.elt list -> @@ -85,20 +94,18 @@ val create_modal: submit:('a Js.t, Dom_html.submitEvent Js.t) Dom_html.event_listener -> [> Html_types.div ] Html.elt -val navcontent: +val navcontent : ?id:string -> string list -> - (string * string list * - [< Html_types.div_content_fun ] Html.elt list) list -> + (string * string list * [< Html_types.div_content_fun ] Html.elt list) list -> [> Html_types.div ] Html.elt -val option_label:string -> string +val option_label : string -> string -val label_news: +val label_news : bool Tyxml_js.Wrap.t -> (Api_types_j.simulation_info option -> int) -> [> `PCDATA | `Span ] Html.elt Tyxml_js.Wrap.tlist -val features: ?default:'a list -> (string * 'a) list -> 'a list -val input_change: - Dom_html.inputElement Js.t -> (string -> unit) -> unit +val features : ?default:'a list -> (string * 'a) list -> 'a list +val input_change : Dom_html.inputElement Js.t -> (string -> unit) -> unit diff --git a/gui/utility.ml b/gui/utility.ml index acf95251fc..8ca7a826e0 100644 --- a/gui/utility.ml +++ b/gui/utility.ml @@ -8,89 +8,74 @@ module Html = Tyxml_js.Html5 -let print_string s list = (Html.txt s)::list +let print_string s list = Html.txt s :: list let print_newline list = print_string "\n" list let print_single_binding_state a list = - print_string - Public_data.binding_state_opening_backend_symbol - (print_string - a - ( - print_string - Public_data.binding_state_closing_backend_symbol list)) + print_string Public_data.binding_state_opening_backend_symbol + (print_string a + (print_string Public_data.binding_state_closing_backend_symbol list)) let print_single_internal_state a list = - print_string - Public_data.internal_state_opening_backend_symbol - (print_string - a - ( - print_string - Public_data.internal_state_closing_backend_symbol list)) + print_string Public_data.internal_state_opening_backend_symbol + (print_string a + (print_string Public_data.internal_state_closing_backend_symbol list)) -let print_counter_interval (a,b) list = +let print_counter_interval (a, b) list = let open_range, inf = match a with - | None -> Public_data.open_interval_exclusive_symbol, Public_data.minus_infinity_symbol + | None -> + ( Public_data.open_interval_exclusive_symbol, + Public_data.minus_infinity_symbol ) | Some a -> Public_data.open_interval_inclusive_symbol, string_of_int a in let close_range, sup = match b with - | None -> Public_data.close_interval_exclusive_symbol, Public_data.plus_infinity_symbol + | None -> + ( Public_data.close_interval_exclusive_symbol, + Public_data.plus_infinity_symbol ) | Some b -> Public_data.close_interval_inclusive_symbol, string_of_int b in print_string open_range (print_string inf (print_string Public_data.counter_state_range_backend_symbol - (print_string sup - (print_string close_range list)))) + (print_string sup (print_string close_range list)))) -let print_counter_state (a,b) list = - print_string - Public_data.counter_state_opening_backend_symbol - (print_counter_interval (a,b) +let print_counter_state (a, b) list = + print_string Public_data.counter_state_opening_backend_symbol + (print_counter_interval (a, b) (print_string Public_data.counter_state_closing_backend_symbol list)) let print_site site list = let site_name, prop_opt, binding_opt, counter_opt = site in let list = match binding_opt with - | None -> - print_string Public_data.missing_binding_site_backend_symbol list - | Some Public_data.Free -> - print_single_binding_state - Public_data.free_backend_symbol list + | None -> print_string Public_data.missing_binding_site_backend_symbol list + | Some Public_data.Free -> + print_single_binding_state Public_data.free_backend_symbol list | Some Public_data.Wildcard -> - print_single_binding_state - Public_data.wildcard_backend_symbol list + print_single_binding_state Public_data.wildcard_backend_symbol list | Some Public_data.Bound_to_unknown -> - print_single_binding_state - Public_data.bound_to_unknown_backend_symbol list - | Some (Public_data.Binding_type (agent_name,site_name)) -> - let binding_type_symbol = - Public_data.binding_type_backend_symbol - in - print_single_binding_state - (Public_data.string_of_binding_type - ~binding_type_symbol ~agent_name ~site_name ()) + print_single_binding_state Public_data.bound_to_unknown_backend_symbol list - | Some (Public_data.Bound_to i) -> + | Some (Public_data.Binding_type (agent_name, site_name)) -> + let binding_type_symbol = Public_data.binding_type_backend_symbol in print_single_binding_state - (string_of_int i) + (Public_data.string_of_binding_type ~binding_type_symbol ~agent_name + ~site_name ()) list + | Some (Public_data.Bound_to i) -> + print_single_binding_state (string_of_int i) list in let list = match counter_opt with | None -> list - | Some a -> - print_counter_state a list + | Some a -> print_counter_state a list in let list = match prop_opt with | None -> list - | Some a -> - print_single_internal_state a list + | Some a -> print_single_internal_state a list in print_string site_name list @@ -100,48 +85,51 @@ let print_agent agent list = let list = snd (List.fold_left - (fun (b,list) site -> - let list = - if b then - print_string "," list - else - list - in - let list = print_site site list in - true,list) - (false,list) interface) + (fun (b, list) site -> + let list = + if b then + print_string "," list + else + list + in + let list = print_site site list in + true, list) + (false, list) interface) in - let list = (Html.txt "(")::list in - let list = (Html.txt agent_name)::list in + let list = Html.txt "(" :: list in + let list = Html.txt agent_name :: list in list let print_site_graph agent_list list = - snd ( - List.fold_left - (fun (b,list) agent -> + snd + (List.fold_left + (fun (b, list) agent -> let list = if b then print_string "," list - else list + else + list in true, print_agent agent list) - (false,list) - (List.rev agent_list)) + (false, list) (List.rev agent_list)) let print_method_handler mh = let uncaught = Exception_without_parameter.get_uncaught_exception_list mh in let caught = Exception_without_parameter.get_caught_exception_list mh in List.fold_right (fun x l -> - Html.p - [Html.txt - (Format.asprintf - "%a" Exception_without_parameter.pp_caught x)]::l) + Html.p + [ + Html.txt + (Format.asprintf "%a" Exception_without_parameter.pp_caught x); + ] + :: l) caught (List.map (fun x -> - Html.p - [Html.txt - (Format.asprintf - "%a" Exception_without_parameter.pp_uncaught x)]) + Html.p + [ + Html.txt + (Format.asprintf "%a" Exception_without_parameter.pp_uncaught x); + ]) uncaught) diff --git a/gui/utility.mli b/gui/utility.mli index 159f40adcd..52d7701db9 100644 --- a/gui/utility.mli +++ b/gui/utility.mli @@ -8,17 +8,21 @@ module Html = Tyxml_js.Html5 -val print_newline: ([> `PCDATA ] as 'a) Html.elt list -> 'a Html.elt list -val print_string: - string Html.wrap -> - ([> `PCDATA ] as 'a) Html.elt list -> 'a Html.elt list -val print_site_graph: - (string Html.wrap * - (string Html.wrap * string Html.wrap option * - Public_data.binding_state option * - (int option * int option) option) - list) - list -> ([> `PCDATA ] as 'a) Html.elt list -> 'a Html.elt list +val print_newline : ([> `PCDATA ] as 'a) Html.elt list -> 'a Html.elt list + +val print_string : + string Html.wrap -> ([> `PCDATA ] as 'a) Html.elt list -> 'a Html.elt list + +val print_site_graph : + (string Html.wrap + * (string Html.wrap + * string Html.wrap option + * Public_data.binding_state option + * (int option * int option) option) + list) + list -> + ([> `PCDATA ] as 'a) Html.elt list -> + 'a Html.elt list val print_method_handler : - Exception_without_parameter.method_handler -> [> Html_types.p ] Html.elt list + Exception_without_parameter.method_handler -> [> Html_types.p ] Html.elt list diff --git a/gui/web_worker_api.ml b/gui/web_worker_api.ml index a8c0cd07f7..a53059e7c1 100644 --- a/gui/web_worker_api.ml +++ b/gui/web_worker_api.ml @@ -14,109 +14,142 @@ class manager () = let kamoha_worker = Worker.create "KaMoHaWorker.js" in let kamoha_mailbox = Kamoha_client.new_mailbox () in let kastor_worker = Worker.create "KaStorWorker.js" in - let stor_state,update_stor_state = Kastor_client.init_state () in - object(self) + let stor_state, update_stor_state = Kastor_client.init_state () in + object (self) val sim_worker = Worker.create "KaSimWorker.js" val mutable is_running = true + initializer - let () = kasa_worker##.onmessage := - (Dom.handler - (fun response_message -> - let response_text = response_message##.data in - let () = Common.debug response_text in - let () = Kasa_client.receive kasa_mailbox response_text in - Js._true - )) in - let () = kamoha_worker##.onmessage := - (Dom.handler - (fun response_message -> - let response_text = response_message##.data in - let () = Common.debug response_text in - let () = Kamoha_client.receive kamoha_mailbox response_text in - Js._true - )) in - let () = kastor_worker##.onmessage := - (Dom.handler - (fun response_message -> - let response_text = response_message##.data in - let () = Common.debug response_text in - let () = Kastor_client.receive update_stor_state response_text in - Js._true - )) in - let () = sim_worker##.onmessage := - (Dom.handler - (fun (response_message : string Worker.messageEvent Js.t) -> - let response_text : string = response_message##.data in - let () = self#receive response_text in - Js._true - )) in - let () = sim_worker##.onerror := - (Dom.handler - (fun _ -> let () = is_running <- false in Js._true)) in - let () = kasa_worker##.onerror := - (Dom.handler - (fun _ -> let () = is_running <- false in Js._true)) in - let () = kamoha_worker##.onerror := - (Dom.handler - (fun _ -> let () = is_running <- false in Js._true)) in - let () = kastor_worker##.onerror := - (Dom.handler - (fun _ -> let () = is_running <- false in Js._true)) in - () + let () = + kasa_worker##.onmessage := + Dom.handler (fun response_message -> + let response_text = response_message##.data in + let () = Common.debug response_text in + let () = Kasa_client.receive kasa_mailbox response_text in + Js._true) + in + let () = + kamoha_worker##.onmessage := + Dom.handler (fun response_message -> + let response_text = response_message##.data in + let () = Common.debug response_text in + let () = Kamoha_client.receive kamoha_mailbox response_text in + Js._true) + in + let () = + kastor_worker##.onmessage := + Dom.handler (fun response_message -> + let response_text = response_message##.data in + let () = Common.debug response_text in + let () = Kastor_client.receive update_stor_state response_text in + Js._true) + in + let () = + sim_worker##.onmessage := + Dom.handler + (fun (response_message : string Worker.messageEvent Js.t) -> + let response_text : string = response_message##.data in + let () = self#receive response_text in + Js._true) + in + let () = + sim_worker##.onerror := + Dom.handler (fun _ -> + let () = is_running <- false in + Js._true) + in + let () = + kasa_worker##.onerror := + Dom.handler (fun _ -> + let () = is_running <- false in + Js._true) + in + let () = + kamoha_worker##.onerror := + Dom.handler (fun _ -> + let () = is_running <- false in + Js._true) + in + let () = + kastor_worker##.onerror := + Dom.handler (fun _ -> + let () = is_running <- false in + Js._true) + in + () + method private sleep timeout = Js_of_ocaml_lwt.Lwt_js.sleep timeout + method private post_message (message_text : string) : unit = - sim_worker##postMessage(message_text) + sim_worker##postMessage message_text + inherit Mpi_api.manager () - inherit Kasa_client.new_uniform_client + + inherit + Kasa_client.new_uniform_client ~is_running:(fun () -> true) ~post:(fun message_text -> - let () = Common.debug (Js.string message_text) in - kasa_worker##postMessage(message_text)) + let () = Common.debug (Js.string message_text) in + kasa_worker##postMessage message_text) kasa_mailbox - inherit Kamoha_client.new_client + + inherit + Kamoha_client.new_client ~post:(fun message_text -> - let () = Common.debug (Js.string message_text) in - kamoha_worker##postMessage(message_text)) + let () = Common.debug (Js.string message_text) in + kamoha_worker##postMessage message_text) kamoha_mailbox - inherit Kastor_client.new_client + + inherit + Kastor_client.new_client ~post:(fun message_text -> - let () = Common.debug (Js.string message_text) in - kastor_worker##postMessage(message_text)) + let () = Common.debug (Js.string message_text) in + kastor_worker##postMessage message_text) stor_state val mutable kasa_locator = [] method project_parse ~patternSharing overwrites = - self#secret_project_parse >>= - Api_common.result_bind_lwt - ~ok:(fun out -> - let load = self#secret_simulation_load patternSharing out overwrites in - let init = self#init_static_analyser out in - let locators = - init >>= Result_util.fold - ~error:(fun e -> - let () = kasa_locator <- [] in - Lwt.return (Result_util.error e)) - ~ok:(fun () -> - self#secret_get_pos_of_rules_and_vars >>= Result_util.fold - ~ok:(fun infos -> - let () = kasa_locator <- infos in - Lwt.return (Result_util.ok ())) + self#secret_project_parse + >>= Api_common.result_bind_lwt ~ok:(fun out -> + let load = + self#secret_simulation_load patternSharing out overwrites + in + let init = self#init_static_analyser out in + let locators = + init + >>= Result_util.fold ~error:(fun e -> - let () = kasa_locator <- [] in - Lwt.return (Result_util.error e))) in - load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) + let () = kasa_locator <- [] in + Lwt.return (Result_util.error e)) + ~ok:(fun () -> + self#secret_get_pos_of_rules_and_vars + >>= Result_util.fold + ~ok:(fun infos -> + let () = kasa_locator <- infos in + Lwt.return (Result_util.ok ())) + ~error:(fun e -> + let () = kasa_locator <- [] in + Lwt.return (Result_util.error e))) + in + load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) method get_influence_map_node_at ~filename pos : _ Api.result Lwt.t = - List.find_opt (fun (_,x) -> Locality.is_included_in filename pos x) kasa_locator |> - Option_util.map fst |> Result_util.ok ?status:None |> Lwt.return + List.find_opt + (fun (_, x) -> Loc.is_included_in filename pos x) + kasa_locator + |> Option_util.map fst + |> Result_util.ok ?status:None + |> Lwt.return method is_running = is_running + method terminate = let () = sim_worker##terminate in kasa_worker##terminate method is_computing = - self#sim_is_computing || Kasa_client.is_computing kasa_mailbox || - self#story_is_computing + self#sim_is_computing + || Kasa_client.is_computing kasa_mailbox + || self#story_is_computing end diff --git a/gui/widget_export.ml b/gui/widget_export.ml index 3233e0bf9e..f1a4f4c452 100644 --- a/gui/widget_export.ml +++ b/gui/widget_export.ml @@ -8,171 +8,158 @@ module Html = Tyxml_js.Html5 -type handler = - { suffix : string; - label: string; - export : string -> unit } +type handler = { suffix: string; label: string; export: string -> unit } -type configuration = - { id : string ; - handlers : handler list; - show : bool React.signal } +type configuration = { + id: string; + handlers: handler list; + show: bool React.signal; +} -let export_format_id - (configuration : configuration) : string = +let export_format_id (configuration : configuration) : string = Format.sprintf "export_%s_select" configuration.id -let export_filename_id - (configuration : configuration) : string = +let export_filename_id (configuration : configuration) : string = Format.sprintf "export_%s_filename" configuration.id -let export_button_id - (configuration : configuration) : string = +let export_button_id (configuration : configuration) : string = Format.sprintf "export_%s_button" configuration.id -let export_data_label - (configuration : configuration) : string = +let export_data_label (configuration : configuration) : string = Format.sprintf "export_%s_label" configuration.id -let export_form_id - (configuration : configuration) : string = +let export_form_id (configuration : configuration) : string = Format.sprintf "export_%s_form" configuration.id -let inline_content - (configuration : configuration) = +let inline_content (configuration : configuration) = let export_filename = Html.input - ~a:[ Html.a_id (export_filename_id configuration) - ; Html.a_input_type `Text - ; Html.a_class ["form-control"] - ; Html.a_placeholder "file name" ] + ~a: + [ + Html.a_id (export_filename_id configuration); + Html.a_input_type `Text; + Html.a_class [ "form-control" ]; + Html.a_placeholder "file name"; + ] () in let export_button = Html.button - ~a:[ Html.a_id (export_button_id configuration) - ; Html.Unsafe.string_attrib "role" "button" - ; Html.a_class ["btn";"btn-default"] - ; Tyxml_js.R.filter_attrib (Html.a_disabled ()) (React.S.map not configuration.show) - ] + ~a: + [ + Html.a_id (export_button_id configuration); + Html.Unsafe.string_attrib "role" "button"; + Html.a_class [ "btn"; "btn-default" ]; + Tyxml_js.R.filter_attrib (Html.a_disabled ()) + (React.S.map not configuration.show); + ] [ Html.cdata "export" ] in let export_formats_select = List.map (fun handler -> - [%html {||}]) + [%html + {||}]) configuration.handlers in - [%html {|
    - + |} + export_formats_select + {|
    - - |}[export_filename]{| + + |} + [ export_filename ] + {|
    - |}]@[export_button] + |}] + @ [ export_button ] let content configuration = Html.form - ~a:[Html.a_id (export_form_id configuration); - Html.a_class ["form-inline"]; - ] + ~a: + [ + Html.a_id (export_form_id configuration); Html.a_class [ "form-inline" ]; + ] (inline_content configuration) -let onload (configuration : configuration) = +let onload (configuration : configuration) = let export_button : Dom_html.buttonElement Js.t = - Ui_common.id_dom (export_button_id configuration) in + Ui_common.id_dom (export_button_id configuration) + in let export_filename : Dom_html.inputElement Js.t = - Ui_common.id_dom (export_filename_id configuration) in + Ui_common.id_dom (export_filename_id configuration) + in let export_format : Dom_html.selectElement Js.t = - Ui_common.id_dom (export_format_id configuration) in + Ui_common.id_dom (export_format_id configuration) + in let export_button_toggle () : unit = let is_disabled : bool Js.t = Js.bool - (not (React.S.value configuration.show) || export_filename##.value##trim##.length = 0) - in - let () = - export_button##.disabled := is_disabled + ((not (React.S.value configuration.show)) + || export_filename##.value##trim##.length = 0) in + let () = export_button##.disabled := is_disabled in () in - let () = - export_button_toggle () - in + let () = export_button_toggle () in let () = export_filename##.oninput := - Dom_html.handler - (fun _ -> - let () = export_button_toggle () in - Js._false) + Dom_html.handler (fun _ -> + let () = export_button_toggle () in + Js._false) in let () = export_button##.onclick := - Dom_html.handler - (fun _ -> - let handler : handler = - List.nth - configuration.handlers - (export_format##.selectedIndex) - in - let filename default : string = - let root : string = - Js.to_string (export_filename##.value) - in - if String.contains root '.' then - root - else - root^"."^default - in - let () = - handler.export (filename handler.suffix) - in - Js._false) + Dom_html.handler (fun _ -> + let handler : handler = + List.nth configuration.handlers export_format##.selectedIndex + in + let filename default : string = + let root : string = Js.to_string export_filename##.value in + if String.contains root '.' then + root + else + root ^ "." ^ default + in + let () = handler.export (filename handler.suffix) in + Js._false) in () -let export_svg - ?svg_style_id - ~(svg_div_id : string) - () : handler = - { suffix = "svg" - ; label = "svg" - ; export = - fun filename -> - Common.plotSVG - ?plotStyleId:svg_style_id - svg_div_id - filename - filename +let export_svg ?svg_style_id ~(svg_div_id : string) () : handler = + { + suffix = "svg"; + label = "svg"; + export = + (fun filename -> + Common.plotSVG ?plotStyleId:svg_style_id svg_div_id filename filename); } -let export_png - ?svg_style_id - ~(svg_div_id : string) - () : handler = - { suffix = "png" - ; label = "png" - ; export = - fun filename -> - Common.plotPNG - ?plotStyleId:svg_style_id - svg_div_id - filename - filename +let export_png ?svg_style_id ~(svg_div_id : string) () : handler = + { + suffix = "png"; + label = "png"; + export = + (fun filename -> + Common.plotPNG ?plotStyleId:svg_style_id svg_div_id filename filename); } -let export_json - ~(serialize_json : unit -> string) - : handler = - { suffix = "json" - ; label = "json" - ; export = - fun filename -> +let export_json ~(serialize_json : unit -> string) : handler = + { + suffix = "json"; + label = "json"; + export = + (fun filename -> let data = Js.string (serialize_json ()) in - Common.saveFile - ~data - ~mime:"application/json" - ~filename:filename + Common.saveFile ~data ~mime:"application/json" ~filename); } diff --git a/gui/widget_export.mli b/gui/widget_export.mli index 0f2cd48596..b240648837 100644 --- a/gui/widget_export.mli +++ b/gui/widget_export.mli @@ -1,23 +1,21 @@ module Html = Tyxml_js.Html5 -type handler = - { suffix : string; - label: string; - export : string -> unit } +type handler = { suffix: string; label: string; export: string -> unit } -type configuration = - { id : string ; - handlers : handler list; - show : bool React.signal } +type configuration = { + id: string; + handlers: handler list; + show: bool React.signal; +} -val content: - configuration -> - [< Html_types.div_content_fun > `Form `Table ] Html.elt +val content : + configuration -> [< Html_types.div_content_fun > `Form `Table ] Html.elt -val export_png: ?svg_style_id:string -> svg_div_id:string -> unit -> handler -val export_json: serialize_json:(unit -> string) -> handler -val export_svg: ?svg_style_id:string -> svg_div_id:string -> unit -> handler -val export_data_label: configuration -> string -val onload: configuration -> unit +val export_png : ?svg_style_id:string -> svg_div_id:string -> unit -> handler +val export_json : serialize_json:(unit -> string) -> handler +val export_svg : ?svg_style_id:string -> svg_div_id:string -> unit -> handler +val export_data_label : configuration -> string +val onload : configuration -> unit -val inline_content: configuration -> [> `Button | `Div | `PCDATA ] Html.elt list +val inline_content : + configuration -> [> `Button | `Div | `PCDATA ] Html.elt list diff --git a/man/KaSim_manual.tex b/man/KaSim_manual.tex index 013e7f3ae1..0b906f1c64 100644 --- a/man/KaSim_manual.tex +++ b/man/KaSim_manual.tex @@ -77,7 +77,7 @@ \input{generated_img/version} \title{Kappa tools reference manual\\ \small (release \version)} -\author{Pierre Boutillier, J\'er\^ome Feret, Jean Krivine\thanks{corresponding author: jean.krivine@irif.fr} and L\'y Kim Quy\^en \\\href{http://www.kappalanguage.org}{KappaLanguage.org}} +\author{Pierre Boutillier, J\'er\^ome Feret, Jean Krivine\thanks{corresponding author: jean.krivine@irif.fr}, Antoine Pouille and L\'y Kim Quy\^en \\\href{http://www.kappalanguage.org}{KappaLanguage.org}} \date{} % Activate to display a given date or no date @@ -305,15 +305,15 @@ \section{General structure} $\_\ [a\sep z\ A \sep Z\ 0\sep 9\ \_\ -\ +]^+ | [ a\sep z\ A\sep Z][a\sep z\ A \sep Z\ 0\sep 9\ \_\ -\ +]^*$. -\section{Sited-graph pattern: Kappa expression} +\section{Site graph pattern: Kappa expression} -The state of the system is represented in Kappa as a sited graph: a +The state of the system is represented in Kappa as a site graph: a graph where edges use sites in nodes. One must think sites as resources. At most one edge of the graph can use a site of a node (representing an agent in our case). Moreover, all the sites of an agent must have different names. -This leads to the property that an embedding between 2 sited graphs is +This leads to the property that an embedding between 2 site graphs is completely defined by the image of one node. This is absolutely critical for the efficiency and we call this concept the \emph{rigidity of \Kappa{}}. @@ -332,13 +332,13 @@ \section{Sited-graph pattern: Kappa expression} \end{table} \subsection{Graphs} -The ASCII syntax we use to represent sited graphs follows the +The ASCII syntax we use to represent site graphs follows the skeletons (describe formally in Table \ref{tab:patterns}): \begin{itemize} -\item We write the type of the agent and then its interface (the space - separated list its sites) between parenthesis. +\item We write the type of the agent and then its interface (the + space-separated list of its sites) between parenthesis. \item The state of a site is written after its name. Sites can have 2 - kind of states: a linking state and an internal states. The order in + kind of states: a linking state and an internal state. The order in which they are specified does not matter. \item The linking state of a site is written in between squared brackets: \ttt{[]} @@ -432,7 +432,7 @@ \section{Agent signatures}\index{agent signature}\label{sec:sig} KF\index{Kappa file} by the following line: \ITE{ \item[] \ttt{\%agent: } \textit{signature\_expression} } according to an extention of the grammar given in Table~\ref{tab:patterns}. Linking -states and internal states are space separated lists instead of being +states and internal states are space-separated lists instead of being singleton. Site binding capabilities are specified by giving a list typed semi-links. diff --git a/man/gkappa_sources/ambiguous_connectiveness.figs.ml b/man/gkappa_sources/ambiguous_connectiveness.figs.ml index fb8b92b4bb..fad93ce3d1 100644 --- a/man/gkappa_sources/ambiguous_connectiveness.figs.ml +++ b/man/gkappa_sources/ambiguous_connectiveness.figs.ml @@ -5,144 +5,145 @@ type state = Free | Bound | None let show_binding_type = false let space_between_proteins = 0.6 + let config = { - config - with - agent_width = 0.25*.config.agent_width ; - agent_height = 0.34*.config.agent_height ; - site_width = 0.4*.config.site_width; - site_height = 0.4*.config.site_height; - free_width = 0.6*.config.free_width ; - free_height = 0.6*.config.free_height ; - bound_height = 0.5*.config.bound_height ; - rule_length = 0.4*.config.rule_length ; - rule_margin = 0.1*.config.rule_margin ; - show_agent_names = false; - show_site_names = false ; - show_state_names = false ; - color_agents = true ; - color_sites = true ; - txt_font = 12; + config with + agent_width = 0.25 *. config.agent_width; + agent_height = 0.34 *. config.agent_height; + site_width = 0.4 *. config.site_width; + site_height = 0.4 *. config.site_height; + free_width = 0.6 *. config.free_width; + free_height = 0.6 *. config.free_height; + bound_height = 0.5 *. config.bound_height; + rule_length = 0.4 *. config.rule_length; + rule_margin = 0.1 *. config.rule_margin; + show_agent_names = false; + show_site_names = false; + show_state_names = false; + color_agents = true; + color_sites = true; + txt_font = 12; } let build_rule = build_rule ~hgap:(Some 0.4) - -let - [ - r, - [ - left,[]; - right,[] - ]], - signature - = +let [ (r, [ (left, []); (right, []) ]) ], signature = add_in_signature [ - "$\text{\raisebox{.5ex}{\agent{\small A}{}}}$",[Shape "hexagon"], - [ - "$\text{\site{\small l}{}{}}$",[Direction ne],[]; - "$\text{\site{\small r}{}{}}$",[Direction se],[] - ] + ( "$\text{\raisebox{.5ex}{\agent{\small A}{}}}$", + [ Shape "hexagon" ], + [ + "$\text{\site{\small l}{}{}}$", [ Direction ne ], []; + "$\text{\site{\small r}{}{}}$", [ Direction se ], []; + ] ); ] (snd (init config)) - -let [agent_a,[site_a,_;site_b,_]; - agent_a',[site_a',_;site_b',_]],protein = +let ( [ + (agent_a, [ (site_a, _); (site_b, _) ]); + (agent_a', [ (site_a', _); (site_b', _) ]); + ], + protein ) = add_in_graph [ - r,0.,0.,[],[left,[],[];right,[],[]]; - r,0.8,0.,[],[left,[Direction nw],[];right,[Direction sw],[]]] + r, 0., 0., [], [ left, [], []; right, [], [] ]; + ( r, + 0.8, + 0., + [], + [ left, [ Direction nw ], []; right, [ Direction sw ], [] ] ); + ] signature -let [pagent_a,[psite_b,_]; - pagent_a',[psite_b',_]],pattern = - add_in_graph - [ - r,0.,0.,[],[right,[],[]]; - r,0.8,0.,[],[right,[Direction sw],[]]] - signature +let [ (pagent_a, [ (psite_b, _) ]); (pagent_a', [ (psite_b', _) ]) ], pattern = + add_in_graph + [ + r, 0., 0., [], [ right, [], [] ]; + r, 0.8, 0., [], [ right, [ Direction sw ], [] ]; + ] + signature let axx = - add_free_list [site_a,[];site_a',[]] - (add_link_list [site_b,site_b'] protein) + add_free_list + [ site_a, []; site_a', [] ] + (add_link_list [ site_b, site_b' ] protein) let ayy = - add_free_list [site_b,[];site_b',[]] - (add_link_list [site_a,site_a'] protein) - -let axxyy = - add_link_list - [site_a,site_a';site_b,site_b'] - protein - -let paxx = - add_link_list [psite_b,psite_b'] pattern - -let paxxfree = add_free_list [psite_b,[];psite_b',[]] pattern - -let la,lhs' = paxxfree + add_free_list + [ site_b, []; site_b', [] ] + (add_link_list [ site_a, site_a' ] protein) + +let axxyy = add_link_list [ site_a, site_a'; site_b, site_b' ] protein +let paxx = add_link_list [ psite_b, psite_b' ] pattern +let paxxfree = add_free_list [ psite_b, []; psite_b', [] ] pattern +let la, lhs' = paxxfree let rhs' = paxx -let _,lhs = ayy +let _, lhs = ayy let rhs = axxyy let f bool = - let rhs = if bool then cross rhs else rhs in - let sigmal,sigmar,_,rule = - build_rule - ~reversible:false signature - (fun _ -> ([],[],[]),lhs) - (fun _ -> ([],[],[]),rhs) + let rhs = + if bool then + cross rhs + else + rhs + in + let sigmal, sigmar, _, rule = + build_rule ~reversible:false signature + (fun _ -> ([], [], []), lhs) + (fun _ -> ([], [], []), rhs) in - let sigmal',sigmar',_,rule' = - build_rule - ~reversible:false signature - ~directives:[Comment (if bool then "$1$" else "$1\{1\}$")] - (fun _ -> ([],[],[]),lhs') - (fun _ -> ([],[],[]),rhs') + let sigmal', sigmar', _, rule' = + build_rule ~reversible:false signature + ~directives: + [ + Comment + (if bool then + "$1$" + else + "$1\{1\}$"); + ] + (fun _ -> ([], [], []), lhs') + (fun _ -> ([], [], []), rhs') in let dim_rule = corners lhs in let dim_rule' = corners lhs' in let delta_x = match dim_rule, dim_rule' with - | None, _ | _,None -> 0. - | Some (min,max,_,_), Some (min',max',_,_) -> - (max-.min+.min'-.max') + | None, _ | _, None -> 0. + | Some (min, max, _, _), Some (min', max', _, _) -> + max -. min +. min' -. max' in let square = move_remanent_above 0.6 rule rule' in - let rule' = translate_graph {abscisse = delta_x*.0.88 ; ordinate = 0.} rule' in - let sigmau,sigmad,square = disjoint_union square rule' in + let rule' = + translate_graph { abscisse = delta_x *. 0.88; ordinate = 0. } rule' + in + let sigmau, sigmad, square = disjoint_union square rule' in let square = add_proj - [lift_agent sigmad - (lift_agent sigmal' pagent_a), - lift_agent sigmau - (lift_agent sigmal agent_a); - lift_agent sigmad - (lift_agent sigmal' pagent_a'), - lift_agent sigmau - (lift_agent sigmal agent_a') + [ + ( lift_agent sigmad (lift_agent sigmal' pagent_a), + lift_agent sigmau (lift_agent sigmal agent_a) ); + ( lift_agent sigmad (lift_agent sigmal' pagent_a'), + lift_agent sigmau (lift_agent sigmal agent_a') ); ] square in let square = add_proj - [lift_agent sigmad - (lift_agent sigmar' pagent_a), - lift_agent sigmau - (lift_agent sigmar agent_a); - lift_agent sigmad - (lift_agent sigmar' pagent_a'), - lift_agent sigmau - (lift_agent sigmar agent_a') - ] - square in + [ + ( lift_agent sigmad (lift_agent sigmar' pagent_a), + lift_agent sigmau (lift_agent sigmar agent_a) ); + ( lift_agent sigmad (lift_agent sigmar' pagent_a'), + lift_agent sigmau (lift_agent sigmar agent_a') ); + ] + square + in square let with_cross = f true let no_cross = f false let no_cross = move_remanent_right_to 1. no_cross with_cross -let _,_,both = disjoint_union no_cross with_cross +let _, _, both = disjoint_union no_cross with_cross let _ = dump "amb_noamb.ladot" both diff --git a/man/gkappa_sources/syntax.figs.ml b/man/gkappa_sources/syntax.figs.ml index 353a77d279..1a3ba81599 100644 --- a/man/gkappa_sources/syntax.figs.ml +++ b/man/gkappa_sources/syntax.figs.ml @@ -5,86 +5,112 @@ type state = Free | Bound | None let show_binding_type = false let space_between_proteins = 0.6 + let config = { - config - with - agent_width = 0.30*.config.agent_width ; - agent_height = 0.23*.config.agent_width ; - site_width = 0.6*.config.site_width; - site_height = 0.6*.config.site_height; - state_width = 1.2*.config.state_width ; - state_height = 1.2*.config.state_height; - free_width = 0.8*.config.free_width ; - free_height = 0.6*.config.free_height ; - bound_height = 0.5*.config.bound_height ; - rule_length = 0.4*.config.rule_length ; - rule_margin = 0.1*.config.rule_margin ; - show_agent_names = true; - show_site_names = true ; - show_state_names = true ; - color_agents = false ; - color_sites = false ; - color_states = false ; - txt_font = 12; + config with + agent_width = 0.30 *. config.agent_width; + agent_height = 0.23 *. config.agent_width; + site_width = 0.6 *. config.site_width; + site_height = 0.6 *. config.site_height; + state_width = 1.2 *. config.state_width; + state_height = 1.2 *. config.state_height; + free_width = 0.8 *. config.free_width; + free_height = 0.6 *. config.free_height; + bound_height = 0.5 *. config.bound_height; + rule_length = 0.4 *. config.rule_length; + rule_margin = 0.1 *. config.rule_margin; + show_agent_names = true; + show_site_names = true; + show_state_names = true; + color_agents = false; + color_sites = false; + color_states = false; + txt_font = 12; } - - -let - [ - a, - [ - x,[]; - y,[yu;yp]; - z,[zu;zp]; - ]], - signature - = +let [ (a, [ (x, []); (y, [ yu; yp ]); (z, [ zu; zp ]) ]) ], signature = add_in_signature [ - "$\texttt{A}$",[Shape "ellipse"], - [ - "$\texttt{x}$",[Direction n],[]; - "$\texttt{y}$",[Direction se], - ["$\texttt{u}$",[]; - "$\texttt{p}$",[]]; - "$\texttt{z}$",[Direction sw], - ["$\texttt{0}$",[]; - "$\texttt{1}$",[]]; - ] + ( "$\texttt{A}$", + [ Shape "ellipse" ], + [ + "$\texttt{x}$", [ Direction n ], []; + ( "$\texttt{y}$", + [ Direction se ], + [ "$\texttt{u}$", []; "$\texttt{p}$", [] ] ); + ( "$\texttt{z}$", + [ Direction sw ], + [ "$\texttt{0}$", []; "$\texttt{1}$", [] ] ); + ] ); ] (snd (init config)) -let [_,[ax,_;ay,_;az,_]],p = +let [ (_, [ (ax, _); (ay, _); (az, _) ]) ], p = add_in_graph - [a,0.,0.,[], - [x,[],[]; - y,[],[Internal_state (yp,[Direction e])]; - z,[],[Internal_state (zu,[Direction w])]]] + [ + ( a, + 0., + 0., + [], + [ + x, [], []; + y, [], [ Internal_state (yp, [ Direction e ]) ]; + z, [], [ Internal_state (zu, [ Direction w ]) ]; + ] ); + ] signature -let _,p = add_free_list [ax,[];ay,[];az,[]] p (* remove if you do not want the symbols -| *) +let _, p = + add_free_list + [ ax, []; ay, []; az, [] ] + p (* remove if you do not want the symbols -| *) + let _ = dump "syntax_agent.ladot" p -let - [a,[ax,_;ay,_;az,_]; - a',[ax',_;ay',_;az',_]; - a'',[ax'',_;ay'',_;az'',_]],ring = +let ( [ + (a, [ (ax, _); (ay, _); (az, _) ]); + (a', [ (ax', _); (ay', _); (az', _) ]); + (a'', [ (ax'', _); (ay'', _); (az'', _) ]); + ], + ring ) = add_in_graph [ - a,0.,0.,[],[x,[Direction se],[];y,[Direction sw],[Internal_state (yu,[Direction w])];z,[Direction n],[Internal_state (zp,[Direction ne])]]; - a,-0.77,-1.,[],[x,[Direction n],[];y,[Direction e],[Internal_state (yu,[Direction ne])];z,[],[Internal_state (zp,[Direction sw])]]; - a,+0.77,-1.,[],[x,[Direction w],[];y,[Direction n],[Internal_state (yu,[Direction ne])];z,[Direction se],[Internal_state (zp,[Direction e])]] + ( a, + 0., + 0., + [], + [ + x, [ Direction se ], []; + y, [ Direction sw ], [ Internal_state (yu, [ Direction w ]) ]; + z, [ Direction n ], [ Internal_state (zp, [ Direction ne ]) ]; + ] ); + ( a, + -0.77, + -1., + [], + [ + x, [ Direction n ], []; + y, [ Direction e ], [ Internal_state (yu, [ Direction ne ]) ]; + z, [], [ Internal_state (zp, [ Direction sw ]) ]; + ] ); + ( a, + 0.77, + -1., + [], + [ + x, [ Direction w ], []; + y, [ Direction n ], [ Internal_state (yu, [ Direction ne ]) ]; + z, [ Direction se ], [ Internal_state (zp, [ Direction e ]) ]; + ] ); ] signature -let ring = - add_link_list - [ax,ay'';ay,ax';ay',ax''] - ring +let ring = add_link_list [ ax, ay''; ay, ax'; ay', ax'' ] ring -let _,ring = - add_free_list [az,[Direction n];az',[Direction w];az'',[Direction se]] +let _, ring = + add_free_list + [ az, [ Direction n ]; az', [ Direction w ]; az'', [ Direction se ] ] ring (* remove if you do not want the symbols -| *) + let _ = dump "syntax_ring.ladot" ring diff --git a/man/gkappa_sources/tutorial.figs.ml b/man/gkappa_sources/tutorial.figs.ml index 9f25f0d177..dc2b9307fb 100644 --- a/man/gkappa_sources/tutorial.figs.ml +++ b/man/gkappa_sources/tutorial.figs.ml @@ -5,20 +5,19 @@ let show_binding_type = false let config = { - config - with - site_width = 0.25*.config.site_width; + config with + site_width = 0.25 *. config.site_width; site_height = 0.25 *. config.site_height; state_height = 0.7 *. config.state_height; state_width = 0.7 *. config.state_width; - free_width = 0.6 *. config.free_width ; - free_height = 0.4 *. config.free_height ; - bound_height = 0.3 *. config.bound_height ; - rule_length = 0.65 *. config.rule_length ; - rule_margin = 0.2 *. config.rule_margin ; - show_agent_names = false ; - show_site_names = false ; - show_state_names = false ; + free_width = 0.6 *. config.free_width; + free_height = 0.4 *. config.free_height; + bound_height = 0.3 *. config.bound_height; + rule_length = 0.65 *. config.rule_length; + rule_margin = 0.2 *. config.rule_margin; + show_agent_names = false; + show_site_names = false; + show_state_names = false; txt_font = 10; } @@ -29,242 +28,229 @@ let build_rule ?mul = let h = match mul with | None -> 0.8 - | Some f -> 0.8*.f + | Some f -> 0.8 *. f in build_rule ~hgap:(Some h) - -let - [ - a, - [ - a_x,[]; - ]; - b, - [ - b_x,[]; - b_y,[b_y_u;b_y_p]; - ]], - signature - = +let ( [ (a, [ (a_x, []) ]); (b, [ (b_x, []); (b_y, [ b_y_u; b_y_p ]) ]) ], + signature ) = add_in_signature [ - "$\text{\agent{A}{}}$",[Shape "circle";Width (0.13*.config.agent_width);Height (0.16*.config.agent_width)], - ["$\text{\site{l}{}{}}$",[Direction e],[]]; - "$\text{\agent{B}{}}$",[Shape "rectangle";Height (0.24*.config.agent_height);Width (0.15*.config.agent_width)], - [ - "$\text{\site{r}{}{}}$",[Direction w],[]; "$\text{\site{l}{}{}}$",[Direction e],["u",[Direction ne];"p",[Direction ne]] - ] + ( "$\text{\agent{A}{}}$", + [ + Shape "circle"; + Width (0.13 *. config.agent_width); + Height (0.16 *. config.agent_width); + ], + [ "$\text{\site{l}{}{}}$", [ Direction e ], [] ] ); + ( "$\text{\agent{B}{}}$", + [ + Shape "rectangle"; + Height (0.24 *. config.agent_height); + Width (0.15 *. config.agent_width); + ], + [ + "$\text{\site{r}{}{}}$", [ Direction w ], []; + ( "$\text{\site{l}{}{}}$", + [ Direction e ], + [ "u", [ Direction ne ]; "p", [ Direction ne ] ] ); + ] ); ] - (snd (init config)) - + (snd (init config)) -let [agent_a,[site_a,_];agent_b,[site_b_x,_]],couple = +let [ (agent_a, [ (site_a, _) ]); (agent_b, [ (site_b_x, _) ]) ], couple = add_in_graph - [ - a,0.,0.,[],[a_x,[],[]]; - b,0.6,0.,[],[b_x,[],[]]; - ] + [ a, 0., 0., [], [ a_x, [], [] ]; b, 0.6, 0., [], [ b_x, [], [] ] ] signature - -let add_bond s1 s2 graph= - let graph = add_link_list [s1,s2] graph in - ([],[],[]),graph +let add_bond s1 s2 graph = + let graph = add_link_list [ s1, s2 ] graph in + ([], [], []), graph let add_free s1 s2 graph = - let _, graph = add_free_list [s1,[];s2,[]] graph in - ([],[],[]),graph + let _, graph = add_free_list [ s1, []; s2, [] ] graph in + ([], [], []), graph let bind ?directives ?file g s1 s2 = build_rule ?directives ?file g (add_free s1 s2) (add_bond s1 s2) - -let _,_,_,bind_g = - bind - ~directives:[Comment "$k$"] ~file:"sect1-bind.ladot" - couple site_a site_b_x - +let _, _, _, bind_g = + bind ~directives:[ Comment "$k$" ] ~file:"sect1-bind.ladot" couple site_a + site_b_x let add_state site state graph = - let _, graph = add_internal_state ~directives:[Direction se] site state graph in - ([],[],[]), graph - + let _, graph = + add_internal_state ~directives:[ Direction se ] site state graph + in + ([], [], []), graph let activate ?directives ?file g s su sp = - build_rule ?directives ?file g - (add_state s su) - (add_state s sp) + build_rule ?directives ?file g (add_state s su) (add_state s sp) let _ = - let site_b_y, g = add_site agent_b b_y couple in - let _,g = add_bond site_a site_b_x g in - activate - ~directives:[Comment "$kp$"] ~file:"sect1-phos.ladot" - g site_b_y b_y_u b_y_p + let site_b_y, g = add_site agent_b b_y couple in + let _, g = add_bond site_a site_b_x g in + activate ~directives:[ Comment "$kp$" ] ~file:"sect1-phos.ladot" g site_b_y + b_y_u b_y_p let refined_domain state = - let s,g = add_site agent_b b_y couple in + let s, g = add_site agent_b b_y couple in snd (add_state s state g) -let _,_,_,bind_u = - bind - ~directives:[Comment "$k$"] ~file:"sect1-bind-ref-u.ladot" +let _, _, _, bind_u = + bind ~directives:[ Comment "$k$" ] ~file:"sect1-bind-ref-u.ladot" (refined_domain b_y_u) site_a site_b_x -let _,_,_,bind_p = - bind - ~directives:[Comment "$k$"] ~file:"sect1-bind-ref-p.ladot" - (refined_domain b_y_p) site_a site_b_x +let _, _, _, bind_p = + bind ~directives:[ Comment "$k$" ] ~file:"sect1-bind-ref-p.ladot" + (refined_domain b_y_p) site_a site_b_x -let ag,fictitious = - add_empty_node 0. 0. signature +let ag, fictitious = add_empty_node 0. 0. signature -let sigmafu,_,bind_u = +let sigmafu, _, bind_u = let g = move_remanent_right_to 0.2 bind_u fictitious in disjoint_union fictitious g let sigmafu = lift_agent sigmafu -let sigmafp,_,bind_p = - let g = move_remanent_right_to 0.2 bind_p fictitious in - disjoint_union fictitious g +let sigmafp, _, bind_p = + let g = move_remanent_right_to 0.2 bind_p fictitious in + disjoint_union fictitious g let sigmafp = lift_agent sigmafp -let sigmad,sigmau,bindup = +let sigmad, sigmau, bindup = let bind_u = move_remanent_above 0.5 bind_u bind_p in disjoint_union bind_u bind_p let sigmad = lift_agent sigmad let sigmau = lift_agent sigmau -let _,sigmaf,bind_g = +let _, sigmaf, bind_g = let g = move_remanent_right_to 0.2 fictitious bind_g in disjoint_union bind_g g let sigmaf = lift_agent sigmaf -let sigmal,sigmar,graph = +let sigmal, sigmar, graph = let g = move_remanent_right_to 1.5 bindup bind_g in - disjoint_union (translate_graph {abscisse=0.;ordinate=0.45} bind_g) g + disjoint_union (translate_graph { abscisse = 0.; ordinate = 0.45 } bind_g) g let sigmal = lift_agent sigmal let sigmar = lift_agent sigmar - -let fl = sigmal (sigmaf (ag)) +let fl = sigmal (sigmaf ag) let fu = sigmar (sigmafu (sigmau ag)) let fp = sigmar (sigmafp (sigmad ag)) - let sigmau x = sigmar (sigmaf (sigmau x)) -let graph = - add_proj ~color:"black" - [fl,fp;fl,fu] - graph - +let graph = add_proj ~color:"black" [ fl, fp; fl, fu ] graph let _ = dump "ref.ladot" graph -let - [ - a, - [ - a_n,[]; - a_e,[u;p]; - ]], - signature - = +let [ (a, [ (a_n, []); (a_e, [ u; p ]) ]) ], signature = add_in_signature [ - "$\text{\agent{A}{}}$", - [Shape "circle"; - Width (0.13*.config.agent_width); - Height (0.16*.config.agent_width)], - ["$\text{\site{n}{}{}}$",[Direction n],[]; - "$\text{\site{n}{}{}}$",[Direction e], - [ - "u",[Direction ne]; - "p",[Direction ne] - ]] + ( "$\text{\agent{A}{}}$", + [ + Shape "circle"; + Width (0.13 *. config.agent_width); + Height (0.16 *. config.agent_width); + ], + [ + "$\text{\site{n}{}{}}$", [ Direction n ], []; + ( "$\text{\site{n}{}{}}$", + [ Direction e ], + [ "u", [ Direction ne ]; "p", [ Direction ne ] ] ); + ] ); ] (snd (init config)) -let - [a,[sn,_;se_,_];a',[sn',_;se',_];a'',[sn'',_;se'',_];a''',[sn''',_;se''',_]], - g - = +let ( [ + (a, [ (sn, _); (se_, _) ]); + (a', [ (sn', _); (se', _) ]); + (a'', [ (sn'', _); (se'', _) ]); + (a''', [ (sn''', _); (se''', _) ]); + ], + g ) = add_in_graph - [ - a,0.,0.,[], [ - a_n,[],[]; - a_e,[],[Internal_state (u,[])];]; - a,0.6,0.,[],[a_n,[],[];a_e,[],[Internal_state (u,[])]]; - a,1.2,0.,[],[a_n,[],[Free_site []];a_e,[],[Internal_state (u,[])]]; - a,1.8,0.,[],[a_n,[],[Free_site []];a_e,[],[]]; - ] - signature + a, 0., 0., [], [ a_n, [], []; a_e, [], [ Internal_state (u, []) ] ]; + a, 0.6, 0., [], [ a_n, [], []; a_e, [], [ Internal_state (u, []) ] ]; + ( a, + 1.2, + 0., + [], + [ a_n, [], [ Free_site [] ]; a_e, [], [ Internal_state (u, []) ] ] ); + a, 1.8, 0., [], [ a_n, [], [ Free_site [] ]; a_e, [], [] ]; + ] + signature let left g = - let _,g = add_free_list [sn,[];sn',[]] g in - let _,g = add_internal_state se''' u g in - ([],[],[]),g + let _, g = add_free_list [ sn, []; sn', [] ] g in + let _, g = add_internal_state se''' u g in + ([], [], []), g let right g = - let g = add_link_list [sn,sn'] g in - let _,g = add_internal_state se''' p g in - ([],[],[]),g + let g = add_link_list [ sn, sn' ] g in + let _, g = add_internal_state se''' p g in + ([], [], []), g -let _ = - build_rule ~file:"auto.ladot" ~directives:[Comment "$k$"] g - left right +let _ = build_rule ~file:"auto.ladot" ~directives:[ Comment "$k$" ] g left right -let - [ - a, - [ - a_x,[]; - a_y,[]; - ]; - ], - signature - = +let [ (a, [ (a_x, []); (a_y, []) ]) ], signature = add_in_signature [ - "$\text{\agent{A}{}}$",[Shape "rectangle";Width (0.10*.config.agent_width);Height (0.16*.config.agent_width)], - [ - "$\text{\site{a}{}{}}$", - [Direction ne], - []; - "$\text{\site{b}{}{}}$",[Direction se],[] - ] + ( "$\text{\agent{A}{}}$", + [ + Shape "rectangle"; + Width (0.10 *. config.agent_width); + Height (0.16 *. config.agent_width); + ], + [ + "$\text{\site{a}{}{}}$", [ Direction ne ], []; + "$\text{\site{b}{}{}}$", [ Direction se ], []; + ] ); ] (snd (init config)) -let [agent_a,[site_a,_;site_b,_];agent_a',[site_a',_;site_b',_]],dimer = +let ( [ + (agent_a, [ (site_a, _); (site_b, _) ]); + (agent_a', [ (site_a', _); (site_b', _) ]); + ], + dimer ) = add_in_graph [ - a,0.,0.,[],[a_x,[],[];a_y,[],[]]; - a,0.6,0.,[],[a_x,[Direction nw],[];a_y,[Direction sw],[]]; + a, 0., 0., [], [ a_x, [], []; a_y, [], [] ]; + a, 0.6, 0., [], [ a_x, [ Direction nw ], []; a_y, [ Direction sw ], [] ]; ] signature let build_rule b1 b2 g = - let sx, sy, s = if b1 then site_a,site_b,"t" else site_b,site_a,"f" in - let sx',sy', s' = if b2 then site_a',site_b',"t" else site_b',site_a',"f" in - let n = - if b1 && b2 then "1" else if b1 then "3" else if b2 then "4" else "2" + let sx, sy, s = + if b1 then + site_a, site_b, "t" + else + site_b, site_a, "f" in - let file = "sym"^s^s'^".ladot" in - let _,domain = add_free_list [sy,[];sy',[]] g in - let free g = - ([],[],[]), snd (add_free_list [sx,[];sx',[]] g) + let sx', sy', s' = + if b2 then + site_a', site_b', "t" + else + site_b', site_a', "f" in - let bind g = - ([],[],[]), add_link_list [sx,sx'] g + let n = + if b1 && b2 then + "1" + else if b1 then + "3" + else if b2 then + "4" + else + "2" in - build_rule ~file ~directives:[Comment ("$k_"^n^"$")] domain - free - bind + let file = "sym" ^ s ^ s' ^ ".ladot" in + let _, domain = add_free_list [ sy, []; sy', [] ] g in + let free g = ([], [], []), snd (add_free_list [ sx, []; sx', [] ] g) in + let bind g = ([], [], []), add_link_list [ sx, sx' ] g in + build_rule ~file ~directives:[ Comment ("$k_" ^ n ^ "$") ] domain free bind let _ = build_rule true true dimer let _ = build_rule false false dimer diff --git a/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/KappaLanguageHighlighter.xml b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/KappaLanguageHighlighter.xml new file mode 100644 index 0000000000..3952510b8c --- /dev/null +++ b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/KappaLanguageHighlighter.xml @@ -0,0 +1,64 @@ + + + + + + + + 00// 01 02 03/* 04*/ + + + + + + + + , + + + + + + + + + + + %agent: %token: + %init: + %mod: [not] [true] [false] $ADD $DEL $SNAPSHOT $STOP $FLUX $TRACK $UPDATE $PLOTENTRY $PRINT $PRINTF ; + -> <-> @ + %def: %var: %obs: %plot: + + - * ^ + + + 00' 01 02' 03" 04 05" 06[ 07 08] 09{ 10 11} 12 13 14 15( 16 17) 18 19 20 21 22 23 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/LICENSE b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/LICENSE new file mode 100644 index 0000000000..2d81e42f2a --- /dev/null +++ b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2023 Hector Medina + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/README.md b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/README.md new file mode 100644 index 0000000000..1272530329 --- /dev/null +++ b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/README.md @@ -0,0 +1,21 @@ +# NotepadPP_Kappa_plugin + +A plugin for syntax highlighting of the [Kappa language](https://kappalanguage.org) for [Notepad++](https://notepad-plus-plus.org). + +This was designed for highlighting edit-notation operations, introduced in the Kappa Simulator v4, while also supporting legacy chemical-notation operations. + +![Screenshot of a simple model, written in Kappa, with the syntax highlighting provided here](Sample.png) + + +## Installation + +To install the Kappa language highlighter in Notepad++, download the [highlighter .xml](./KappaLanguageHighlighter.xml) file, then in Notepad++: + +Language Menu -> DefineYourLanguage -> Import + + +## See also + +For rendering Kappa files into HTML, LaTeX, PDF, or other formats, we [provide a plugin](../Pygments_Kappa_plugin-master/) for the [Pygments framework](https://pygments.org). + +Project originally hosted at https://github.com/hmedina/NotepadPP_Kappa_plugin \ No newline at end of file diff --git a/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/Sample.png b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/Sample.png new file mode 100644 index 0000000000..80b157cab0 Binary files /dev/null and b/syntax_highlighting_plugins/NotepadPP_Kappa_plugin/Sample.png differ diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/LICENSE b/syntax_highlighting_plugins/Pygments_Kappa_plugin/LICENSE new file mode 100644 index 0000000000..b7020c7d2c --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019-2023 Hector Medina + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/Pygments_Kappa_plugin.toml b/syntax_highlighting_plugins/Pygments_Kappa_plugin/Pygments_Kappa_plugin.toml new file mode 100644 index 0000000000..80be9c38cd --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/Pygments_Kappa_plugin.toml @@ -0,0 +1,6 @@ +[build-system] +requires = [ + "setuptools>=49", + "wheel" +] +build-backend = "setuptools.build_meta" diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/README.md b/syntax_highlighting_plugins/Pygments_Kappa_plugin/README.md new file mode 100644 index 0000000000..951d452ba6 --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/README.md @@ -0,0 +1,89 @@ +# Pygments Kappa plugin + +A plugin for the [Pygments package](https://pygments.org/) adding lexing and styling support for the [Kappa language](https://kappalanguage.org/). + +![kappa_style_edit](./example_files/kappa_edit_notation_style_edit.png) + +## Installation +This is a python plugin, and uses `setuptools` entry points to extend the lexers and styles known to Pygments. It thus works on a stock Pygments installation. + +`pip install . [--user]` + + +## Uninstallation +If unsure of the package name, use `pip freeze` to display the list of packages pip is aware of. Otherwise: + +`pip uninstall Pygments-Kappa-plugin` + + +## Usage +Once installed, the entire Pygments stack will be aware of the new lexer and styles. This includes the [command-line script](https://pygments.org/docs/cmdline/) `pygmentize`. For example, to highlight a file called `foo.ka` using the style `kappa_style_edit`, formatting into an HTML file that contains the CSS style-sheet (i.e. a "full" file) called `foo.html`: + +``pygmentize -f html -O style=kappa_style_edit,full -o foo.html foo.ka``[^1] + +[^1]: As the lexer declares `.ka` as the extension for kappa files, it doesn't have to be specified so long as the input file has that extension. + +The Pygments-provided formatters to `LaTeX` and various image formats are supported[^2]. + +[^2]: The rasterized image formatters (i.e. `png`, `bmp`, `jpg`) have poor support for coloring text background (some work was done in [PR 1374](https://github.com/pygments/pygments/pull/1374)) or underlining, so for advanced styling, the `LaTeX` and `HTML` formatters are recommended. + + +## Contents +Pygments works by having a lexer issue a token for every component it finds. Those tokens are then styled by a user-given style-sheet. Thus the plugin consists of a module `core` containing three files, `KappaLexer.py`, `KappaStyle.py`, and `KappaToken.py`, each for a class type. + +### KappaLexer +`KappaLexer.py` contains the lexer, a multi-state parser based on regular expressions. As of this writing, it lexes the entire KaSim4 test suite successfully (the files that pass the test suite anyhow...). + +### KappaToken +Given the hierarchy of Kappa expressions, I designed the token structure to take advantage of inheritance to form a tree. The file `KappaToken.py` declares this tree, and is meant to be modular. For convenience, each tree element has an alias, e.g. `Agent_name` in `Agent_Name = Token.Kappa.Rule.Agent.Name`; the alias is what is referenced in the style sheet. + +As an example of the inheritance mechanism, a style that applies to `Token.Kappa.Rule.Agent` will be inherited to all its children, including: + ``` + Token.Kappa.Rule.Agent.Name + Token.Kappa.Rule.Agent.Signature.Site + Token.Kappa.Rule.Agent.Signature.Site.Internal.State + ``` +By the same logic, a style that applies to `Token.Kappa.Rule.Agent.Name` will not apply to `Token.Kappa.Rule.Agent.Signature`. This means one can highlight agent names without highlighting the agent signature, or the parenthesis around it, or italicize the agent signature components without italicizing the surrounding parenthesis or in-woven commas. + +This inheritance mechanism coupled with the multi-state lexer allows the distinction of identical local syntax in different uses, for example a counter edit operation vs. a counter's range in the agent's declaration; the former lives under `Token.Kappa.Rule` while the latter under `Token.Kappa.Declaration`, even though their syntax is identical. + +### KappaStyle +The token inheritance behavior allows one to define a style for the various components of a kappa file. These are defined in the `KappaStyle` file. These are provided: + + +#### `kappa_style_browser` +Mimics the style used in the "KaSim-in-browser" [GUI](https://tools.kappalanguage.org/try/?model=https%3A//raw.githubusercontent.com/Kappa-Dev/KaSim/master/models/abc-pert.ka), the only addition is the proper handling of counter syntax in agent declarations. + +![kappa_style_browser](./example_files/kappa_edit_notation_style_browser.png) + +#### `kappa_style_edit` +Agent names in rules will be bolded, edit operations will have a colored background according to their type: bond changes in green, state changes in blue, counter changes in orange, agent abundance changes in red. This style was developped to present the code in my PhD thesis, being designed to ease identification of edit operations in rules that have a lot of material in their contexts (i.e. long rules). + +![kappa_style_edit](./example_files/kappa_edit_notation_style_edit.png) + +#### `kappa_style_edit_dark` +Dark twin of the above. Agent names in rules will be bolded, edit operations will have a colored background according to their type: bond changes in green, state changes in blue, counter changes in orange, agent abundance changes in red. + +![kappa_style_edit_dark](./example_files/kappa_edit_notation_style_edit_dark.png) + +#### `kappa_style_demo` +Showcases some nuances the lexer is capable of, like bolding the agent name that types a bond, or only underlining edit operations ignoring bond typing constraints. + +![kappa_style_demo](./example_files/kappa_edit_notation_style_demo.png) + + +## Creating custom styles +Style rules are partially documented by Pygments in the [package documentation](https://pygments.org/docs/styles/#style-rules). To create a custom style (for examples, see `core/KappaStyle.py`): +1) Create a subclass that inherits from `pygments.style:Style`, e.g. `MathyStyle(Style)` +1) Add the `default_style` (everything not specified later will default to this style) +1) Add the `styles` dictionary, where keys are token aliases (see `core/KappaToken.py`) and values a string with the desired appearance. +1) Save somewhere (e.g. under `core/MyStyles.py`) and declare it in the `setup.py` file's entrypoints (e.g. add `my_super_kappa_style = core.MyStyles:MathyStyle` in the `[pygments.styles]` section). +1) Refresh/reinstall the plugin so the entry point database gets updated. +1) Pygments should now be aware of the new style; try `$ pygmentize -S` to display the entire list of lexers, formatters, and styles. `my_super_kappa_style` should be in the list. + + +## See also + +We also provide a [syntax-highlighting plugin](../NotepadPP_Kappa_plugin/) for [Notepad++](https://notepad-plus-plus.org/) + +Originally hosted at https://github.com/hmedina/Pygments_Kappa_plugin \ No newline at end of file diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaLexer.py b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaLexer.py new file mode 100644 index 0000000000..0a7031c5f0 --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaLexer.py @@ -0,0 +1,142 @@ +#! /usr/bin/env python3 + +from pygments.lexer import RegexLexer, bygroups, words +from core.KappaToken import * + + +class KappaLexer(RegexLexer): + """Pygments lexer for the Kappa language (https://kappalanguage.org)""" + name = 'Kappa' + aliases = ['kappa'] + filenames = ['*.ka'] + + integer = r'[0-9]+' + real = r'([0-9]+[eE][+-]?[0-9+])|((([0-9]+\.[0-9]*)|(\.[0-9]+))([eE][+-]?[0-9]+)?)' + ident = r'[_~][a-zA-Z0-9~+_]+|[a-zA-Z][a-zA-Z0-9_~+-]*' + + tokens = { + 'root': [ + # comments + (r'//.*?$', Comment.Singleline), + (r'/\*', Comment.Multiline, 'comment'), + (r'\s+', Whitespace), + # agent name + (r'(' + ident + r')(\()', bygroups(Agent_Name, Agent_Decor), 'agent_rule'), + # various keywords + (r'(%agent:)(\s*)(' + ident + r')(\()', bygroups(Dec_Keyword, Whitespace, Dec_Ag_Name, Dec_Ag_Decor), + 'agent_declaration'), + (r'(%token:)(\s*)(' + ident + r')', bygroups(Dec_Keyword, Whitespace, String)), + (words(('obs', 'init', 'var', 'plot', 'def'), + prefix='%', suffix=':'), Misc_Keyword), + (words(('?', ':', 'log', 'sin', 'cos', 'tan', 'exp', 'int', 'mod', 'sqrt', 'pi', 'max', 'min'), + prefix=r'\[\s*', suffix=r'\s*\]'), Misc_Func), + # perturbation language + (r'%mod:', Pert_Keyword), + (r';', Pert_Keyword), + (words(('INF', 'inf', 'alarm'), + prefix=r'\b', suffix=r'\b'), Pert_Constructs), + (words(('true', 'false', 'not', 'E', 'E+', 'T', 'Tsim', 'Emax', 'Tmax'), + prefix=r'\[\s*', suffix=r'\s*\]'), Pert_Constructs), + (words(('do', 'repeat'), + prefix=r'\b', suffix=r'\b'), Pert_Decor), + (words(('APPLY', 'DEL', 'ADD', 'SNAPSHOT', 'STOP', 'DIN', 'TRACK', 'UPDATE', 'PRINT', 'PRINTF', 'RUN', + 'SPECIES_OF'), + prefix=r'\$', suffix=r'\b'), Pert_Oper), + (words(('&&', '||')), Pert_Constructs), + # double-quoted, unquoted, and single-quoted strings + (r'"[^"]+"', Pert_FileName), + (r"([_~][a-zA-Z0-9~+_]+|[a-zA-Z][a-zA-Z0-9_~+-]*)|('[^']*')", String), + # numbers + (real, Number), + (integer, Number), + # rule decorations & markers + (r'@|<->|->|{|}|:', Rule_Decor), + (r',', Rule_Decor), + (r'[-+/*^|><=()]', Alge_Oper), + (r'\.', Rule_Decor) # chemical notation placeholder marking agent creation/destruction + ], + 'comment': [ + (r'[^*/]', Comment.Multiline), + (r'/\*', Comment.Multiline, '#push'), + (r'\*/', Comment.Multiline, '#pop'), + (r'[*/]', Comment.Multiline) + ], + 'agent_rule': [ + # comments + (r'//.*?$', Comment.Singleline), + (r'/\*', Comment.Multiline, 'comment'), + # end of expression, agent edit operation + (r'(\))([+-]?)', bygroups(Agent_Decor, Agent_Oper), '#pop'), + # bond states + (r'(\[\s*)(\d+|_|#|\.)(\s*\])', # [99] + bygroups(Site_Bond_Decor, Site_Bond_State, Site_Bond_Decor)), + (r'(\[\s*)(' + ident + r')(.)(' + ident + r')(\s*\])', # [site.Agent] + bygroups(Site_Bond_Decor, Site_Bond_State_Site, Site_Bond_Decor, Site_Bond_State_Agent, Site_Bond_Decor)), + (r'(\[\s*)(\d+|_|#|\.)(\s*/\s*)(\d+|\.)(\s*\])', # [99/56] + bygroups(Site_Bond_Oper_Decor, Site_Bond_Oper_State, Site_Bond_Oper_Decor, Site_Bond_Oper_State, Site_Bond_Oper_Decor)), + (r'(\[\s*)(' + ident + r')(.)(' + ident + r')(\s*/\s*)(\d+|\.)(\s*\])', # [site.Agent/.] + bygroups(Site_Bond_Oper_Decor, Site_Bond_Oper_State_Site, Site_Bond_Oper_Decor, Site_Bond_Oper_State_Agent, Site_Bond_Oper_Decor, Site_Bond_Oper_State, Site_Bond_Oper_Decor)), + # internal states + (r'({\s*)(' + ident + r'|#)(\s*})', # {ph} + bygroups(Site_Int_Decor, Site_Int_State, Site_Int_Decor)), + (r'({\s*)(' + ident + r'|#)(\s*/\s*)(' + ident + r')(\s*})', # {ph/un} + bygroups(Site_Int_Oper_Decor, Site_Int_Oper_State, Site_Int_Oper_Decor, Site_Int_Oper_State, Site_Int_Oper_Decor)), + # counter states + (r'({\s*(?:>=|>|=)\s*)(\d+)(\s*})', # {>55} + bygroups(Site_Count_Decor, Site_Count_State, Site_Count_Decor)), + (r'({\s*=\s*)(' + ident + r')(\s*})', # {=x} + bygroups(Site_Count_Decor, Site_Count_State, Site_Count_Decor)), + (r'({\s*[-+]=\s*)(-?\d+)(\s*})', # {+= -55} + bygroups(Site_Count_Oper_Decor, Site_Count_Oper_State, Site_Count_Oper_Decor)), + (r'({\s*=\s*)(\d+)(\s*/\s*[+-]=\s*)(-?\d+)(\s*})', # {= 55 / += -3} + bygroups(Site_Count_Oper_Decor, Site_Count_Oper_State, Site_Count_Oper_Decor, Site_Count_Oper_State, Site_Count_Oper_Decor)), + # rest of components + (r'\s', Agent_Sign), + (r',', Agent_Sign_Decor), + (ident, Site_Name) + ], + # the declaration pods exists because counter syntax is identical for edit notation in rules and for declaration + # statements in %agent: + # With it, I avoid issuing the wrong tokens (e.g. highlighting as edit operation statements in agent declaration + # statement), at the expense of more token types. + 'agent_declaration' : [ + # comments + (r'//.*?$', Comment.Singleline), + (r'/\*', Comment.Multiline, 'comment'), + # kappa + (r'\)', Dec_Ag_Decor, '#pop'), # end of expression + (r'({\s*=\s*)(\d+)(\s*/\s*[+-]=\s*)(-?\d+)(\s*})', # {= 55 / += 3} :: counters + bygroups(Dec_Ag_Sign_Site_Ct_d, Dec_Ag_Sign_Site_Ct_s, Dec_Ag_Sign_Site_Ct_d, Dec_Ag_Sign_Site_Ct_s, Dec_Ag_Sign_Site_Ct_d)), + (r'({\s*=\s*)(\d+)(\s*})', # {= 55 } :: counters_cont + bygroups(Dec_Ag_Sign_Site_Ct_d, Dec_Ag_Sign_Site_Ct_s, Dec_Ag_Sign_Site_Ct_d)), + (r'\[', Dec_Ag_Sign_Site_Bd_d, 'declaration_bond_type'), # change state + (r'{', Dec_Ag_Sign_Site_In_d, 'declaration_internal_list'), # change state + # rest of components + (r'\s+', Dec_Ag_Sign_Decor), + (r',', Dec_Ag_Sign_Decor), + (ident, Dec_Ag_Sign_Site_Name) + ], + 'declaration_bond_type' : [ + # comments + (r'//.*?$', Comment.Singleline), + (r'/\*', Comment.Multiline, 'comment'), + # bond data + (r'\]', Dec_Ag_Sign_Site_Bd_d, '#pop'), + (r'(' + ident + r')(\.)(' + ident + r')', bygroups(Dec_Ag_Sign_Site_Bd_s, Dec_Ag_Sign_Site_Bd_d, Dec_Ag_Sign_Site_Bd_a)), + (r'\s+', Dec_Ag_Sign_Site_Bd_d), + (r',', Dec_Ag_Sign_Site_Bd_d) + ], + 'declaration_internal_list' : [ + # comments + (r'//.*?$', Comment.Singleline), + (r'/\*', Comment.Multiline, 'comment'), + # internal state data + (r'}', Dec_Ag_Sign_Site_In_d, '#pop'), + (ident, Dec_Ag_Sign_Site_In_s), + (r'\s+', Dec_Ag_Sign_Site_In_d), + (r',', Dec_Ag_Sign_Site_In_d) + ], + } + + + diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaStyle.py b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaStyle.py new file mode 100644 index 0000000000..87f6cc1bf9 --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaStyle.py @@ -0,0 +1,91 @@ +#! /usr/bin/env python3 + +from pygments.style import Style +from pygments.token import Operator +from core.KappaToken import * + +"""Kappa has a lot of idiosyncratic components; a lot of those have a Pygments-token associated to them. +Refer to those defined in KappaToken.py for documentation and hierarchy.""" + +class DemoStyle(Style): + """This style showcases some of the subtleties in the lexer.""" + default_style = '' + styles = { + Agent_Name: 'bold', + Site_Bond_State_Agent: 'bold', + Agent_Oper: 'underline #f00', + Site_Bond: '#cc00cc', + Site_Int: '#0000ff', + Site_Count: '#009999', + String: 'italic', + Site_Bond_Oper: 'underline', + Site_Int_Oper: 'underline', + Site_Count_Oper: 'underline', + Dec_Ag_Sign_Site_Bd: '#999999', + Pert_Keyword: 'bold', + Pert_Decor: 'italic', + Pert_Oper: 'bg:#ffcccc', + Comment: 'bg:#f2f2f2 italic', + Number: '#cc7a00', + Dec_Keyword: 'bold', + Misc_Keyword: 'bold', + Rule_Decor: '#009900', + # Comment: '#f00', + # Number: '#f00', + # String: '#f00', + # Number: '#f00', + # Operator: '#f00' + } + + +class KaSimInBrowserStyle(Style): + """This style mimics the CodeMirror interface used in the GUI / KappApp.""" + default_style = '' + styles = { + Comment: '#a50', + Misc_Keyword: '#708', + Dec_Keyword: '#708', + Pert_Keyword: '#708', + Agent_Decor: '#05a', + Dec_Ag_Decor: '#05a', + Rule_Decor: '#05a', + Number: '#164', + Operator: '#05a', + Misc_Func: '#05a', + Pert_Oper: '#05a', + Pert_Decor: '#05a', + Pert_FileName: '#a11', + Pert_Constructs: '#708', + } + + +class EditNotationDeltasStyle(Style): + """This style highlights edit notation operations.""" + default_style = '' + styles = { + String: '#808080 italic', + Agent_Name: 'bold', + Site_Bond_Oper: 'bg:#c9f2d6', + Site_Int_Oper: 'bg:#c9e4f2', + Agent_Oper: 'bg:#f2c9e4', + Site_Count_Oper: 'bg:#f2d6c9', + Rule_Decor: '#cc0000', + Comment: 'bg:#b3b3b3' + } + + +class EditNotationDeltasStyleDark(Style): + """An edit notation style sheet for dark backgrounds.""" + default_style = '' + background_color = '#000' + styles = { + Token.Kappa: '#eee', + String: '#aaa italic', + Agent_Name: 'bold', + Site_Bond_Oper: '#fff bg:#0e750e', + Site_Int_Oper: '#fff bg:#0e0e75', + Site_Count_Oper: '#fff bg:#0e0e75', + Agent_Oper: '#fff bg:#750e0e', + Rule_Decor: '#a31414', + Comment: 'bg:#666' + } diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaToken.py b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaToken.py new file mode 100644 index 0000000000..b1900caa2a --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/KappaToken.py @@ -0,0 +1,77 @@ +#! /usr/bin/env python3 + +from pygments.token import Token + + +# rule components +Rule = Token.Kappa.Rule +Rule_Decor = Token.Kappa.Rule.Decor # e.g. commas between agents +Rule_Agent = Token.Kappa.Rule.Agent # whole agent +Agent_Name = Token.Kappa.Rule.Agent.Name # agent's name +Agent_Oper = Token.Kappa.Rule.Agent.Operation # edit operation following the parenthesis +Agent_Decor = Token.Kappa.Rule.Agent.Decorators # e.g. the parenthesis themselves +Agent_Sign = Token.Kappa.Rule.Agent.Signature # the whole signature, sites plus commas +Agent_Sign_Decor = Token.Kappa.Rule.Agent.Signature.Decorators # the commas between sites + +Agent_Site = Token.Kappa.Rule.Agent.Signature.Site # a single site +Site_Name = Token.Kappa.Rule.Agent.Signature.Site.Name # the site's name +Site_Bond = Token.Kappa.Rule.Agent.Signature.Site.Bond # the site's bond data +Site_Bond_Decor = Token.Kappa.Rule.Agent.Signature.Site.Bond.Decorators # e.g. square brackets +Site_Bond_State = Token.Kappa.Rule.Agent.Signature.Site.Bond.State # bond identifier, or typing +Site_Bond_State_Agent = Token.Kappa.Rule.Agent.Signature.Site.Bond.State.Agent # agent in site.Agent +Site_Bond_State_Site = Token.Kappa.Rule.Agent.Signature.Site.Bond.State.Site # site in site.Agent +Site_Bond_Oper = Token.Kappa.Rule.Agent.Signature.Site.Bond.Operation # if edit operation, whole operation +Site_Bond_Oper_Decor = Token.Kappa.Rule.Agent.Signature.Site.Bond.Operation.Decorators # e.g. the slash +Site_Bond_Oper_State = Token.Kappa.Rule.Agent.Signature.Site.Bond.Operation.States # the before slash, and after slash components +Site_Bond_Oper_State_Agent = Token.Kappa.Rule.Agent.Signature.Site.Bond.Operation.States.Agent # when typing in edit operation, the agent +Site_Bond_Oper_State_Site = Token.Kappa.Rule.Agent.Signature.Site.Bond.Operation.States.Site # when typing in edit operation, the site + +Site_Int = Token.Kappa.Rule.Agent.Signature.Site.Internal # the site's internal state data +Site_Int_Decor = Token.Kappa.Rule.Agent.Signature.Site.Internal.Decorators # e.g. curly brackets +Site_Int_State = Token.Kappa.Rule.Agent.Signature.Site.Internal.State # internal state data +Site_Int_Oper = Token.Kappa.Rule.Agent.Signature.Site.Internal.Operation # if edit operation, whole expression +Site_Int_Oper_Decor = Token.Kappa.Rule.Agent.Signature.Site.Internal.Operation.Decorators # e.g. the slash +Site_Int_Oper_State = Token.Kappa.Rule.Agent.Signature.Site.Internal.Operation.States # the before slash, and after slash components + +Site_Count = Token.Kappa.Rule.Agent.Signature.Site.Counter # the site's counter data +Site_Count_Decor = Token.Kappa.Rule.Agent.Signature.Site.Counter.Decorators # e.g. curly brackets +Site_Count_State = Token.Kappa.Rule.Agent.Signature.Site.Counter.State # the counter state data +Site_Count_Oper = Token.Kappa.Rule.Agent.Signature.Site.Counter.Operation # if operation, whole expression +Site_Count_Oper_Decor = Token.Kappa.Rule.Agent.Signature.Site.Counter.Operation.Decorators # e.g. the slash +Site_Count_Oper_State = Token.Kappa.Rule.Agent.Signature.Site.Counter.Operation.States # the before slash, and after slash components + +# declaration components +Declaration = Token.Kappa.Declaration +Dec_Keyword = Token.Kappa.Declaration.Keyword # either %agent: or %token: +Dec_Ag = Token.Kappa.Declaration.Agent # the kappa agent being declared +Dec_Ag_Name = Token.Kappa.Declaration.Agent.Name # the agent's name +Dec_Ag_Decor = Token.Kappa.Declaration.Agent.Decoration # the parenthesis +Dec_Ag_Sign = Token.Kappa.Declaration.Agent.Signature # the agent's signature +Dec_Ag_Sign_Decor = Token.Kappa.Declaration.Agent.Signature.Decorator # inter-site commas +Dec_Ag_Sign_Site = Token.Kappa.Declaration.Agent.Signature.Site # a site, with internal/bond/counter data +Dec_Ag_Sign_Site_Name = Token.Kappa.Declaration.Agent.Signature.Site.Name # a site's name +Dec_Ag_Sign_Site_Bd = Token.Kappa.Declaration.Agent.Signature.Site.Bond # type specifier, i.e: [site.Agent] +Dec_Ag_Sign_Site_Bd_s = Token.Kappa.Declaration.Agent.Signature.Site.Bond.Site # site in [site.Agent] +Dec_Ag_Sign_Site_Bd_a = Token.Kappa.Declaration.Agent.Signature.Site.Bond.Agent # Agent in [site.Agent] +Dec_Ag_Sign_Site_Bd_d = Token.Kappa.Declaration.Agent.Signature.Site.Bond.Decorator # brackets and period in [site.Agent] +Dec_Ag_Sign_Site_In_s = Token.Kappa.Declaration.Agent.Signature.Site.Internal.State # un ph in {un, ph} +Dec_Ag_Sign_Site_In_d = Token.Kappa.Declaration.Agent.Signature.Site.Internal.Decorator # comma and curlies in {un, ph} +Dec_Ag_Sign_Site_Ct_s = Token.Kappa.Declaration.Agent.Signature.Site.Counter.State # 1 and 5 in {=1/+=5} +Dec_Ag_Sign_Site_Ct_d = Token.Kappa.Declaration.Agent.Signature.Site.Counter.Decorator # equals, slash, curlies in {=1/+=5} + +# perturbations +Perturbation = Token.Kappa.Perturbation # the whole perturbation syntax (minus agent usage) +Pert_Keyword = Token.Kappa.Perturbation.Keyword # %mod: +Pert_Decor = Token.Kappa.Perturbation.Decorators # do, repeat +Pert_Oper = Token.Kappa.Perturbation.Operation # e.g. STOP, SNAPSHOT, ADD +Pert_Constructs = Token.Kappa.Perturbation.Constructs # e.g. [E], [T], alarm +Pert_FileName = Token.Kappa.Perturbation.FileName # double-quoted string used for filenames + +# other script components +Alge_Oper = Token.Kappa.Operand # algebraic operations: + - * / ^ +Misc_Keyword = Token.Kappa.Miscelaneous # e.g. %obs:, %init:, %var: +Misc_Func = Token.Kappa.Function # e.g. exp, sqrt, max, cos +Comment = Token.Kappa.Comment # comments +Whitespace = Token.Kappa.Whitespace +Number = Token.Kappa.Number +String = Token.Kappa.String # Unquoted and single-quoted identifiers, like rule names \ No newline at end of file diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/__init__.py b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/__init__.py new file mode 100644 index 0000000000..21ab5da3a8 --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/core/__init__.py @@ -0,0 +1 @@ +#! /usr/bin/env python3 diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_comprehensive.ka b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_comprehensive.ka new file mode 100644 index 0000000000..4e9486e4cf --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_comprehensive.ka @@ -0,0 +1,58 @@ +/*** some glorious header +spanning multiple lines ***/ + + +%agent: A(x[~x.~B], c[_1._C, x2._C]) // in-line comment +%agent: ~B(~x[x.A]) +%agent: _C(_1{u p}[c.A] /*some comment*/ x2{~a _p _55}[c.A]) +%agent: ~9(c{=1 / +=5}) +%token: Bob + + +'99' A(x[.]),~B(~x[.]) -> A(x[1]),~B(~x[1]) @ 'on_rate' * [tan] 3 + +A(x[1/.]),~B(~x[1/.]) @ 'off_rate' + +A(x[_],c[.]),_C(_1{u}[.]) -> A(x[_],c[2]),_C(_1{u}[2]) + @ 'on_rate' + +_C(_1{u}[1]),A(c[1]) -> _C(_1[.]{p}),A(c[.]) @ 'mod_rate' +_C(_1{u/p}) @ 'mod_rate' + +'a.c' A(x[.],c[.]),_C(_1{p}[.],x2[.]{~a}) -> + A(x[.],c[1]),_C(_1{p}[.],x2[1]{~a}) @ 'on_rate' + +A(x[.],c[1]),_C(_1{p},x2{~a}[1]) -> + A(x[.],c[.]),_C(_1{p},x2{_p}[.]) @ 'mod_rate' + +~9()+ @ 1.0 {'mod_rate'} + +~9()- @ .1 { 'mod_rate' * 'on_rate' } + +~9(c{=1}) -> ~9(c{+=1}) @ 'on_rate' * 'off_rate' / 'mod_rate' {1.0} + +~9(c{=1 / +=1}) @ 1 + +A() -> . | 1 Bob @ 1 + +%var: 'on_rate' 1.0E-3 +%var: 'off_rate' 0.1 +%var: 'mod_rate' 1E3 +%obs: 'AB' |A(x[~x.~B])| +%obs: 'Cuu' |_C(_1{u},x2{~a})| +%var: 'n_ab' 1000 * [tan] 3e1 +%obs: 'n_c' 0 +%var: 'C' |_C()| +%init: 'n_ab' A(),~B() +%init: 'n_c' _C() +%init: 5 ~9() +%init: 55 Bob + +%mod: alarm 10.0 do $ADD 10^2 * |~9()| _C(); +%mod: [T] > 50 do $SNAPSHOT "my_snap.ka"; +%mod: [E] > 1 do $STOP ; +/* open1 /* open2 close 2*/ +close */ +/* bla blaa */ +/* bla / bla */ +/* bla * bla */ diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation.ka b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation.ka new file mode 100644 index 0000000000..3da0fa8eed --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation.ka @@ -0,0 +1,9 @@ +Bob(site[./1]), Mary(site[./1]) @ on_rate {uni_rate} +Bob(site[1/.]), Mary(site[1/.]) @ off_rate +Bob(site[site.Mary]) | 1 that_token @ 1e5 +// some comment +Anne(site{one/two}) @ 'rate' + +Greg(count{=5/+=4}) @ rate / rate_other + +Alpha()+, Omega()- @ 1.0 diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_browser.png b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_browser.png new file mode 100644 index 0000000000..f08433de06 Binary files /dev/null and b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_browser.png differ diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_demo.png b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_demo.png new file mode 100644 index 0000000000..37b915d093 Binary files /dev/null and b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_demo.png differ diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_edit.png b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_edit.png new file mode 100644 index 0000000000..0dd535fbbe Binary files /dev/null and b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_edit.png differ diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_edit_dark.png b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_edit_dark.png new file mode 100644 index 0000000000..3e9a2c549b Binary files /dev/null and b/syntax_highlighting_plugins/Pygments_Kappa_plugin/example_files/kappa_edit_notation_style_edit_dark.png differ diff --git a/syntax_highlighting_plugins/Pygments_Kappa_plugin/pyproject.toml b/syntax_highlighting_plugins/Pygments_Kappa_plugin/pyproject.toml new file mode 100644 index 0000000000..bd28783662 --- /dev/null +++ b/syntax_highlighting_plugins/Pygments_Kappa_plugin/pyproject.toml @@ -0,0 +1,40 @@ +[build-system] + requires = ["setuptools >= 61.0"] + build-backend = "setuptools.build_meta" + +[project] +name = "Pygments_Kappa_plugin" +version = "0.3" +description = "Plugin for Pygments to highlight Kappa." +readme = "README.md" +requires-python = ">=3.7" +license = {file = "LICENSE"} +authors = [ + {name = "Hector Medina"}, + {email = "hector.f.medina.a@gmail.com"} +] +classifiers = [ + "Programming Language :: Python :: 3", + "License :: OSI Approved :: MIT License", + "Operating System :: OS Independent", + "Environment :: Plugins", + "Intended Audience :: Science/Research" +] +dependencies = [ + "Pygments >= 2.5.1" +] +[project.urls] + repository = "https://github.com/hmedina/Pygments_Kappa_plugin" + + +[project.entry-points."pygments.lexers"] + kappa_lexer = "core.KappaLexer:KappaLexer" + +[project.entry-points."pygments.styles"] + kappa_style_demo = "core.KappaStyle:DemoStyle" + kappa_style_browser = "core.KappaStyle:KaSimInBrowserStyle" + kappa_style_edit = "core.KappaStyle:EditNotationDeltasStyle" + kappa_style_edit_dark = "core.KappaStyle:EditNotationDeltasStyleDark" + +[tool.setuptools] + packages = ["core"] diff --git a/syntax_highlighting_plugins/README.md b/syntax_highlighting_plugins/README.md new file mode 100644 index 0000000000..017d9c35c0 --- /dev/null +++ b/syntax_highlighting_plugins/README.md @@ -0,0 +1,4 @@ +We provide the following plugins for editors & syntax highlighting: + +* a [plugin](./NotepadPP_Kappa_plugin/) for [Notepad++](https://notepad-plus-plus.org/), meant for code development +* a [plugin](./Pygments_Kappa_plugin/) for [Pygments](https://pygments.org/), meant for code presentation diff --git a/tests/integration/README.md b/tests/integration/README.md new file mode 100644 index 0000000000..50e1ec635b --- /dev/null +++ b/tests/integration/README.md @@ -0,0 +1,7 @@ +# Integration Test Suite + +Each level-2 subdirectory `/` defines a test. A test is defined by an arbitrary shell script named `README` that typically runs KaSim and/or other analysis tools, outputting results in an `output` directory. For every generated file `output/`, an expected output can be provided in the form of an `output/.ref` file. + +To run a particular test, run `make /error`. This executes the `README` script and compares all generated outputs to their expected versions. A diff is stored in an `error` file. The test is considered passing if and only if `error` is empty. While running the `README` script, `stdout` is captured and stored in `output/LOG` while `stderr` is captured and stored in `output/errors.log`. + +To run all integration tests, run `make all`. To clean all generated files, run `make clean`. \ No newline at end of file diff --git a/tests/integration/cflows/cflows_json/output/cflow_Weakly_env.json.ref b/tests/integration/cflows/cflows_json/output/cflow_Weakly_env.json.ref index bdf0d0dd03..f7547a3309 100644 --- a/tests/integration/cflows/cflows_json/output/cflow_Weakly_env.json.ref +++ b/tests/integration/cflows/cflows_json/output/cflow_Weakly_env.json.ref @@ -1 +1 @@ -{"filenames":["","json.ka"],"update":{"signatures":[{"name":"A","decl":[{"name":"a","decl":[[{"name":"u","decl":null},{"name":"p","decl":null}],null,null]}]},{"name":"B","decl":[{"name":"a","decl":[[{"name":"u","decl":null},{"name":"p","decl":null}],null,null]},{"name":"b","decl":[[],null,null]}]}],"single_agents":[null,null],"elementaries":[[[[[[[1,0],0],[[2,1],1]],12],[[[[1,0],0],[[2,1],0]],11],[[[[1,0],0],1],10],[[[[1,0],0],0],9],[[[[1,0],0],null],8]]],[[[[[[1,0],0],[[2,1],0]],11],[[[[2,1],0],1],15],[[[[2,1],0],0],14],[[[[2,1],0],null],13]],[[[[[1,0],0],[[2,1],1]],12],[[[[2,1],1],null],16]]]],"dag":[{"content":null,"roots":null,"deps":[],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,1]]]},"roots":[[1],0],"deps":[["MODIF",0],["RULE",4],["RULE",2],["ALG",0]],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,1],[false,null]]]},"roots":[[2],1],"deps":[["MODIF",0],["RULE",2],["ALG",0]],"sons":[{"dst":7,"inj":[[2,2]],"nav":[[[2,1],null]]}]},{"content":{"sorts":[null,0,1,0],"nodes":[null,[[{"node":2,"site":0},1]],[[{"node":1,"site":0},1],[{"node":3,"site":0},null]],[[{"node":2,"site":1},1]]]},"roots":[[1],0],"deps":[["MODIF",1],["ALG",1]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,0]]]},"roots":[[1],0],"deps":[["RULE",0]],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,0],[false,null]]]},"roots":[[2],1],"deps":[["RULE",1]],"sons":[]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},1]],[[{"node":1,"site":0},1],[false,null]]]},"roots":[[1],0],"deps":[["RULE",3]],"sons":[{"dst":3,"inj":[[3,3],[2,2],[1,1]],"nav":[[[2,1],[[3,0],0]],[[3,0],1]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,1],[true,null]]]},"roots":[[2],1],"deps":[["RULE",4]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,null]]]},"roots":null,"deps":[],"sons":[{"dst":1,"inj":[[1,1]],"nav":[[[1,0],1]]},{"dst":4,"inj":[[1,1]],"nav":[[[1,0],0]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,0]]]},"roots":null,"deps":[],"sons":[{"dst":4,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,1]]]},"roots":null,"deps":[],"sons":[{"dst":3,"inj":[[3,1],[2,2],[1,3]],"nav":[[[1,0],[[2,1],1]],[[2,0],[[3,0],0]],[[2,0],1],[[3,0],1]]},{"dst":6,"inj":[[2,2],[1,1]],"nav":[[[1,0],[[2,1],0]],[[2,0],1]]},{"dst":1,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},null]],[[{"node":1,"site":0},null],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":6,"inj":[[2,2],[1,1]],"nav":[[[2,0],1],[[1,0],1]]}]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":1},null]],[[false,null],[{"node":1,"site":0},null]]]},"roots":null,"deps":[],"sons":[{"dst":3,"inj":[[3,1],[2,2],[1,3]],"nav":[[[2,0],[[3,0],0]],[[1,0],1],[[2,0],1],[[3,0],1]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,null],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":2,"inj":[[2,2]],"nav":[[[2,0],1]]},{"dst":5,"inj":[[2,2]],"nav":[[[2,0],0]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,0],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":5,"inj":[[2,2]],"nav":[[[2,0],null]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,1],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":6,"inj":[[2,2],[1,1]],"nav":[[[2,0],[[1,0],0]],[[1,0],1]]},{"dst":2,"inj":[[2,2]],"nav":[[[2,0],null]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,null],[true,null]]]},"roots":null,"deps":[],"sons":[{"dst":7,"inj":[[2,2]],"nav":[[[2,0],null],[[2,0],1]]}]}],"id_by_type":[[1,3],[2]],"max_obs":17},"tokens":[],"algs":[{"name":"ApBp","decl":["MIX",[[1,2]]]},{"name":"ABA","decl":["MIX",[[3]]]}],"observables":["[T]",["VAR",0],["VAR",1]],"ast_rules":[["Ap",{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},"Maintained"]],"states":[[0,1]],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":4,"bchr":32,"echr":36}},"unary_rate":null,"editStyle":false}],["Bp",{"mixture":[{"type":1,"bindings":[[{"val":"FREE"},"Maintained"],[{"val":null},"Maintained"]],"states":[[0,1],null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":5,"bchr":32,"echr":36}},"unary_rate":null,"editStyle":false}],["A.B",{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[1,1]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1],[{"val":null},"Maintained"]],"states":[[1,1],null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":7,"bchr":57,"echr":61}},"unary_rate":null,"editStyle":false}],["A..B",{"mixture":[{"type":0,"bindings":[[{"val":[1,0,1],"loc":{"file":1,"bline":8,"bchr":14,"echr":15}},"Freed"]],"states":[[1,1]],"erased":false},{"type":1,"bindings":[[{"val":[1,0,0],"loc":{"file":1,"bline":8,"bchr":26,"echr":27}},"Freed"],[{"val":null},"Maintained"]],"states":[[1,1],null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":8,"bchr":58,"echr":62}},"unary_rate":null,"editStyle":false}],["A.B.A",{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[1,1]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1],[{"val":"FREE"},2]],"states":[[1,1],null],"erased":false},{"type":0,"bindings":[[{"val":"FREE"},2]],"states":[[1,1]],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":9,"bchr":93,"echr":97}},"unary_rate":null,"editStyle":false}]],"elementary_rules":[{"rate":{"val":0.01,"loc":{"file":1,"bline":4,"bchr":32,"echr":36}},"connected_components":[4],"removed":[{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"PositiveInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0,1]}],"syntactic_rule":1,"instantiations":[[[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],0],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":5,"bchr":32,"echr":36}},"connected_components":[5],"removed":[{"NegativeInternalized":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]}],"inserted":[{"PositiveInternalized":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,1]}],"syntactic_rule":2,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],0],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":7,"bchr":57,"echr":61}},"connected_components":[1,2],"removed":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":3,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":8,"bchr":58,"echr":62}},"connected_components":[6],"removed":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":4,"instantiations":[[[[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[4,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[4,[{"Existing":[{"agent":[2,1]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":9,"bchr":93,"echr":97}},"connected_components":[1,7,1],"removed":[{"Freed":[{"Existing":[{"agent":[1,0]},{"type":2}]},0]},{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},1]},{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[1,0]},{"type":2}]},0,{"Existing":[{"agent":[2,1]},{"type":1}]},1]},{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":5,"instantiations":[[[[2,[{"Existing":[{"agent":[1,0]},{"type":2}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":2}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":2}]}]],[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},1]],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[2,[{"Existing":[{"agent":[1,0]},{"type":2}]},0],[{"Existing":[{"agent":[2,1]},{"type":1}]},1]],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]}],"contact_map":[[[[1,0],[[1,1],[1,0]]]],[[[1,0],[[0,0]]],[[],[[0,0]]]]],"interventions":[{"alarm":null,"condition":{"val":true,"loc":{"file":1,"bline":14,"bchr":6,"echr":12}},"effect":[{"action":"CFLOW","name":"ApBp","pattern":[1,2],"tests":[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]]}],"repeat":{"val":false},"needs_backtrack":false},{"alarm":null,"condition":{"val":true,"loc":{"file":1,"bline":15,"bchr":6,"echr":12}},"effect":[{"action":"CFLOW","name":"ABA","pattern":[3],"tests":[[[5,[{"Existing":[{"agent":[3,0]},{"type":0}]},0],[{"Existing":[{"agent":[2,1]},{"type":0}]},1]],[1,[{"Existing":[{"agent":[3,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[3,0]},{"type":0}]}],[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]]}],"repeat":{"val":false},"needs_backtrack":false}],"dependencies_in_time":[],"dependencies_in_event":[],"algs_reverse_dependencies":[[],[]],"tokens_reverse_dependencies":[]} +{"filenames":["","json.ka"],"update":{"signatures":[{"name":"A","decl":[{"name":"a","decl":{"internal_state":[{"name":"u","decl":null},{"name":"p","decl":null}],"links":null,"counters_info":null}}]},{"name":"B","decl":[{"name":"a","decl":{"internal_state":[{"name":"u","decl":null},{"name":"p","decl":null}],"links":null,"counters_info":null}},{"name":"b","decl":{"internal_state":[],"links":null,"counters_info":null}}]}],"single_agents":[null,null],"elementaries":[[[[[[[1,0],0],[[2,1],1]],12],[[[[1,0],0],[[2,1],0]],11],[[[[1,0],0],1],10],[[[[1,0],0],0],9],[[[[1,0],0],null],8]]],[[[[[[1,0],0],[[2,1],0]],11],[[[[2,1],0],1],15],[[[[2,1],0],0],14],[[[[2,1],0],null],13]],[[[[[1,0],0],[[2,1],1]],12],[[[[2,1],1],null],16]]]],"dag":[{"content":null,"roots":null,"deps":[],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,1]]]},"roots":[[1],0],"deps":[["MODIF",0],["RULE",4],["RULE",2],["ALG",0]],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,1],[false,null]]]},"roots":[[2],1],"deps":[["MODIF",0],["RULE",2],["ALG",0]],"sons":[{"dst":7,"inj":[[2,2]],"nav":[[[2,1],null]]}]},{"content":{"sorts":[null,0,1,0],"nodes":[null,[[{"node":2,"site":0},1]],[[{"node":1,"site":0},1],[{"node":3,"site":0},null]],[[{"node":2,"site":1},1]]]},"roots":[[1],0],"deps":[["MODIF",1],["ALG",1]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,0]]]},"roots":[[1],0],"deps":[["RULE",0]],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,0],[false,null]]]},"roots":[[2],1],"deps":[["RULE",1]],"sons":[]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},1]],[[{"node":1,"site":0},1],[false,null]]]},"roots":[[1],0],"deps":[["RULE",3]],"sons":[{"dst":3,"inj":[[3,3],[2,2],[1,1]],"nav":[[[2,1],[[3,0],0]],[[3,0],1]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,1],[true,null]]]},"roots":[[2],1],"deps":[["RULE",4]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,null]]]},"roots":null,"deps":[],"sons":[{"dst":1,"inj":[[1,1]],"nav":[[[1,0],1]]},{"dst":4,"inj":[[1,1]],"nav":[[[1,0],0]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,0]]]},"roots":null,"deps":[],"sons":[{"dst":4,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,1]]]},"roots":null,"deps":[],"sons":[{"dst":3,"inj":[[3,1],[2,2],[1,3]],"nav":[[[1,0],[[2,1],1]],[[2,0],[[3,0],0]],[[2,0],1],[[3,0],1]]},{"dst":6,"inj":[[2,2],[1,1]],"nav":[[[1,0],[[2,1],0]],[[2,0],1]]},{"dst":1,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},null]],[[{"node":1,"site":0},null],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":6,"inj":[[2,2],[1,1]],"nav":[[[2,0],1],[[1,0],1]]}]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":1},null]],[[false,null],[{"node":1,"site":0},null]]]},"roots":null,"deps":[],"sons":[{"dst":3,"inj":[[3,1],[2,2],[1,3]],"nav":[[[2,0],[[3,0],0]],[[1,0],1],[[2,0],1],[[3,0],1]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,null],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":2,"inj":[[2,2]],"nav":[[[2,0],1]]},{"dst":5,"inj":[[2,2]],"nav":[[[2,0],0]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,0],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":5,"inj":[[2,2]],"nav":[[[2,0],null]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,1],[false,null]]]},"roots":null,"deps":[],"sons":[{"dst":6,"inj":[[2,2],[1,1]],"nav":[[[2,0],[[1,0],0]],[[1,0],1]]},{"dst":2,"inj":[[2,2]],"nav":[[[2,0],null]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,null],[true,null]]]},"roots":null,"deps":[],"sons":[{"dst":7,"inj":[[2,2]],"nav":[[[2,0],null],[[2,0],1]]}]}],"id_by_type":[[1,3],[2]],"max_obs":17},"tokens":[],"algs":[{"name":"ApBp","decl":["MIX",[[1,2]]]},{"name":"ABA","decl":["MIX",[[3]]]}],"observables":["[T]",["VAR",0],["VAR",1]],"ast_rules":[["Ap",{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},"Maintained"]],"states":[[0,1]],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":4,"bchr":32,"echr":36}},"unary_rate":null,"edit_style":false}],["Bp",{"mixture":[{"type":1,"bindings":[[{"val":"FREE"},"Maintained"],[{"val":null},"Maintained"]],"states":[[0,1],null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":5,"bchr":32,"echr":36}},"unary_rate":null,"edit_style":false}],["A.B",{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[1,1]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1],[{"val":null},"Maintained"]],"states":[[1,1],null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":7,"bchr":57,"echr":61}},"unary_rate":null,"edit_style":false}],["A..B",{"mixture":[{"type":0,"bindings":[[{"val":[1,0,1],"loc":{"file":1,"bline":8,"bchr":14,"echr":15}},"Freed"]],"states":[[1,1]],"erased":false},{"type":1,"bindings":[[{"val":[1,0,0],"loc":{"file":1,"bline":8,"bchr":26,"echr":27}},"Freed"],[{"val":null},"Maintained"]],"states":[[1,1],null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":8,"bchr":58,"echr":62}},"unary_rate":null,"edit_style":false}],["A.B.A",{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[1,1]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1],[{"val":"FREE"},2]],"states":[[1,1],null],"erased":false},{"type":0,"bindings":[[{"val":"FREE"},2]],"states":[[1,1]],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":0.01,"loc":{"file":1,"bline":9,"bchr":93,"echr":97}},"unary_rate":null,"edit_style":false}]],"elementary_rules":[{"rate":{"val":0.01,"loc":{"file":1,"bline":4,"bchr":32,"echr":36}},"connected_components":[4],"removed":[{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"PositiveInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0,1]}],"syntactic_rule":1,"instantiations":[[[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],0],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":5,"bchr":32,"echr":36}},"connected_components":[5],"removed":[{"NegativeInternalized":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]}],"inserted":[{"PositiveInternalized":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,1]}],"syntactic_rule":2,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],0],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":7,"bchr":57,"echr":61}},"connected_components":[1,2],"removed":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":3,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":8,"bchr":58,"echr":62}},"connected_components":[6],"removed":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":4,"instantiations":[[[[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[4,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[4,[{"Existing":[{"agent":[2,1]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":0.01,"loc":{"file":1,"bline":9,"bchr":93,"echr":97}},"connected_components":[1,7,1],"removed":[{"Freed":[{"Existing":[{"agent":[1,0]},{"type":2}]},0]},{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},1]},{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[1,0]},{"type":2}]},0,{"Existing":[{"agent":[2,1]},{"type":1}]},1]},{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":5,"instantiations":[[[[2,[{"Existing":[{"agent":[1,0]},{"type":2}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":2}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":2}]}]],[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},1]],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[2,[{"Existing":[{"agent":[1,0]},{"type":2}]},0],[{"Existing":[{"agent":[2,1]},{"type":1}]},1]],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]}],"contact_map":[[[[1,0],[[1,1],[1,0]]]],[[[1,0],[[0,0]]],[[],[[0,0]]]]],"interventions":[{"alarm":null,"condition":{"val":true,"loc":{"file":1,"bline":14,"bchr":6,"echr":12}},"effect":[{"action":"CFLOW","name":"ApBp","pattern":[1,2],"tests":[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]]}],"repeat":{"val":false},"needs_backtrack":false},{"alarm":null,"condition":{"val":true,"loc":{"file":1,"bline":15,"bchr":6,"echr":12}},"effect":[{"action":"CFLOW","name":"ABA","pattern":[3],"tests":[[[5,[{"Existing":[{"agent":[3,0]},{"type":0}]},0],[{"Existing":[{"agent":[2,1]},{"type":0}]},1]],[1,[{"Existing":[{"agent":[3,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[3,0]},{"type":0}]}],[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]]}],"repeat":{"val":false},"needs_backtrack":false}],"dependencies_in_time":[],"dependencies_in_event":[],"algs_reverse_dependencies":[[],[]],"tokens_reverse_dependencies":[]} diff --git a/tests/integration/cflows/side-effects3/output/trace.json.ref b/tests/integration/cflows/side-effects3/output/trace.json.ref index abe0ead3a2..b43e71a64a 100644 --- a/tests/integration/cflows/side-effects3/output/trace.json.ref +++ b/tests/integration/cflows/side-effects3/output/trace.json.ref @@ -1,5 +1,5 @@ { "dict":{"agent":{"id":0,"type":1},"binding_type":{"type":0,"site":1},"quark":{"agent":0,"site":1},"test":["Is_here","Has_Internal","Is_Free","Is_Bound","Has_Binding_type","Is_Bound_to"],"actions":["Create","Mod_internal","Bind","Bind_to","Free","Remove"],"binding_state":["ANY","FREE","BOUND","BOUND_TYPE","BOUND_to"],"event":{"tests":0,"actions":1,"side_effect_src":2,"side_effect_dst":3,"connectivity_tests":4},"simulation_info":{"id":0,"time":1,"event":2,"profiling":3},"step":["Subs","Rule","Pert","Init","Obs","Dummy"]}, -"model":{"filenames":["","side-effects.ka"],"update":{"signatures":[{"name":"A","decl":[{"name":"x","decl":[[{"name":"a","decl":null},{"name":"b","decl":null}],null,null]}]},{"name":"B","decl":[{"name":"x","decl":[[{"name":"a","decl":null},{"name":"b","decl":null}],null,null]}]},{"name":"C","decl":[]}],"single_agents":[null,null,null],"elementaries":[[[[[[[1,0],0],[[2,1],0]],1],[[[[1,0],0],1],8],[[[[1,0],0],0],7],[[[[1,0],0],null],6]]],[[[[[[1,0],0],[[2,1],0]],1],[[[[2,1],0],1],10],[[[[2,1],0],0],9],[[[[2,1],0],null],3]]],[]],"dag":[{"content":null,"roots":null,"deps":[],"sons":[]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},null]],[[{"node":1,"site":0},null]]]},"roots":[[1],0],"deps":[["RULE",1]],"sons":[{"dst":5,"inj":[[2,2],[1,1]],"nav":[[[2,0],1],[[1,0],1]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[true,0]]]},"roots":[[1],0],"deps":[["RULE",2]],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,null]]]},"roots":[[2],1],"deps":[["RULE",3],["RULE",2]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,1]]]},"roots":[[1],0],"deps":[["RULE",3]],"sons":[]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},1]],[[{"node":1,"site":0},1]]]},"roots":[[1],0],"deps":[["MODIF",0],["RULE",4]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,null]]]},"roots":null,"deps":[],"sons":[{"dst":4,"inj":[[1,1]],"nav":[[[1,0],1]]},{"dst":2,"inj":[[1,1]],"nav":[[[1,0],0]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,0]]]},"roots":null,"deps":[],"sons":[{"dst":2,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,1]]]},"roots":null,"deps":[],"sons":[{"dst":5,"inj":[[2,2],[1,1]],"nav":[[[1,0],[[2,1],0]],[[2,0],1]]},{"dst":4,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,0]]]},"roots":null,"deps":[],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,1]]]},"roots":null,"deps":[],"sons":[{"dst":5,"inj":[[2,2],[1,1]],"nav":[[[2,0],[[1,0],0]],[[1,0],1]]}]}],"id_by_type":[[1],[2],[]],"max_obs":11},"tokens":[],"algs":[],"observables":["[T]"],"ast_rules":[[null,{"mixture":[],"created":[{"type":2,"sites":[],"internals":[]}],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":1,"bchr":11,"echr":12}},"unary_rate":null,"editStyle":false}],[null,{"mixture":[{"type":0,"bindings":[[{"val":"SOME","loc":{"file":1,"bline":2,"bchr":4,"echr":5}},"Freed"]],"states":[null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":2,"bchr":21,"echr":22}},"unary_rate":null,"editStyle":false}],[null,{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[0,1]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1]],"states":[null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":3,"bchr":43,"echr":44}},"unary_rate":null,"editStyle":false}],[null,{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[1,0]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1]],"states":[null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":4,"bchr":43,"echr":44}},"unary_rate":null,"editStyle":false}],["GOAL",{"mixture":[{"type":0,"bindings":[[{"val":[1,0,1],"loc":{"file":1,"bline":5,"bchr":14,"echr":15}},"Erased"]],"states":[[1,"ERASED"]],"erased":true},{"type":1,"bindings":[[{"val":[1,0,0],"loc":{"file":1,"bline":5,"bchr":25,"echr":26}},"Erased"]],"states":[[1,"ERASED"]],"erased":true}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":5,"bchr":38,"echr":39}},"unary_rate":null,"editStyle":false}]],"elementary_rules":[{"rate":{"val":1,"loc":{"file":1,"bline":1,"bchr":11,"echr":12}},"inserted":[{"Agent":{"Fresh":{"id":2,"type":0}}}],"syntactic_rule":1,"instantiations":[[],[[0,{"Fresh":{"id":2,"type":0}},[]]],[],[],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":2,"bchr":21,"echr":22}},"connected_components":[1],"removed":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":2,"instantiations":[[[[3,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[4,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[[[{"Existing":[{"agent":[1,0]},{"type":0}]},0],[2]]],[[{"Existing":[{"agent":[2,1]},{"type":0}]},0]],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":3,"bchr":43,"echr":44}},"connected_components":[2,3],"removed":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"PositiveInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0,1]}],"syntactic_rule":3,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],0],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":4,"bchr":43,"echr":44}},"connected_components":[4,3],"removed":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"PositiveInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0,0]}],"syntactic_rule":4,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],0],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":5,"bchr":38,"echr":39}},"connected_components":[5],"removed":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"NegativeInternalized":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]},{"Agent":{"Existing":[{"agent":[2,1]},{"type":0}]}},{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"Agent":{"Existing":[{"agent":[1,0]},{"type":0}]}}],"syntactic_rule":5,"instantiations":[[[[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[5,{"Existing":[{"agent":[1,0]},{"type":0}]}],[5,{"Existing":[{"agent":[2,1]},{"type":0}]}]],[],[],[]]}],"contact_map":[[],[[[1,0],[[0,0]]]],[[[1,0],[[1,0]]]]],"interventions":[{"alarm":null,"condition":{"val":true,"loc":{"file":1,"bline":10,"bchr":6,"echr":12}},"effect":[{"action":"CFLOW","name":"GOAL","pattern":[5],"tests":[[[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]]}],"repeat":{"val":false},"needs_backtrack":false}],"dependencies_in_time":[],"dependencies_in_event":[],"algs_reverse_dependencies":[],"tokens_reverse_dependencies":[]}, +"model":{"filenames":["","side-effects.ka"],"update":{"signatures":[{"name":"A","decl":[{"name":"x","decl":{"internal_state":[{"name":"a","decl":null},{"name":"b","decl":null}],"links":null,"counters_info":null}}]},{"name":"B","decl":[{"name":"x","decl":{"internal_state":[{"name":"a","decl":null},{"name":"b","decl":null}],"links":null,"counters_info":null}}]},{"name":"C","decl":[]}],"single_agents":[null,null,null],"elementaries":[[[[[[[1,0],0],[[2,1],0]],1],[[[[1,0],0],1],8],[[[[1,0],0],0],7],[[[[1,0],0],null],6]]],[[[[[[1,0],0],[[2,1],0]],1],[[[[2,1],0],1],10],[[[[2,1],0],0],9],[[[[2,1],0],null],3]]],[]],"dag":[{"content":null,"roots":null,"deps":[],"sons":[]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},null]],[[{"node":1,"site":0},null]]]},"roots":[[1],0],"deps":[["RULE",1]],"sons":[{"dst":5,"inj":[[2,2],[1,1]],"nav":[[[2,0],1],[[1,0],1]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[true,0]]]},"roots":[[1],0],"deps":[["RULE",2]],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[true,null]]]},"roots":[[2],1],"deps":[["RULE",3],["RULE",2]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,1]]]},"roots":[[1],0],"deps":[["RULE",3]],"sons":[]},{"content":{"sorts":[null,0,1],"nodes":[null,[[{"node":2,"site":0},1]],[[{"node":1,"site":0},1]]]},"roots":[[1],0],"deps":[["MODIF",0],["RULE",4]],"sons":[]},{"content":{"sorts":[null,0],"nodes":[null,[[true,null]]]},"roots":null,"deps":[],"sons":[{"dst":4,"inj":[[1,1]],"nav":[[[1,0],1]]},{"dst":2,"inj":[[1,1]],"nav":[[[1,0],0]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,0]]]},"roots":null,"deps":[],"sons":[{"dst":2,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,0],"nodes":[null,[[false,1]]]},"roots":null,"deps":[],"sons":[{"dst":5,"inj":[[2,2],[1,1]],"nav":[[[1,0],[[2,1],0]],[[2,0],1]]},{"dst":4,"inj":[[1,1]],"nav":[[[1,0],null]]}]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,0]]]},"roots":null,"deps":[],"sons":[]},{"content":{"sorts":[null,null,1],"nodes":[null,null,[[false,1]]]},"roots":null,"deps":[],"sons":[{"dst":5,"inj":[[2,2],[1,1]],"nav":[[[2,0],[[1,0],0]],[[1,0],1]]}]}],"id_by_type":[[1],[2],[]],"max_obs":11},"tokens":[],"algs":[],"observables":["[T]"],"ast_rules":[[null,{"mixture":[],"created":[{"type":2,"sites":[],"internals":[]}],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":1,"bchr":11,"echr":12}},"unary_rate":null,"edit_style":false}],[null,{"mixture":[{"type":0,"bindings":[[{"val":"SOME","loc":{"file":1,"bline":2,"bchr":4,"echr":5}},"Freed"]],"states":[null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":2,"bchr":21,"echr":22}},"unary_rate":null,"edit_style":false}],[null,{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[0,1]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1]],"states":[null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":3,"bchr":43,"echr":44}},"unary_rate":null,"edit_style":false}],[null,{"mixture":[{"type":0,"bindings":[[{"val":"FREE"},1]],"states":[[1,0]],"erased":false},{"type":1,"bindings":[[{"val":"FREE"},1]],"states":[null],"erased":false}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":4,"bchr":43,"echr":44}},"unary_rate":null,"edit_style":false}],["GOAL",{"mixture":[{"type":0,"bindings":[[{"val":[1,0,1],"loc":{"file":1,"bline":5,"bchr":14,"echr":15}},"Erased"]],"states":[[1,"ERASED"]],"erased":true},{"type":1,"bindings":[[{"val":[1,0,0],"loc":{"file":1,"bline":5,"bchr":25,"echr":26}},"Erased"]],"states":[[1,"ERASED"]],"erased":true}],"created":[],"delta_tokens":[],"rate":{"val":1,"loc":{"file":1,"bline":5,"bchr":38,"echr":39}},"unary_rate":null,"edit_style":false}]],"elementary_rules":[{"rate":{"val":1,"loc":{"file":1,"bline":1,"bchr":11,"echr":12}},"inserted":[{"Agent":{"Fresh":{"id":2,"type":0}}}],"syntactic_rule":1,"instantiations":[[],[[0,{"Fresh":{"id":2,"type":0}},[]]],[],[],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":2,"bchr":21,"echr":22}},"connected_components":[1],"removed":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"syntactic_rule":2,"instantiations":[[[[3,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[4,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[[[{"Existing":[{"agent":[1,0]},{"type":0}]},0],[2]]],[[{"Existing":[{"agent":[2,1]},{"type":0}]},0]],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":3,"bchr":43,"echr":44}},"connected_components":[2,3],"removed":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"PositiveInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0,1]}],"syntactic_rule":3,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],0],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":4,"bchr":43,"echr":44}},"connected_components":[4,3],"removed":[{"Freed":[{"Existing":[{"agent":[2,1]},{"type":1}]},0]},{"Freed":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]}],"inserted":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":1}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"PositiveInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0,0]}],"syntactic_rule":4,"instantiations":[[[[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0]],[0,{"Existing":[{"agent":[2,1]},{"type":1}]}]],[[2,[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],0],[2,[{"Existing":[{"agent":[2,1]},{"type":1}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]]],[],[],[]]},{"rate":{"val":1,"loc":{"file":1,"bline":5,"bchr":38,"echr":39}},"connected_components":[5],"removed":[{"Linked":[{"Existing":[{"agent":[2,1]},{"type":0}]},0,{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"NegativeInternalized":[{"Existing":[{"agent":[2,1]},{"type":0}]},0]},{"Agent":{"Existing":[{"agent":[2,1]},{"type":0}]}},{"NegativeInternalized":[{"Existing":[{"agent":[1,0]},{"type":0}]},0]},{"Agent":{"Existing":[{"agent":[1,0]},{"type":0}]}}],"syntactic_rule":5,"instantiations":[[[[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]],[[5,{"Existing":[{"agent":[1,0]},{"type":0}]}],[5,{"Existing":[{"agent":[2,1]},{"type":0}]}]],[],[],[]]}],"contact_map":[[],[[[1,0],[[0,0]]]],[[[1,0],[[1,0]]]]],"interventions":[{"alarm":null,"condition":{"val":true,"loc":{"file":1,"bline":10,"bchr":6,"echr":12}},"effect":[{"action":"CFLOW","name":"GOAL","pattern":[5],"tests":[[[5,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],[{"Existing":[{"agent":[1,0]},{"type":0}]},0]],[1,[{"Existing":[{"agent":[2,1]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[2,1]},{"type":0}]}],[1,[{"Existing":[{"agent":[1,0]},{"type":0}]},0],1],[0,{"Existing":[{"agent":[1,0]},{"type":0}]}]]]}],"repeat":{"val":false},"needs_backtrack":false}],"dependencies_in_time":[],"dependencies_in_event":[],"algs_reverse_dependencies":[],"tokens_reverse_dependencies":[]}, "trace":[[3,[[0,[0,0],[[0,0]]],[0,[1,1],[[0,1]]],[3,[[1,1],0],[[0,0],0]],[3,[[0,0],0],[[1,1],0]],[1,[[1,1],0],1],[1,[[0,0],0],0]]],[3,[[0,[2,1],[[0,0]]],[4,[[2,1],0]],[1,[[2,1],0],0]]],[3,[[0,[3,1],[[0,0]]],[4,[[3,1],0]],[1,[[3,1],0],0]]],[3,[[0,[4,1],[[0,0]]],[4,[[4,1],0]],[1,[[4,1],0],0]]],[3,[[0,[5,1],[[0,0]]],[4,[[5,1],0]],[1,[[5,1],0],0]]],[3,[[0,[6,1],[[0,0]]],[4,[[6,1],0]],[1,[[6,1],0],0]]],[3,[[0,[7,1],[[0,0]]],[4,[[7,1],0]],[1,[[7,1],0],0]]],[3,[[0,[8,1],[[0,0]]],[4,[[8,1],0]],[1,[[8,1],0],0]]],[3,[[0,[9,1],[[0,0]]],[4,[[9,1],0]],[1,[[9,1],0],0]]],[3,[[0,[10,1],[[0,0]]],[4,[[10,1],0]],[1,[[10,1],0],0]]],[3,[[0,[11,1],[[0,0]]],[4,[[11,1],0]],[1,[[11,1],0],0]]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[1,1],0]],[]],[-1,0.13823092776645854,1,null]],[1,2,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[-1,0.2336477634914299,2,null]],[1,0,[[],[[0,[12,2],[]]],[],[],[]],[-1,0.6020852152278433,3,null]],[1,0,[[],[[0,[13,2],[]]],[],[],[]],[-1,0.753963826966871,4,null]],[1,0,[[],[[0,[14,2],[]]],[],[],[]],[-1,1.1857271317886693,5,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[-1,1.4479897575337672,6,null]],[1,3,[[[[0,[3,1]],[2,[[3,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[3,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[-1,1.626526792640157,7,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[3,1],0]],[]],[-1,1.694399269405521,8,null]],[1,2,[[[[0,[7,1]],[2,[[7,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[7,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[-1,1.7360715939394153,9,null]],[1,0,[[],[[0,[15,2],[]]],[],[],[]],[-1,2.459919167473559,10,null]],[1,0,[[],[[0,[16,2],[]]],[],[],[]],[-1,2.5812814214359765,11,null]],[1,0,[[],[[0,[17,2],[]]],[],[],[]],[-1,2.667802570951534,12,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[7,1],0]],[]],[-1,2.7597142370975534,13,null]],[1,3,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[-1,2.805247638580207,14,null]],[1,0,[[],[[0,[18,2],[]]],[],[],[]],[-1,3.3537951297472084,15,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[-1,3.488364089958148,16,null]],[1,2,[[[[0,[3,1]],[2,[[3,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[3,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[-1,3.4909102221521375,17,null]],[1,0,[[],[[0,[19,2],[]]],[],[],[]],[-1,3.645170784457633,18,null]],[1,0,[[],[[0,[20,2],[]]],[],[],[]],[-1,3.9423458730348933,19,null]],[1,0,[[],[[0,[21,2],[]]],[],[],[]],[-1,4.341679746398391,20,null]],[1,0,[[],[[0,[22,2],[]]],[],[],[]],[-1,4.434357796224944,21,null]],[1,0,[[],[[0,[23,2],[]]],[],[],[]],[-1,4.916008520028986,22,null]],[1,0,[[],[[0,[24,2],[]]],[],[],[]],[-1,5.080240108051781,23,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[3,1],0]],[]],[-1,5.938225320375272,24,null]],[1,3,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[-1,5.998992351062857,25,null]],[1,0,[[],[[0,[25,2],[]]],[],[],[]],[-1,6.041503777915859,26,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[-1,7.304262330229044,27,null]],[1,2,[[[[0,[6,1]],[2,[[6,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[6,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[-1,7.37483820694515,28,null]],[1,0,[[],[[0,[26,2],[]]],[],[],[]],[-1,8.020261029820229,29,null]],[1,0,[[],[[0,[27,2],[]]],[],[],[]],[-1,8.026326967284767,30,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[6,1],0]],[]],[-1,8.573087115389793,31,null]],[1,3,[[[[0,[3,1]],[2,[[3,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[3,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[-1,8.648001700685402,32,null]],[1,0,[[],[[0,[28,2],[]]],[],[],[]],[-1,9.79735928173821,33,null]],[1,0,[[],[[0,[29,2],[]]],[],[],[]],[-1,10.225470481224072,34,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[3,1],0]],[]],[-1,10.255129992912112,35,null]],[1,2,[[[[0,[1,1]],[2,[[1,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[1,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[-1,10.330258056457728,36,null]],[4,"GOAL",[[[5,[[1,1],0],[[0,0],0]],[1,[[1,1],0],1],[0,[1,1]],[1,[[0,0],0],1],[0,[0,0]]]],[0,10.330258056457728,36,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[1,1],0]],[]],[0,10.43488219113191,37,null]],[1,3,[[[[0,[5,1]],[2,[[5,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[5,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,10.461288453408391,38,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[5,1],0]],[]],[0,10.74278735319708,39,null]],[1,2,[[[[0,[3,1]],[2,[[3,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[3,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,10.800242424294126,40,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[3,1],0]],[]],[0,11.105090715503655,41,null]],[1,3,[[[[0,[8,1]],[2,[[8,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[8,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,11.113446152479197,42,null]],[1,0,[[],[[0,[30,2],[]]],[],[],[]],[0,11.418490200525016,43,null]],[1,0,[[],[[0,[31,2],[]]],[],[],[]],[0,11.724351651371544,44,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[8,1],0]],[]],[0,12.471429005391435,45,null]],[1,0,[[],[[0,[32,2],[]]],[],[],[]],[0,12.486124450221796,46,null]],[1,2,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,12.76768321179996,47,null]],[1,0,[[],[[0,[33,2],[]]],[],[],[]],[0,13.024225497191784,48,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[0,15.925201543346688,49,null]],[1,3,[[[[0,[4,1]],[2,[[4,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[4,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,15.956692460372864,50,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[4,1],0]],[]],[0,16.95516113865209,51,null]],[1,2,[[[[0,[7,1]],[2,[[7,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[7,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,17.006031537627784,52,null]],[1,0,[[],[[0,[34,2],[]]],[],[],[]],[0,18.762982130501385,53,null]],[1,0,[[],[[0,[35,2],[]]],[],[],[]],[0,18.908988252459206,54,null]],[1,0,[[],[[0,[36,2],[]]],[],[],[]],[0,18.97850904982092,55,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[7,1],0]],[]],[0,19.23808623142504,56,null]],[1,3,[[[[0,[1,1]],[2,[[1,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[1,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,19.44815534655682,57,null]],[1,0,[[],[[0,[37,2],[]]],[],[],[]],[0,19.994623189169175,58,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[1,1],0]],[]],[0,20.638077346545646,59,null]],[1,2,[[[[0,[4,1]],[2,[[4,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[4,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,20.68375391678002,60,null]],[1,0,[[],[[0,[38,2],[]]],[],[],[]],[0,20.710914625206815,61,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[4,1],0]],[]],[0,20.912125511242472,62,null]],[1,3,[[[[0,[6,1]],[2,[[6,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[6,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,21.017657525564676,63,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[6,1],0]],[]],[0,21.15423751634369,64,null]],[1,2,[[[[0,[8,1]],[2,[[8,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[8,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,21.19165523107778,65,null]],[1,0,[[],[[0,[39,2],[]]],[],[],[]],[0,22.10312915121163,66,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[8,1],0]],[]],[0,22.424912825105707,67,null]],[1,0,[[],[[0,[40,2],[]]],[],[],[]],[0,22.49845197947521,68,null]],[1,3,[[[[0,[2,1]],[2,[[2,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[2,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,22.787215505466673,69,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[2,1],0]],[]],[0,22.850766922374206,70,null]],[1,2,[[[[0,[6,1]],[2,[[6,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[6,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,23.051101628343282,71,null]],[1,0,[[],[[0,[41,2],[]]],[],[],[]],[0,23.654573441546543,72,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[6,1],0]],[]],[0,24.473422416662334,73,null]],[1,3,[[[[0,[5,1]],[2,[[5,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[5,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,24.534887306968972,74,null]],[1,0,[[],[[0,[42,2],[]]],[],[],[]],[0,25.39795204140594,75,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[5,1],0]],[]],[0,25.529229359302782,76,null]],[1,2,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,25.569217346847054,77,null]],[1,0,[[],[[0,[43,2],[]]],[],[],[]],[0,26.07128837550854,78,null]],[1,0,[[],[[0,[44,2],[]]],[],[],[]],[0,26.516461716254526,79,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[0,27.427755694247335,80,null]],[1,3,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,27.711229118585187,81,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[0,28.910631551124876,82,null]],[1,2,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,29.14482013879848,83,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[0,30.037901571711018,84,null]],[1,3,[[[[0,[6,1]],[2,[[6,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[6,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,30.220010286647604,85,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[6,1],0]],[]],[0,30.39225205616227,86,null]],[1,2,[[[[0,[8,1]],[2,[[8,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[8,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,30.510848307941473,87,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[8,1],0]],[]],[0,30.88775834419144,88,null]],[1,3,[[[[0,[3,1]],[2,[[3,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[3,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,30.904574640773408,89,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[3,1],0]],[]],[0,31.884446123975675,90,null]],[1,2,[[[[0,[2,1]],[2,[[2,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[2,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,32.17363656417754,91,null]],[1,0,[[],[[0,[45,2],[]]],[],[],[]],[0,32.32295654205527,92,null]],[1,0,[[],[[0,[46,2],[]]],[],[],[]],[0,32.600966895541816,93,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[2,1],0]],[]],[0,33.07587641114492,94,null]],[1,3,[[[[0,[6,1]],[2,[[6,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[6,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,33.100271099414414,95,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[6,1],0]],[]],[0,33.29771303674189,96,null]],[1,2,[[[[0,[3,1]],[2,[[3,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[3,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,33.35358941527632,97,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[3,1],0]],[]],[0,33.713447280053295,98,null]],[1,3,[[[[0,[10,1]],[2,[[10,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[10,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,33.795464867588166,99,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[10,1],0]],[]],[0,34.86006243613086,100,null]],[1,2,[[[[0,[11,1]],[2,[[11,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[11,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,34.87022309590219,101,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[11,1],0]],[]],[0,35.027150147133405,102,null]],[1,3,[[[[0,[4,1]],[2,[[4,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[4,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,35.17178972212714,103,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[4,1],0]],[]],[0,36.143369884112474,104,null]],[1,2,[[[[0,[6,1]],[2,[[6,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[6,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,36.18948504450144,105,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[6,1],0]],[]],[0,36.86363243247595,106,null]],[1,3,[[[[0,[3,1]],[2,[[3,1],0]]],[[0,[0,0]],[1,[[0,0],0],1],[2,[[0,0],0]]]],[[2,[[3,1],0],[[0,0],0]],[1,[[0,0],0],0]],[],[],[]],[0,37.04252564956838,107,null]],[1,0,[[],[[0,[47,2],[]]],[],[],[]],[0,37.790458776616134,108,null]],[1,1,[[[[0,[0,0]],[3,[[0,0],0]]]],[[4,[[0,0],0]]],[[[[0,0],0],[2]]],[[[3,1],0]],[]],[0,38.04583677097828,109,null]],[1,2,[[[[0,[1,1]],[2,[[1,1],0]]],[[0,[0,0]],[1,[[0,0],0],0],[2,[[0,0],0]]]],[[2,[[1,1],0],[[0,0],0]],[1,[[0,0],0],1]],[],[],[]],[0,38.0464533255708,110,null]],[4,"GOAL",[[[5,[[1,1],0],[[0,0],0]],[1,[[1,1],0],1],[0,[1,1]],[1,[[0,0],0],1],[0,[0,0]]]],[1,38.0464533255708,110,null]],[1,4,[[[[0,[0,0]],[1,[[0,0],0],1],[0,[1,1]],[1,[[1,1],0],1],[5,[[1,1],0],[[0,0],0]]]],[[5,[1,1]],[5,[0,0]]],[],[],[]],[1,38.494097516076884,111,null]],[1,0,[[],[[0,[0,2],[]]],[],[],[]],[1,39.590521527652506,112,null]],[1,0,[[],[[0,[1,2],[]]],[],[],[]],[1,39.845413696129405,113,null]],[1,0,[[],[[0,[48,2],[]]],[],[],[]],[1,40.834442403493796,114,null]],[1,0,[[],[[0,[49,2],[]]],[],[],[]],[1,42.15964811691397,115,null]],[1,0,[[],[[0,[50,2],[]]],[],[],[]],[1,44.16380354850672,116,null]],[1,0,[[],[[0,[51,2],[]]],[],[],[]],[1,46.12185529518045,117,null]],[1,0,[[],[[0,[52,2],[]]],[],[],[]],[1,46.99020734328918,118,null]],[1,0,[[],[[0,[53,2],[]]],[],[],[]],[1,47.3195069041112,119,null]],[1,0,[[],[[0,[54,2],[]]],[],[],[]],[1,47.73501527654362,120,null]],[1,0,[[],[[0,[55,2],[]]],[],[],[]],[1,48.08037645904664,121,null]],[1,0,[[],[[0,[56,2],[]]],[],[],[]],[1,48.317057159348366,122,null]],[1,0,[[],[[0,[57,2],[]]],[],[],[]],[1,49.927819525247614,123,null]],[1,0,[[],[[0,[58,2],[]]],[],[],[]],[1,50.76896644557583,124,null]],[1,0,[[],[[0,[59,2],[]]],[],[],[]],[1,51.41382265556848,125,null]],[1,0,[[],[[0,[60,2],[]]],[],[],[]],[1,51.47946061956511,126,null]],[1,0,[[],[[0,[61,2],[]]],[],[],[]],[1,51.52410360626088,127,null]],[1,0,[[],[[0,[62,2],[]]],[],[],[]],[1,53.14318973162175,128,null]],[1,0,[[],[[0,[63,2],[]]],[],[],[]],[1,53.49460683049122,129,null]],[1,0,[[],[[0,[64,2],[]]],[],[],[]],[1,53.735906855421625,130,null]],[1,0,[[],[[0,[65,2],[]]],[],[],[]],[1,54.471226597667616,131,null]],[1,0,[[],[[0,[66,2],[]]],[],[],[]],[1,54.62366447803344,132,null]],[1,0,[[],[[0,[67,2],[]]],[],[],[]],[1,58.64891952667402,133,null]],[1,0,[[],[[0,[68,2],[]]],[],[],[]],[1,58.66571677933717,134,null]],[1,0,[[],[[0,[69,2],[]]],[],[],[]],[1,58.84261217832868,135,null]],[1,0,[[],[[0,[70,2],[]]],[],[],[]],[1,59.4104108357406,136,null]],[1,0,[[],[[0,[71,2],[]]],[],[],[]],[1,60.024837732409054,137,null]],[1,0,[[],[[0,[72,2],[]]],[],[],[]],[1,60.6835991122626,138,null]],[1,0,[[],[[0,[73,2],[]]],[],[],[]],[1,63.3158673530187,139,null]],[1,0,[[],[[0,[74,2],[]]],[],[],[]],[1,63.38727082230276,140,null]],[1,0,[[],[[0,[75,2],[]]],[],[],[]],[1,65.72170701603665,141,null]],[1,0,[[],[[0,[76,2],[]]],[],[],[]],[1,66.18079768519735,142,null]],[1,0,[[],[[0,[77,2],[]]],[],[],[]],[1,67.41232406185625,143,null]],[1,0,[[],[[0,[78,2],[]]],[],[],[]],[1,71.10030192720819,144,null]],[1,0,[[],[[0,[79,2],[]]],[],[],[]],[1,71.23991846826897,145,null]],[1,0,[[],[[0,[80,2],[]]],[],[],[]],[1,71.55358919906384,146,null]],[1,0,[[],[[0,[81,2],[]]],[],[],[]],[1,72.53844218807349,147,null]],[1,0,[[],[[0,[82,2],[]]],[],[],[]],[1,73.70309448099336,148,null]],[1,0,[[],[[0,[83,2],[]]],[],[],[]],[1,74.07464291937578,149,null]],[1,0,[[],[[0,[84,2],[]]],[],[],[]],[1,75.74858439444773,150,null]],[1,0,[[],[[0,[85,2],[]]],[],[],[]],[1,75.99083804520345,151,null]],[1,0,[[],[[0,[86,2],[]]],[],[],[]],[1,75.99474244284836,152,null]],[1,0,[[],[[0,[87,2],[]]],[],[],[]],[1,79.91041368447468,153,null]],[1,0,[[],[[0,[88,2],[]]],[],[],[]],[1,80.3617705040289,154,null]],[1,0,[[],[[0,[89,2],[]]],[],[],[]],[1,80.47115964962752,155,null]],[1,0,[[],[[0,[90,2],[]]],[],[],[]],[1,81.16950393224009,156,null]],[1,0,[[],[[0,[91,2],[]]],[],[],[]],[1,82.84208581519334,157,null]],[1,0,[[],[[0,[92,2],[]]],[],[],[]],[1,82.96862445066279,158,null]],[1,0,[[],[[0,[93,2],[]]],[],[],[]],[1,83.02574451634469,159,null]],[1,0,[[],[[0,[94,2],[]]],[],[],[]],[1,83.43494540628078,160,null]],[1,0,[[],[[0,[95,2],[]]],[],[],[]],[1,84.75897414500096,161,null]],[1,0,[[],[[0,[96,2],[]]],[],[],[]],[1,86.27800687992146,162,null]],[1,0,[[],[[0,[97,2],[]]],[],[],[]],[1,86.70523863145627,163,null]],[1,0,[[],[[0,[98,2],[]]],[],[],[]],[1,87.00291202216177,164,null]],[1,0,[[],[[0,[99,2],[]]],[],[],[]],[1,87.47683984452136,165,null]],[1,0,[[],[[0,[100,2],[]]],[],[],[]],[1,88.27692884308469,166,null]],[1,0,[[],[[0,[101,2],[]]],[],[],[]],[1,89.45094491401196,167,null]],[1,0,[[],[[0,[102,2],[]]],[],[],[]],[1,90.7999534354089,168,null]],[1,0,[[],[[0,[103,2],[]]],[],[],[]],[1,91.34000842351216,169,null]],[1,0,[[],[[0,[104,2],[]]],[],[],[]],[1,91.36124183554971,170,null]],[1,0,[[],[[0,[105,2],[]]],[],[],[]],[1,92.42637142894652,171,null]],[1,0,[[],[[0,[106,2],[]]],[],[],[]],[1,92.91976615768908,172,null]],[1,0,[[],[[0,[107,2],[]]],[],[],[]],[1,93.19804536448288,173,null]],[1,0,[[],[[0,[108,2],[]]],[],[],[]],[1,95.09421553172456,174,null]],[1,0,[[],[[0,[109,2],[]]],[],[],[]],[1,95.52108673781673,175,null]],[1,0,[[],[[0,[110,2],[]]],[],[],[]],[1,95.7469521442698,176,null]],[1,0,[[],[[0,[111,2],[]]],[],[],[]],[1,95.81231866505402,177,null]],[1,0,[[],[[0,[112,2],[]]],[],[],[]],[1,96.03214880580897,178,null]],[1,0,[[],[[0,[113,2],[]]],[],[],[]],[1,96.23827228909866,179,null]],[1,0,[[],[[0,[114,2],[]]],[],[],[]],[1,96.84541742093506,180,null]],[1,0,[[],[[0,[115,2],[]]],[],[],[]],[1,97.11530276779472,181,null]],[1,0,[[],[[0,[116,2],[]]],[],[],[]],[1,97.43980247159546,182,null]],[1,0,[[],[[0,[117,2],[]]],[],[],[]],[1,97.89061527379926,183,null]],[1,0,[[],[[0,[118,2],[]]],[],[],[]],[1,99.78604285068981,184,null]],[1,0,[[],[[0,[119,2],[]]],[],[],[]],[1,100.10249665795644,185,null]],[1,0,[[],[[0,[120,2],[]]],[],[],[]],[1,103.11273417850109,186,null]],[1,0,[[],[[0,[121,2],[]]],[],[],[]],[1,104.23313308244514,187,null]],[1,0,[[],[[0,[122,2],[]]],[],[],[]],[1,104.39464153879467,188,null]],[1,0,[[],[[0,[123,2],[]]],[],[],[]],[1,104.43775981504315,189,null]],[1,0,[[],[[0,[124,2],[]]],[],[],[]],[1,105.15012677269257,190,null]],[1,0,[[],[[0,[125,2],[]]],[],[],[]],[1,106.87820496904953,191,null]],[1,0,[[],[[0,[126,2],[]]],[],[],[]],[1,107.2378573981612,192,null]],[1,0,[[],[[0,[127,2],[]]],[],[],[]],[1,107.28791165470423,193,null]],[1,0,[[],[[0,[128,2],[]]],[],[],[]],[1,107.69861556813046,194,null]],[1,0,[[],[[0,[129,2],[]]],[],[],[]],[1,110.02295451648506,195,null]],[1,0,[[],[[0,[130,2],[]]],[],[],[]],[1,112.22226658416241,196,null]],[1,0,[[],[[0,[131,2],[]]],[],[],[]],[1,112.43722357268074,197,null]],[1,0,[[],[[0,[132,2],[]]],[],[],[]],[1,112.65766296263841,198,null]],[1,0,[[],[[0,[133,2],[]]],[],[],[]],[1,112.76894147316574,199,null]]] } diff --git a/tests/integration/cflows/trace-parsing/README b/tests/integration/cflows/trace-parsing/README new file mode 100644 index 0000000000..3b9da1891b --- /dev/null +++ b/tests/integration/cflows/trace-parsing/README @@ -0,0 +1,8 @@ +#!/bin/sh + +"${KAPPABIN}"KaSim -i model.ka -seed 0 -d output -trace trace.json -syntax 4 || exit 0 +"${KAPPABIN}"KaStor -d output --none --weak --time-independent output/trace.json || exit 0 +cd output ; rm -f *.dat *.ka *.json *.txt *.html # We only check that KaStor successfully parses the trace. + +# Check that trace files are properly parsed in the presence of $SNAPSHOT perturbations. +# Added after: https://github.com/Kappa-Dev/KappaTools/issues/656 \ No newline at end of file diff --git a/tests/integration/cflows/trace-parsing/model.ka b/tests/integration/cflows/trace-parsing/model.ka new file mode 100644 index 0000000000..c42ab68991 --- /dev/null +++ b/tests/integration/cflows/trace-parsing/model.ka @@ -0,0 +1,28 @@ +%agent: timer(s{tik, tok}) %init: 1 timer() +timer(s{tik}) <-> timer(s{tok}) @ 1, 1 + +%mod: [E] = 1 do $SNAPSHOT ; +%mod: [E] = 2 do $SNAPSHOT [true] ; +%mod: [E] = 3 do $SNAPSHOT [false] ; +%mod: [E] = 4 do $SNAPSHOT [true] ; repeat [true] +%mod: [E] = 5 do $SNAPSHOT [true] ; repeat [false] +%mod: [E] = 6 do $SNAPSHOT [false] ; repeat [true] +%mod: [E] = 7 do $SNAPSHOT [false] ; repeat [false] + +%mod: [E] = 11 do $SNAPSHOT "snap_".[E].".ka" ; +%mod: [E] = 12 do $SNAPSHOT "snap_".[E].".ka" [true] ; +%mod: [E] = 13 do $SNAPSHOT "snap_".[E].".ka" [false] ; +%mod: [E] = 14 do $SNAPSHOT "snap_".[E].".ka" [true] ; repeat [true] +%mod: [E] = 15 do $SNAPSHOT "snap_".[E].".ka" [true] ; repeat [false] +%mod: [E] = 16 do $SNAPSHOT "snap_".[E].".ka" [false] ; repeat [true] +%mod: [E] = 17 do $SNAPSHOT "snap_".[E].".ka" [false] ; repeat [false] + +%mod: [E] = 21 do $SNAPSHOT "snap_".[E].".json" ; +%mod: [E] = 22 do $SNAPSHOT "snap_".[E].".json" [true] ; +%mod: [E] = 23 do $SNAPSHOT "snap_".[E].".json" [false] ; +%mod: [E] = 24 do $SNAPSHOT "snap_".[E].".json" [true] ; repeat [true] +%mod: [E] = 25 do $SNAPSHOT "snap_".[E].".json" [true] ; repeat [false] +%mod: [E] = 26 do $SNAPSHOT "snap_".[E].".json" [false] ; repeat [true] +%mod: [E] = 27 do $SNAPSHOT "snap_".[E].".json" [false] ; repeat [false] + +%mod: [E] = 30 do $STOP ; diff --git a/tests/integration/cflows/trace-parsing/output/LOG.ref b/tests/integration/cflows/trace-parsing/output/LOG.ref new file mode 100644 index 0000000000..84ab147463 --- /dev/null +++ b/tests/integration/cflows/trace-parsing/output/LOG.ref @@ -0,0 +1,24 @@ +Parsing model.ka... +done ++ simulation parameters ++ Sanity checks ++ Compiling... ++ Building initial simulation conditions... + -variable declarations + -rules + -interventions + -observables + -update_domain construction + 3 (sub)observables 0 navigation steps + -initial conditions ++ Building initial state (1 agents) +Done ++ Command line to rerun is: 'KaSim' '-i' 'model.ka' '-seed' '0' '-d' 'output' '-trace' 'trace.json' '-syntax' '4' +______________________________________________________________________ +###################################################################### +Simulation ended ++ Loading trace + - removing events occurring after the last observable: -31 events ++ No causal flow found ++ Pretty printing 0 flow ++ Pretty printing 0 weakly compressed flow diff --git a/tests/integration/cflows/trace-parsing/output/error.log.ref b/tests/integration/cflows/trace-parsing/output/error.log.ref new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/integration/compiler/counters_perturbation/output/counter_perturbation.ka.ref b/tests/integration/compiler/counters_perturbation/output/counter_perturbation.ka.ref index 0a2c0a62c5..c389c0d59c 100644 --- a/tests/integration/compiler/counters_perturbation/output/counter_perturbation.ka.ref +++ b/tests/integration/compiler/counters_perturbation/output/counter_perturbation.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 4] -%def: "T0" "0.0860731" +%def: "T0" "0.08607308272389651" %init: 1 /*1 agents*/ A(x{u}[.] c{=4}) %init: 39 /*1 agents*/ A(x{u}[.] c{=0}) diff --git a/tests/integration/compiler/counters_signature_with_contact_map/output/counter_perturbation.ka.ref b/tests/integration/compiler/counters_signature_with_contact_map/output/counter_perturbation.ka.ref index c3e07f0af6..0b3f3888f0 100644 --- a/tests/integration/compiler/counters_signature_with_contact_map/output/counter_perturbation.ka.ref +++ b/tests/integration/compiler/counters_signature_with_contact_map/output/counter_perturbation.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 39] -%def: "T0" "2.30101" +%def: "T0" "2.3010139423073865" %init: 1 /*2 agents*/ A(x[1] c{=3} d{=1}), B(x[1] c{=3}) %init: 1 /*2 agents*/ A(x[1] c{=2} d{=1}), B(x[1] c{=3}) diff --git a/tests/integration/compiler/counters_smaller_than/README b/tests/integration/compiler/counters_smaller_than/README new file mode 100644 index 0000000000..3e10065cfe --- /dev/null +++ b/tests/integration/compiler/counters_smaller_than/README @@ -0,0 +1,2 @@ +#Command-line: +"${KAPPABIN}"KaSim -l 1 counters_smaller_than.ka -seed 23014 -d output -syntax 4 || true diff --git a/tests/integration/compiler/counters_smaller_than/counters_smaller_than.ka b/tests/integration/compiler/counters_smaller_than/counters_smaller_than.ka new file mode 100644 index 0000000000..1b2a9d07c3 --- /dev/null +++ b/tests/integration/compiler/counters_smaller_than/counters_smaller_than.ka @@ -0,0 +1,21 @@ +%agent: A(c{=0 / += 7}) +%agent: B() + +'rule_a' A(c{<=2}) -> A(c{+=1}) @ 1 +'rule_b' A(c{>=5}) -> A(c{-=1}) @ 1 +'rule_c' A(c{=3}) -> A(c{+=1}) @ 1 +'rule_aa' A(c{<=1}),. -> ., B() @ 0.2 + +%init: 10 A(c{=0}) +%init: 10 A(c{=7}) + +// %obs: 'A' |A()| +%obs: 'B' |B()| +%obs: 'A0' |A(c{=0})| +%obs: 'A1' |A(c{=1})| +%obs: 'A2' |A(c{=2})| +%obs: 'A3' |A(c{=3})| +%obs: 'A4' |A(c{=4})| +%obs: 'A5' |A(c{=5})| +%obs: 'A6' |A(c{=6})| +%obs: 'A7' |A(c{=7})| diff --git a/tests/integration/compiler/counters_smaller_than/output/LOG.ref b/tests/integration/compiler/counters_smaller_than/output/LOG.ref new file mode 100644 index 0000000000..2c9d6f0d41 --- /dev/null +++ b/tests/integration/compiler/counters_smaller_than/output/LOG.ref @@ -0,0 +1,19 @@ +Parsing counters_smaller_than.ka... +done ++ simulation parameters ++ Sanity checks ++ Compiling... ++ Building initial simulation conditions... + -variable declarations + -rules + -interventions + -observables + -update_domain construction + 28 (sub)observables 58 navigation steps + -initial conditions ++ Building initial state (200 agents) +Done ++ Command line to rerun is: 'KaSim' '-l' '1' 'counters_smaller_than.ka' '-seed' '23014' '-d' 'output' '-syntax' '4' +______________________________________________________________________ +###################################################################### +Simulation ended diff --git a/tests/integration/compiler/counters_smaller_than/output/data.csv.ref b/tests/integration/compiler/counters_smaller_than/output/data.csv.ref new file mode 100644 index 0000000000..4a807970b8 --- /dev/null +++ b/tests/integration/compiler/counters_smaller_than/output/data.csv.ref @@ -0,0 +1,4 @@ +# Output of 'KaSim' '-l' '1' 'counters_smaller_than.ka' '-seed' '23014' '-d' 'output' '-syntax' '4' +"[T]","B","A0","A1","A2","A3","A4","A5","A6","A7" +0.,0,10,0,0,0,0,0,0,10 +1.,2,3,2,2,0,1,2,3,5 diff --git a/tests/integration/compiler/counters_smaller_than/output/error.log.ref b/tests/integration/compiler/counters_smaller_than/output/error.log.ref new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/integration/compiler/counters_smaller_than/output/inputs.ka.ref b/tests/integration/compiler/counters_smaller_than/output/inputs.ka.ref new file mode 100644 index 0000000000..836df5b984 --- /dev/null +++ b/tests/integration/compiler/counters_smaller_than/output/inputs.ka.ref @@ -0,0 +1,44 @@ +%def: "seed" "23014" +%def: "dumpIfDeadlocked" "true" +%def: "maxConsecutiveClash" "3" +%def: "progressBarSize" "70" +%def: "progressBarSymbol" "#" +%def: "plotPeriod" "1" "t.u." +%def: "outputFileName" "data.csv" + + +%agent: A(c{=0/+=7} c__inverted{=0/+=7}) +%agent: B() + +%var:/*0*/ 'B' |B()| +%var:/*1*/ 'A0' |A(c{=0})| +%var:/*2*/ 'A1' |A(c{=1})| +%var:/*3*/ 'A2' |A(c{=2})| +%var:/*4*/ 'A3' |A(c{=3})| +%var:/*5*/ 'A4' |A(c{=4})| +%var:/*6*/ 'A5' |A(c{=5})| +%var:/*7*/ 'A6' |A(c{=6})| +%var:/*8*/ 'A7' |A(c{=7})| +%plot: [T] +%plot: B +%plot: A0 +%plot: A1 +%plot: A2 +%plot: A3 +%plot: A4 +%plot: A5 +%plot: A6 +%plot: A7 + +'rule_a' A(c{>=0/+=1} c__inverted{>=5/+=-1}) @ 1 +'rule_b' A(c{>=5/+=-1} c__inverted{>=0/+=1}) @ 1 +'rule_c' A(c{=3/+=1} c__inverted{>=1/+=-1}) @ 1 +'rule_aa' A(c[#] c__inverted{>=6})-, B()+ @ 0.2 + +/*0*/%mod: (|A(c__inverted{=8})| = 1) do $PRINTF ""; $PRINTF "Counter c__inverted of agent A reached maximum"; $STOP "counter_perturbation.ka"; repeat [false] +/*1*/%mod: (|A(c{=8})| = 1) do $PRINTF ""; $PRINTF "Counter c of agent A reached maximum"; $STOP "counter_perturbation.ka"; repeat [false] + +%init: 10 A(c{=0} c__inverted{=7}) +%init: 10 A(c{=7} c__inverted{=0}) + +%mod: [E] = 19 do $STOP; diff --git a/tests/integration/compiler/lpc1/output/deadlock.ka.ref b/tests/integration/compiler/lpc1/output/deadlock.ka.ref index 3a281feaa7..7b09772bd9 100644 --- a/tests/integration/compiler/lpc1/output/deadlock.ka.ref +++ b/tests/integration/compiler/lpc1/output/deadlock.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 1] -%def: "T0" "0.154278" +%def: "T0" "0.15427774235458555" %init: 1 /*2 agents*/ A(x[.] y[1] z[.]), B(x[1]) diff --git a/tests/integration/compiler/site_mismatch/output/LOG.ref b/tests/integration/compiler/site_mismatch/output/LOG.ref index 762122c5f0..28c6fc2ce4 100644 --- a/tests/integration/compiler/site_mismatch/output/LOG.ref +++ b/tests/integration/compiler/site_mismatch/output/LOG.ref @@ -73,4 +73,4 @@ every agent may occur in the model ------------------------------------------------------------ Some exceptions have been raised -error: file_name: core/KaSa_rep/frontend/prepreprocess.ml; message: line 840, File "crash.ka", line 4, characters 5-69:: missaligned rule: the rule is ignored; exception:Exit +error: file_name: core/KaSa_rep/frontend/prepreprocess.ml; message: line 719, File "crash.ka", line 4, characters 5-69:: missaligned rule: the rule is ignored; exception:Exit diff --git a/tests/integration/kasa_preprocessing/complex/output/LOG.ref b/tests/integration/kasa_preprocessing/complex/output/LOG.ref index f538d202f8..a482ebd510 100644 --- a/tests/integration/kasa_preprocessing/complex/output/LOG.ref +++ b/tests/integration/kasa_preprocessing/complex/output/LOG.ref @@ -552,9 +552,9 @@ C cannot occur in the model ------------------------------------------------------------ Some exceptions have been raised -error: file_name: core/KaSa_rep/reachability_analysis/common_static.ml; message: line 1035; exception:Exit -error: file_name: core/KaSa_rep/reachability_analysis/common_static.ml; message: line 1035; exception:Exit -error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 340; exception:Exit -error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 340; exception:Exit -error: file_name: core/KaSa_rep/reachability_analysis/counters_domain_static.ml; message: line 661; exception:Exit -error: file_name: core/KaSa_rep/reachability_analysis/counters_domain_static.ml; message: line 661; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/common_static.ml; message: line 846; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/common_static.ml; message: line 846; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 286; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 286; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/counters_domain_static.ml; message: line 550; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/counters_domain_static.ml; message: line 550; exception:Exit diff --git a/tests/integration/kasa_preprocessing/counters/output/LOG.ref b/tests/integration/kasa_preprocessing/counters/output/LOG.ref index 8fd174e4ab..148460f0a8 100644 --- a/tests/integration/kasa_preprocessing/counters/output/LOG.ref +++ b/tests/integration/kasa_preprocessing/counters/output/LOG.ref @@ -4189,5 +4189,5 @@ A()=> [A(d:[1 .. 4])] B()=> [B(c:]-oo .. 0])] Some exceptions have been raised -error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 340; exception:Exit -error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 340; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 286; exception:Exit +error: file_name: core/KaSa_rep/reachability_analysis/bdu_static_views.ml; message: line 286; exception:Exit diff --git a/tests/integration/simulation/clashing_instances/output/deadlock.ka.ref b/tests/integration/simulation/clashing_instances/output/deadlock.ka.ref index ee566cda9c..49a0544aef 100644 --- a/tests/integration/simulation/clashing_instances/output/deadlock.ka.ref +++ b/tests/integration/simulation/clashing_instances/output/deadlock.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 99] -%def: "T0" "3.18589" +%def: "T0" "3.1858930696879684" %init: 1 /*1 agents*/ A(x[.]) diff --git a/tests/integration/simulation/distance2_unary_abbc/output/abc.ka.ref b/tests/integration/simulation/distance2_unary_abbc/output/abc.ka.ref index 5a7ae639d6..ce8a5e0b71 100644 --- a/tests/integration/simulation/distance2_unary_abbc/output/abc.ka.ref +++ b/tests/integration/simulation/distance2_unary_abbc/output/abc.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 200] -%def: "T0" "1.52033" +%def: "T0" "1.520325441377089" %init: 1 /*6 agents*/ x2:A(a{p}[1]), x183:B(a[1] b[2] c[3]), x173:B(a[4] b[2] c[5]), x50:A(a{p}[4]), x298:C(c[5]), x219:C(c[3]) diff --git a/tests/integration/simulation/mix_changing_pert/output/deadlock.ka.ref b/tests/integration/simulation/mix_changing_pert/output/deadlock.ka.ref index 6b60afb76d..0770918f1e 100644 --- a/tests/integration/simulation/mix_changing_pert/output/deadlock.ka.ref +++ b/tests/integration/simulation/mix_changing_pert/output/deadlock.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 24] -%def: "T0" "2.33472" +%def: "T0" "2.33471537032762" %init: 10 /*1 agents*/ A(st{c}[.]) diff --git a/tests/integration/simulation/mixture_and_intervention/output/snap.ka.ref b/tests/integration/simulation/mixture_and_intervention/output/snap.ka.ref index b1d37e8ac0..3c863835a5 100644 --- a/tests/integration/simulation/mixture_and_intervention/output/snap.ka.ref +++ b/tests/integration/simulation/mixture_and_intervention/output/snap.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 5027] -%def: "T0" "4" +%def: "T0" "4.0" %init: 1 /*25 agents*/ A(l[1] r[2]), A(l[3] r[1]), A(l[.] r[3]), A(l[2] r[4]), A(l[4] r[5]), A(l[5] r[6]), A(l[6] r[7]), A(l[7] r[8]), diff --git a/tests/integration/simulation/perturbation_after_deadlock/output/deadlock.ka.ref b/tests/integration/simulation/perturbation_after_deadlock/output/deadlock.ka.ref index 224d8275c5..b65ec2999e 100644 --- a/tests/integration/simulation/perturbation_after_deadlock/output/deadlock.ka.ref +++ b/tests/integration/simulation/perturbation_after_deadlock/output/deadlock.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 0] -%def: "T0" "3.20387" +%def: "T0" "3.2038652031773935" %init: 1 /*1 agents*/ A(m[.] n[.]) diff --git a/tests/integration/simulation/perturbation_multiple_alarms/output/rt.ka.ref b/tests/integration/simulation/perturbation_multiple_alarms/output/rt.ka.ref index 73dc7af6b5..df2f582e9d 100644 --- a/tests/integration/simulation/perturbation_multiple_alarms/output/rt.ka.ref +++ b/tests/integration/simulation/perturbation_multiple_alarms/output/rt.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 0] -%def: "T0" "0" +%def: "T0" "0.0" %init: 10000 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_193.ka.ref b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_193.ka.ref index 6a6e6307c0..b9d55dc1d5 100644 --- a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_193.ka.ref +++ b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_193.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 193] -%def: "T0" "2" +%def: "T0" "2.0" %init: 189 /*1 agents*/ A(a{p}[.]) %init: 9801 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_294.ka.ref b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_294.ka.ref index 853e2b64fd..37cea152ca 100644 --- a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_294.ka.ref +++ b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_294.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 294] -%def: "T0" "3" +%def: "T0" "3.0" %init: 288 /*1 agents*/ A(a{p}[.]) %init: 9702 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_386.ka.ref b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_386.ka.ref index 5babbbaa5f..33d559d250 100644 --- a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_386.ka.ref +++ b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_386.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 386] -%def: "T0" "4" +%def: "T0" "4.0" %init: 372 /*1 agents*/ A(a{p}[.]) %init: 9618 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_473.ka.ref b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_473.ka.ref index 5ed32779e1..ceeaf19ed4 100644 --- a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_473.ka.ref +++ b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_473.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 473] -%def: "T0" "5" +%def: "T0" "5.0" %init: 451 /*1 agents*/ A(a{p}[.]) %init: 9539 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_92.ka.ref b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_92.ka.ref index bf95ead167..ff7eb0bda8 100644 --- a/tests/integration/simulation/perturbation_multiple_alarms/output/rt_92.ka.ref +++ b/tests/integration/simulation/perturbation_multiple_alarms/output/rt_92.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 92] -%def: "T0" "1" +%def: "T0" "1.0" %init: 92 /*1 agents*/ A(a{p}[.]) %init: 9908 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_periodic_time/output/rt.ka.ref b/tests/integration/simulation/perturbation_periodic_time/output/rt.ka.ref index 73dc7af6b5..df2f582e9d 100644 --- a/tests/integration/simulation/perturbation_periodic_time/output/rt.ka.ref +++ b/tests/integration/simulation/perturbation_periodic_time/output/rt.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 0] -%def: "T0" "0" +%def: "T0" "0.0" %init: 10000 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_periodic_time/output/rt_194.ka.ref b/tests/integration/simulation/perturbation_periodic_time/output/rt_194.ka.ref index 8c5317dd2d..11b6b2ea40 100644 --- a/tests/integration/simulation/perturbation_periodic_time/output/rt_194.ka.ref +++ b/tests/integration/simulation/perturbation_periodic_time/output/rt_194.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 194] -%def: "T0" "2" +%def: "T0" "2.0" %init: 186 /*1 agents*/ A(a{p}[.]) %init: 9814 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_periodic_time/output/rt_277.ka.ref b/tests/integration/simulation/perturbation_periodic_time/output/rt_277.ka.ref index 0d74c33e63..99fa363ab1 100644 --- a/tests/integration/simulation/perturbation_periodic_time/output/rt_277.ka.ref +++ b/tests/integration/simulation/perturbation_periodic_time/output/rt_277.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 277] -%def: "T0" "3" +%def: "T0" "3.0" %init: 265 /*1 agents*/ A(a{p}[.]) %init: 9735 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_periodic_time/output/rt_363.ka.ref b/tests/integration/simulation/perturbation_periodic_time/output/rt_363.ka.ref index 57994f5bdb..debdfb10ab 100644 --- a/tests/integration/simulation/perturbation_periodic_time/output/rt_363.ka.ref +++ b/tests/integration/simulation/perturbation_periodic_time/output/rt_363.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 363] -%def: "T0" "4" +%def: "T0" "4.0" %init: 345 /*1 agents*/ A(a{p}[.]) %init: 9655 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_periodic_time/output/rt_467.ka.ref b/tests/integration/simulation/perturbation_periodic_time/output/rt_467.ka.ref index 1bd211dd21..147c7d004a 100644 --- a/tests/integration/simulation/perturbation_periodic_time/output/rt_467.ka.ref +++ b/tests/integration/simulation/perturbation_periodic_time/output/rt_467.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 467] -%def: "T0" "5" +%def: "T0" "5.0" %init: 447 /*1 agents*/ A(a{p}[.]) %init: 9553 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/perturbation_periodic_time/output/rt_92.ka.ref b/tests/integration/simulation/perturbation_periodic_time/output/rt_92.ka.ref index bf95ead167..ff7eb0bda8 100644 --- a/tests/integration/simulation/perturbation_periodic_time/output/rt_92.ka.ref +++ b/tests/integration/simulation/perturbation_periodic_time/output/rt_92.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 92] -%def: "T0" "1" +%def: "T0" "1.0" %init: 92 /*1 agents*/ A(a{p}[.]) %init: 9908 /*1 agents*/ A(a{u}[.]) diff --git a/tests/integration/simulation/rafinements/output/final.ka.ref b/tests/integration/simulation/rafinements/output/final.ka.ref index 57e165b41d..a356c8cff5 100644 --- a/tests/integration/simulation/rafinements/output/final.ka.ref +++ b/tests/integration/simulation/rafinements/output/final.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 141489] -%def: "T0" "2" +%def: "T0" "2.0" %init: 2 /*13 agents*/ C(b[1] a[2]), B(a[3] c[1]), A(c[4] b[3]), C(b[5] a[4]), B(a[6] c[5]), A(c[7] b[6]), C(b[8] a[7]), B(a[9] c[8]), diff --git a/tests/integration/simulation/reload/output/snap_0.ka.ref b/tests/integration/simulation/reload/output/snap_0.ka.ref index 4279bfc4c2..b56da61b5c 100644 --- a/tests/integration/simulation/reload/output/snap_0.ka.ref +++ b/tests/integration/simulation/reload/output/snap_0.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 0] -%def: "T0" "0" +%def: "T0" "0.0" %init: 100 /*1 agents*/ B(s[.]) %init: 100 /*1 agents*/ A(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_0_0.ka.ref b/tests/integration/simulation/reload/output/snap_0_0.ka.ref index f1658c76ae..bad35ed88a 100644 --- a/tests/integration/simulation/reload/output/snap_0_0.ka.ref +++ b/tests/integration/simulation/reload/output/snap_0_0.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 0] -%def: "T0" "10" +%def: "T0" "10.0" %init: 31 /*2 agents*/ B(s[1]), A(s[1]) %init: 69 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_11.ka.ref b/tests/integration/simulation/reload/output/snap_11.ka.ref index 6c276c75e2..1b6e9c8fc5 100644 --- a/tests/integration/simulation/reload/output/snap_11.ka.ref +++ b/tests/integration/simulation/reload/output/snap_11.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 11] -%def: "T0" "11" +%def: "T0" "11.0" %init: 40 /*2 agents*/ B(s[1]), A(s[1]) %init: 60 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_12.ka.ref b/tests/integration/simulation/reload/output/snap_12.ka.ref index bae7237890..cf68903d39 100644 --- a/tests/integration/simulation/reload/output/snap_12.ka.ref +++ b/tests/integration/simulation/reload/output/snap_12.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 12] -%def: "T0" "1" +%def: "T0" "1.0" %init: 12 /*2 agents*/ A(s[1]), B(s[1]) %init: 88 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_18.ka.ref b/tests/integration/simulation/reload/output/snap_18.ka.ref index fcae09b02b..9456334fed 100644 --- a/tests/integration/simulation/reload/output/snap_18.ka.ref +++ b/tests/integration/simulation/reload/output/snap_18.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 18] -%def: "T0" "2" +%def: "T0" "2.0" %init: 16 /*2 agents*/ B(s[1]), A(s[1]) %init: 84 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_18_18.ka.ref b/tests/integration/simulation/reload/output/snap_18_18.ka.ref index dbb359d3d1..fe10eb275c 100644 --- a/tests/integration/simulation/reload/output/snap_18_18.ka.ref +++ b/tests/integration/simulation/reload/output/snap_18_18.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 18] -%def: "T0" "12" +%def: "T0" "12.0" %init: 37 /*2 agents*/ B(s[1]), A(s[1]) %init: 63 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_23.ka.ref b/tests/integration/simulation/reload/output/snap_23.ka.ref index 421649323d..f3122ae0b1 100644 --- a/tests/integration/simulation/reload/output/snap_23.ka.ref +++ b/tests/integration/simulation/reload/output/snap_23.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 23] -%def: "T0" "13" +%def: "T0" "13.0" %init: 38 /*2 agents*/ B(s[1]), A(s[1]) %init: 62 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_27.ka.ref b/tests/integration/simulation/reload/output/snap_27.ka.ref index 3ff7a2a122..5ec53f7c35 100644 --- a/tests/integration/simulation/reload/output/snap_27.ka.ref +++ b/tests/integration/simulation/reload/output/snap_27.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 27] -%def: "T0" "14" +%def: "T0" "14.0" %init: 38 /*2 agents*/ B(s[1]), A(s[1]) %init: 62 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_28.ka.ref b/tests/integration/simulation/reload/output/snap_28.ka.ref index 52f0da7aa3..43244bca3d 100644 --- a/tests/integration/simulation/reload/output/snap_28.ka.ref +++ b/tests/integration/simulation/reload/output/snap_28.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 28] -%def: "T0" "15" +%def: "T0" "15.0" %init: 37 /*2 agents*/ B(s[1]), A(s[1]) %init: 63 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_29.ka.ref b/tests/integration/simulation/reload/output/snap_29.ka.ref index c308c8a794..bfde5765a5 100644 --- a/tests/integration/simulation/reload/output/snap_29.ka.ref +++ b/tests/integration/simulation/reload/output/snap_29.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 29] -%def: "T0" "3" +%def: "T0" "3.0" %init: 21 /*2 agents*/ A(s[1]), B(s[1]) %init: 79 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_35.ka.ref b/tests/integration/simulation/reload/output/snap_35.ka.ref index ab187b5f61..a6dc97f736 100644 --- a/tests/integration/simulation/reload/output/snap_35.ka.ref +++ b/tests/integration/simulation/reload/output/snap_35.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 35] -%def: "T0" "4" +%def: "T0" "4.0" %init: 21 /*2 agents*/ A(s[1]), B(s[1]) %init: 79 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_42.ka.ref b/tests/integration/simulation/reload/output/snap_42.ka.ref index 116efac586..c5d9c6960a 100644 --- a/tests/integration/simulation/reload/output/snap_42.ka.ref +++ b/tests/integration/simulation/reload/output/snap_42.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 42] -%def: "T0" "5" +%def: "T0" "5.0" %init: 22 /*2 agents*/ A(s[1]), B(s[1]) %init: 78 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_51.ka.ref b/tests/integration/simulation/reload/output/snap_51.ka.ref index 7e8fd3e7ef..89859ae270 100644 --- a/tests/integration/simulation/reload/output/snap_51.ka.ref +++ b/tests/integration/simulation/reload/output/snap_51.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 51] -%def: "T0" "6" +%def: "T0" "6.0" %init: 27 /*2 agents*/ A(s[1]), B(s[1]) %init: 73 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_56.ka.ref b/tests/integration/simulation/reload/output/snap_56.ka.ref index d15e6e41fa..a711edbecd 100644 --- a/tests/integration/simulation/reload/output/snap_56.ka.ref +++ b/tests/integration/simulation/reload/output/snap_56.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 56] -%def: "T0" "7" +%def: "T0" "7.0" %init: 28 /*2 agents*/ A(s[1]), B(s[1]) %init: 72 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_65.ka.ref b/tests/integration/simulation/reload/output/snap_65.ka.ref index b73f48edb8..20d774aa3e 100644 --- a/tests/integration/simulation/reload/output/snap_65.ka.ref +++ b/tests/integration/simulation/reload/output/snap_65.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 65] -%def: "T0" "8" +%def: "T0" "8.0" %init: 27 /*2 agents*/ B(s[1]), A(s[1]) %init: 73 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_71.ka.ref b/tests/integration/simulation/reload/output/snap_71.ka.ref index e46b3df5be..2515a449e7 100644 --- a/tests/integration/simulation/reload/output/snap_71.ka.ref +++ b/tests/integration/simulation/reload/output/snap_71.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 71] -%def: "T0" "9" +%def: "T0" "9.0" %init: 31 /*2 agents*/ B(s[1]), A(s[1]) %init: 69 /*1 agents*/ B(s[.]) diff --git a/tests/integration/simulation/reload/output/snap_75.ka.ref b/tests/integration/simulation/reload/output/snap_75.ka.ref index 2f284a5f66..c9f4cf8d70 100644 --- a/tests/integration/simulation/reload/output/snap_75.ka.ref +++ b/tests/integration/simulation/reload/output/snap_75.ka.ref @@ -1,5 +1,5 @@ // Snapshot [Event: 75] -%def: "T0" "10" +%def: "T0" "10.0" %init: 31 /*2 agents*/ B(s[1]), A(s[1]) %init: 69 /*1 agents*/ B(s[.]) diff --git a/webapp/WebSim.ml b/webapp/WebSim.ml index 9890da0e32..5f45fd7773 100644 --- a/webapp/WebSim.ml +++ b/webapp/WebSim.ml @@ -8,101 +8,91 @@ open Lwt.Infix -let logger (handler : Cohttp_lwt_unix.Server.conn -> - Cohttp.Request.t -> - Cohttp_lwt.Body.t -> - (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) - (conn : Cohttp_lwt_unix.Server.conn) - (request : Cohttp.Request.t) - (body : Cohttp_lwt.Body.t) - : (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = - (Lwt.catch - (fun () -> handler conn request body) - (fun exn -> Logs_lwt.err (fun m -> m "%s" (Printexc.to_string exn)) >>= - (fun () -> Lwt.fail exn)) - ) - >>= - (fun (response,body) -> - let ip : string = - match fst conn with - | Conduit_lwt_unix.TCP {Conduit_lwt_unix.fd; _} -> - (match Lwt_unix.getpeername fd with - | Lwt_unix.ADDR_INET (ia,port) -> - Printf.sprintf - "%s:%d" - (Ipaddr.to_string (Ipaddr_unix.of_inet_addr ia)) - port - | Lwt_unix.ADDR_UNIX path -> Printf.sprintf "sock:%s" path) - | Conduit_lwt_unix.Vchan _ - | Conduit_lwt_unix.Domain_socket _ -> "unknown" - in - let t = Unix.localtime (Unix.time ()) in - let request_method : string = - Cohttp.Code.string_of_method request.Cohttp_lwt_unix.Request.meth - in - let uri : Uri.t = Cohttp_lwt_unix.Request.uri request in - let request_path : string = Uri.path uri in - let response_code : string = - Cohttp.Code.string_of_status - response.Cohttp.Response.status - in - Logs_lwt.info - (fun m -> - m "%s\t[%02d/%02d/%04d %02d:%02d:%02d]\t\"%s %s\"\t%s" - ip - t.Unix.tm_mday t.Unix.tm_mon (1900 + t.Unix.tm_year) - t.Unix.tm_hour t.Unix.tm_min t.Unix.tm_sec - request_method - request_path - response_code) - >>= - (fun _ -> Lwt.return (response,body)) - ) +let logger + (handler : + Cohttp_lwt_unix.Server.conn -> + Cohttp.Request.t -> + Cohttp_lwt.Body.t -> + (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) + (conn : Cohttp_lwt_unix.Server.conn) (request : Cohttp.Request.t) + (body : Cohttp_lwt.Body.t) : (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = + Lwt.catch + (fun () -> handler conn request body) + (fun exn -> + Logs_lwt.err (fun m -> m "%s" (Printexc.to_string exn)) >>= fun () -> + Lwt.fail exn) + >>= fun (response, body) -> + let ip : string = + match fst conn with + | Conduit_lwt_unix.TCP { Conduit_lwt_unix.fd; _ } -> + (match Lwt_unix.getpeername fd with + | Lwt_unix.ADDR_INET (ia, port) -> + Printf.sprintf "%s:%d" + (Ipaddr.to_string (Ipaddr_unix.of_inet_addr ia)) + port + | Lwt_unix.ADDR_UNIX path -> Printf.sprintf "sock:%s" path) + | Conduit_lwt_unix.Vchan _ | Conduit_lwt_unix.Domain_socket _ -> "unknown" + in + let t = Unix.localtime (Unix.time ()) in + let request_method : string = + Cohttp.Code.string_of_method request.Cohttp_lwt_unix.Request.meth + in + let uri : Uri.t = Cohttp_lwt_unix.Request.uri request in + let request_path : string = Uri.path uri in + let response_code : string = + Cohttp.Code.string_of_status response.Cohttp.Response.status + in + Logs_lwt.info (fun m -> + m "%s\t[%02d/%02d/%04d %02d:%02d:%02d]\t\"%s %s\"\t%s" ip t.Unix.tm_mday + t.Unix.tm_mon (1900 + t.Unix.tm_year) t.Unix.tm_hour t.Unix.tm_min + t.Unix.tm_sec request_method request_path response_code) + >>= fun _ -> Lwt.return (response, body) let server = let app_args = App_args.default in let common_args = Common_args.default in let websim_args = Websim_args.default in - let options = App_args.options app_args @ - Websim_args.options websim_args @ - Common_args.options common_args + let options = + App_args.options app_args + @ Websim_args.options websim_args + @ Common_args.options common_args in let usage_msg : string = "kappa webservice" in let () = Arg.parse options (fun _ -> ()) usage_msg in - let () = Logs.set_reporter - (Agent_common.lwt_reporter app_args.App_args.log_channel) in + let () = + Logs.set_reporter (Agent_common.lwt_reporter app_args.App_args.log_channel) + in let () = Printexc.record_backtrace common_args.Common_args.backtrace in - let mode = match websim_args.Websim_args.cert_dir with + let mode = + match websim_args.Websim_args.cert_dir with | None -> `TCP (`Port websim_args.Websim_args.port) | Some dir -> - `TLS (`Crt_file_path (dir^"cert.pem"), - `Key_file_path (dir^"privkey.pem"), - `No_password, - `Port websim_args.Websim_args.port) in + `TLS + ( `Crt_file_path (dir ^ "cert.pem"), + `Key_file_path (dir ^ "privkey.pem"), + `No_password, + `Port websim_args.Websim_args.port ) + in let route_handler : - Cohttp_lwt_unix.Server.conn -> - Cohttp.Request.t -> - Cohttp_lwt.Body.t -> - (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t - = Webapp.route_handler - ~shutdown_key:websim_args.Websim_args.shutdown_key - () + Cohttp_lwt_unix.Server.conn -> + Cohttp.Request.t -> + Cohttp_lwt.Body.t -> + (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = + Webapp.route_handler ~shutdown_key:websim_args.Websim_args.shutdown_key () in - Cohttp_lwt_unix.Server.create - ~mode + Cohttp_lwt_unix.Server.create ~mode (Cohttp_lwt_unix.Server.make ~callback: - (logger - (match app_args.App_args.api with - | App_args.V2 -> route_handler - ) - ) - () - ) >>= fun () -> + (logger + (match app_args.App_args.api with + | App_args.V2 -> route_handler)) + ()) + >>= fun () -> match app_args.App_args.log_channel with | None -> Lwt.return_unit | Some ch -> Lwt_io.close ch let () = - let () = Lwt.async_exception_hook := ignore in (* see https://github.com/mirage/ocaml-cohttp/issues/511 *) + let () = Lwt.async_exception_hook := ignore in + (* see https://github.com/mirage/ocaml-cohttp/issues/511 *) ignore (Lwt_main.run server) diff --git a/webapp/dune b/webapp/dune index c41ca46d5d..03ad6a6b88 100644 --- a/webapp/dune +++ b/webapp/dune @@ -1,23 +1,44 @@ (executable - (name WebSim) - (libraries num str lwt.unix cohttp-lwt-unix - kappa_staticanalyses - kappa_json_api kappa_agents) - (public_name WebSim) - (package kappa-server) - (flags (:standard - -open Kappa_generic_toolset - -open Kappa_version - -open Kappa_runtime - -open Kappa_grammar - -open Kappa_logging - -open Kappa_errors - -open Kappa_parameters - -open Kappa_reachability - -open Kappa_staticanalyses - -open Kappa_kasa_frontend - -open Kappa_kasa_export - -open Kappa_kasa_type_interface - -open Kappa_agents - -open Kappa_cli - -open Kappa_json_api))) + (name WebSim) + (libraries + num + str + lwt.unix + cohttp-lwt-unix + kappa_staticanalyses + kappa_json_api + kappa_agents) + (public_name WebSim) + (package kappa-server) + (flags + (:standard + -open + Kappa_generic_toolset + -open + Kappa_version + -open + Kappa_runtime + -open + Kappa_grammar + -open + Kappa_logging + -open + Kappa_errors + -open + Kappa_parameters + -open + Kappa_reachability + -open + Kappa_staticanalyses + -open + Kappa_kasa_frontend + -open + Kappa_kasa_export + -open + Kappa_kasa_type_interface + -open + Kappa_agents + -open + Kappa_cli + -open + Kappa_json_api))) diff --git a/webapp/route_root.ml b/webapp/route_root.ml index f8c39461e1..177b697854 100644 --- a/webapp/route_root.ml +++ b/webapp/route_root.ml @@ -8,150 +8,177 @@ open Lwt.Infix -let project_ref context = - List.assoc "projectid" context.Webapp_common.arguments +let project_ref context = List.assoc "projectid" context.Webapp_common.arguments + let file_ref context = - (List.assoc "projectid" context.Webapp_common.arguments, - List.assoc "fileid" context.Webapp_common.arguments) + ( List.assoc "projectid" context.Webapp_common.arguments, + List.assoc "fileid" context.Webapp_common.arguments ) + let pos_file_ref context = - (List.assoc "projectid" context.Webapp_common.arguments, - List.assoc "fileid" context.Webapp_common.arguments, - int_of_string (List.assoc "filepos" context.Webapp_common.arguments)) + ( List.assoc "projectid" context.Webapp_common.arguments, + List.assoc "fileid" context.Webapp_common.arguments, + int_of_string (List.assoc "filepos" context.Webapp_common.arguments) ) + let field_ref context field = - (List.assoc "projectid" context.Webapp_common.arguments, - List.assoc field context.Webapp_common.arguments) + ( List.assoc "projectid" context.Webapp_common.arguments, + List.assoc field context.Webapp_common.arguments ) class new_manager = let re = Re.compile (Re.str "WebSim") in let sa_command = Re.replace_string re ~by:"KaSaAgent" Sys.argv.(0) in - let sa_process = Lwt_process.open_process (sa_command,[|sa_command|]) in + let sa_process = Lwt_process.open_process (sa_command, [| sa_command |]) in let sim_command = Re.replace_string re ~by:"KaSimAgent" Sys.argv.(0) in - let sim_process = Lwt_process.open_process (sim_command,[|sim_command|]) in + let sim_process = Lwt_process.open_process (sim_command, [| sim_command |]) in let stor_command = Re.replace_string re ~by:"KaStor" Sys.argv.(0) in - let stor_process = Lwt_process.open_process (stor_command,[|stor_command|]) in + let stor_process = + Lwt_process.open_process (stor_command, [| stor_command |]) + in let moha_command = Re.replace_string re ~by:"KaMoHa" Sys.argv.(0) in - let moha_process = Lwt_process.open_process (moha_command,[|moha_command|]) in + let moha_process = + Lwt_process.open_process (moha_command, [| moha_command |]) + in let sa_mailbox = Kasa_client.new_mailbox () in let moha_mailbox = Kamoha_client.new_mailbox () in - let stor_state,update_stor_state = Kastor_client.init_state () in - object(self) + let stor_state, update_stor_state = Kastor_client.init_state () in + object (self) initializer let () = Lwt.ignore_result - (Agent_common.serve - sa_process#stdout Tools.default_message_delimter + (Agent_common.serve sa_process#stdout Tools.default_message_delimter (fun r -> - let ()= Kasa_client.receive sa_mailbox r in Lwt.return_unit)) in + let () = Kasa_client.receive sa_mailbox r in + Lwt.return_unit)) + in let () = Lwt.ignore_result - (Agent_common.serve - moha_process#stdout Tools.default_message_delimter + (Agent_common.serve moha_process#stdout Tools.default_message_delimter (fun r -> - let ()= - Kamoha_client.receive moha_mailbox r in Lwt.return_unit)) in + let () = Kamoha_client.receive moha_mailbox r in + Lwt.return_unit)) + in let () = Lwt.ignore_result - (Agent_common.serve - sim_process#stdout Tools.default_message_delimter - (fun r -> let () = self#receive r in Lwt.return_unit)) in + (Agent_common.serve sim_process#stdout Tools.default_message_delimter + (fun r -> + let () = self#receive r in + Lwt.return_unit)) + in let () = Lwt.ignore_result - (Agent_common.serve - stor_process#stdout Tools.default_message_delimter + (Agent_common.serve stor_process#stdout Tools.default_message_delimter (fun r -> - let () = Kastor_client.receive update_stor_state r in - Lwt.return_unit)) in + let () = Kastor_client.receive update_stor_state r in + Lwt.return_unit)) + in () + method is_running = - sim_process#state = Lwt_process.Running && - stor_process#state = Lwt_process.Running && - sa_process#state = Lwt_process.Running + sim_process#state = Lwt_process.Running + && stor_process#state = Lwt_process.Running + && sa_process#state = Lwt_process.Running + method private sleep t = Lwt_unix.sleep t + method private post_message message_text = Lwt.ignore_result (Lwt_io.atomic (fun f -> - Lwt_io.write f message_text >>= fun () -> - Lwt_io.write_char f Tools.default_message_delimter) + Lwt_io.write f message_text >>= fun () -> + Lwt_io.write_char f Tools.default_message_delimter) sim_process#stdin) + inherit Mpi_api.manager () - inherit Kasa_client.new_client + + inherit + Kasa_client.new_client ~is_running:(fun () -> sa_process#state = Lwt_process.Running) ~post:(fun message_text -> - Lwt.ignore_result - (Lwt_io.atomic - (fun f -> - Lwt_io.write f message_text >>= fun () -> - Lwt_io.write_char f Tools.default_message_delimter) - sa_process#stdin)) + Lwt.ignore_result + (Lwt_io.atomic + (fun f -> + Lwt_io.write f message_text >>= fun () -> + Lwt_io.write_char f Tools.default_message_delimter) + sa_process#stdin)) sa_mailbox - inherit Kamoha_client.new_client + + inherit + Kamoha_client.new_client ~post:(fun message_text -> - Lwt.ignore_result - (Lwt_io.atomic - (fun f -> - Lwt_io.write f message_text >>= fun () -> - Lwt_io.write_char f Tools.default_message_delimter) - moha_process#stdin)) + Lwt.ignore_result + (Lwt_io.atomic + (fun f -> + Lwt_io.write f message_text >>= fun () -> + Lwt_io.write_char f Tools.default_message_delimter) + moha_process#stdin)) moha_mailbox - inherit Kastor_client.new_client + + inherit + Kastor_client.new_client ~post:(fun message_text -> - Lwt.ignore_result - (Lwt_io.atomic - (fun f -> - Lwt_io.write f message_text >>= fun () -> - Lwt_io.write_char f Tools.default_message_delimter) - stor_process#stdin)) + Lwt.ignore_result + (Lwt_io.atomic + (fun f -> + Lwt_io.write f message_text >>= fun () -> + Lwt_io.write_char f Tools.default_message_delimter) + stor_process#stdin)) stor_state + method terminate = let () = sim_process#terminate in let () = stor_process#terminate in sa_process#terminate + method is_computing = - self#sim_is_computing || Kasa_client.is_computing sa_mailbox || - self#story_is_computing + self#sim_is_computing + || Kasa_client.is_computing sa_mailbox + || self#story_is_computing val mutable kasa_locator = [] method project_parse ~patternSharing overwrites = - self#secret_project_parse >>= - Api_common.result_bind_lwt - ~ok:(fun out -> - let load = - self#secret_simulation_load patternSharing out overwrites in - let init = self#init_static_analyser out in - let locators = - init >>= function - | Result.Error _ as e -> - let () = kasa_locator <- [] in - Lwt.return (Api_common.result_kasa e) - | Result.Ok () -> - self#get_pos_of_rules_and_vars >>= function - | Result.Ok infos -> - let () = kasa_locator <- infos in - Lwt.return (Result_util.ok ()) - |Result.Error _ as e -> + self#secret_project_parse + >>= Api_common.result_bind_lwt ~ok:(fun out -> + let load = + self#secret_simulation_load patternSharing out overwrites + in + let init = self#init_static_analyser out in + let locators = + init >>= function + | Result.Error _ as e -> let () = kasa_locator <- [] in - Lwt.return (Api_common.result_kasa e) in - load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) + Lwt.return (Api_common.result_kasa e) + | Result.Ok () -> + self#get_pos_of_rules_and_vars >>= ( function + | Result.Ok infos -> + let () = kasa_locator <- infos in + Lwt.return (Result_util.ok ()) + | Result.Error _ as e -> + let () = kasa_locator <- [] in + Lwt.return (Api_common.result_kasa e) ) + in + load >>= Api_common.result_bind_lwt ~ok:(fun () -> locators)) method get_influence_map_node_at ~filename pos : _ Api.result Lwt.t = - List.find_opt (fun (_,x) -> Locality.is_included_in filename pos x) kasa_locator |> - Option_util.map fst |> Result_util.ok ?status:None |> Lwt.return + List.find_opt + (fun (_, x) -> Loc.is_included_in filename pos x) + kasa_locator + |> Option_util.map fst + |> Result_util.ok ?status:None + |> Lwt.return end let bind_projects f id projects = match Mods.StringMap.find_option id !projects with | Some p -> f p | None -> - let m = "Project '"^id^"' not found" in + let m = "Project '" ^ id ^ "' not found" in Lwt.return (Api_common.result_error_msg ~result_code:`Not_found m) let tmp_bind_projects f id projects = match Mods.StringMap.find_option id !projects with | Some p -> f p | None -> - let message = "Project '"^id^"' not found" in + let message = "Project '" ^ id ^ "' not found" in Lwt.return_error (Exception_without_parameter.add_uncaught_error (Exception_without_parameter.build_uncaught_exception @@ -162,32 +189,32 @@ let tmp_bind_projects_raw f id projects = match Mods.StringMap.find_option id !projects with | Some p -> f p | None -> - let message = "Project '"^id^"' not found" in + let message = "Project '" ^ id ^ "' not found" in let err = Exception_without_parameter.add_uncaught_error (Exception_without_parameter.build_uncaught_exception ~file_name:"route_root" ~message Not_found) - Exception_without_parameter.empty_error_handler in + Exception_without_parameter.empty_error_handler + in Webapp_common.kasa_response ~string_of_success:(fun x -> Yojson.Basic.to_string x) (Result.Error err) let add_projects parameter projects = let project_id = parameter.Api_types_j.project_parameter_project_id in - if Mods.StringMap.mem project_id !projects then - let message = "project "^project_id^" exists" in - Lwt.return - (Api_common.result_error_msg ~result_code:`Conflict message) - else + if Mods.StringMap.mem project_id !projects then ( + let message = "project " ^ project_id ^ " exists" in + Lwt.return (Api_common.result_error_msg ~result_code:`Conflict message) + ) else ( let manager = new new_manager in let () = projects := Mods.StringMap.add project_id manager !projects in Lwt.return (Result_util.ok ()) + ) -let delete_projects project_id projects : - unit Api.result Lwt.t = +let delete_projects project_id projects : unit Api.result Lwt.t = match Mods.StringMap.pop project_id !projects with - | None,_ -> - let m = "Project '"^project_id^"' not found" in + | None, _ -> + let m = "Project '" ^ project_id ^ "' not found" in Lwt.return (Api_common.result_error_msg ~result_code:`Not_found m) | Some m, p -> let () = projects := p in @@ -198,373 +225,390 @@ let influence_node_of_string = let rule_re = Re.compile (Re.whole_string - (Re.seq [Re.str "_rule_"; Re.group (Re.rep1 Re.digit)])) in + (Re.seq [ Re.str "_rule_"; Re.group (Re.rep1 Re.digit) ])) + in let var_re = Re.compile - (Re.whole_string - (Re.seq [Re.str "_var_"; Re.group (Re.rep1 Re.digit)])) in - fun node_id -> match Re.exec_opt rule_re node_id with + (Re.whole_string (Re.seq [ Re.str "_var_"; Re.group (Re.rep1 Re.digit) ])) + in + fun node_id -> + match Re.exec_opt rule_re node_id with | Some g -> Public_data.Rule (Re.Group.get g 1 |> int_of_string) | None -> - Public_data.Var - (Re.Group.get (Re.exec var_re node_id) 1 |> int_of_string) + Public_data.Var (Re.Group.get (Re.exec var_re node_id) 1 |> int_of_string) -let route - ~(shutdown_key: string option) - : Webapp_common.route_handler list = +let route ~(shutdown_key : string option) : Webapp_common.route_handler list = let projects = ref Mods.StringMap.empty in [ - { Webapp_common.path = "/v2" ; + { + Webapp_common.path = "/v2"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let info = { - Api_types_j.environment_projects = - Mods.StringMap.size !projects; - Api_types_j.environment_build = Version.version_string; - } in - Webapp_common.api_result_response - ~string_of_success:(Api_types_j.string_of_environment_info - ?len:None) - (Result_util.ok info) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let info = + { + Api_types_j.environment_projects = + Mods.StringMap.size !projects; + Api_types_j.environment_build = Version.version_string; + } + in + Webapp_common.api_result_response + ~string_of_success: + (Api_types_j.string_of_environment_info ?len:None) + (Result_util.ok info) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/shutdown" ; + { + Webapp_common.path = "/v2/shutdown"; Webapp_common.operation = - let methods = [ `OPTIONS ; `POST ; ] in - fun ~context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `POST -> - (Cohttp_lwt.Body.to_string context.Webapp_common.body) - >>= (fun body -> - match shutdown_key with - | Some shutdown_key when shutdown_key = body -> - let () = - Lwt.async - (fun () -> - let () = - Mods.StringMap.iter - (fun _ p -> p#terminate) - !projects in - Lwt_unix.sleep 1.0 >>= - fun () -> exit 0) - in - Lwt.return - (Result_util.ok "shutting down") - | _ -> - Lwt.return - (Result_util.error ~status:`Bad_request - [{ Result_util.severity = Logs.Error ; + (let methods = [ `OPTIONS; `POST ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `POST -> + ( Cohttp_lwt.Body.to_string context.Webapp_common.body + >>= fun body -> + match shutdown_key with + | Some shutdown_key when shutdown_key = body -> + let () = + Lwt.async (fun () -> + let () = + Mods.StringMap.iter (fun _ p -> p#terminate) !projects + in + Lwt_unix.sleep 1.0 >>= fun () -> exit 0) + in + Lwt.return (Result_util.ok "shutting down") + | _ -> + Lwt.return + (Result_util.error ~status:`Bad_request + [ + { + Result_util.severity = Logs.Error; Result_util.text = "invalid key"; - Result_util.range = None ; }])) - >>= fun msg -> - Webapp_common.api_result_response - ~string_of_success:(fun x -> x) msg - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + Result_util.range = None; + }; + ]) ) + >>= fun msg -> + Webapp_common.api_result_response + ~string_of_success:(fun x -> x) + msg + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects" ; + { + Webapp_common.path = "/v2/projects"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; `POST ] in - fun ~context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let names = List.map fst (Mods.StringMap.bindings !projects) in - Webapp_common.api_result_response - ~string_of_success: - (JsonUtil.string_of_write - (JsonUtil.write_list Yojson.Basic.write_string) ?len:None) - (Result_util.ok names) - | `POST -> - (Cohttp_lwt.Body.to_string context.Webapp_common.body) >|= - Mpi_message_j.project_parameter_of_string >>= - (fun param -> add_projects param projects) >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET; `POST ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let names = List.map fst (Mods.StringMap.bindings !projects) in + Webapp_common.api_result_response + ~string_of_success: + (JsonUtil.string_of_write + (JsonUtil.write_list Yojson.Basic.write_string) + ?len:None) + (Result_util.ok names) + | `POST -> + Cohttp_lwt.Body.to_string context.Webapp_common.body + >|= Mpi_message_j.project_parameter_of_string + >>= (fun param -> add_projects param projects) + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}" ; + { + Webapp_common.path = "/v2/projects/{projectid}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `DELETE ] in - fun ~context -> - let project_id = project_ref context in - match context.Webapp_common.request.Cohttp.Request.meth with - | `DELETE -> - (delete_projects project_id projects) >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `DELETE ] in + fun ~context -> + let project_id = project_ref context in + match context.Webapp_common.request.Cohttp.Request.meth with + | `DELETE -> + delete_projects project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/parse/{sharing}" ; + { + Webapp_common.path = "/v2/projects/{projectid}/parse/{sharing}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `POST ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `POST -> - let (project_id,sharing_level) = field_ref context "sharing" in - let request = context.Webapp_common.request in - let uri = Cohttp.Request.uri request in - let overwrites = Uri.query uri in - let overwrites = - List.map - (function - | _, ([] | _::_::_) -> assert false - | x, [ n ] -> (x,Nbr.of_string n)) - overwrites in - bind_projects - (fun manager -> + (let methods = [ `OPTIONS; `POST ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `POST -> + let project_id, sharing_level = field_ref context "sharing" in + let request = context.Webapp_common.request in + let uri = Cohttp.Request.uri request in + let overwrites = Uri.query uri in + let overwrites = + List.map + (function + | _, ([] | _ :: _ :: _) -> assert false + | x, [ n ] -> x, Nbr.of_string n) + overwrites + in + bind_projects + (fun manager -> Api_common.result_bind_lwt ~ok:(fun patternSharing -> - manager#project_parse ~patternSharing overwrites) + manager#project_parse ~patternSharing overwrites) (if sharing_level = "no_sharing" then Result_util.ok Kappa_terms.Pattern.No_sharing else if sharing_level = "max_sharing" then Result_util.ok Kappa_terms.Pattern.Max_sharing else if sharing_level = "compatible_patterns" then Result_util.ok Kappa_terms.Pattern.Compatible_patterns - else Api_common.result_error_msg - ~result_code:`Bad_request + else + Api_common.result_error_msg ~result_code:`Bad_request "Incorrect sharing level between patterns")) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/overwrite/{fileid}" ; + { + Webapp_common.path = "/v2/projects/{projectid}/overwrite/{fileid}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `POST ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `POST -> - let (project_id,file_id) = file_ref context in - (Cohttp_lwt.Body.to_string context.Webapp_common.body) >|= - (JsonUtil.read_of_string (Ast.read_parsing_compil)) - >>= fun ast -> - bind_projects - (fun manager -> manager#project_overwrite file_id ast) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `POST ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `POST -> + let project_id, file_id = file_ref context in + Cohttp_lwt.Body.to_string context.Webapp_common.body + >|= JsonUtil.read_of_string Ast.read_parsing_compil + >>= fun ast -> + bind_projects + (fun manager -> manager#project_overwrite file_id ast) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/files" ; + { + Webapp_common.path = "/v2/projects/{projectid}/files"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ] in - fun ~context:context -> - let project_id = project_ref context in - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - bind_projects - (fun manager -> manager#file_catalog) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:( - JsonUtil.string_of_write - (JsonUtil.write_list Kfiles.write_catalog_item))) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + let project_id = project_ref context in + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + bind_projects + (fun manager -> manager#file_catalog) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (JsonUtil.string_of_write + (JsonUtil.write_list Kfiles.write_catalog_item)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/files/{fileid}" ; + { + Webapp_common.path = "/v2/projects/{projectid}/files/{fileid}"; Webapp_common.operation = - fun ~context:context -> - let methods = [ `OPTIONS ; `DELETE ; `GET ; `POST ] in - let (project_id,file_id) = file_ref context in + (fun ~context -> + let methods = [ `OPTIONS; `DELETE; `GET; `POST ] in + let project_id, file_id = file_ref context in match context.Webapp_common.request.Cohttp.Request.meth with | `DELETE -> bind_projects (fun manager -> manager#file_delete file_id) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") | `GET -> bind_projects (fun manager -> manager#file_get file_id) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:( - JsonUtil.string_of_write - (JsonUtil.write_compact_pair - Yojson.Basic.write_string - Yojson.Basic.write_int))) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (JsonUtil.string_of_write + (JsonUtil.write_compact_pair Yojson.Basic.write_string + Yojson.Basic.write_int)) | `POST -> - (Cohttp_lwt.Body.to_string context.Webapp_common.body) >|= - JsonUtil.read_of_string Yojson.Basic.read_string >>= fun modif -> + Cohttp_lwt.Body.to_string context.Webapp_common.body + >|= JsonUtil.read_of_string Yojson.Basic.read_string + >>= fun modif -> bind_projects (fun manager -> manager#file_update file_id modif) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/files/{fileid}/position/{filepos}" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/files/{fileid}/position/{filepos}"; Webapp_common.operation = - fun ~context:context -> - let methods = [ `OPTIONS ; `POST ; `PUT ] in - let (project_id,file_id,file_pos) = pos_file_ref context in + (fun ~context -> + let methods = [ `OPTIONS; `POST; `PUT ] in + let project_id, file_id, file_pos = pos_file_ref context in match context.Webapp_common.request.Cohttp.Request.meth with | `POST -> bind_projects (fun manager -> manager#file_move file_pos file_id) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") | `PUT -> - (Cohttp_lwt.Body.to_string context.Webapp_common.body) >|= - JsonUtil.read_of_string Yojson.Basic.read_string >>= fun content -> + Cohttp_lwt.Body.to_string context.Webapp_common.body + >|= JsonUtil.read_of_string Yojson.Basic.read_string + >>= fun content -> bind_projects (fun manager -> manager#file_create file_pos file_id content) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/simulation" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation"; Webapp_common.operation = - fun ~context -> - let methods = [ `OPTIONS ; `DELETE ; `GET ; `POST ] in + (fun ~context -> + let methods = [ `OPTIONS; `DELETE; `GET; `POST ] in let project_id = project_ref context in match context.Webapp_common.request.Cohttp.Request.meth with | `DELETE -> bind_projects (fun manager -> manager#simulation_delete) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null") - ) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") | `GET -> bind_projects (fun manager -> manager#simulation_info) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_simulation_info - ?len:None)) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_simulation_info ?len:None) | `POST -> - (Cohttp_lwt.Body.to_string context.Webapp_common.body) >|= - Mpi_message_j.simulation_parameter_of_string >>= fun params -> + Cohttp_lwt.Body.to_string context.Webapp_common.body + >|= Mpi_message_j.simulation_parameter_of_string + >>= fun params -> bind_projects (fun manager -> manager#simulation_start params) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_simulation_artifact - ?len:None)) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_simulation_artifact ?len:None) | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/simulation/trace" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/trace"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_raw_trace) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun out -> out)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_raw_trace) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success:(fun out -> out) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/simulation/outputs" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/outputs"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_outputs_zip) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun out -> Base64.encode out)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_outputs_zip) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success:(fun out -> Base64.encode out) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/parameter" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/parameter"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_parameter) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success: - (Mpi_message_j.string_of_simulation_parameter - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_parameter) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_simulation_parameter ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/filelines/{filelinesid}" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/simulation/filelines/{filelinesid}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let (project_id,filelines_id) = field_ref context "filelinesid" in - bind_projects - (fun manager -> manager#simulation_detail_file_line - filelines_id) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success: - (fun l -> Yojson.Safe.to_string - (`List (List.map (fun x -> `String x) l)))) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id, filelines_id = field_ref context "filelinesid" in + bind_projects + (fun manager -> manager#simulation_detail_file_line filelines_id) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun l -> + Yojson.Safe.to_string + (`List (List.map (fun x -> `String x) l))) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/DIN/{fluxmapsid}" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/simulation/DIN/{fluxmapsid}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let (project_id,fluxmaps_id) = field_ref context "fluxmapsid" in - bind_projects - (fun manager -> manager#simulation_detail_din fluxmaps_id) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_din - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id, fluxmaps_id = field_ref context "fluxmapsid" in + bind_projects + (fun manager -> manager#simulation_detail_din fluxmaps_id) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success:(Mpi_message_j.string_of_din ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/logmessages" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/logmessages"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - let project_id = project_ref context in - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - bind_projects - (fun manager -> manager#simulation_detail_log_message) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_log_message - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + let project_id = project_ref context in + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + bind_projects + (fun manager -> manager#simulation_detail_log_message) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_log_message ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = "/v2/projects/{projectid}/simulation/plot" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/plot"; (* get args *) Webapp_common.operation = - fun ~context:context -> - let methods = [ `OPTIONS ; `GET ; ] in + (fun ~context -> + let methods = [ `OPTIONS; `GET ] in match context.Webapp_common.request.Cohttp.Request.meth with | `GET -> (* "max_points" "limit_method" *) @@ -574,8 +618,7 @@ let route let plot_limit_points : int option = match query "plot_limit_points" with | None -> None - | Some plot_limit_points -> - Some (int_of_string plot_limit_points) + | Some plot_limit_points -> Some (int_of_string plot_limit_points) in let plot_limit_offset : int option = match query "plot_limit_offset" with @@ -583,442 +626,462 @@ let route | Some t -> Some (int_of_string t) in let plot_limit : Api_types_j.plot_limit = - { Api_types_j.plot_limit_offset = plot_limit_offset ; - Api_types_j.plot_limit_points = plot_limit_points ; } in + { Api_types_j.plot_limit_offset; Api_types_j.plot_limit_points } + in let project_id = project_ref context in (* handle malformed *) - (Lwt.return - (Result_util.ok - plot_limit )) >>= - (Api_common.result_bind_lwt - ~ok:(fun plot_parameter -> - bind_projects - (fun manager -> manager#simulation_detail_plot - plot_parameter) - project_id projects)) >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_plot ?len:None)) + Lwt.return (Result_util.ok plot_limit) + >>= Api_common.result_bind_lwt ~ok:(fun plot_parameter -> + bind_projects + (fun manager -> + manager#simulation_detail_plot plot_parameter) + project_id projects) + >>= Webapp_common.api_result_response + ~string_of_success:(Mpi_message_j.string_of_plot ?len:None) | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/snapshots/{snapshotid}" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/simulation/snapshots/{snapshotid}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let (project_id,snapshot_id) = field_ref context "snapshotid" in - bind_projects - (fun manager -> manager#simulation_detail_snapshot snapshot_id) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_snapshot_detail - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id, snapshot_id = field_ref context "snapshotid" in + bind_projects + (fun manager -> manager#simulation_detail_snapshot snapshot_id) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_snapshot_detail ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/efficiency" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/efficiency"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_efficiency) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Counter.Efficiency.string_of_t - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_efficiency) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success:(Counter.Efficiency.string_of_t ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/filelines" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/filelines"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_catalog_file_line) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_file_line_catalog - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_catalog_file_line) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_file_line_catalog ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/DIN" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/DIN"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_catalog_din) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_din_catalog - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_catalog_din) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_din_catalog ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/snapshots" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/snapshots"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_catalog_snapshot) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(Mpi_message_j.string_of_snapshot_catalog - ?len:None)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_catalog_snapshot) + project_id projects + >>= Webapp_common.api_result_response + ~string_of_success: + (Mpi_message_j.string_of_snapshot_catalog ?len:None) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; (* use the controller pattern *) - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/continue" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/continue"; Webapp_common.operation = - let methods = [ `OPTIONS ; `PUT ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `PUT -> - let project_id = project_ref context in - (Cohttp_lwt.Body.to_string context.Webapp_common.body) >|= - (fun s -> + (let methods = [ `OPTIONS; `PUT ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `PUT -> + let project_id = project_ref context in + ( Cohttp_lwt.Body.to_string context.Webapp_common.body >|= fun s -> Yojson.Safe.read_string - (Yojson.Safe.init_lexer ()) (Lexing.from_string s)) - >>= fun params -> - bind_projects - (fun manager -> manager#simulation_continue params) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (Yojson.Safe.init_lexer ()) + (Lexing.from_string s) ) + >>= fun params -> + bind_projects + (fun manager -> manager#simulation_continue params) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/pause" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/pause"; Webapp_common.operation = - let methods = [ `OPTIONS ; `PUT ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `PUT -> - let project_id = project_ref context in - bind_projects - (fun manager -> manager#simulation_pause) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun () -> "null")) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `PUT ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `PUT -> + let project_id = project_ref context in + bind_projects + (fun manager -> manager#simulation_pause) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun () -> + "null") + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/simulation/intervention" ; + { + Webapp_common.path = "/v2/projects/{projectid}/simulation/intervention"; Webapp_common.operation = - let methods = [ `OPTIONS ; `PUT ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `PUT -> - let project_id = project_ref context in - (Cohttp_lwt.Body.to_string context.Webapp_common.body) >|= - Api_types_j.simulation_intervention_of_string >>= fun pert -> - bind_projects - (fun manager -> manager#simulation_intervention pert) - project_id projects >>= - (Webapp_common.api_result_response - ~string_of_success:(fun s -> Yojson.Safe.to_string (`String s))) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `PUT ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `PUT -> + let project_id = project_ref context in + Cohttp_lwt.Body.to_string context.Webapp_common.body + >|= Api_types_j.simulation_intervention_of_string + >>= fun pert -> + bind_projects + (fun manager -> manager#simulation_intervention pert) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun s -> + Yojson.Safe.to_string (`String s)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - (* Static analyses *) - { Webapp_common.path = "/v2/projects/{projectid}/analyses" ; + { + Webapp_common.path = "/v2/projects/{projectid}/analyses"; Webapp_common.operation = - let methods = [ `OPTIONS ; `PUT ; ] in - fun ~context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `PUT -> - let project_id = project_ref context in - Cohttp_lwt.Body.to_string context.Webapp_common.body >>= - fun compil -> tmp_bind_projects - (fun manager -> manager#init_static_analyser_raw compil) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun () -> "null") - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `PUT ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `PUT -> + let project_id = project_ref context in + Cohttp_lwt.Body.to_string context.Webapp_common.body + >>= fun compil -> + tmp_bind_projects + (fun manager -> manager#init_static_analyser_raw compil) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun () -> + "null") + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/contact_map" ; + { + Webapp_common.path = "/v2/projects/{projectid}/analyses/contact_map"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - let request = context.Webapp_common.request in - let uri = Cohttp.Request.uri request in - let query = Uri.get_query_param uri in - let accuracy = Option_util.bind - Public_data.accuracy_of_string (query "accuracy") in - tmp_bind_projects - (fun manager -> manager#get_contact_map accuracy) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> Yojson.Basic.to_string x) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + let request = context.Webapp_common.request in + let uri = Cohttp.Request.uri request in + let query = Uri.get_query_param uri in + let accuracy = + Option_util.bind Public_data.accuracy_of_string + (query "accuracy") + in + tmp_bind_projects + (fun manager -> manager#get_contact_map accuracy) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string x) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/influence_map" ; + { + Webapp_common.path = "/v2/projects/{projectid}/analyses/influence_map"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - let request = context.Webapp_common.request in - let uri = Cohttp.Request.uri request in - let query = Uri.get_query_param uri in - let accuracy = Option_util.bind - Public_data.accuracy_of_string (query "accuracy") in - let fwd = Option_util.map int_of_string (query "fwd") in - let bwd = Option_util.map int_of_string (query "bdw") in - let total = Option_util.map int_of_string (query "total") in - let origin = - Option_util.map influence_node_of_string (query "origin") in - tmp_bind_projects_raw - (fun manager -> + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + let request = context.Webapp_common.request in + let uri = Cohttp.Request.uri request in + let query = Uri.get_query_param uri in + let accuracy = + Option_util.bind Public_data.accuracy_of_string + (query "accuracy") + in + let fwd = Option_util.map int_of_string (query "fwd") in + let bwd = Option_util.map int_of_string (query "bdw") in + let total = Option_util.map int_of_string (query "total") in + let origin = + Option_util.map influence_node_of_string (query "origin") + in + tmp_bind_projects_raw + (fun manager -> match total with | Some total -> - manager#get_local_influence_map - ?fwd ?bwd ?origin ~total accuracy >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> - Yojson.Basic.to_string - (Public_data.local_influence_map_to_json x)) - | _ -> manager#get_influence_map_raw accuracy >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> x)) - project_id projects - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + manager#get_local_influence_map ?fwd ?bwd ?origin ~total + accuracy + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string + (Public_data.local_influence_map_to_json x)) + | _ -> + manager#get_influence_map_raw accuracy + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + x)) + project_id projects + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/influence_map/initial_node" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/analyses/influence_map/initial_node"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - tmp_bind_projects - (fun manager -> manager#get_initial_node) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> - let o = JsonUtil.of_option - Public_data.refined_influence_node_to_json x in - Yojson.Basic.to_string o) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + tmp_bind_projects + (fun manager -> manager#get_initial_node) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + let o = + JsonUtil.of_option + Public_data.refined_influence_node_to_json x + in + Yojson.Basic.to_string o) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/influence_map/next_node{nodeid}" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/analyses/influence_map/next_node{nodeid}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let (project_id,node_id) = field_ref context "nodeid" in - let node = - if node_id = "" then None - else Some (influence_node_of_string node_id) in - tmp_bind_projects - (fun manager -> manager#get_next_node node) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> - let o = JsonUtil.of_option - Public_data.refined_influence_node_to_json x in - Yojson.Basic.to_string o) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id, node_id = field_ref context "nodeid" in + let node = + if node_id = "" then + None + else + Some (influence_node_of_string node_id) + in + tmp_bind_projects + (fun manager -> manager#get_next_node node) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + let o = + JsonUtil.of_option + Public_data.refined_influence_node_to_json x + in + Yojson.Basic.to_string o) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = + { + Webapp_common.path = "/v2/projects/{projectid}/analyses/influence_map/previous_node{nodeid}"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let (project_id,node_id) = field_ref context "nodeid" in - let node = - if node_id = "" then None - else Some (influence_node_of_string node_id) in - tmp_bind_projects - (fun manager -> manager#get_previous_node node) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> - let o = JsonUtil.of_option - Public_data.refined_influence_node_to_json x in - Yojson.Basic.to_string o) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id, node_id = field_ref context "nodeid" in + let node = + if node_id = "" then + None + else + Some (influence_node_of_string node_id) + in + tmp_bind_projects + (fun manager -> manager#get_previous_node node) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + let o = + JsonUtil.of_option + Public_data.refined_influence_node_to_json x + in + Yojson.Basic.to_string o) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/influence_map/node_at" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/analyses/influence_map/node_at"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - let request = context.Webapp_common.request in - let uri = Cohttp.Request.uri request in - let filename = - Option_util.unsome "" (Uri.get_query_param uri "file") in - let line = - int_of_string - (Option_util.unsome "0" (Uri.get_query_param uri "line")) in - let chr = - int_of_string - (Option_util.unsome "0" (Uri.get_query_param uri "chr")) in - bind_projects - (fun manager -> - manager#get_influence_map_node_at - ~filename { Locality.line; Locality.chr }) - project_id projects >>= - Webapp_common.api_result_response - ~string_of_success:(fun x -> - let o = JsonUtil.of_option - Public_data.short_influence_node_to_json x in - Yojson.Basic.to_string o) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + let request = context.Webapp_common.request in + let uri = Cohttp.Request.uri request in + let filename = + Option_util.unsome "" (Uri.get_query_param uri "file") + in + let line = + int_of_string + (Option_util.unsome "0" (Uri.get_query_param uri "line")) + in + let chr = + int_of_string + (Option_util.unsome "0" (Uri.get_query_param uri "chr")) + in + bind_projects + (fun manager -> + manager#get_influence_map_node_at ~filename + { Loc.line; Loc.chr }) + project_id projects + >>= Webapp_common.api_result_response ~string_of_success:(fun x -> + let o = + JsonUtil.of_option + Public_data.short_influence_node_to_json x + in + Yojson.Basic.to_string o) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/all_nodes_of_influence_map" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/analyses/all_nodes_of_influence_map"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - let request = context.Webapp_common.request in - let uri = Cohttp.Request.uri request in - let query = Uri.get_query_param uri in - let accuracy = Option_util.bind - Public_data.accuracy_of_string (query "accuracy") in - tmp_bind_projects - (fun manager -> - manager#get_nodes_of_influence_map - accuracy) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> - Yojson.Basic.to_string - (Public_data.nodes_of_influence_map_to_json x)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + let request = context.Webapp_common.request in + let uri = Cohttp.Request.uri request in + let query = Uri.get_query_param uri in + let accuracy = + Option_util.bind Public_data.accuracy_of_string + (query "accuracy") + in + tmp_bind_projects + (fun manager -> manager#get_nodes_of_influence_map accuracy) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string + (Public_data.nodes_of_influence_map_to_json x)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/dead_rules" ; + { + Webapp_common.path = "/v2/projects/{projectid}/analyses/dead_rules"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - tmp_bind_projects - (fun manager -> manager#get_dead_rules) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> Yojson.Basic.to_string - (Public_data.dead_rules_to_json x)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + tmp_bind_projects + (fun manager -> manager#get_dead_rules) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string (Public_data.dead_rules_to_json x)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/dead_agents" ; + { + Webapp_common.path = "/v2/projects/{projectid}/analyses/dead_agents"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - tmp_bind_projects - (fun manager -> manager#get_dead_agents) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> Yojson.Basic.to_string - (Public_data.json_of_dead_agents x)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + tmp_bind_projects + (fun manager -> manager#get_dead_agents) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string (Public_data.json_of_dead_agents x)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/non_weakly_reversible_transitions" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/analyses/non_weakly_reversible_transitions"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - tmp_bind_projects - (fun manager -> manager#get_non_weakly_reversible_transitions) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> - Yojson.Basic.to_string - (Public_data.separating_transitions_to_json x)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + tmp_bind_projects + (fun manager -> manager#get_non_weakly_reversible_transitions) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string + (Public_data.separating_transitions_to_json x)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/constraints" ; + { + Webapp_common.path = "/v2/projects/{projectid}/analyses/constraints"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - tmp_bind_projects - (fun manager -> manager#get_constraints_list) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> - Yojson.Basic.to_string (Public_data.lemmas_list_to_json x)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + tmp_bind_projects + (fun manager -> manager#get_constraints_list) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string (Public_data.lemmas_list_to_json x)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; - { Webapp_common.path = - "/v2/projects/{projectid}/analyses/potential_polymers" ; + { + Webapp_common.path = + "/v2/projects/{projectid}/analyses/potential_polymers"; Webapp_common.operation = - let methods = [ `OPTIONS ; `GET ; ] in - fun ~context:context -> - match context.Webapp_common.request.Cohttp.Request.meth with - | `GET -> - let project_id = project_ref context in - tmp_bind_projects - (fun manager -> manager#get_potential_polymers (Some Public_data.High) (Some Public_data.High)) (*TO DO make it tunable *) - project_id projects >>= - Webapp_common.kasa_response - ~string_of_success:(fun x -> Yojson.Basic.to_string - (Public_data.scc_to_json x)) - | `OPTIONS -> Webapp_common.options_respond methods - | _ -> Webapp_common.method_not_allowed_respond methods + (let methods = [ `OPTIONS; `GET ] in + fun ~context -> + match context.Webapp_common.request.Cohttp.Request.meth with + | `GET -> + let project_id = project_ref context in + tmp_bind_projects + (fun manager -> + manager#get_potential_polymers (Some Public_data.High) + (Some Public_data.High)) (*TO DO make it tunable *) + project_id projects + >>= Webapp_common.kasa_response ~string_of_success:(fun x -> + Yojson.Basic.to_string (Public_data.scc_to_json x)) + | `OPTIONS -> Webapp_common.options_respond methods + | _ -> Webapp_common.method_not_allowed_respond methods); }; ] diff --git a/webapp/route_root.mli b/webapp/route_root.mli index 47e32ca849..c3bd9a9c3d 100644 --- a/webapp/route_root.mli +++ b/webapp/route_root.mli @@ -6,5 +6,4 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -val route : - shutdown_key:string option -> Webapp_common.route_handler list +val route : shutdown_key:string option -> Webapp_common.route_handler list diff --git a/webapp/webapp.ml b/webapp/webapp.ml index c172991f7d..5db7c6b21d 100644 --- a/webapp/webapp.ml +++ b/webapp/webapp.ml @@ -6,24 +6,22 @@ (* |_|\_\ * GNU Lesser General Public License Version 3 *) (******************************************************************************) -let route_handler - ?(shutdown_key : string option = None) - () - : +let route_handler ?(shutdown_key : string option = None) () : Cohttp_lwt_unix.Server.conn -> Cohttp.Request.t -> Cohttp_lwt.Body.t -> - (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t - = + (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = let intermediate = - Webapp_common.route_handler (Route_root.route ~shutdown_key) in - fun (conn : Cohttp_lwt_unix.Server.conn) - (request : Cohttp.Request.t) - (body : Cohttp_lwt.Body.t) - -> - let context = { Webapp_common.arguments = [] - ; Webapp_common.connection = conn - ; Webapp_common.request = request - ; Webapp_common.body = body } - in - intermediate ~context + Webapp_common.route_handler (Route_root.route ~shutdown_key) + in + fun (conn : Cohttp_lwt_unix.Server.conn) (request : Cohttp.Request.t) + (body : Cohttp_lwt.Body.t) -> + let context = + { + Webapp_common.arguments = []; + Webapp_common.connection = conn; + Webapp_common.request; + Webapp_common.body; + } + in + intermediate ~context diff --git a/webapp/webapp_common.ml b/webapp/webapp_common.ml index 48a50d4ea3..57f1e3305e 100644 --- a/webapp/webapp_common.ml +++ b/webapp/webapp_common.ml @@ -9,10 +9,13 @@ open Lwt.Infix open Cohttp_lwt_unix -type context = { arguments : (string * string) list - ; connection : Cohttp_lwt_unix.Server.conn - ; request : Cohttp.Request.t - ; body : Cohttp_lwt.Body.t } +type context = { + arguments: (string * string) list; + connection: Cohttp_lwt_unix.Server.conn; + request: Cohttp.Request.t; + body: Cohttp_lwt.Body.t; +} + (* Default headers for http requests note support has been added for CORS headers. *) @@ -21,36 +24,26 @@ let headers = let h = Cohttp.Header.add h "content-type" "application/json" in h -let string_response ?(headers=headers) = Server.respond_string ~headers +let string_response ?(headers = headers) = Server.respond_string ~headers -let error_response - ?(headers = headers) - ?(status = `Internal_server_error) - (errors : Result_util.message list) - : (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = +let error_response ?(headers = headers) ?(status = `Internal_server_error) + (errors : Result_util.message list) : + (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = let error_msg : string = JsonUtil.string_of_write - (JsonUtil.write_list Result_util.write_message) errors in + (JsonUtil.write_list Result_util.write_message) + errors + in let () = - Lwt.async - (fun () -> - Logs_lwt.debug - (fun m -> m " + error : %s" error_msg)) + Lwt.async (fun () -> Logs_lwt.debug (fun m -> m " + error : %s" error_msg)) in - Server.respond_string - ~headers - ~status - ~body:error_msg - () - - + Server.respond_string ~headers ~status ~body:error_msg () (* Given a result and a way to serialize a success result, return to client the the http response. *) -let api_result_response - ~(string_of_success: 'ok -> string) - : 'ok Api.result -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = function +let api_result_response ~(string_of_success : 'ok -> string) : + 'ok Api.result -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = function | { Result_util.value = Result.Ok ok; Result_util.status; _ } -> let body : string = string_of_success ok in let status :> Cohttp.Code.status_code = status in @@ -58,7 +51,9 @@ let api_result_response | { Result_util.value = Result.Error errors; Result_util.status; _ } -> let error_msg : string = JsonUtil.string_of_write - (JsonUtil.write_list Result_util.write_message) errors in + (JsonUtil.write_list Result_util.write_message) + errors + in let status :> Cohttp.Code.status_code = status in Logs_lwt.err (fun m -> m "%s" error_msg) >>= fun () -> Server.respond_string ~headers ~status ~body:error_msg () @@ -68,135 +63,118 @@ let kasa_response ~string_of_success x = let method_not_allowed_respond meths = let headers = - Cohttp.Header.add_multi - (Cohttp.Header.init ()) - "Allow" - (List.map Cohttp.Code.string_of_method meths) in - Server.respond - ~headers ~status:`Method_not_allowed ~body:Cohttp_lwt.Body.empty () + Cohttp.Header.add_multi (Cohttp.Header.init ()) "Allow" + (List.map Cohttp.Code.string_of_method meths) + in + Server.respond ~headers ~status:`Method_not_allowed + ~body:Cohttp_lwt.Body.empty () let options_respond methods = let meths_str = List.map Cohttp.Code.string_of_method methods in + let headers = Cohttp.Header.init_with "Access-Control-Allow-Origin" "*" in let headers = - Cohttp.Header.init_with "Access-Control-Allow-Origin" "*" in - let headers = - Cohttp.Header.add headers "Access-Control-Allow-Headers" "Content-Type" in - let headers = - Cohttp.Header.add_multi headers "Allow" meths_str in + Cohttp.Header.add headers "Access-Control-Allow-Headers" "Content-Type" + in + let headers = Cohttp.Header.add_multi headers "Allow" meths_str in let headers = - Cohttp.Header.add_multi headers "Access-Control-Allow-Methods" meths_str in + Cohttp.Header.add_multi headers "Access-Control-Allow-Methods" meths_str + in let headers = - Cohttp.Header.add - headers "Access-Control-Request-Headers" "X-Custom-Header" in + Cohttp.Header.add headers "Access-Control-Request-Headers" "X-Custom-Header" + in Server.respond ~headers ~status:`OK ~body:Cohttp_lwt.Body.empty () - - -type 'a route = - { path : string ; - operation : 'a } +type 'a route = { path: string; operation: 'a } type route_handler = - (context:context -> - (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) - route + (context:context -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) route type route_filter = (context:context -> - chain:(context:context -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) -> - (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) - route + chain:(context:context -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) -> + (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t) + route + +type url_matcher = { re: Re.re; labels: string list; route: string } -type url_matcher = - { re : Re.re; - labels : string list ; - route : string } +let label_prepattern = Re.rep1 (Re.alt [ Re.alnum; Re.char '_' ]) -let label_prepattern = Re.rep1 (Re.alt [Re.alnum; Re.char '_']) let variable_pattern = - Re.compile (Re.seq [Re.char '{'; label_prepattern; Re.char '}']) + Re.compile (Re.seq [ Re.char '{'; label_prepattern; Re.char '}' ]) + let label_pattern = Re.compile label_prepattern let create_url_matcher (url : string) : url_matcher = let labels = Re.matches variable_pattern url in - let labels = - List.flatten - (List.map (Re.matches label_pattern) labels) - in + let labels = List.flatten (List.map (Re.matches label_pattern) labels) in let pattern = - Re.split_full variable_pattern url |> - List.map (function - | `Text s -> Re.str s - | `Delim _ -> Re.group (Re.rep (Re.compl [Re.char '/']))) |> - Re.seq |> Re.whole_string in + Re.split_full variable_pattern url + |> List.map (function + | `Text s -> Re.str s + | `Delim _ -> Re.group (Re.rep (Re.compl [ Re.char '/' ]))) + |> Re.seq |> Re.whole_string + in let () = - Lwt.async - (fun () -> - Logs_lwt.debug - (fun m -> m " + route : %a" Re.pp pattern)) + Lwt.async (fun () -> + Logs_lwt.debug (fun m -> m " + route : %a" Re.pp pattern)) in let re = Re.compile pattern in - { re; labels; route = url ; } + { re; labels; route = url } -let rec match_url - (url_matchers : ('a * url_matcher) list) - (url : string) - : ('a * (string * string) list) list = +let rec match_url (url_matchers : ('a * url_matcher) list) (url : string) : + ('a * (string * string) list) list = match url_matchers with - | (arg,matcher)::tail -> + | (arg, matcher) :: tail -> (try let matching = - Re.exec matcher.re url |> - Re.Group.all |> - Array.to_list |> List.tl in + Re.exec matcher.re url |> Re.Group.all |> Array.to_list |> List.tl + in let get_parameters : (string * string) list = - List.combine matcher.labels matching in + List.combine matcher.labels matching + in let () = - Lwt.async - (fun () -> - Logs_lwt.debug - (fun m -> m - "match_url :\n+ url : '%s'\n+ route: '%s'\n+ args: { @[%a@] }" - url matcher.route - (Pp.list Pp.comma - (fun f (key,value) -> Format.fprintf f "%s: %s" key value)) - get_parameters)) in - [arg,get_parameters] + Lwt.async (fun () -> + Logs_lwt.debug (fun m -> + m + "match_url :\n\ + + url : '%s'\n\ + + route: '%s'\n\ + + args: { @[%a@] }" url matcher.route + (Pp.list Pp.comma (fun f (key, value) -> + Format.fprintf f "%s: %s" key value)) + get_parameters)) + in + [ arg, get_parameters ] with Not_found -> []) - @(match_url tail url) + @ match_url tail url | [] -> [] let request_handler context = function | [] -> Server.respond_not_found ~uri:(Request.uri context.request) () - | [route,arguments] -> + | [ (route, arguments) ] -> Lwt.catch (fun () -> - let context = { context with arguments = arguments } in - route.operation ~context - ) + let context = { context with arguments } in + route.operation ~context) (fun exn -> - api_result_response - ~string_of_success:(fun x -> x) - (match exn with - | Yojson.Json_error e -> (Api_common.result_error_msg e) - | exn -> (Api_common.result_error_exception exn) - ) - ) - | _::_ -> - error_response - ?headers:None ?status:None [Api_common.error_msg "multiple routes match url"] - - -let route_handler - (routes : route_handler list) : - context:context -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = - let url_matchers : (route_handler * url_matcher ) list = - List.map - (fun route -> (route,create_url_matcher route.path)) routes in + api_result_response + ~string_of_success:(fun x -> x) + (match exn with + | Yojson.Json_error e -> Api_common.result_error_msg e + | exn -> Api_common.result_error_exception exn)) + | _ :: _ -> + error_response ?headers:None ?status:None + [ Api_common.error_msg "multiple routes match url" ] + +let route_handler (routes : route_handler list) : + context:context -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t = + let url_matchers : (route_handler * url_matcher) list = + List.map (fun route -> route, create_url_matcher route.path) routes + in fun ~context -> let url : string = - Uri.pct_decode - (Uri.path (Cohttp.Request.uri context.request)) in + Uri.pct_decode (Uri.path (Cohttp.Request.uri context.request)) + in request_handler context (* get the list of matching handlers with their arguments *) diff --git a/webapp/websim_args.ml b/webapp/websim_args.ml index 26a454af27..162d31e1a1 100644 --- a/webapp/websim_args.ml +++ b/webapp/websim_args.ml @@ -7,29 +7,24 @@ (******************************************************************************) type t = { - mutable port : int; - mutable cert_dir : string option; - mutable shutdown_key : string option; + mutable port: int; + mutable cert_dir: string option; + mutable shutdown_key: string option; } -let default : t = { - port = 8080; - cert_dir = None; - shutdown_key = None; -} -let usage_msg = "[--development] | [-port port] [--shutdownkey shulog file] [--level [debug|info|notice|warning|error|fatal]]" +let default : t = { port = 8080; cert_dir = None; shutdown_key = None } + +let usage_msg = + "[--development] | [-port port] [--shutdownkey shulog file] [--level \ + [debug|info|notice|warning|error|fatal]]" -let options (t :t) : (string * Arg.spec * string) list = [ - ("--port", - Arg.Int - (fun port -> t.port <- port), - "port to serve on"); - ("--shutdown-key", - Arg.String - (fun key -> t.shutdown_key <- Some key), - "key to shutdown server"); - ("--cert-dir", - Arg.String - (fun key -> t.cert_dir <- Some key), - "Directory where to find cert.pem and privkey.pem") +let options (t : t) : (string * Arg.spec * string) list = + [ + "--port", Arg.Int (fun port -> t.port <- port), "port to serve on"; + ( "--shutdown-key", + Arg.String (fun key -> t.shutdown_key <- Some key), + "key to shutdown server" ); + ( "--cert-dir", + Arg.String (fun key -> t.cert_dir <- Some key), + "Directory where to find cert.pem and privkey.pem" ); ]